1 /* Statement translation -- generate GCC trees from gfc_code. 2 Copyright (C) 2002-2019 Free Software Foundation, Inc. 3 Contributed by Paul Brook <paul@nowt.org> 4 and Steven Bosscher <s.bosscher@student.tudelft.nl> 5 6 This file is part of GCC. 7 8 GCC is free software; you can redistribute it and/or modify it under 9 the terms of the GNU General Public License as published by the Free 10 Software Foundation; either version 3, or (at your option) any later 11 version. 12 13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14 WARRANTY; without even the implied warranty of MERCHANTABILITY or 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16 for more details. 17 18 You should have received a copy of the GNU General Public License 19 along with GCC; see the file COPYING3. If not see 20 <http://www.gnu.org/licenses/>. */ 21 22 23 #include "config.h" 24 #include "system.h" 25 #include "coretypes.h" 26 #include "options.h" 27 #include "tree.h" 28 #include "gfortran.h" 29 #include "trans.h" 30 #include "stringpool.h" 31 #include "fold-const.h" 32 #include "trans-stmt.h" 33 #include "trans-types.h" 34 #include "trans-array.h" 35 #include "trans-const.h" 36 #include "dependency.h" 37 38 typedef struct iter_info 39 { 40 tree var; 41 tree start; 42 tree end; 43 tree step; 44 struct iter_info *next; 45 } 46 iter_info; 47 48 typedef struct forall_info 49 { 50 iter_info *this_loop; 51 tree mask; 52 tree maskindex; 53 int nvar; 54 tree size; 55 struct forall_info *prev_nest; 56 bool do_concurrent; 57 } 58 forall_info; 59 60 static void gfc_trans_where_2 (gfc_code *, tree, bool, 61 forall_info *, stmtblock_t *); 62 63 /* Translate a F95 label number to a LABEL_EXPR. */ 64 65 tree 66 gfc_trans_label_here (gfc_code * code) 67 { 68 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); 69 } 70 71 72 /* Given a variable expression which has been ASSIGNed to, find the decl 73 containing the auxiliary variables. For variables in common blocks this 74 is a field_decl. */ 75 76 void 77 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) 78 { 79 gcc_assert (expr->symtree->n.sym->attr.assign == 1); 80 gfc_conv_expr (se, expr); 81 /* Deals with variable in common block. Get the field declaration. */ 82 if (TREE_CODE (se->expr) == COMPONENT_REF) 83 se->expr = TREE_OPERAND (se->expr, 1); 84 /* Deals with dummy argument. Get the parameter declaration. */ 85 else if (TREE_CODE (se->expr) == INDIRECT_REF) 86 se->expr = TREE_OPERAND (se->expr, 0); 87 } 88 89 /* Translate a label assignment statement. */ 90 91 tree 92 gfc_trans_label_assign (gfc_code * code) 93 { 94 tree label_tree; 95 gfc_se se; 96 tree len; 97 tree addr; 98 tree len_tree; 99 int label_len; 100 101 /* Start a new block. */ 102 gfc_init_se (&se, NULL); 103 gfc_start_block (&se.pre); 104 gfc_conv_label_variable (&se, code->expr1); 105 106 len = GFC_DECL_STRING_LEN (se.expr); 107 addr = GFC_DECL_ASSIGN_ADDR (se.expr); 108 109 label_tree = gfc_get_label_decl (code->label1); 110 111 if (code->label1->defined == ST_LABEL_TARGET 112 || code->label1->defined == ST_LABEL_DO_TARGET) 113 { 114 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); 115 len_tree = build_int_cst (gfc_charlen_type_node, -1); 116 } 117 else 118 { 119 gfc_expr *format = code->label1->format; 120 121 label_len = format->value.character.length; 122 len_tree = build_int_cst (gfc_charlen_type_node, label_len); 123 label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, 124 format->value.character.string); 125 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); 126 } 127 128 gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); 129 gfc_add_modify (&se.pre, addr, label_tree); 130 131 return gfc_finish_block (&se.pre); 132 } 133 134 /* Translate a GOTO statement. */ 135 136 tree 137 gfc_trans_goto (gfc_code * code) 138 { 139 locus loc = code->loc; 140 tree assigned_goto; 141 tree target; 142 tree tmp; 143 gfc_se se; 144 145 if (code->label1 != NULL) 146 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); 147 148 /* ASSIGNED GOTO. */ 149 gfc_init_se (&se, NULL); 150 gfc_start_block (&se.pre); 151 gfc_conv_label_variable (&se, code->expr1); 152 tmp = GFC_DECL_STRING_LEN (se.expr); 153 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, 154 build_int_cst (TREE_TYPE (tmp), -1)); 155 gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, 156 "Assigned label is not a target label"); 157 158 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); 159 160 /* We're going to ignore a label list. It does not really change the 161 statement's semantics (because it is just a further restriction on 162 what's legal code); before, we were comparing label addresses here, but 163 that's a very fragile business and may break with optimization. So 164 just ignore it. */ 165 166 target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node, 167 assigned_goto); 168 gfc_add_expr_to_block (&se.pre, target); 169 return gfc_finish_block (&se.pre); 170 } 171 172 173 /* Translate an ENTRY statement. Just adds a label for this entry point. */ 174 tree 175 gfc_trans_entry (gfc_code * code) 176 { 177 return build1_v (LABEL_EXPR, code->ext.entry->label); 178 } 179 180 181 /* Replace a gfc_ss structure by another both in the gfc_se struct 182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies 183 to replace a variable ss by the corresponding temporary. */ 184 185 static void 186 replace_ss (gfc_se *se, gfc_ss *old_ss, gfc_ss *new_ss) 187 { 188 gfc_ss **sess, **loopss; 189 190 /* The old_ss is a ss for a single variable. */ 191 gcc_assert (old_ss->info->type == GFC_SS_SECTION); 192 193 for (sess = &(se->ss); *sess != gfc_ss_terminator; sess = &((*sess)->next)) 194 if (*sess == old_ss) 195 break; 196 gcc_assert (*sess != gfc_ss_terminator); 197 198 *sess = new_ss; 199 new_ss->next = old_ss->next; 200 201 202 for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; 203 loopss = &((*loopss)->loop_chain)) 204 if (*loopss == old_ss) 205 break; 206 gcc_assert (*loopss != gfc_ss_terminator); 207 208 *loopss = new_ss; 209 new_ss->loop_chain = old_ss->loop_chain; 210 new_ss->loop = old_ss->loop; 211 212 gfc_free_ss (old_ss); 213 } 214 215 216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of 217 elemental subroutines. Make temporaries for output arguments if any such 218 dependencies are found. Output arguments are chosen because internal_unpack 219 can be used, as is, to copy the result back to the variable. */ 220 static void 221 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, 222 gfc_symbol * sym, gfc_actual_arglist * arg, 223 gfc_dep_check check_variable) 224 { 225 gfc_actual_arglist *arg0; 226 gfc_expr *e; 227 gfc_formal_arglist *formal; 228 gfc_se parmse; 229 gfc_ss *ss; 230 gfc_symbol *fsym; 231 tree data; 232 tree size; 233 tree tmp; 234 235 if (loopse->ss == NULL) 236 return; 237 238 ss = loopse->ss; 239 arg0 = arg; 240 formal = gfc_sym_get_dummy_args (sym); 241 242 /* Loop over all the arguments testing for dependencies. */ 243 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) 244 { 245 e = arg->expr; 246 if (e == NULL) 247 continue; 248 249 /* Obtain the info structure for the current argument. */ 250 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) 251 if (ss->info->expr == e) 252 break; 253 254 /* If there is a dependency, create a temporary and use it 255 instead of the variable. */ 256 fsym = formal ? formal->sym : NULL; 257 if (e->expr_type == EXPR_VARIABLE 258 && e->rank && fsym 259 && fsym->attr.intent != INTENT_IN 260 && gfc_check_fncall_dependency (e, fsym->attr.intent, 261 sym, arg0, check_variable)) 262 { 263 tree initial, temptype; 264 stmtblock_t temp_post; 265 gfc_ss *tmp_ss; 266 267 tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen, 268 GFC_SS_SECTION); 269 gfc_mark_ss_chain_used (tmp_ss, 1); 270 tmp_ss->info->expr = ss->info->expr; 271 replace_ss (loopse, ss, tmp_ss); 272 273 /* Obtain the argument descriptor for unpacking. */ 274 gfc_init_se (&parmse, NULL); 275 parmse.want_pointer = 1; 276 gfc_conv_expr_descriptor (&parmse, e); 277 gfc_add_block_to_block (&se->pre, &parmse.pre); 278 279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), 280 initialize the array temporary with a copy of the values. */ 281 if (fsym->attr.intent == INTENT_INOUT 282 || (fsym->ts.type ==BT_DERIVED 283 && fsym->attr.intent == INTENT_OUT)) 284 initial = parmse.expr; 285 /* For class expressions, we always initialize with the copy of 286 the values. */ 287 else if (e->ts.type == BT_CLASS) 288 initial = parmse.expr; 289 else 290 initial = NULL_TREE; 291 292 if (e->ts.type != BT_CLASS) 293 { 294 /* Find the type of the temporary to create; we don't use the type 295 of e itself as this breaks for subcomponent-references in e 296 (where the type of e is that of the final reference, but 297 parmse.expr's type corresponds to the full derived-type). */ 298 /* TODO: Fix this somehow so we don't need a temporary of the whole 299 array but instead only the components referenced. */ 300 temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ 301 gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); 302 temptype = TREE_TYPE (temptype); 303 temptype = gfc_get_element_type (temptype); 304 } 305 306 else 307 /* For class arrays signal that the size of the dynamic type has to 308 be obtained from the vtable, using the 'initial' expression. */ 309 temptype = NULL_TREE; 310 311 /* Generate the temporary. Cleaning up the temporary should be the 312 very last thing done, so we add the code to a new block and add it 313 to se->post as last instructions. */ 314 size = gfc_create_var (gfc_array_index_type, NULL); 315 data = gfc_create_var (pvoid_type_node, NULL); 316 gfc_init_block (&temp_post); 317 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, 318 temptype, initial, false, true, 319 false, &arg->expr->where); 320 gfc_add_modify (&se->pre, size, tmp); 321 tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); 322 gfc_add_modify (&se->pre, data, tmp); 323 324 /* Update other ss' delta. */ 325 gfc_set_delta (loopse->loop); 326 327 /* Copy the result back using unpack..... */ 328 if (e->ts.type != BT_CLASS) 329 tmp = build_call_expr_loc (input_location, 330 gfor_fndecl_in_unpack, 2, parmse.expr, data); 331 else 332 { 333 /* ... except for class results where the copy is 334 unconditional. */ 335 tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); 336 tmp = gfc_conv_descriptor_data_get (tmp); 337 tmp = build_call_expr_loc (input_location, 338 builtin_decl_explicit (BUILT_IN_MEMCPY), 339 3, tmp, data, 340 fold_convert (size_type_node, size)); 341 } 342 gfc_add_expr_to_block (&se->post, tmp); 343 344 /* parmse.pre is already added above. */ 345 gfc_add_block_to_block (&se->post, &parmse.post); 346 gfc_add_block_to_block (&se->post, &temp_post); 347 } 348 } 349 } 350 351 352 /* Get the interface symbol for the procedure corresponding to the given call. 353 We can't get the procedure symbol directly as we have to handle the case 354 of (deferred) type-bound procedures. */ 355 356 static gfc_symbol * 357 get_proc_ifc_for_call (gfc_code *c) 358 { 359 gfc_symbol *sym; 360 361 gcc_assert (c->op == EXEC_ASSIGN_CALL || c->op == EXEC_CALL); 362 363 sym = gfc_get_proc_ifc_for_expr (c->expr1); 364 365 /* Fall back/last resort try. */ 366 if (sym == NULL) 367 sym = c->resolved_sym; 368 369 return sym; 370 } 371 372 373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */ 374 375 tree 376 gfc_trans_call (gfc_code * code, bool dependency_check, 377 tree mask, tree count1, bool invert) 378 { 379 gfc_se se; 380 gfc_ss * ss; 381 int has_alternate_specifier; 382 gfc_dep_check check_variable; 383 tree index = NULL_TREE; 384 tree maskexpr = NULL_TREE; 385 tree tmp; 386 387 /* A CALL starts a new block because the actual arguments may have to 388 be evaluated first. */ 389 gfc_init_se (&se, NULL); 390 gfc_start_block (&se.pre); 391 392 gcc_assert (code->resolved_sym); 393 394 ss = gfc_ss_terminator; 395 if (code->resolved_sym->attr.elemental) 396 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, 397 get_proc_ifc_for_call (code), 398 GFC_SS_REFERENCE); 399 400 /* Is not an elemental subroutine call with array valued arguments. */ 401 if (ss == gfc_ss_terminator) 402 { 403 404 /* Translate the call. */ 405 has_alternate_specifier 406 = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual, 407 code->expr1, NULL); 408 409 /* A subroutine without side-effect, by definition, does nothing! */ 410 TREE_SIDE_EFFECTS (se.expr) = 1; 411 412 /* Chain the pieces together and return the block. */ 413 if (has_alternate_specifier) 414 { 415 gfc_code *select_code; 416 gfc_symbol *sym; 417 select_code = code->next; 418 gcc_assert(select_code->op == EXEC_SELECT); 419 sym = select_code->expr1->symtree->n.sym; 420 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); 421 if (sym->backend_decl == NULL) 422 sym->backend_decl = gfc_get_symbol_decl (sym); 423 gfc_add_modify (&se.pre, sym->backend_decl, se.expr); 424 } 425 else 426 gfc_add_expr_to_block (&se.pre, se.expr); 427 428 gfc_add_block_to_block (&se.pre, &se.post); 429 } 430 431 else 432 { 433 /* An elemental subroutine call with array valued arguments has 434 to be scalarized. */ 435 gfc_loopinfo loop; 436 stmtblock_t body; 437 stmtblock_t block; 438 gfc_se loopse; 439 gfc_se depse; 440 441 /* gfc_walk_elemental_function_args renders the ss chain in the 442 reverse order to the actual argument order. */ 443 ss = gfc_reverse_ss (ss); 444 445 /* Initialize the loop. */ 446 gfc_init_se (&loopse, NULL); 447 gfc_init_loopinfo (&loop); 448 gfc_add_ss_to_loop (&loop, ss); 449 450 gfc_conv_ss_startstride (&loop); 451 /* TODO: gfc_conv_loop_setup generates a temporary for vector 452 subscripts. This could be prevented in the elemental case 453 as temporaries are handled separatedly 454 (below in gfc_conv_elemental_dependencies). */ 455 if (code->expr1) 456 gfc_conv_loop_setup (&loop, &code->expr1->where); 457 else 458 gfc_conv_loop_setup (&loop, &code->loc); 459 460 gfc_mark_ss_chain_used (ss, 1); 461 462 /* Convert the arguments, checking for dependencies. */ 463 gfc_copy_loopinfo_to_se (&loopse, &loop); 464 loopse.ss = ss; 465 466 /* For operator assignment, do dependency checking. */ 467 if (dependency_check) 468 check_variable = ELEM_CHECK_VARIABLE; 469 else 470 check_variable = ELEM_DONT_CHECK_VARIABLE; 471 472 gfc_init_se (&depse, NULL); 473 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym, 474 code->ext.actual, check_variable); 475 476 gfc_add_block_to_block (&loop.pre, &depse.pre); 477 gfc_add_block_to_block (&loop.post, &depse.post); 478 479 /* Generate the loop body. */ 480 gfc_start_scalarized_body (&loop, &body); 481 gfc_init_block (&block); 482 483 if (mask && count1) 484 { 485 /* Form the mask expression according to the mask. */ 486 index = count1; 487 maskexpr = gfc_build_array_ref (mask, index, NULL); 488 if (invert) 489 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, 490 TREE_TYPE (maskexpr), maskexpr); 491 } 492 493 /* Add the subroutine call to the block. */ 494 gfc_conv_procedure_call (&loopse, code->resolved_sym, 495 code->ext.actual, code->expr1, 496 NULL); 497 498 if (mask && count1) 499 { 500 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, 501 build_empty_stmt (input_location)); 502 gfc_add_expr_to_block (&loopse.pre, tmp); 503 tmp = fold_build2_loc (input_location, PLUS_EXPR, 504 gfc_array_index_type, 505 count1, gfc_index_one_node); 506 gfc_add_modify (&loopse.pre, count1, tmp); 507 } 508 else 509 gfc_add_expr_to_block (&loopse.pre, loopse.expr); 510 511 gfc_add_block_to_block (&block, &loopse.pre); 512 gfc_add_block_to_block (&block, &loopse.post); 513 514 /* Finish up the loop block and the loop. */ 515 gfc_add_expr_to_block (&body, gfc_finish_block (&block)); 516 gfc_trans_scalarizing_loops (&loop, &body); 517 gfc_add_block_to_block (&se.pre, &loop.pre); 518 gfc_add_block_to_block (&se.pre, &loop.post); 519 gfc_add_block_to_block (&se.pre, &se.post); 520 gfc_cleanup_loop (&loop); 521 } 522 523 return gfc_finish_block (&se.pre); 524 } 525 526 527 /* Translate the RETURN statement. */ 528 529 tree 530 gfc_trans_return (gfc_code * code) 531 { 532 if (code->expr1) 533 { 534 gfc_se se; 535 tree tmp; 536 tree result; 537 538 /* If code->expr is not NULL, this return statement must appear 539 in a subroutine and current_fake_result_decl has already 540 been generated. */ 541 542 result = gfc_get_fake_result_decl (NULL, 0); 543 if (!result) 544 { 545 gfc_warning (0, 546 "An alternate return at %L without a * dummy argument", 547 &code->expr1->where); 548 return gfc_generate_return (); 549 } 550 551 /* Start a new block for this statement. */ 552 gfc_init_se (&se, NULL); 553 gfc_start_block (&se.pre); 554 555 gfc_conv_expr (&se, code->expr1); 556 557 /* Note that the actually returned expression is a simple value and 558 does not depend on any pointers or such; thus we can clean-up with 559 se.post before returning. */ 560 tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result), 561 result, fold_convert (TREE_TYPE (result), 562 se.expr)); 563 gfc_add_expr_to_block (&se.pre, tmp); 564 gfc_add_block_to_block (&se.pre, &se.post); 565 566 tmp = gfc_generate_return (); 567 gfc_add_expr_to_block (&se.pre, tmp); 568 return gfc_finish_block (&se.pre); 569 } 570 571 return gfc_generate_return (); 572 } 573 574 575 /* Translate the PAUSE statement. We have to translate this statement 576 to a runtime library call. */ 577 578 tree 579 gfc_trans_pause (gfc_code * code) 580 { 581 tree gfc_int8_type_node = gfc_get_int_type (8); 582 gfc_se se; 583 tree tmp; 584 585 /* Start a new block for this statement. */ 586 gfc_init_se (&se, NULL); 587 gfc_start_block (&se.pre); 588 589 590 if (code->expr1 == NULL) 591 { 592 tmp = build_int_cst (size_type_node, 0); 593 tmp = build_call_expr_loc (input_location, 594 gfor_fndecl_pause_string, 2, 595 build_int_cst (pchar_type_node, 0), tmp); 596 } 597 else if (code->expr1->ts.type == BT_INTEGER) 598 { 599 gfc_conv_expr (&se, code->expr1); 600 tmp = build_call_expr_loc (input_location, 601 gfor_fndecl_pause_numeric, 1, 602 fold_convert (gfc_int8_type_node, se.expr)); 603 } 604 else 605 { 606 gfc_conv_expr_reference (&se, code->expr1); 607 tmp = build_call_expr_loc (input_location, 608 gfor_fndecl_pause_string, 2, 609 se.expr, fold_convert (size_type_node, 610 se.string_length)); 611 } 612 613 gfc_add_expr_to_block (&se.pre, tmp); 614 615 gfc_add_block_to_block (&se.pre, &se.post); 616 617 return gfc_finish_block (&se.pre); 618 } 619 620 621 /* Translate the STOP statement. We have to translate this statement 622 to a runtime library call. */ 623 624 tree 625 gfc_trans_stop (gfc_code *code, bool error_stop) 626 { 627 gfc_se se; 628 tree tmp; 629 630 /* Start a new block for this statement. */ 631 gfc_init_se (&se, NULL); 632 gfc_start_block (&se.pre); 633 634 if (code->expr1 == NULL) 635 { 636 tmp = build_int_cst (size_type_node, 0); 637 tmp = build_call_expr_loc (input_location, 638 error_stop 639 ? (flag_coarray == GFC_FCOARRAY_LIB 640 ? gfor_fndecl_caf_error_stop_str 641 : gfor_fndecl_error_stop_string) 642 : (flag_coarray == GFC_FCOARRAY_LIB 643 ? gfor_fndecl_caf_stop_str 644 : gfor_fndecl_stop_string), 645 3, build_int_cst (pchar_type_node, 0), tmp, 646 boolean_false_node); 647 } 648 else if (code->expr1->ts.type == BT_INTEGER) 649 { 650 gfc_conv_expr (&se, code->expr1); 651 tmp = build_call_expr_loc (input_location, 652 error_stop 653 ? (flag_coarray == GFC_FCOARRAY_LIB 654 ? gfor_fndecl_caf_error_stop 655 : gfor_fndecl_error_stop_numeric) 656 : (flag_coarray == GFC_FCOARRAY_LIB 657 ? gfor_fndecl_caf_stop_numeric 658 : gfor_fndecl_stop_numeric), 2, 659 fold_convert (integer_type_node, se.expr), 660 boolean_false_node); 661 } 662 else 663 { 664 gfc_conv_expr_reference (&se, code->expr1); 665 tmp = build_call_expr_loc (input_location, 666 error_stop 667 ? (flag_coarray == GFC_FCOARRAY_LIB 668 ? gfor_fndecl_caf_error_stop_str 669 : gfor_fndecl_error_stop_string) 670 : (flag_coarray == GFC_FCOARRAY_LIB 671 ? gfor_fndecl_caf_stop_str 672 : gfor_fndecl_stop_string), 673 3, se.expr, fold_convert (size_type_node, 674 se.string_length), 675 boolean_false_node); 676 } 677 678 gfc_add_expr_to_block (&se.pre, tmp); 679 680 gfc_add_block_to_block (&se.pre, &se.post); 681 682 return gfc_finish_block (&se.pre); 683 } 684 685 /* Translate the FAIL IMAGE statement. */ 686 687 tree 688 gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) 689 { 690 if (flag_coarray == GFC_FCOARRAY_LIB) 691 return build_call_expr_loc (input_location, 692 gfor_fndecl_caf_fail_image, 1, 693 build_int_cst (pchar_type_node, 0)); 694 else 695 { 696 const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); 697 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); 698 tree tmp = gfc_get_symbol_decl (exsym); 699 return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); 700 } 701 } 702 703 /* Translate the FORM TEAM statement. */ 704 705 tree 706 gfc_trans_form_team (gfc_code *code) 707 { 708 if (flag_coarray == GFC_FCOARRAY_LIB) 709 { 710 gfc_se se; 711 gfc_se argse1, argse2; 712 tree team_id, team_type, tmp; 713 714 gfc_init_se (&se, NULL); 715 gfc_init_se (&argse1, NULL); 716 gfc_init_se (&argse2, NULL); 717 gfc_start_block (&se.pre); 718 719 gfc_conv_expr_val (&argse1, code->expr1); 720 gfc_conv_expr_val (&argse2, code->expr2); 721 team_id = fold_convert (integer_type_node, argse1.expr); 722 team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); 723 724 gfc_add_block_to_block (&se.pre, &argse1.pre); 725 gfc_add_block_to_block (&se.pre, &argse2.pre); 726 tmp = build_call_expr_loc (input_location, 727 gfor_fndecl_caf_form_team, 3, 728 team_id, team_type, 729 build_int_cst (integer_type_node, 0)); 730 gfc_add_expr_to_block (&se.pre, tmp); 731 gfc_add_block_to_block (&se.pre, &argse1.post); 732 gfc_add_block_to_block (&se.pre, &argse2.post); 733 return gfc_finish_block (&se.pre); 734 } 735 else 736 { 737 const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); 738 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); 739 tree tmp = gfc_get_symbol_decl (exsym); 740 return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); 741 } 742 } 743 744 /* Translate the CHANGE TEAM statement. */ 745 746 tree 747 gfc_trans_change_team (gfc_code *code) 748 { 749 if (flag_coarray == GFC_FCOARRAY_LIB) 750 { 751 gfc_se argse; 752 tree team_type, tmp; 753 754 gfc_init_se (&argse, NULL); 755 gfc_conv_expr_val (&argse, code->expr1); 756 team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); 757 758 tmp = build_call_expr_loc (input_location, 759 gfor_fndecl_caf_change_team, 2, team_type, 760 build_int_cst (integer_type_node, 0)); 761 gfc_add_expr_to_block (&argse.pre, tmp); 762 gfc_add_block_to_block (&argse.pre, &argse.post); 763 return gfc_finish_block (&argse.pre); 764 } 765 else 766 { 767 const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); 768 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); 769 tree tmp = gfc_get_symbol_decl (exsym); 770 return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); 771 } 772 } 773 774 /* Translate the END TEAM statement. */ 775 776 tree 777 gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) 778 { 779 if (flag_coarray == GFC_FCOARRAY_LIB) 780 { 781 return build_call_expr_loc (input_location, 782 gfor_fndecl_caf_end_team, 1, 783 build_int_cst (pchar_type_node, 0)); 784 } 785 else 786 { 787 const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); 788 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); 789 tree tmp = gfc_get_symbol_decl (exsym); 790 return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); 791 } 792 } 793 794 /* Translate the SYNC TEAM statement. */ 795 796 tree 797 gfc_trans_sync_team (gfc_code *code) 798 { 799 if (flag_coarray == GFC_FCOARRAY_LIB) 800 { 801 gfc_se argse; 802 tree team_type, tmp; 803 804 gfc_init_se (&argse, NULL); 805 gfc_conv_expr_val (&argse, code->expr1); 806 team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); 807 808 tmp = build_call_expr_loc (input_location, 809 gfor_fndecl_caf_sync_team, 2, 810 team_type, 811 build_int_cst (integer_type_node, 0)); 812 gfc_add_expr_to_block (&argse.pre, tmp); 813 gfc_add_block_to_block (&argse.pre, &argse.post); 814 return gfc_finish_block (&argse.pre); 815 } 816 else 817 { 818 const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); 819 gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); 820 tree tmp = gfc_get_symbol_decl (exsym); 821 return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); 822 } 823 } 824 825 tree 826 gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) 827 { 828 gfc_se se, argse; 829 tree stat = NULL_TREE, stat2 = NULL_TREE; 830 tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE; 831 832 /* Short cut: For single images without STAT= or LOCK_ACQUIRED 833 return early. (ERRMSG= is always untouched for -fcoarray=single.) */ 834 if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB) 835 return NULL_TREE; 836 837 if (code->expr2) 838 { 839 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); 840 gfc_init_se (&argse, NULL); 841 gfc_conv_expr_val (&argse, code->expr2); 842 stat = argse.expr; 843 } 844 else if (flag_coarray == GFC_FCOARRAY_LIB) 845 stat = null_pointer_node; 846 847 if (code->expr4) 848 { 849 gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); 850 gfc_init_se (&argse, NULL); 851 gfc_conv_expr_val (&argse, code->expr4); 852 lock_acquired = argse.expr; 853 } 854 else if (flag_coarray == GFC_FCOARRAY_LIB) 855 lock_acquired = null_pointer_node; 856 857 gfc_start_block (&se.pre); 858 if (flag_coarray == GFC_FCOARRAY_LIB) 859 { 860 tree tmp, token, image_index, errmsg, errmsg_len; 861 tree index = build_zero_cst (gfc_array_index_type); 862 tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); 863 864 if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED 865 || code->expr1->symtree->n.sym->ts.u.derived->from_intmod 866 != INTMOD_ISO_FORTRAN_ENV 867 || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id 868 != ISOFORTRAN_LOCK_TYPE) 869 { 870 gfc_error ("Sorry, the lock component of derived type at %L is not " 871 "yet supported", &code->expr1->where); 872 return NULL_TREE; 873 } 874 875 gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, 876 code->expr1); 877 878 if (gfc_is_coindexed (code->expr1)) 879 image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); 880 else 881 image_index = integer_zero_node; 882 883 /* For arrays, obtain the array index. */ 884 if (gfc_expr_attr (code->expr1).dimension) 885 { 886 tree desc, tmp, extent, lbound, ubound; 887 gfc_array_ref *ar, ar2; 888 int i; 889 890 /* TODO: Extend this, once DT components are supported. */ 891 ar = &code->expr1->ref->u.ar; 892 ar2 = *ar; 893 memset (ar, '\0', sizeof (*ar)); 894 ar->as = ar2.as; 895 ar->type = AR_FULL; 896 897 gfc_init_se (&argse, NULL); 898 argse.descriptor_only = 1; 899 gfc_conv_expr_descriptor (&argse, code->expr1); 900 gfc_add_block_to_block (&se.pre, &argse.pre); 901 desc = argse.expr; 902 *ar = ar2; 903 904 extent = build_one_cst (gfc_array_index_type); 905 for (i = 0; i < ar->dimen; i++) 906 { 907 gfc_init_se (&argse, NULL); 908 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); 909 gfc_add_block_to_block (&argse.pre, &argse.pre); 910 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); 911 tmp = fold_build2_loc (input_location, MINUS_EXPR, 912 TREE_TYPE (lbound), argse.expr, lbound); 913 tmp = fold_build2_loc (input_location, MULT_EXPR, 914 TREE_TYPE (tmp), extent, tmp); 915 index = fold_build2_loc (input_location, PLUS_EXPR, 916 TREE_TYPE (tmp), index, tmp); 917 if (i < ar->dimen - 1) 918 { 919 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); 920 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); 921 extent = fold_build2_loc (input_location, MULT_EXPR, 922 TREE_TYPE (tmp), extent, tmp); 923 } 924 } 925 } 926 927 /* errmsg. */ 928 if (code->expr3) 929 { 930 gfc_init_se (&argse, NULL); 931 argse.want_pointer = 1; 932 gfc_conv_expr (&argse, code->expr3); 933 gfc_add_block_to_block (&se.pre, &argse.pre); 934 errmsg = argse.expr; 935 errmsg_len = fold_convert (size_type_node, argse.string_length); 936 } 937 else 938 { 939 errmsg = null_pointer_node; 940 errmsg_len = build_zero_cst (size_type_node); 941 } 942 943 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) 944 { 945 stat2 = stat; 946 stat = gfc_create_var (integer_type_node, "stat"); 947 } 948 949 if (lock_acquired != null_pointer_node 950 && TREE_TYPE (lock_acquired) != integer_type_node) 951 { 952 lock_acquired2 = lock_acquired; 953 lock_acquired = gfc_create_var (integer_type_node, "acquired"); 954 } 955 956 index = fold_convert (size_type_node, index); 957 if (op == EXEC_LOCK) 958 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, 959 token, index, image_index, 960 lock_acquired != null_pointer_node 961 ? gfc_build_addr_expr (NULL, lock_acquired) 962 : lock_acquired, 963 stat != null_pointer_node 964 ? gfc_build_addr_expr (NULL, stat) : stat, 965 errmsg, errmsg_len); 966 else 967 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, 968 token, index, image_index, 969 stat != null_pointer_node 970 ? gfc_build_addr_expr (NULL, stat) : stat, 971 errmsg, errmsg_len); 972 gfc_add_expr_to_block (&se.pre, tmp); 973 974 /* It guarantees memory consistency within the same segment */ 975 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 976 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 977 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 978 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 979 ASM_VOLATILE_P (tmp) = 1; 980 981 gfc_add_expr_to_block (&se.pre, tmp); 982 983 if (stat2 != NULL_TREE) 984 gfc_add_modify (&se.pre, stat2, 985 fold_convert (TREE_TYPE (stat2), stat)); 986 987 if (lock_acquired2 != NULL_TREE) 988 gfc_add_modify (&se.pre, lock_acquired2, 989 fold_convert (TREE_TYPE (lock_acquired2), 990 lock_acquired)); 991 992 return gfc_finish_block (&se.pre); 993 } 994 995 if (stat != NULL_TREE) 996 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); 997 998 if (lock_acquired != NULL_TREE) 999 gfc_add_modify (&se.pre, lock_acquired, 1000 fold_convert (TREE_TYPE (lock_acquired), 1001 boolean_true_node)); 1002 1003 return gfc_finish_block (&se.pre); 1004 } 1005 1006 tree 1007 gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op) 1008 { 1009 gfc_se se, argse; 1010 tree stat = NULL_TREE, stat2 = NULL_TREE; 1011 tree until_count = NULL_TREE; 1012 1013 if (code->expr2) 1014 { 1015 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); 1016 gfc_init_se (&argse, NULL); 1017 gfc_conv_expr_val (&argse, code->expr2); 1018 stat = argse.expr; 1019 } 1020 else if (flag_coarray == GFC_FCOARRAY_LIB) 1021 stat = null_pointer_node; 1022 1023 if (code->expr4) 1024 { 1025 gfc_init_se (&argse, NULL); 1026 gfc_conv_expr_val (&argse, code->expr4); 1027 until_count = fold_convert (integer_type_node, argse.expr); 1028 } 1029 else 1030 until_count = integer_one_node; 1031 1032 if (flag_coarray != GFC_FCOARRAY_LIB) 1033 { 1034 gfc_start_block (&se.pre); 1035 gfc_init_se (&argse, NULL); 1036 gfc_conv_expr_val (&argse, code->expr1); 1037 1038 if (op == EXEC_EVENT_POST) 1039 gfc_add_modify (&se.pre, argse.expr, 1040 fold_build2_loc (input_location, PLUS_EXPR, 1041 TREE_TYPE (argse.expr), argse.expr, 1042 build_int_cst (TREE_TYPE (argse.expr), 1))); 1043 else 1044 gfc_add_modify (&se.pre, argse.expr, 1045 fold_build2_loc (input_location, MINUS_EXPR, 1046 TREE_TYPE (argse.expr), argse.expr, 1047 fold_convert (TREE_TYPE (argse.expr), 1048 until_count))); 1049 if (stat != NULL_TREE) 1050 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); 1051 1052 return gfc_finish_block (&se.pre); 1053 } 1054 1055 gfc_start_block (&se.pre); 1056 tree tmp, token, image_index, errmsg, errmsg_len; 1057 tree index = build_zero_cst (gfc_array_index_type); 1058 tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); 1059 1060 if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED 1061 || code->expr1->symtree->n.sym->ts.u.derived->from_intmod 1062 != INTMOD_ISO_FORTRAN_ENV 1063 || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id 1064 != ISOFORTRAN_EVENT_TYPE) 1065 { 1066 gfc_error ("Sorry, the event component of derived type at %L is not " 1067 "yet supported", &code->expr1->where); 1068 return NULL_TREE; 1069 } 1070 1071 gfc_init_se (&argse, NULL); 1072 gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE, 1073 code->expr1); 1074 gfc_add_block_to_block (&se.pre, &argse.pre); 1075 1076 if (gfc_is_coindexed (code->expr1)) 1077 image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); 1078 else 1079 image_index = integer_zero_node; 1080 1081 /* For arrays, obtain the array index. */ 1082 if (gfc_expr_attr (code->expr1).dimension) 1083 { 1084 tree desc, tmp, extent, lbound, ubound; 1085 gfc_array_ref *ar, ar2; 1086 int i; 1087 1088 /* TODO: Extend this, once DT components are supported. */ 1089 ar = &code->expr1->ref->u.ar; 1090 ar2 = *ar; 1091 memset (ar, '\0', sizeof (*ar)); 1092 ar->as = ar2.as; 1093 ar->type = AR_FULL; 1094 1095 gfc_init_se (&argse, NULL); 1096 argse.descriptor_only = 1; 1097 gfc_conv_expr_descriptor (&argse, code->expr1); 1098 gfc_add_block_to_block (&se.pre, &argse.pre); 1099 desc = argse.expr; 1100 *ar = ar2; 1101 1102 extent = build_one_cst (gfc_array_index_type); 1103 for (i = 0; i < ar->dimen; i++) 1104 { 1105 gfc_init_se (&argse, NULL); 1106 gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); 1107 gfc_add_block_to_block (&argse.pre, &argse.pre); 1108 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); 1109 tmp = fold_build2_loc (input_location, MINUS_EXPR, 1110 TREE_TYPE (lbound), argse.expr, lbound); 1111 tmp = fold_build2_loc (input_location, MULT_EXPR, 1112 TREE_TYPE (tmp), extent, tmp); 1113 index = fold_build2_loc (input_location, PLUS_EXPR, 1114 TREE_TYPE (tmp), index, tmp); 1115 if (i < ar->dimen - 1) 1116 { 1117 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); 1118 tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); 1119 extent = fold_build2_loc (input_location, MULT_EXPR, 1120 TREE_TYPE (tmp), extent, tmp); 1121 } 1122 } 1123 } 1124 1125 /* errmsg. */ 1126 if (code->expr3) 1127 { 1128 gfc_init_se (&argse, NULL); 1129 argse.want_pointer = 1; 1130 gfc_conv_expr (&argse, code->expr3); 1131 gfc_add_block_to_block (&se.pre, &argse.pre); 1132 errmsg = argse.expr; 1133 errmsg_len = fold_convert (size_type_node, argse.string_length); 1134 } 1135 else 1136 { 1137 errmsg = null_pointer_node; 1138 errmsg_len = build_zero_cst (size_type_node); 1139 } 1140 1141 if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) 1142 { 1143 stat2 = stat; 1144 stat = gfc_create_var (integer_type_node, "stat"); 1145 } 1146 1147 index = fold_convert (size_type_node, index); 1148 if (op == EXEC_EVENT_POST) 1149 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6, 1150 token, index, image_index, 1151 stat != null_pointer_node 1152 ? gfc_build_addr_expr (NULL, stat) : stat, 1153 errmsg, errmsg_len); 1154 else 1155 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6, 1156 token, index, until_count, 1157 stat != null_pointer_node 1158 ? gfc_build_addr_expr (NULL, stat) : stat, 1159 errmsg, errmsg_len); 1160 gfc_add_expr_to_block (&se.pre, tmp); 1161 1162 /* It guarantees memory consistency within the same segment */ 1163 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1164 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1165 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 1166 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 1167 ASM_VOLATILE_P (tmp) = 1; 1168 gfc_add_expr_to_block (&se.pre, tmp); 1169 1170 if (stat2 != NULL_TREE) 1171 gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat)); 1172 1173 return gfc_finish_block (&se.pre); 1174 } 1175 1176 tree 1177 gfc_trans_sync (gfc_code *code, gfc_exec_op type) 1178 { 1179 gfc_se se, argse; 1180 tree tmp; 1181 tree images = NULL_TREE, stat = NULL_TREE, 1182 errmsg = NULL_TREE, errmsglen = NULL_TREE; 1183 1184 /* Short cut: For single images without bound checking or without STAT=, 1185 return early. (ERRMSG= is always untouched for -fcoarray=single.) */ 1186 if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 1187 && flag_coarray != GFC_FCOARRAY_LIB) 1188 return NULL_TREE; 1189 1190 gfc_init_se (&se, NULL); 1191 gfc_start_block (&se.pre); 1192 1193 if (code->expr1 && code->expr1->rank == 0) 1194 { 1195 gfc_init_se (&argse, NULL); 1196 gfc_conv_expr_val (&argse, code->expr1); 1197 images = argse.expr; 1198 } 1199 1200 if (code->expr2) 1201 { 1202 gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); 1203 gfc_init_se (&argse, NULL); 1204 gfc_conv_expr_val (&argse, code->expr2); 1205 stat = argse.expr; 1206 } 1207 else 1208 stat = null_pointer_node; 1209 1210 if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB) 1211 { 1212 gcc_assert (code->expr3->expr_type == EXPR_VARIABLE); 1213 gfc_init_se (&argse, NULL); 1214 argse.want_pointer = 1; 1215 gfc_conv_expr (&argse, code->expr3); 1216 gfc_conv_string_parameter (&argse); 1217 errmsg = gfc_build_addr_expr (NULL, argse.expr); 1218 errmsglen = fold_convert (size_type_node, argse.string_length); 1219 } 1220 else if (flag_coarray == GFC_FCOARRAY_LIB) 1221 { 1222 errmsg = null_pointer_node; 1223 errmsglen = build_int_cst (size_type_node, 0); 1224 } 1225 1226 /* Check SYNC IMAGES(imageset) for valid image index. 1227 FIXME: Add a check for image-set arrays. */ 1228 if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 1229 && code->expr1->rank == 0) 1230 { 1231 tree cond; 1232 if (flag_coarray != GFC_FCOARRAY_LIB) 1233 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1234 images, build_int_cst (TREE_TYPE (images), 1)); 1235 else 1236 { 1237 tree cond2; 1238 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 1239 2, integer_zero_node, 1240 build_int_cst (integer_type_node, -1)); 1241 cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, 1242 images, tmp); 1243 cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 1244 images, 1245 build_int_cst (TREE_TYPE (images), 1)); 1246 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, 1247 logical_type_node, cond, cond2); 1248 } 1249 gfc_trans_runtime_check (true, false, cond, &se.pre, 1250 &code->expr1->where, "Invalid image number " 1251 "%d in SYNC IMAGES", 1252 fold_convert (integer_type_node, images)); 1253 } 1254 1255 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the 1256 image control statements SYNC IMAGES and SYNC ALL. */ 1257 if (flag_coarray == GFC_FCOARRAY_LIB) 1258 { 1259 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1260 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1261 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 1262 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 1263 ASM_VOLATILE_P (tmp) = 1; 1264 gfc_add_expr_to_block (&se.pre, tmp); 1265 } 1266 1267 if (flag_coarray != GFC_FCOARRAY_LIB) 1268 { 1269 /* Set STAT to zero. */ 1270 if (code->expr2) 1271 gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); 1272 } 1273 else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY) 1274 { 1275 /* SYNC ALL => stat == null_pointer_node 1276 SYNC ALL(stat=s) => stat has an integer type 1277 1278 If "stat" has the wrong integer type, use a temp variable of 1279 the right type and later cast the result back into "stat". */ 1280 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) 1281 { 1282 if (TREE_TYPE (stat) == integer_type_node) 1283 stat = gfc_build_addr_expr (NULL, stat); 1284 1285 if(type == EXEC_SYNC_MEMORY) 1286 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory, 1287 3, stat, errmsg, errmsglen); 1288 else 1289 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, 1290 3, stat, errmsg, errmsglen); 1291 1292 gfc_add_expr_to_block (&se.pre, tmp); 1293 } 1294 else 1295 { 1296 tree tmp_stat = gfc_create_var (integer_type_node, "stat"); 1297 1298 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, 1299 3, gfc_build_addr_expr (NULL, tmp_stat), 1300 errmsg, errmsglen); 1301 gfc_add_expr_to_block (&se.pre, tmp); 1302 1303 gfc_add_modify (&se.pre, stat, 1304 fold_convert (TREE_TYPE (stat), tmp_stat)); 1305 } 1306 } 1307 else 1308 { 1309 tree len; 1310 1311 gcc_assert (type == EXEC_SYNC_IMAGES); 1312 1313 if (!code->expr1) 1314 { 1315 len = build_int_cst (integer_type_node, -1); 1316 images = null_pointer_node; 1317 } 1318 else if (code->expr1->rank == 0) 1319 { 1320 len = build_int_cst (integer_type_node, 1); 1321 images = gfc_build_addr_expr (NULL_TREE, images); 1322 } 1323 else 1324 { 1325 /* FIXME. */ 1326 if (code->expr1->ts.kind != gfc_c_int_kind) 1327 gfc_fatal_error ("Sorry, only support for integer kind %d " 1328 "implemented for image-set at %L", 1329 gfc_c_int_kind, &code->expr1->where); 1330 1331 gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len); 1332 images = se.expr; 1333 1334 tmp = gfc_typenode_for_spec (&code->expr1->ts); 1335 if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) 1336 tmp = gfc_get_element_type (tmp); 1337 1338 len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 1339 TREE_TYPE (len), len, 1340 fold_convert (TREE_TYPE (len), 1341 TYPE_SIZE_UNIT (tmp))); 1342 len = fold_convert (integer_type_node, len); 1343 } 1344 1345 /* SYNC IMAGES(imgs) => stat == null_pointer_node 1346 SYNC IMAGES(imgs,stat=s) => stat has an integer type 1347 1348 If "stat" has the wrong integer type, use a temp variable of 1349 the right type and later cast the result back into "stat". */ 1350 if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) 1351 { 1352 if (TREE_TYPE (stat) == integer_type_node) 1353 stat = gfc_build_addr_expr (NULL, stat); 1354 1355 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 1356 5, fold_convert (integer_type_node, len), 1357 images, stat, errmsg, errmsglen); 1358 gfc_add_expr_to_block (&se.pre, tmp); 1359 } 1360 else 1361 { 1362 tree tmp_stat = gfc_create_var (integer_type_node, "stat"); 1363 1364 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, 1365 5, fold_convert (integer_type_node, len), 1366 images, gfc_build_addr_expr (NULL, tmp_stat), 1367 errmsg, errmsglen); 1368 gfc_add_expr_to_block (&se.pre, tmp); 1369 1370 gfc_add_modify (&se.pre, stat, 1371 fold_convert (TREE_TYPE (stat), tmp_stat)); 1372 } 1373 } 1374 1375 return gfc_finish_block (&se.pre); 1376 } 1377 1378 1379 /* Generate GENERIC for the IF construct. This function also deals with 1380 the simple IF statement, because the front end translates the IF 1381 statement into an IF construct. 1382 1383 We translate: 1384 1385 IF (cond) THEN 1386 then_clause 1387 ELSEIF (cond2) 1388 elseif_clause 1389 ELSE 1390 else_clause 1391 ENDIF 1392 1393 into: 1394 1395 pre_cond_s; 1396 if (cond_s) 1397 { 1398 then_clause; 1399 } 1400 else 1401 { 1402 pre_cond_s 1403 if (cond_s) 1404 { 1405 elseif_clause 1406 } 1407 else 1408 { 1409 else_clause; 1410 } 1411 } 1412 1413 where COND_S is the simplified version of the predicate. PRE_COND_S 1414 are the pre side-effects produced by the translation of the 1415 conditional. 1416 We need to build the chain recursively otherwise we run into 1417 problems with folding incomplete statements. */ 1418 1419 static tree 1420 gfc_trans_if_1 (gfc_code * code) 1421 { 1422 gfc_se if_se; 1423 tree stmt, elsestmt; 1424 locus saved_loc; 1425 location_t loc; 1426 1427 /* Check for an unconditional ELSE clause. */ 1428 if (!code->expr1) 1429 return gfc_trans_code (code->next); 1430 1431 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ 1432 gfc_init_se (&if_se, NULL); 1433 gfc_start_block (&if_se.pre); 1434 1435 /* Calculate the IF condition expression. */ 1436 if (code->expr1->where.lb) 1437 { 1438 gfc_save_backend_locus (&saved_loc); 1439 gfc_set_backend_locus (&code->expr1->where); 1440 } 1441 1442 gfc_conv_expr_val (&if_se, code->expr1); 1443 1444 if (code->expr1->where.lb) 1445 gfc_restore_backend_locus (&saved_loc); 1446 1447 /* Translate the THEN clause. */ 1448 stmt = gfc_trans_code (code->next); 1449 1450 /* Translate the ELSE clause. */ 1451 if (code->block) 1452 elsestmt = gfc_trans_if_1 (code->block); 1453 else 1454 elsestmt = build_empty_stmt (input_location); 1455 1456 /* Build the condition expression and add it to the condition block. */ 1457 loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location; 1458 stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, 1459 elsestmt); 1460 1461 gfc_add_expr_to_block (&if_se.pre, stmt); 1462 1463 /* Finish off this statement. */ 1464 return gfc_finish_block (&if_se.pre); 1465 } 1466 1467 tree 1468 gfc_trans_if (gfc_code * code) 1469 { 1470 stmtblock_t body; 1471 tree exit_label; 1472 1473 /* Create exit label so it is available for trans'ing the body code. */ 1474 exit_label = gfc_build_label_decl (NULL_TREE); 1475 code->exit_label = exit_label; 1476 1477 /* Translate the actual code in code->block. */ 1478 gfc_init_block (&body); 1479 gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); 1480 1481 /* Add exit label. */ 1482 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); 1483 1484 return gfc_finish_block (&body); 1485 } 1486 1487 1488 /* Translate an arithmetic IF expression. 1489 1490 IF (cond) label1, label2, label3 translates to 1491 1492 if (cond <= 0) 1493 { 1494 if (cond < 0) 1495 goto label1; 1496 else // cond == 0 1497 goto label2; 1498 } 1499 else // cond > 0 1500 goto label3; 1501 1502 An optimized version can be generated in case of equal labels. 1503 E.g., if label1 is equal to label2, we can translate it to 1504 1505 if (cond <= 0) 1506 goto label1; 1507 else 1508 goto label3; 1509 */ 1510 1511 tree 1512 gfc_trans_arithmetic_if (gfc_code * code) 1513 { 1514 gfc_se se; 1515 tree tmp; 1516 tree branch1; 1517 tree branch2; 1518 tree zero; 1519 1520 /* Start a new block. */ 1521 gfc_init_se (&se, NULL); 1522 gfc_start_block (&se.pre); 1523 1524 /* Pre-evaluate COND. */ 1525 gfc_conv_expr_val (&se, code->expr1); 1526 se.expr = gfc_evaluate_now (se.expr, &se.pre); 1527 1528 /* Build something to compare with. */ 1529 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); 1530 1531 if (code->label1->value != code->label2->value) 1532 { 1533 /* If (cond < 0) take branch1 else take branch2. 1534 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ 1535 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); 1536 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); 1537 1538 if (code->label1->value != code->label3->value) 1539 tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, 1540 se.expr, zero); 1541 else 1542 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1543 se.expr, zero); 1544 1545 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1546 tmp, branch1, branch2); 1547 } 1548 else 1549 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); 1550 1551 if (code->label1->value != code->label3->value 1552 && code->label2->value != code->label3->value) 1553 { 1554 /* if (cond <= 0) take branch1 else take branch2. */ 1555 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); 1556 tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, 1557 se.expr, zero); 1558 branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1559 tmp, branch1, branch2); 1560 } 1561 1562 /* Append the COND_EXPR to the evaluation of COND, and return. */ 1563 gfc_add_expr_to_block (&se.pre, branch1); 1564 return gfc_finish_block (&se.pre); 1565 } 1566 1567 1568 /* Translate a CRITICAL block. */ 1569 tree 1570 gfc_trans_critical (gfc_code *code) 1571 { 1572 stmtblock_t block; 1573 tree tmp, token = NULL_TREE; 1574 1575 gfc_start_block (&block); 1576 1577 if (flag_coarray == GFC_FCOARRAY_LIB) 1578 { 1579 token = gfc_get_symbol_decl (code->resolved_sym); 1580 token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); 1581 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, 1582 token, integer_zero_node, integer_one_node, 1583 null_pointer_node, null_pointer_node, 1584 null_pointer_node, integer_zero_node); 1585 gfc_add_expr_to_block (&block, tmp); 1586 1587 /* It guarantees memory consistency within the same segment */ 1588 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1589 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1590 gfc_build_string_const (1, ""), 1591 NULL_TREE, NULL_TREE, 1592 tree_cons (NULL_TREE, tmp, NULL_TREE), 1593 NULL_TREE); 1594 ASM_VOLATILE_P (tmp) = 1; 1595 1596 gfc_add_expr_to_block (&block, tmp); 1597 } 1598 1599 tmp = gfc_trans_code (code->block->next); 1600 gfc_add_expr_to_block (&block, tmp); 1601 1602 if (flag_coarray == GFC_FCOARRAY_LIB) 1603 { 1604 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, 1605 token, integer_zero_node, integer_one_node, 1606 null_pointer_node, null_pointer_node, 1607 integer_zero_node); 1608 gfc_add_expr_to_block (&block, tmp); 1609 1610 /* It guarantees memory consistency within the same segment */ 1611 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1612 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1613 gfc_build_string_const (1, ""), 1614 NULL_TREE, NULL_TREE, 1615 tree_cons (NULL_TREE, tmp, NULL_TREE), 1616 NULL_TREE); 1617 ASM_VOLATILE_P (tmp) = 1; 1618 1619 gfc_add_expr_to_block (&block, tmp); 1620 } 1621 1622 return gfc_finish_block (&block); 1623 } 1624 1625 1626 /* Return true, when the class has a _len component. */ 1627 1628 static bool 1629 class_has_len_component (gfc_symbol *sym) 1630 { 1631 gfc_component *comp = sym->ts.u.derived->components; 1632 while (comp) 1633 { 1634 if (strcmp (comp->name, "_len") == 0) 1635 return true; 1636 comp = comp->next; 1637 } 1638 return false; 1639 } 1640 1641 1642 /* Do proper initialization for ASSOCIATE names. */ 1643 1644 static void 1645 trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) 1646 { 1647 gfc_expr *e; 1648 tree tmp; 1649 bool class_target; 1650 bool unlimited; 1651 tree desc; 1652 tree offset; 1653 tree dim; 1654 int n; 1655 tree charlen; 1656 bool need_len_assign; 1657 bool whole_array = true; 1658 gfc_ref *ref; 1659 1660 gcc_assert (sym->assoc); 1661 e = sym->assoc->target; 1662 1663 class_target = (e->expr_type == EXPR_VARIABLE) 1664 && (gfc_is_class_scalar_expr (e) 1665 || gfc_is_class_array_ref (e, NULL)); 1666 1667 unlimited = UNLIMITED_POLY (e); 1668 1669 for (ref = e->ref; ref; ref = ref->next) 1670 if (ref->type == REF_ARRAY 1671 && ref->u.ar.type == AR_FULL 1672 && ref->next) 1673 { 1674 whole_array = false; 1675 break; 1676 } 1677 1678 /* Assignments to the string length need to be generated, when 1679 ( sym is a char array or 1680 sym has a _len component) 1681 and the associated expression is unlimited polymorphic, which is 1682 not (yet) correctly in 'unlimited', because for an already associated 1683 BT_DERIVED the u-poly flag is not set, i.e., 1684 __tmp_CHARACTER_0_1 => w => arg 1685 ^ generated temp ^ from code, the w does not have the u-poly 1686 flag set, where UNLIMITED_POLY(e) expects it. */ 1687 need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED 1688 && e->ts.u.derived->attr.unlimited_polymorphic)) 1689 && (sym->ts.type == BT_CHARACTER 1690 || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) 1691 && class_has_len_component (sym)))); 1692 /* Do a `pointer assignment' with updated descriptor (or assign descriptor 1693 to array temporary) for arrays with either unknown shape or if associating 1694 to a variable. */ 1695 if (sym->attr.dimension && !class_target 1696 && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) 1697 { 1698 gfc_se se; 1699 tree desc; 1700 bool cst_array_ctor; 1701 1702 desc = sym->backend_decl; 1703 cst_array_ctor = e->expr_type == EXPR_ARRAY 1704 && gfc_constant_array_constructor_p (e->value.constructor) 1705 && e->ts.type != BT_CHARACTER; 1706 1707 /* If association is to an expression, evaluate it and create temporary. 1708 Otherwise, get descriptor of target for pointer assignment. */ 1709 gfc_init_se (&se, NULL); 1710 1711 if (sym->assoc->variable || cst_array_ctor) 1712 { 1713 se.direct_byref = 1; 1714 se.use_offset = 1; 1715 se.expr = desc; 1716 GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; 1717 } 1718 1719 gfc_conv_expr_descriptor (&se, e); 1720 1721 if (sym->ts.type == BT_CHARACTER 1722 && !se.direct_byref && sym->ts.deferred 1723 && !sym->attr.select_type_temporary 1724 && VAR_P (sym->ts.u.cl->backend_decl) 1725 && se.string_length != sym->ts.u.cl->backend_decl) 1726 { 1727 gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, 1728 fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), 1729 se.string_length)); 1730 } 1731 1732 /* If we didn't already do the pointer assignment, set associate-name 1733 descriptor to the one generated for the temporary. */ 1734 if ((!sym->assoc->variable && !cst_array_ctor) 1735 || !whole_array) 1736 { 1737 int dim; 1738 1739 if (whole_array) 1740 gfc_add_modify (&se.pre, desc, se.expr); 1741 1742 /* The generated descriptor has lower bound zero (as array 1743 temporary), shift bounds so we get lower bounds of 1. */ 1744 for (dim = 0; dim < e->rank; ++dim) 1745 gfc_conv_shift_descriptor_lbound (&se.pre, desc, 1746 dim, gfc_index_one_node); 1747 } 1748 1749 /* If this is a subreference array pointer associate name use the 1750 associate variable element size for the value of 'span'. */ 1751 if (sym->attr.subref_array_pointer && !se.direct_byref) 1752 { 1753 gcc_assert (e->expr_type == EXPR_VARIABLE); 1754 tmp = gfc_get_array_span (se.expr, e); 1755 1756 gfc_conv_descriptor_span_set (&se.pre, desc, tmp); 1757 } 1758 1759 if (e->expr_type == EXPR_FUNCTION 1760 && sym->ts.type == BT_DERIVED 1761 && sym->ts.u.derived 1762 && sym->ts.u.derived->attr.pdt_type) 1763 { 1764 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr, 1765 sym->as->rank); 1766 gfc_add_expr_to_block (&se.post, tmp); 1767 } 1768 1769 /* Done, register stuff as init / cleanup code. */ 1770 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), 1771 gfc_finish_block (&se.post)); 1772 } 1773 1774 /* Temporaries, arising from TYPE IS, just need the descriptor of class 1775 arrays to be assigned directly. */ 1776 else if (class_target && sym->attr.dimension 1777 && (sym->ts.type == BT_DERIVED || unlimited)) 1778 { 1779 gfc_se se; 1780 1781 gfc_init_se (&se, NULL); 1782 se.descriptor_only = 1; 1783 /* In a select type the (temporary) associate variable shall point to 1784 a standard fortran array (lower bound == 1), but conv_expr () 1785 just maps to the input array in the class object, whose lbound may 1786 be arbitrary. conv_expr_descriptor solves this by inserting a 1787 temporary array descriptor. */ 1788 gfc_conv_expr_descriptor (&se, e); 1789 1790 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) 1791 || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); 1792 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); 1793 1794 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) 1795 { 1796 if (INDIRECT_REF_P (se.expr)) 1797 tmp = TREE_OPERAND (se.expr, 0); 1798 else 1799 tmp = se.expr; 1800 1801 gfc_add_modify (&se.pre, sym->backend_decl, 1802 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); 1803 } 1804 else 1805 gfc_add_modify (&se.pre, sym->backend_decl, se.expr); 1806 1807 if (unlimited) 1808 { 1809 /* Recover the dtype, which has been overwritten by the 1810 assignment from an unlimited polymorphic object. */ 1811 tmp = gfc_conv_descriptor_dtype (sym->backend_decl); 1812 gfc_add_modify (&se.pre, tmp, 1813 gfc_get_dtype (TREE_TYPE (sym->backend_decl))); 1814 } 1815 1816 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), 1817 gfc_finish_block (&se.post)); 1818 } 1819 1820 /* Do a scalar pointer assignment; this is for scalar variable targets. */ 1821 else if (gfc_is_associate_pointer (sym)) 1822 { 1823 gfc_se se; 1824 1825 gcc_assert (!sym->attr.dimension); 1826 1827 gfc_init_se (&se, NULL); 1828 1829 /* Class associate-names come this way because they are 1830 unconditionally associate pointers and the symbol is scalar. */ 1831 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) 1832 { 1833 tree target_expr; 1834 /* For a class array we need a descriptor for the selector. */ 1835 gfc_conv_expr_descriptor (&se, e); 1836 /* Needed to get/set the _len component below. */ 1837 target_expr = se.expr; 1838 1839 /* Obtain a temporary class container for the result. */ 1840 gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false); 1841 se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 1842 1843 /* Set the offset. */ 1844 desc = gfc_class_data_get (se.expr); 1845 offset = gfc_index_zero_node; 1846 for (n = 0; n < e->rank; n++) 1847 { 1848 dim = gfc_rank_cst[n]; 1849 tmp = fold_build2_loc (input_location, MULT_EXPR, 1850 gfc_array_index_type, 1851 gfc_conv_descriptor_stride_get (desc, dim), 1852 gfc_conv_descriptor_lbound_get (desc, dim)); 1853 offset = fold_build2_loc (input_location, MINUS_EXPR, 1854 gfc_array_index_type, 1855 offset, tmp); 1856 } 1857 if (need_len_assign) 1858 { 1859 if (e->symtree 1860 && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) 1861 && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl) 1862 && TREE_CODE (target_expr) != COMPONENT_REF) 1863 /* Use the original class descriptor stored in the saved 1864 descriptor to get the target_expr. */ 1865 target_expr = 1866 GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); 1867 else 1868 /* Strip the _data component from the target_expr. */ 1869 target_expr = TREE_OPERAND (target_expr, 0); 1870 /* Add a reference to the _len comp to the target expr. */ 1871 tmp = gfc_class_len_get (target_expr); 1872 /* Get the component-ref for the temp structure's _len comp. */ 1873 charlen = gfc_class_len_get (se.expr); 1874 /* Add the assign to the beginning of the block... */ 1875 gfc_add_modify (&se.pre, charlen, 1876 fold_convert (TREE_TYPE (charlen), tmp)); 1877 /* and the oposite way at the end of the block, to hand changes 1878 on the string length back. */ 1879 gfc_add_modify (&se.post, tmp, 1880 fold_convert (TREE_TYPE (tmp), charlen)); 1881 /* Length assignment done, prevent adding it again below. */ 1882 need_len_assign = false; 1883 } 1884 gfc_conv_descriptor_offset_set (&se.pre, desc, offset); 1885 } 1886 else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS 1887 && CLASS_DATA (e)->attr.dimension) 1888 { 1889 /* This is bound to be a class array element. */ 1890 gfc_conv_expr_reference (&se, e); 1891 /* Get the _vptr component of the class object. */ 1892 tmp = gfc_get_vptr_from_expr (se.expr); 1893 /* Obtain a temporary class container for the result. */ 1894 gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); 1895 se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 1896 } 1897 else 1898 { 1899 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign, 1900 which has the string length included. For CHARACTERS it is still 1901 needed and will be done at the end of this routine. */ 1902 gfc_conv_expr (&se, e); 1903 need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER; 1904 } 1905 1906 if (sym->ts.type == BT_CHARACTER 1907 && !sym->attr.select_type_temporary 1908 && VAR_P (sym->ts.u.cl->backend_decl) 1909 && se.string_length != sym->ts.u.cl->backend_decl) 1910 { 1911 gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, 1912 fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), 1913 se.string_length)); 1914 if (e->expr_type == EXPR_FUNCTION) 1915 { 1916 tmp = gfc_call_free (sym->backend_decl); 1917 gfc_add_expr_to_block (&se.post, tmp); 1918 } 1919 } 1920 1921 if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER 1922 && POINTER_TYPE_P (TREE_TYPE (se.expr))) 1923 { 1924 /* These are pointer types already. */ 1925 tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr); 1926 } 1927 else 1928 { 1929 tmp = TREE_TYPE (sym->backend_decl); 1930 tmp = gfc_build_addr_expr (tmp, se.expr); 1931 } 1932 1933 gfc_add_modify (&se.pre, sym->backend_decl, tmp); 1934 1935 gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), 1936 gfc_finish_block (&se.post)); 1937 } 1938 1939 /* Do a simple assignment. This is for scalar expressions, where we 1940 can simply use expression assignment. */ 1941 else 1942 { 1943 gfc_expr *lhs; 1944 tree res; 1945 gfc_se se; 1946 1947 gfc_init_se (&se, NULL); 1948 1949 /* resolve.c converts some associate names to allocatable so that 1950 allocation can take place automatically in gfc_trans_assignment. 1951 The frontend prevents them from being either allocated, 1952 deallocated or reallocated. */ 1953 if (sym->attr.allocatable) 1954 { 1955 tmp = sym->backend_decl; 1956 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 1957 tmp = gfc_conv_descriptor_data_get (tmp); 1958 gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), 1959 null_pointer_node)); 1960 } 1961 1962 lhs = gfc_lval_expr_from_sym (sym); 1963 res = gfc_trans_assignment (lhs, e, false, true); 1964 gfc_add_expr_to_block (&se.pre, res); 1965 1966 tmp = sym->backend_decl; 1967 if (e->expr_type == EXPR_FUNCTION 1968 && sym->ts.type == BT_DERIVED 1969 && sym->ts.u.derived 1970 && sym->ts.u.derived->attr.pdt_type) 1971 { 1972 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp, 1973 0); 1974 } 1975 else if (e->expr_type == EXPR_FUNCTION 1976 && sym->ts.type == BT_CLASS 1977 && CLASS_DATA (sym)->ts.u.derived 1978 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) 1979 { 1980 tmp = gfc_class_data_get (tmp); 1981 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived, 1982 tmp, 0); 1983 } 1984 else if (sym->attr.allocatable) 1985 { 1986 tmp = sym->backend_decl; 1987 1988 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 1989 tmp = gfc_conv_descriptor_data_get (tmp); 1990 1991 /* A simple call to free suffices here. */ 1992 tmp = gfc_call_free (tmp); 1993 1994 /* Make sure that reallocation on assignment cannot occur. */ 1995 sym->attr.allocatable = 0; 1996 } 1997 else 1998 tmp = NULL_TREE; 1999 2000 res = gfc_finish_block (&se.pre); 2001 gfc_add_init_cleanup (block, res, tmp); 2002 gfc_free_expr (lhs); 2003 } 2004 2005 /* Set the stringlength, when needed. */ 2006 if (need_len_assign) 2007 { 2008 gfc_se se; 2009 gfc_init_se (&se, NULL); 2010 if (e->symtree->n.sym->ts.type == BT_CHARACTER) 2011 { 2012 /* Deferred strings are dealt with in the preceeding. */ 2013 gcc_assert (!e->symtree->n.sym->ts.deferred); 2014 tmp = e->symtree->n.sym->ts.u.cl->backend_decl; 2015 } 2016 else if (e->symtree->n.sym->attr.function 2017 && e->symtree->n.sym == e->symtree->n.sym->result) 2018 { 2019 tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); 2020 tmp = gfc_class_len_get (tmp); 2021 } 2022 else 2023 tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); 2024 gfc_get_symbol_decl (sym); 2025 charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl 2026 : gfc_class_len_get (sym->backend_decl); 2027 /* Prevent adding a noop len= len. */ 2028 if (tmp != charlen) 2029 { 2030 gfc_add_modify (&se.pre, charlen, 2031 fold_convert (TREE_TYPE (charlen), tmp)); 2032 gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), 2033 gfc_finish_block (&se.post)); 2034 } 2035 } 2036 } 2037 2038 2039 /* Translate a BLOCK construct. This is basically what we would do for a 2040 procedure body. */ 2041 2042 tree 2043 gfc_trans_block_construct (gfc_code* code) 2044 { 2045 gfc_namespace* ns; 2046 gfc_symbol* sym; 2047 gfc_wrapped_block block; 2048 tree exit_label; 2049 stmtblock_t body; 2050 gfc_association_list *ass; 2051 2052 ns = code->ext.block.ns; 2053 gcc_assert (ns); 2054 sym = ns->proc_name; 2055 gcc_assert (sym); 2056 2057 /* Process local variables. */ 2058 gcc_assert (!sym->tlink); 2059 sym->tlink = sym; 2060 gfc_process_block_locals (ns); 2061 2062 /* Generate code including exit-label. */ 2063 gfc_init_block (&body); 2064 exit_label = gfc_build_label_decl (NULL_TREE); 2065 code->exit_label = exit_label; 2066 2067 finish_oacc_declare (ns, sym, true); 2068 2069 gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); 2070 gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); 2071 2072 /* Finish everything. */ 2073 gfc_start_wrapped_block (&block, gfc_finish_block (&body)); 2074 gfc_trans_deferred_vars (sym, &block); 2075 for (ass = code->ext.block.assoc; ass; ass = ass->next) 2076 trans_associate_var (ass->st->n.sym, &block); 2077 2078 return gfc_finish_wrapped_block (&block); 2079 } 2080 2081 /* Translate the simple DO construct in a C-style manner. 2082 This is where the loop variable has integer type and step +-1. 2083 Following code will generate infinite loop in case where TO is INT_MAX 2084 (for +1 step) or INT_MIN (for -1 step) 2085 2086 We translate a do loop from: 2087 2088 DO dovar = from, to, step 2089 body 2090 END DO 2091 2092 to: 2093 2094 [Evaluate loop bounds and step] 2095 dovar = from; 2096 for (;;) 2097 { 2098 if (dovar > to) 2099 goto end_label; 2100 body; 2101 cycle_label: 2102 dovar += step; 2103 } 2104 end_label: 2105 2106 This helps the optimizers by avoiding the extra pre-header condition and 2107 we save a register as we just compare the updated IV (not a value in 2108 previous step). */ 2109 2110 static tree 2111 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, 2112 tree from, tree to, tree step, tree exit_cond) 2113 { 2114 stmtblock_t body; 2115 tree type; 2116 tree cond; 2117 tree tmp; 2118 tree saved_dovar = NULL; 2119 tree cycle_label; 2120 tree exit_label; 2121 location_t loc; 2122 type = TREE_TYPE (dovar); 2123 bool is_step_positive = tree_int_cst_sgn (step) > 0; 2124 2125 loc = code->ext.iterator->start->where.lb->location; 2126 2127 /* Initialize the DO variable: dovar = from. */ 2128 gfc_add_modify_loc (loc, pblock, dovar, 2129 fold_convert (TREE_TYPE (dovar), from)); 2130 2131 /* Save value for do-tinkering checking. */ 2132 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2133 { 2134 saved_dovar = gfc_create_var (type, ".saved_dovar"); 2135 gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); 2136 } 2137 2138 /* Cycle and exit statements are implemented with gotos. */ 2139 cycle_label = gfc_build_label_decl (NULL_TREE); 2140 exit_label = gfc_build_label_decl (NULL_TREE); 2141 2142 /* Put the labels where they can be found later. See gfc_trans_do(). */ 2143 code->cycle_label = cycle_label; 2144 code->exit_label = exit_label; 2145 2146 /* Loop body. */ 2147 gfc_start_block (&body); 2148 2149 /* Exit the loop if there is an I/O result condition or error. */ 2150 if (exit_cond) 2151 { 2152 tmp = build1_v (GOTO_EXPR, exit_label); 2153 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, 2154 exit_cond, tmp, 2155 build_empty_stmt (loc)); 2156 gfc_add_expr_to_block (&body, tmp); 2157 } 2158 2159 /* Evaluate the loop condition. */ 2160 if (is_step_positive) 2161 cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar, 2162 fold_convert (type, to)); 2163 else 2164 cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar, 2165 fold_convert (type, to)); 2166 2167 cond = gfc_evaluate_now_loc (loc, cond, &body); 2168 if (code->ext.iterator->unroll && cond != error_mark_node) 2169 cond 2170 = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2171 build_int_cst (integer_type_node, annot_expr_unroll_kind), 2172 build_int_cst (integer_type_node, code->ext.iterator->unroll)); 2173 2174 if (code->ext.iterator->ivdep && cond != error_mark_node) 2175 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2176 build_int_cst (integer_type_node, annot_expr_ivdep_kind), 2177 integer_zero_node); 2178 if (code->ext.iterator->vector && cond != error_mark_node) 2179 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2180 build_int_cst (integer_type_node, annot_expr_vector_kind), 2181 integer_zero_node); 2182 if (code->ext.iterator->novector && cond != error_mark_node) 2183 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2184 build_int_cst (integer_type_node, annot_expr_no_vector_kind), 2185 integer_zero_node); 2186 2187 /* The loop exit. */ 2188 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); 2189 TREE_USED (exit_label) = 1; 2190 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, 2191 cond, tmp, build_empty_stmt (loc)); 2192 gfc_add_expr_to_block (&body, tmp); 2193 2194 /* Check whether the induction variable is equal to INT_MAX 2195 (respectively to INT_MIN). */ 2196 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2197 { 2198 tree boundary = is_step_positive ? TYPE_MAX_VALUE (type) 2199 : TYPE_MIN_VALUE (type); 2200 2201 tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node, 2202 dovar, boundary); 2203 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, 2204 "Loop iterates infinitely"); 2205 } 2206 2207 /* Main loop body. */ 2208 tmp = gfc_trans_code_cond (code->block->next, exit_cond); 2209 gfc_add_expr_to_block (&body, tmp); 2210 2211 /* Label for cycle statements (if needed). */ 2212 if (TREE_USED (cycle_label)) 2213 { 2214 tmp = build1_v (LABEL_EXPR, cycle_label); 2215 gfc_add_expr_to_block (&body, tmp); 2216 } 2217 2218 /* Check whether someone has modified the loop variable. */ 2219 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2220 { 2221 tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, 2222 dovar, saved_dovar); 2223 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, 2224 "Loop variable has been modified"); 2225 } 2226 2227 /* Increment the loop variable. */ 2228 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); 2229 gfc_add_modify_loc (loc, &body, dovar, tmp); 2230 2231 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2232 gfc_add_modify_loc (loc, &body, saved_dovar, dovar); 2233 2234 /* Finish the loop body. */ 2235 tmp = gfc_finish_block (&body); 2236 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); 2237 2238 gfc_add_expr_to_block (pblock, tmp); 2239 2240 /* Add the exit label. */ 2241 tmp = build1_v (LABEL_EXPR, exit_label); 2242 gfc_add_expr_to_block (pblock, tmp); 2243 2244 return gfc_finish_block (pblock); 2245 } 2246 2247 /* Translate the DO construct. This obviously is one of the most 2248 important ones to get right with any compiler, but especially 2249 so for Fortran. 2250 2251 We special case some loop forms as described in gfc_trans_simple_do. 2252 For other cases we implement them with a separate loop count, 2253 as described in the standard. 2254 2255 We translate a do loop from: 2256 2257 DO dovar = from, to, step 2258 body 2259 END DO 2260 2261 to: 2262 2263 [evaluate loop bounds and step] 2264 empty = (step > 0 ? to < from : to > from); 2265 countm1 = (to - from) / step; 2266 dovar = from; 2267 if (empty) goto exit_label; 2268 for (;;) 2269 { 2270 body; 2271 cycle_label: 2272 dovar += step 2273 countm1t = countm1; 2274 countm1--; 2275 if (countm1t == 0) goto exit_label; 2276 } 2277 exit_label: 2278 2279 countm1 is an unsigned integer. It is equal to the loop count minus one, 2280 because the loop count itself can overflow. */ 2281 2282 tree 2283 gfc_trans_do (gfc_code * code, tree exit_cond) 2284 { 2285 gfc_se se; 2286 tree dovar; 2287 tree saved_dovar = NULL; 2288 tree from; 2289 tree to; 2290 tree step; 2291 tree countm1; 2292 tree type; 2293 tree utype; 2294 tree cond; 2295 tree cycle_label; 2296 tree exit_label; 2297 tree tmp; 2298 stmtblock_t block; 2299 stmtblock_t body; 2300 location_t loc; 2301 2302 gfc_start_block (&block); 2303 2304 loc = code->ext.iterator->start->where.lb->location; 2305 2306 /* Evaluate all the expressions in the iterator. */ 2307 gfc_init_se (&se, NULL); 2308 gfc_conv_expr_lhs (&se, code->ext.iterator->var); 2309 gfc_add_block_to_block (&block, &se.pre); 2310 dovar = se.expr; 2311 type = TREE_TYPE (dovar); 2312 2313 gfc_init_se (&se, NULL); 2314 gfc_conv_expr_val (&se, code->ext.iterator->start); 2315 gfc_add_block_to_block (&block, &se.pre); 2316 from = gfc_evaluate_now (se.expr, &block); 2317 2318 gfc_init_se (&se, NULL); 2319 gfc_conv_expr_val (&se, code->ext.iterator->end); 2320 gfc_add_block_to_block (&block, &se.pre); 2321 to = gfc_evaluate_now (se.expr, &block); 2322 2323 gfc_init_se (&se, NULL); 2324 gfc_conv_expr_val (&se, code->ext.iterator->step); 2325 gfc_add_block_to_block (&block, &se.pre); 2326 step = gfc_evaluate_now (se.expr, &block); 2327 2328 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2329 { 2330 tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step, 2331 build_zero_cst (type)); 2332 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, 2333 "DO step value is zero"); 2334 } 2335 2336 /* Special case simple loops. */ 2337 if (TREE_CODE (type) == INTEGER_TYPE 2338 && (integer_onep (step) 2339 || tree_int_cst_equal (step, integer_minus_one_node))) 2340 return gfc_trans_simple_do (code, &block, dovar, from, to, step, 2341 exit_cond); 2342 2343 if (TREE_CODE (type) == INTEGER_TYPE) 2344 utype = unsigned_type_for (type); 2345 else 2346 utype = unsigned_type_for (gfc_array_index_type); 2347 countm1 = gfc_create_var (utype, "countm1"); 2348 2349 /* Cycle and exit statements are implemented with gotos. */ 2350 cycle_label = gfc_build_label_decl (NULL_TREE); 2351 exit_label = gfc_build_label_decl (NULL_TREE); 2352 TREE_USED (exit_label) = 1; 2353 2354 /* Put these labels where they can be found later. */ 2355 code->cycle_label = cycle_label; 2356 code->exit_label = exit_label; 2357 2358 /* Initialize the DO variable: dovar = from. */ 2359 gfc_add_modify (&block, dovar, from); 2360 2361 /* Save value for do-tinkering checking. */ 2362 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2363 { 2364 saved_dovar = gfc_create_var (type, ".saved_dovar"); 2365 gfc_add_modify_loc (loc, &block, saved_dovar, dovar); 2366 } 2367 2368 /* Initialize loop count and jump to exit label if the loop is empty. 2369 This code is executed before we enter the loop body. We generate: 2370 if (step > 0) 2371 { 2372 countm1 = (to - from) / step; 2373 if (to < from) 2374 goto exit_label; 2375 } 2376 else 2377 { 2378 countm1 = (from - to) / -step; 2379 if (to > from) 2380 goto exit_label; 2381 } 2382 */ 2383 2384 if (TREE_CODE (type) == INTEGER_TYPE) 2385 { 2386 tree pos, neg, tou, fromu, stepu, tmp2; 2387 2388 /* The distance from FROM to TO cannot always be represented in a signed 2389 type, thus use unsigned arithmetic, also to avoid any undefined 2390 overflow issues. */ 2391 tou = fold_convert (utype, to); 2392 fromu = fold_convert (utype, from); 2393 stepu = fold_convert (utype, step); 2394 2395 /* For a positive step, when to < from, exit, otherwise compute 2396 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */ 2397 tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from); 2398 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, 2399 fold_build2_loc (loc, MINUS_EXPR, utype, 2400 tou, fromu), 2401 stepu); 2402 pos = build2 (COMPOUND_EXPR, void_type_node, 2403 fold_build2 (MODIFY_EXPR, void_type_node, 2404 countm1, tmp2), 2405 build3_loc (loc, COND_EXPR, void_type_node, 2406 gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), 2407 build1_loc (loc, GOTO_EXPR, void_type_node, 2408 exit_label), NULL_TREE)); 2409 2410 /* For a negative step, when to > from, exit, otherwise compute 2411 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */ 2412 tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from); 2413 tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, 2414 fold_build2_loc (loc, MINUS_EXPR, utype, 2415 fromu, tou), 2416 fold_build1_loc (loc, NEGATE_EXPR, utype, stepu)); 2417 neg = build2 (COMPOUND_EXPR, void_type_node, 2418 fold_build2 (MODIFY_EXPR, void_type_node, 2419 countm1, tmp2), 2420 build3_loc (loc, COND_EXPR, void_type_node, 2421 gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), 2422 build1_loc (loc, GOTO_EXPR, void_type_node, 2423 exit_label), NULL_TREE)); 2424 2425 tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step, 2426 build_int_cst (TREE_TYPE (step), 0)); 2427 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos); 2428 2429 gfc_add_expr_to_block (&block, tmp); 2430 } 2431 else 2432 { 2433 tree pos_step; 2434 2435 /* TODO: We could use the same width as the real type. 2436 This would probably cause more problems that it solves 2437 when we implement "long double" types. */ 2438 2439 tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); 2440 tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); 2441 tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); 2442 gfc_add_modify (&block, countm1, tmp); 2443 2444 /* We need a special check for empty loops: 2445 empty = (step > 0 ? to < from : to > from); */ 2446 pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step, 2447 build_zero_cst (type)); 2448 tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step, 2449 fold_build2_loc (loc, LT_EXPR, 2450 logical_type_node, to, from), 2451 fold_build2_loc (loc, GT_EXPR, 2452 logical_type_node, to, from)); 2453 /* If the loop is empty, go directly to the exit label. */ 2454 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, 2455 build1_v (GOTO_EXPR, exit_label), 2456 build_empty_stmt (input_location)); 2457 gfc_add_expr_to_block (&block, tmp); 2458 } 2459 2460 /* Loop body. */ 2461 gfc_start_block (&body); 2462 2463 /* Main loop body. */ 2464 tmp = gfc_trans_code_cond (code->block->next, exit_cond); 2465 gfc_add_expr_to_block (&body, tmp); 2466 2467 /* Label for cycle statements (if needed). */ 2468 if (TREE_USED (cycle_label)) 2469 { 2470 tmp = build1_v (LABEL_EXPR, cycle_label); 2471 gfc_add_expr_to_block (&body, tmp); 2472 } 2473 2474 /* Check whether someone has modified the loop variable. */ 2475 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2476 { 2477 tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, 2478 saved_dovar); 2479 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, 2480 "Loop variable has been modified"); 2481 } 2482 2483 /* Exit the loop if there is an I/O result condition or error. */ 2484 if (exit_cond) 2485 { 2486 tmp = build1_v (GOTO_EXPR, exit_label); 2487 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, 2488 exit_cond, tmp, 2489 build_empty_stmt (input_location)); 2490 gfc_add_expr_to_block (&body, tmp); 2491 } 2492 2493 /* Increment the loop variable. */ 2494 tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); 2495 gfc_add_modify_loc (loc, &body, dovar, tmp); 2496 2497 if (gfc_option.rtcheck & GFC_RTCHECK_DO) 2498 gfc_add_modify_loc (loc, &body, saved_dovar, dovar); 2499 2500 /* Initialize countm1t. */ 2501 tree countm1t = gfc_create_var (utype, "countm1t"); 2502 gfc_add_modify_loc (loc, &body, countm1t, countm1); 2503 2504 /* Decrement the loop count. */ 2505 tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, 2506 build_int_cst (utype, 1)); 2507 gfc_add_modify_loc (loc, &body, countm1, tmp); 2508 2509 /* End with the loop condition. Loop until countm1t == 0. */ 2510 cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t, 2511 build_int_cst (utype, 0)); 2512 if (code->ext.iterator->unroll && cond != error_mark_node) 2513 cond 2514 = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2515 build_int_cst (integer_type_node, annot_expr_unroll_kind), 2516 build_int_cst (integer_type_node, code->ext.iterator->unroll)); 2517 2518 if (code->ext.iterator->ivdep && cond != error_mark_node) 2519 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2520 build_int_cst (integer_type_node, annot_expr_ivdep_kind), 2521 integer_zero_node); 2522 if (code->ext.iterator->vector && cond != error_mark_node) 2523 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2524 build_int_cst (integer_type_node, annot_expr_vector_kind), 2525 integer_zero_node); 2526 if (code->ext.iterator->novector && cond != error_mark_node) 2527 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 2528 build_int_cst (integer_type_node, annot_expr_no_vector_kind), 2529 integer_zero_node); 2530 2531 tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); 2532 tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, 2533 cond, tmp, build_empty_stmt (loc)); 2534 gfc_add_expr_to_block (&body, tmp); 2535 2536 /* End of loop body. */ 2537 tmp = gfc_finish_block (&body); 2538 2539 /* The for loop itself. */ 2540 tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); 2541 gfc_add_expr_to_block (&block, tmp); 2542 2543 /* Add the exit label. */ 2544 tmp = build1_v (LABEL_EXPR, exit_label); 2545 gfc_add_expr_to_block (&block, tmp); 2546 2547 return gfc_finish_block (&block); 2548 } 2549 2550 2551 /* Translate the DO WHILE construct. 2552 2553 We translate 2554 2555 DO WHILE (cond) 2556 body 2557 END DO 2558 2559 to: 2560 2561 for ( ; ; ) 2562 { 2563 pre_cond; 2564 if (! cond) goto exit_label; 2565 body; 2566 cycle_label: 2567 } 2568 exit_label: 2569 2570 Because the evaluation of the exit condition `cond' may have side 2571 effects, we can't do much for empty loop bodies. The backend optimizers 2572 should be smart enough to eliminate any dead loops. */ 2573 2574 tree 2575 gfc_trans_do_while (gfc_code * code) 2576 { 2577 gfc_se cond; 2578 tree tmp; 2579 tree cycle_label; 2580 tree exit_label; 2581 stmtblock_t block; 2582 2583 /* Everything we build here is part of the loop body. */ 2584 gfc_start_block (&block); 2585 2586 /* Cycle and exit statements are implemented with gotos. */ 2587 cycle_label = gfc_build_label_decl (NULL_TREE); 2588 exit_label = gfc_build_label_decl (NULL_TREE); 2589 2590 /* Put the labels where they can be found later. See gfc_trans_do(). */ 2591 code->cycle_label = cycle_label; 2592 code->exit_label = exit_label; 2593 2594 /* Create a GIMPLE version of the exit condition. */ 2595 gfc_init_se (&cond, NULL); 2596 gfc_conv_expr_val (&cond, code->expr1); 2597 gfc_add_block_to_block (&block, &cond.pre); 2598 cond.expr = fold_build1_loc (code->expr1->where.lb->location, 2599 TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), cond.expr); 2600 2601 /* Build "IF (! cond) GOTO exit_label". */ 2602 tmp = build1_v (GOTO_EXPR, exit_label); 2603 TREE_USED (exit_label) = 1; 2604 tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR, 2605 void_type_node, cond.expr, tmp, 2606 build_empty_stmt (code->expr1->where.lb->location)); 2607 gfc_add_expr_to_block (&block, tmp); 2608 2609 /* The main body of the loop. */ 2610 tmp = gfc_trans_code (code->block->next); 2611 gfc_add_expr_to_block (&block, tmp); 2612 2613 /* Label for cycle statements (if needed). */ 2614 if (TREE_USED (cycle_label)) 2615 { 2616 tmp = build1_v (LABEL_EXPR, cycle_label); 2617 gfc_add_expr_to_block (&block, tmp); 2618 } 2619 2620 /* End of loop body. */ 2621 tmp = gfc_finish_block (&block); 2622 2623 gfc_init_block (&block); 2624 /* Build the loop. */ 2625 tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR, 2626 void_type_node, tmp); 2627 gfc_add_expr_to_block (&block, tmp); 2628 2629 /* Add the exit label. */ 2630 tmp = build1_v (LABEL_EXPR, exit_label); 2631 gfc_add_expr_to_block (&block, tmp); 2632 2633 return gfc_finish_block (&block); 2634 } 2635 2636 2637 /* Deal with the particular case of SELECT_TYPE, where the vtable 2638 addresses are used for the selection. Since these are not sorted, 2639 the selection has to be made by a series of if statements. */ 2640 2641 static tree 2642 gfc_trans_select_type_cases (gfc_code * code) 2643 { 2644 gfc_code *c; 2645 gfc_case *cp; 2646 tree tmp; 2647 tree cond; 2648 tree low; 2649 tree high; 2650 gfc_se se; 2651 gfc_se cse; 2652 stmtblock_t block; 2653 stmtblock_t body; 2654 bool def = false; 2655 gfc_expr *e; 2656 gfc_start_block (&block); 2657 2658 /* Calculate the switch expression. */ 2659 gfc_init_se (&se, NULL); 2660 gfc_conv_expr_val (&se, code->expr1); 2661 gfc_add_block_to_block (&block, &se.pre); 2662 2663 /* Generate an expression for the selector hash value, for 2664 use to resolve character cases. */ 2665 e = gfc_copy_expr (code->expr1->value.function.actual->expr); 2666 gfc_add_hash_component (e); 2667 2668 TREE_USED (code->exit_label) = 0; 2669 2670 repeat: 2671 for (c = code->block; c; c = c->block) 2672 { 2673 cp = c->ext.block.case_list; 2674 2675 /* Assume it's the default case. */ 2676 low = NULL_TREE; 2677 high = NULL_TREE; 2678 tmp = NULL_TREE; 2679 2680 /* Put the default case at the end. */ 2681 if ((!def && !cp->low) || (def && cp->low)) 2682 continue; 2683 2684 if (cp->low && (cp->ts.type == BT_CLASS 2685 || cp->ts.type == BT_DERIVED)) 2686 { 2687 gfc_init_se (&cse, NULL); 2688 gfc_conv_expr_val (&cse, cp->low); 2689 gfc_add_block_to_block (&block, &cse.pre); 2690 low = cse.expr; 2691 } 2692 else if (cp->ts.type != BT_UNKNOWN) 2693 { 2694 gcc_assert (cp->high); 2695 gfc_init_se (&cse, NULL); 2696 gfc_conv_expr_val (&cse, cp->high); 2697 gfc_add_block_to_block (&block, &cse.pre); 2698 high = cse.expr; 2699 } 2700 2701 gfc_init_block (&body); 2702 2703 /* Add the statements for this case. */ 2704 tmp = gfc_trans_code (c->next); 2705 gfc_add_expr_to_block (&body, tmp); 2706 2707 /* Break to the end of the SELECT TYPE construct. The default 2708 case just falls through. */ 2709 if (!def) 2710 { 2711 TREE_USED (code->exit_label) = 1; 2712 tmp = build1_v (GOTO_EXPR, code->exit_label); 2713 gfc_add_expr_to_block (&body, tmp); 2714 } 2715 2716 tmp = gfc_finish_block (&body); 2717 2718 if (low != NULL_TREE) 2719 { 2720 /* Compare vtable pointers. */ 2721 cond = fold_build2_loc (input_location, EQ_EXPR, 2722 TREE_TYPE (se.expr), se.expr, low); 2723 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 2724 cond, tmp, 2725 build_empty_stmt (input_location)); 2726 } 2727 else if (high != NULL_TREE) 2728 { 2729 /* Compare hash values for character cases. */ 2730 gfc_init_se (&cse, NULL); 2731 gfc_conv_expr_val (&cse, e); 2732 gfc_add_block_to_block (&block, &cse.pre); 2733 2734 cond = fold_build2_loc (input_location, EQ_EXPR, 2735 TREE_TYPE (se.expr), high, cse.expr); 2736 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 2737 cond, tmp, 2738 build_empty_stmt (input_location)); 2739 } 2740 2741 gfc_add_expr_to_block (&block, tmp); 2742 } 2743 2744 if (!def) 2745 { 2746 def = true; 2747 goto repeat; 2748 } 2749 2750 gfc_free_expr (e); 2751 2752 return gfc_finish_block (&block); 2753 } 2754 2755 2756 /* Translate the SELECT CASE construct for INTEGER case expressions, 2757 without killing all potential optimizations. The problem is that 2758 Fortran allows unbounded cases, but the back-end does not, so we 2759 need to intercept those before we enter the equivalent SWITCH_EXPR 2760 we can build. 2761 2762 For example, we translate this, 2763 2764 SELECT CASE (expr) 2765 CASE (:100,101,105:115) 2766 block_1 2767 CASE (190:199,200:) 2768 block_2 2769 CASE (300) 2770 block_3 2771 CASE DEFAULT 2772 block_4 2773 END SELECT 2774 2775 to the GENERIC equivalent, 2776 2777 switch (expr) 2778 { 2779 case (minimum value for typeof(expr) ... 100: 2780 case 101: 2781 case 105 ... 114: 2782 block1: 2783 goto end_label; 2784 2785 case 200 ... (maximum value for typeof(expr): 2786 case 190 ... 199: 2787 block2; 2788 goto end_label; 2789 2790 case 300: 2791 block_3; 2792 goto end_label; 2793 2794 default: 2795 block_4; 2796 goto end_label; 2797 } 2798 2799 end_label: */ 2800 2801 static tree 2802 gfc_trans_integer_select (gfc_code * code) 2803 { 2804 gfc_code *c; 2805 gfc_case *cp; 2806 tree end_label; 2807 tree tmp; 2808 gfc_se se; 2809 stmtblock_t block; 2810 stmtblock_t body; 2811 2812 gfc_start_block (&block); 2813 2814 /* Calculate the switch expression. */ 2815 gfc_init_se (&se, NULL); 2816 gfc_conv_expr_val (&se, code->expr1); 2817 gfc_add_block_to_block (&block, &se.pre); 2818 2819 end_label = gfc_build_label_decl (NULL_TREE); 2820 2821 gfc_init_block (&body); 2822 2823 for (c = code->block; c; c = c->block) 2824 { 2825 for (cp = c->ext.block.case_list; cp; cp = cp->next) 2826 { 2827 tree low, high; 2828 tree label; 2829 2830 /* Assume it's the default case. */ 2831 low = high = NULL_TREE; 2832 2833 if (cp->low) 2834 { 2835 low = gfc_conv_mpz_to_tree (cp->low->value.integer, 2836 cp->low->ts.kind); 2837 2838 /* If there's only a lower bound, set the high bound to the 2839 maximum value of the case expression. */ 2840 if (!cp->high) 2841 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); 2842 } 2843 2844 if (cp->high) 2845 { 2846 /* Three cases are possible here: 2847 2848 1) There is no lower bound, e.g. CASE (:N). 2849 2) There is a lower bound .NE. high bound, that is 2850 a case range, e.g. CASE (N:M) where M>N (we make 2851 sure that M>N during type resolution). 2852 3) There is a lower bound, and it has the same value 2853 as the high bound, e.g. CASE (N:N). This is our 2854 internal representation of CASE(N). 2855 2856 In the first and second case, we need to set a value for 2857 high. In the third case, we don't because the GCC middle 2858 end represents a single case value by just letting high be 2859 a NULL_TREE. We can't do that because we need to be able 2860 to represent unbounded cases. */ 2861 2862 if (!cp->low 2863 || (mpz_cmp (cp->low->value.integer, 2864 cp->high->value.integer) != 0)) 2865 high = gfc_conv_mpz_to_tree (cp->high->value.integer, 2866 cp->high->ts.kind); 2867 2868 /* Unbounded case. */ 2869 if (!cp->low) 2870 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); 2871 } 2872 2873 /* Build a label. */ 2874 label = gfc_build_label_decl (NULL_TREE); 2875 2876 /* Add this case label. 2877 Add parameter 'label', make it match GCC backend. */ 2878 tmp = build_case_label (low, high, label); 2879 gfc_add_expr_to_block (&body, tmp); 2880 } 2881 2882 /* Add the statements for this case. */ 2883 tmp = gfc_trans_code (c->next); 2884 gfc_add_expr_to_block (&body, tmp); 2885 2886 /* Break to the end of the construct. */ 2887 tmp = build1_v (GOTO_EXPR, end_label); 2888 gfc_add_expr_to_block (&body, tmp); 2889 } 2890 2891 tmp = gfc_finish_block (&body); 2892 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp); 2893 gfc_add_expr_to_block (&block, tmp); 2894 2895 tmp = build1_v (LABEL_EXPR, end_label); 2896 gfc_add_expr_to_block (&block, tmp); 2897 2898 return gfc_finish_block (&block); 2899 } 2900 2901 2902 /* Translate the SELECT CASE construct for LOGICAL case expressions. 2903 2904 There are only two cases possible here, even though the standard 2905 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., 2906 .FALSE., and DEFAULT. 2907 2908 We never generate more than two blocks here. Instead, we always 2909 try to eliminate the DEFAULT case. This way, we can translate this 2910 kind of SELECT construct to a simple 2911 2912 if {} else {}; 2913 2914 expression in GENERIC. */ 2915 2916 static tree 2917 gfc_trans_logical_select (gfc_code * code) 2918 { 2919 gfc_code *c; 2920 gfc_code *t, *f, *d; 2921 gfc_case *cp; 2922 gfc_se se; 2923 stmtblock_t block; 2924 2925 /* Assume we don't have any cases at all. */ 2926 t = f = d = NULL; 2927 2928 /* Now see which ones we actually do have. We can have at most two 2929 cases in a single case list: one for .TRUE. and one for .FALSE. 2930 The default case is always separate. If the cases for .TRUE. and 2931 .FALSE. are in the same case list, the block for that case list 2932 always executed, and we don't generate code a COND_EXPR. */ 2933 for (c = code->block; c; c = c->block) 2934 { 2935 for (cp = c->ext.block.case_list; cp; cp = cp->next) 2936 { 2937 if (cp->low) 2938 { 2939 if (cp->low->value.logical == 0) /* .FALSE. */ 2940 f = c; 2941 else /* if (cp->value.logical != 0), thus .TRUE. */ 2942 t = c; 2943 } 2944 else 2945 d = c; 2946 } 2947 } 2948 2949 /* Start a new block. */ 2950 gfc_start_block (&block); 2951 2952 /* Calculate the switch expression. We always need to do this 2953 because it may have side effects. */ 2954 gfc_init_se (&se, NULL); 2955 gfc_conv_expr_val (&se, code->expr1); 2956 gfc_add_block_to_block (&block, &se.pre); 2957 2958 if (t == f && t != NULL) 2959 { 2960 /* Cases for .TRUE. and .FALSE. are in the same block. Just 2961 translate the code for these cases, append it to the current 2962 block. */ 2963 gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); 2964 } 2965 else 2966 { 2967 tree true_tree, false_tree, stmt; 2968 2969 true_tree = build_empty_stmt (input_location); 2970 false_tree = build_empty_stmt (input_location); 2971 2972 /* If we have a case for .TRUE. and for .FALSE., discard the default case. 2973 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, 2974 make the missing case the default case. */ 2975 if (t != NULL && f != NULL) 2976 d = NULL; 2977 else if (d != NULL) 2978 { 2979 if (t == NULL) 2980 t = d; 2981 else 2982 f = d; 2983 } 2984 2985 /* Translate the code for each of these blocks, and append it to 2986 the current block. */ 2987 if (t != NULL) 2988 true_tree = gfc_trans_code (t->next); 2989 2990 if (f != NULL) 2991 false_tree = gfc_trans_code (f->next); 2992 2993 stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, 2994 se.expr, true_tree, false_tree); 2995 gfc_add_expr_to_block (&block, stmt); 2996 } 2997 2998 return gfc_finish_block (&block); 2999 } 3000 3001 3002 /* The jump table types are stored in static variables to avoid 3003 constructing them from scratch every single time. */ 3004 static GTY(()) tree select_struct[2]; 3005 3006 /* Translate the SELECT CASE construct for CHARACTER case expressions. 3007 Instead of generating compares and jumps, it is far simpler to 3008 generate a data structure describing the cases in order and call a 3009 library subroutine that locates the right case. 3010 This is particularly true because this is the only case where we 3011 might have to dispose of a temporary. 3012 The library subroutine returns a pointer to jump to or NULL if no 3013 branches are to be taken. */ 3014 3015 static tree 3016 gfc_trans_character_select (gfc_code *code) 3017 { 3018 tree init, end_label, tmp, type, case_num, label, fndecl; 3019 stmtblock_t block, body; 3020 gfc_case *cp, *d; 3021 gfc_code *c; 3022 gfc_se se, expr1se; 3023 int n, k; 3024 vec<constructor_elt, va_gc> *inits = NULL; 3025 3026 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); 3027 3028 /* The jump table types are stored in static variables to avoid 3029 constructing them from scratch every single time. */ 3030 static tree ss_string1[2], ss_string1_len[2]; 3031 static tree ss_string2[2], ss_string2_len[2]; 3032 static tree ss_target[2]; 3033 3034 cp = code->block->ext.block.case_list; 3035 while (cp->left != NULL) 3036 cp = cp->left; 3037 3038 /* Generate the body */ 3039 gfc_start_block (&block); 3040 gfc_init_se (&expr1se, NULL); 3041 gfc_conv_expr_reference (&expr1se, code->expr1); 3042 3043 gfc_add_block_to_block (&block, &expr1se.pre); 3044 3045 end_label = gfc_build_label_decl (NULL_TREE); 3046 3047 gfc_init_block (&body); 3048 3049 /* Attempt to optimize length 1 selects. */ 3050 if (integer_onep (expr1se.string_length)) 3051 { 3052 for (d = cp; d; d = d->right) 3053 { 3054 gfc_charlen_t i; 3055 if (d->low) 3056 { 3057 gcc_assert (d->low->expr_type == EXPR_CONSTANT 3058 && d->low->ts.type == BT_CHARACTER); 3059 if (d->low->value.character.length > 1) 3060 { 3061 for (i = 1; i < d->low->value.character.length; i++) 3062 if (d->low->value.character.string[i] != ' ') 3063 break; 3064 if (i != d->low->value.character.length) 3065 { 3066 if (optimize && d->high && i == 1) 3067 { 3068 gcc_assert (d->high->expr_type == EXPR_CONSTANT 3069 && d->high->ts.type == BT_CHARACTER); 3070 if (d->high->value.character.length > 1 3071 && (d->low->value.character.string[0] 3072 == d->high->value.character.string[0]) 3073 && d->high->value.character.string[1] != ' ' 3074 && ((d->low->value.character.string[1] < ' ') 3075 == (d->high->value.character.string[1] 3076 < ' '))) 3077 continue; 3078 } 3079 break; 3080 } 3081 } 3082 } 3083 if (d->high) 3084 { 3085 gcc_assert (d->high->expr_type == EXPR_CONSTANT 3086 && d->high->ts.type == BT_CHARACTER); 3087 if (d->high->value.character.length > 1) 3088 { 3089 for (i = 1; i < d->high->value.character.length; i++) 3090 if (d->high->value.character.string[i] != ' ') 3091 break; 3092 if (i != d->high->value.character.length) 3093 break; 3094 } 3095 } 3096 } 3097 if (d == NULL) 3098 { 3099 tree ctype = gfc_get_char_type (code->expr1->ts.kind); 3100 3101 for (c = code->block; c; c = c->block) 3102 { 3103 for (cp = c->ext.block.case_list; cp; cp = cp->next) 3104 { 3105 tree low, high; 3106 tree label; 3107 gfc_char_t r; 3108 3109 /* Assume it's the default case. */ 3110 low = high = NULL_TREE; 3111 3112 if (cp->low) 3113 { 3114 /* CASE ('ab') or CASE ('ab':'az') will never match 3115 any length 1 character. */ 3116 if (cp->low->value.character.length > 1 3117 && cp->low->value.character.string[1] != ' ') 3118 continue; 3119 3120 if (cp->low->value.character.length > 0) 3121 r = cp->low->value.character.string[0]; 3122 else 3123 r = ' '; 3124 low = build_int_cst (ctype, r); 3125 3126 /* If there's only a lower bound, set the high bound 3127 to the maximum value of the case expression. */ 3128 if (!cp->high) 3129 high = TYPE_MAX_VALUE (ctype); 3130 } 3131 3132 if (cp->high) 3133 { 3134 if (!cp->low 3135 || (cp->low->value.character.string[0] 3136 != cp->high->value.character.string[0])) 3137 { 3138 if (cp->high->value.character.length > 0) 3139 r = cp->high->value.character.string[0]; 3140 else 3141 r = ' '; 3142 high = build_int_cst (ctype, r); 3143 } 3144 3145 /* Unbounded case. */ 3146 if (!cp->low) 3147 low = TYPE_MIN_VALUE (ctype); 3148 } 3149 3150 /* Build a label. */ 3151 label = gfc_build_label_decl (NULL_TREE); 3152 3153 /* Add this case label. 3154 Add parameter 'label', make it match GCC backend. */ 3155 tmp = build_case_label (low, high, label); 3156 gfc_add_expr_to_block (&body, tmp); 3157 } 3158 3159 /* Add the statements for this case. */ 3160 tmp = gfc_trans_code (c->next); 3161 gfc_add_expr_to_block (&body, tmp); 3162 3163 /* Break to the end of the construct. */ 3164 tmp = build1_v (GOTO_EXPR, end_label); 3165 gfc_add_expr_to_block (&body, tmp); 3166 } 3167 3168 tmp = gfc_string_to_single_character (expr1se.string_length, 3169 expr1se.expr, 3170 code->expr1->ts.kind); 3171 case_num = gfc_create_var (ctype, "case_num"); 3172 gfc_add_modify (&block, case_num, tmp); 3173 3174 gfc_add_block_to_block (&block, &expr1se.post); 3175 3176 tmp = gfc_finish_block (&body); 3177 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, 3178 case_num, tmp); 3179 gfc_add_expr_to_block (&block, tmp); 3180 3181 tmp = build1_v (LABEL_EXPR, end_label); 3182 gfc_add_expr_to_block (&block, tmp); 3183 3184 return gfc_finish_block (&block); 3185 } 3186 } 3187 3188 if (code->expr1->ts.kind == 1) 3189 k = 0; 3190 else if (code->expr1->ts.kind == 4) 3191 k = 1; 3192 else 3193 gcc_unreachable (); 3194 3195 if (select_struct[k] == NULL) 3196 { 3197 tree *chain = NULL; 3198 select_struct[k] = make_node (RECORD_TYPE); 3199 3200 if (code->expr1->ts.kind == 1) 3201 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); 3202 else if (code->expr1->ts.kind == 4) 3203 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); 3204 else 3205 gcc_unreachable (); 3206 3207 #undef ADD_FIELD 3208 #define ADD_FIELD(NAME, TYPE) \ 3209 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ 3210 get_identifier (stringize(NAME)), \ 3211 TYPE, \ 3212 &chain) 3213 3214 ADD_FIELD (string1, pchartype); 3215 ADD_FIELD (string1_len, gfc_charlen_type_node); 3216 3217 ADD_FIELD (string2, pchartype); 3218 ADD_FIELD (string2_len, gfc_charlen_type_node); 3219 3220 ADD_FIELD (target, integer_type_node); 3221 #undef ADD_FIELD 3222 3223 gfc_finish_type (select_struct[k]); 3224 } 3225 3226 n = 0; 3227 for (d = cp; d; d = d->right) 3228 d->n = n++; 3229 3230 for (c = code->block; c; c = c->block) 3231 { 3232 for (d = c->ext.block.case_list; d; d = d->next) 3233 { 3234 label = gfc_build_label_decl (NULL_TREE); 3235 tmp = build_case_label ((d->low == NULL && d->high == NULL) 3236 ? NULL 3237 : build_int_cst (integer_type_node, d->n), 3238 NULL, label); 3239 gfc_add_expr_to_block (&body, tmp); 3240 } 3241 3242 tmp = gfc_trans_code (c->next); 3243 gfc_add_expr_to_block (&body, tmp); 3244 3245 tmp = build1_v (GOTO_EXPR, end_label); 3246 gfc_add_expr_to_block (&body, tmp); 3247 } 3248 3249 /* Generate the structure describing the branches */ 3250 for (d = cp; d; d = d->right) 3251 { 3252 vec<constructor_elt, va_gc> *node = NULL; 3253 3254 gfc_init_se (&se, NULL); 3255 3256 if (d->low == NULL) 3257 { 3258 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); 3259 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); 3260 } 3261 else 3262 { 3263 gfc_conv_expr_reference (&se, d->low); 3264 3265 CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); 3266 CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); 3267 } 3268 3269 if (d->high == NULL) 3270 { 3271 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); 3272 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); 3273 } 3274 else 3275 { 3276 gfc_init_se (&se, NULL); 3277 gfc_conv_expr_reference (&se, d->high); 3278 3279 CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); 3280 CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); 3281 } 3282 3283 CONSTRUCTOR_APPEND_ELT (node, ss_target[k], 3284 build_int_cst (integer_type_node, d->n)); 3285 3286 tmp = build_constructor (select_struct[k], node); 3287 CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); 3288 } 3289 3290 type = build_array_type (select_struct[k], 3291 build_index_type (size_int (n-1))); 3292 3293 init = build_constructor (type, inits); 3294 TREE_CONSTANT (init) = 1; 3295 TREE_STATIC (init) = 1; 3296 /* Create a static variable to hold the jump table. */ 3297 tmp = gfc_create_var (type, "jumptable"); 3298 TREE_CONSTANT (tmp) = 1; 3299 TREE_STATIC (tmp) = 1; 3300 TREE_READONLY (tmp) = 1; 3301 DECL_INITIAL (tmp) = init; 3302 init = tmp; 3303 3304 /* Build the library call */ 3305 init = gfc_build_addr_expr (pvoid_type_node, init); 3306 3307 if (code->expr1->ts.kind == 1) 3308 fndecl = gfor_fndecl_select_string; 3309 else if (code->expr1->ts.kind == 4) 3310 fndecl = gfor_fndecl_select_string_char4; 3311 else 3312 gcc_unreachable (); 3313 3314 tmp = build_call_expr_loc (input_location, 3315 fndecl, 4, init, 3316 build_int_cst (gfc_charlen_type_node, n), 3317 expr1se.expr, expr1se.string_length); 3318 case_num = gfc_create_var (integer_type_node, "case_num"); 3319 gfc_add_modify (&block, case_num, tmp); 3320 3321 gfc_add_block_to_block (&block, &expr1se.post); 3322 3323 tmp = gfc_finish_block (&body); 3324 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, 3325 case_num, tmp); 3326 gfc_add_expr_to_block (&block, tmp); 3327 3328 tmp = build1_v (LABEL_EXPR, end_label); 3329 gfc_add_expr_to_block (&block, tmp); 3330 3331 return gfc_finish_block (&block); 3332 } 3333 3334 3335 /* Translate the three variants of the SELECT CASE construct. 3336 3337 SELECT CASEs with INTEGER case expressions can be translated to an 3338 equivalent GENERIC switch statement, and for LOGICAL case 3339 expressions we build one or two if-else compares. 3340 3341 SELECT CASEs with CHARACTER case expressions are a whole different 3342 story, because they don't exist in GENERIC. So we sort them and 3343 do a binary search at runtime. 3344 3345 Fortran has no BREAK statement, and it does not allow jumps from 3346 one case block to another. That makes things a lot easier for 3347 the optimizers. */ 3348 3349 tree 3350 gfc_trans_select (gfc_code * code) 3351 { 3352 stmtblock_t block; 3353 tree body; 3354 tree exit_label; 3355 3356 gcc_assert (code && code->expr1); 3357 gfc_init_block (&block); 3358 3359 /* Build the exit label and hang it in. */ 3360 exit_label = gfc_build_label_decl (NULL_TREE); 3361 code->exit_label = exit_label; 3362 3363 /* Empty SELECT constructs are legal. */ 3364 if (code->block == NULL) 3365 body = build_empty_stmt (input_location); 3366 3367 /* Select the correct translation function. */ 3368 else 3369 switch (code->expr1->ts.type) 3370 { 3371 case BT_LOGICAL: 3372 body = gfc_trans_logical_select (code); 3373 break; 3374 3375 case BT_INTEGER: 3376 body = gfc_trans_integer_select (code); 3377 break; 3378 3379 case BT_CHARACTER: 3380 body = gfc_trans_character_select (code); 3381 break; 3382 3383 default: 3384 gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); 3385 /* Not reached */ 3386 } 3387 3388 /* Build everything together. */ 3389 gfc_add_expr_to_block (&block, body); 3390 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); 3391 3392 return gfc_finish_block (&block); 3393 } 3394 3395 tree 3396 gfc_trans_select_type (gfc_code * code) 3397 { 3398 stmtblock_t block; 3399 tree body; 3400 tree exit_label; 3401 3402 gcc_assert (code && code->expr1); 3403 gfc_init_block (&block); 3404 3405 /* Build the exit label and hang it in. */ 3406 exit_label = gfc_build_label_decl (NULL_TREE); 3407 code->exit_label = exit_label; 3408 3409 /* Empty SELECT constructs are legal. */ 3410 if (code->block == NULL) 3411 body = build_empty_stmt (input_location); 3412 else 3413 body = gfc_trans_select_type_cases (code); 3414 3415 /* Build everything together. */ 3416 gfc_add_expr_to_block (&block, body); 3417 3418 if (TREE_USED (exit_label)) 3419 gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); 3420 3421 return gfc_finish_block (&block); 3422 } 3423 3424 3425 /* Traversal function to substitute a replacement symtree if the symbol 3426 in the expression is the same as that passed. f == 2 signals that 3427 that variable itself is not to be checked - only the references. 3428 This group of functions is used when the variable expression in a 3429 FORALL assignment has internal references. For example: 3430 FORALL (i = 1:4) p(p(i)) = i 3431 The only recourse here is to store a copy of 'p' for the index 3432 expression. */ 3433 3434 static gfc_symtree *new_symtree; 3435 static gfc_symtree *old_symtree; 3436 3437 static bool 3438 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) 3439 { 3440 if (expr->expr_type != EXPR_VARIABLE) 3441 return false; 3442 3443 if (*f == 2) 3444 *f = 1; 3445 else if (expr->symtree->n.sym == sym) 3446 expr->symtree = new_symtree; 3447 3448 return false; 3449 } 3450 3451 static void 3452 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) 3453 { 3454 gfc_traverse_expr (e, sym, forall_replace, f); 3455 } 3456 3457 static bool 3458 forall_restore (gfc_expr *expr, 3459 gfc_symbol *sym ATTRIBUTE_UNUSED, 3460 int *f ATTRIBUTE_UNUSED) 3461 { 3462 if (expr->expr_type != EXPR_VARIABLE) 3463 return false; 3464 3465 if (expr->symtree == new_symtree) 3466 expr->symtree = old_symtree; 3467 3468 return false; 3469 } 3470 3471 static void 3472 forall_restore_symtree (gfc_expr *e) 3473 { 3474 gfc_traverse_expr (e, NULL, forall_restore, 0); 3475 } 3476 3477 static void 3478 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) 3479 { 3480 gfc_se tse; 3481 gfc_se rse; 3482 gfc_expr *e; 3483 gfc_symbol *new_sym; 3484 gfc_symbol *old_sym; 3485 gfc_symtree *root; 3486 tree tmp; 3487 3488 /* Build a copy of the lvalue. */ 3489 old_symtree = c->expr1->symtree; 3490 old_sym = old_symtree->n.sym; 3491 e = gfc_lval_expr_from_sym (old_sym); 3492 if (old_sym->attr.dimension) 3493 { 3494 gfc_init_se (&tse, NULL); 3495 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); 3496 gfc_add_block_to_block (pre, &tse.pre); 3497 gfc_add_block_to_block (post, &tse.post); 3498 tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); 3499 3500 if (c->expr1->ref->u.ar.type != AR_SECTION) 3501 { 3502 /* Use the variable offset for the temporary. */ 3503 tmp = gfc_conv_array_offset (old_sym->backend_decl); 3504 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); 3505 } 3506 } 3507 else 3508 { 3509 gfc_init_se (&tse, NULL); 3510 gfc_init_se (&rse, NULL); 3511 gfc_conv_expr (&rse, e); 3512 if (e->ts.type == BT_CHARACTER) 3513 { 3514 tse.string_length = rse.string_length; 3515 tmp = gfc_get_character_type_len (gfc_default_character_kind, 3516 tse.string_length); 3517 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), 3518 rse.string_length); 3519 gfc_add_block_to_block (pre, &tse.pre); 3520 gfc_add_block_to_block (post, &tse.post); 3521 } 3522 else 3523 { 3524 tmp = gfc_typenode_for_spec (&e->ts); 3525 tse.expr = gfc_create_var (tmp, "temp"); 3526 } 3527 3528 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, 3529 e->expr_type == EXPR_VARIABLE, false); 3530 gfc_add_expr_to_block (pre, tmp); 3531 } 3532 gfc_free_expr (e); 3533 3534 /* Create a new symbol to represent the lvalue. */ 3535 new_sym = gfc_new_symbol (old_sym->name, NULL); 3536 new_sym->ts = old_sym->ts; 3537 new_sym->attr.referenced = 1; 3538 new_sym->attr.temporary = 1; 3539 new_sym->attr.dimension = old_sym->attr.dimension; 3540 new_sym->attr.flavor = old_sym->attr.flavor; 3541 3542 /* Use the temporary as the backend_decl. */ 3543 new_sym->backend_decl = tse.expr; 3544 3545 /* Create a fake symtree for it. */ 3546 root = NULL; 3547 new_symtree = gfc_new_symtree (&root, old_sym->name); 3548 new_symtree->n.sym = new_sym; 3549 gcc_assert (new_symtree == root); 3550 3551 /* Go through the expression reference replacing the old_symtree 3552 with the new. */ 3553 forall_replace_symtree (c->expr1, old_sym, 2); 3554 3555 /* Now we have made this temporary, we might as well use it for 3556 the right hand side. */ 3557 forall_replace_symtree (c->expr2, old_sym, 1); 3558 } 3559 3560 3561 /* Handles dependencies in forall assignments. */ 3562 static int 3563 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) 3564 { 3565 gfc_ref *lref; 3566 gfc_ref *rref; 3567 int need_temp; 3568 gfc_symbol *lsym; 3569 3570 lsym = c->expr1->symtree->n.sym; 3571 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); 3572 3573 /* Now check for dependencies within the 'variable' 3574 expression itself. These are treated by making a complete 3575 copy of variable and changing all the references to it 3576 point to the copy instead. Note that the shallow copy of 3577 the variable will not suffice for derived types with 3578 pointer components. We therefore leave these to their 3579 own devices. */ 3580 if (lsym->ts.type == BT_DERIVED 3581 && lsym->ts.u.derived->attr.pointer_comp) 3582 return need_temp; 3583 3584 new_symtree = NULL; 3585 if (find_forall_index (c->expr1, lsym, 2)) 3586 { 3587 forall_make_variable_temp (c, pre, post); 3588 need_temp = 0; 3589 } 3590 3591 /* Substrings with dependencies are treated in the same 3592 way. */ 3593 if (c->expr1->ts.type == BT_CHARACTER 3594 && c->expr1->ref 3595 && c->expr2->expr_type == EXPR_VARIABLE 3596 && lsym == c->expr2->symtree->n.sym) 3597 { 3598 for (lref = c->expr1->ref; lref; lref = lref->next) 3599 if (lref->type == REF_SUBSTRING) 3600 break; 3601 for (rref = c->expr2->ref; rref; rref = rref->next) 3602 if (rref->type == REF_SUBSTRING) 3603 break; 3604 3605 if (rref && lref 3606 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) 3607 { 3608 forall_make_variable_temp (c, pre, post); 3609 need_temp = 0; 3610 } 3611 } 3612 return need_temp; 3613 } 3614 3615 3616 static void 3617 cleanup_forall_symtrees (gfc_code *c) 3618 { 3619 forall_restore_symtree (c->expr1); 3620 forall_restore_symtree (c->expr2); 3621 free (new_symtree->n.sym); 3622 free (new_symtree); 3623 } 3624 3625 3626 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY 3627 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG 3628 indicates whether we should generate code to test the FORALLs mask 3629 array. OUTER is the loop header to be used for initializing mask 3630 indices. 3631 3632 The generated loop format is: 3633 count = (end - start + step) / step 3634 loopvar = start 3635 while (1) 3636 { 3637 if (count <=0 ) 3638 goto end_of_loop 3639 <body> 3640 loopvar += step 3641 count -- 3642 } 3643 end_of_loop: */ 3644 3645 static tree 3646 gfc_trans_forall_loop (forall_info *forall_tmp, tree body, 3647 int mask_flag, stmtblock_t *outer) 3648 { 3649 int n, nvar; 3650 tree tmp; 3651 tree cond; 3652 stmtblock_t block; 3653 tree exit_label; 3654 tree count; 3655 tree var, start, end, step; 3656 iter_info *iter; 3657 3658 /* Initialize the mask index outside the FORALL nest. */ 3659 if (mask_flag && forall_tmp->mask) 3660 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node); 3661 3662 iter = forall_tmp->this_loop; 3663 nvar = forall_tmp->nvar; 3664 for (n = 0; n < nvar; n++) 3665 { 3666 var = iter->var; 3667 start = iter->start; 3668 end = iter->end; 3669 step = iter->step; 3670 3671 exit_label = gfc_build_label_decl (NULL_TREE); 3672 TREE_USED (exit_label) = 1; 3673 3674 /* The loop counter. */ 3675 count = gfc_create_var (TREE_TYPE (var), "count"); 3676 3677 /* The body of the loop. */ 3678 gfc_init_block (&block); 3679 3680 /* The exit condition. */ 3681 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, 3682 count, build_int_cst (TREE_TYPE (count), 0)); 3683 3684 /* PR 83064 means that we cannot use annot_expr_parallel_kind until 3685 the autoparallelizer can hande this. */ 3686 if (forall_tmp->do_concurrent) 3687 cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, 3688 build_int_cst (integer_type_node, 3689 annot_expr_ivdep_kind), 3690 integer_zero_node); 3691 3692 tmp = build1_v (GOTO_EXPR, exit_label); 3693 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 3694 cond, tmp, build_empty_stmt (input_location)); 3695 gfc_add_expr_to_block (&block, tmp); 3696 3697 /* The main loop body. */ 3698 gfc_add_expr_to_block (&block, body); 3699 3700 /* Increment the loop variable. */ 3701 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, 3702 step); 3703 gfc_add_modify (&block, var, tmp); 3704 3705 /* Advance to the next mask element. Only do this for the 3706 innermost loop. */ 3707 if (n == 0 && mask_flag && forall_tmp->mask) 3708 { 3709 tree maskindex = forall_tmp->maskindex; 3710 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 3711 maskindex, gfc_index_one_node); 3712 gfc_add_modify (&block, maskindex, tmp); 3713 } 3714 3715 /* Decrement the loop counter. */ 3716 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, 3717 build_int_cst (TREE_TYPE (var), 1)); 3718 gfc_add_modify (&block, count, tmp); 3719 3720 body = gfc_finish_block (&block); 3721 3722 /* Loop var initialization. */ 3723 gfc_init_block (&block); 3724 gfc_add_modify (&block, var, start); 3725 3726 3727 /* Initialize the loop counter. */ 3728 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, 3729 start); 3730 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, 3731 tmp); 3732 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), 3733 tmp, step); 3734 gfc_add_modify (&block, count, tmp); 3735 3736 /* The loop expression. */ 3737 tmp = build1_v (LOOP_EXPR, body); 3738 gfc_add_expr_to_block (&block, tmp); 3739 3740 /* The exit label. */ 3741 tmp = build1_v (LABEL_EXPR, exit_label); 3742 gfc_add_expr_to_block (&block, tmp); 3743 3744 body = gfc_finish_block (&block); 3745 iter = iter->next; 3746 } 3747 return body; 3748 } 3749 3750 3751 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG 3752 is nonzero, the body is controlled by all masks in the forall nest. 3753 Otherwise, the innermost loop is not controlled by it's mask. This 3754 is used for initializing that mask. */ 3755 3756 static tree 3757 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, 3758 int mask_flag) 3759 { 3760 tree tmp; 3761 stmtblock_t header; 3762 forall_info *forall_tmp; 3763 tree mask, maskindex; 3764 3765 gfc_start_block (&header); 3766 3767 forall_tmp = nested_forall_info; 3768 while (forall_tmp != NULL) 3769 { 3770 /* Generate body with masks' control. */ 3771 if (mask_flag) 3772 { 3773 mask = forall_tmp->mask; 3774 maskindex = forall_tmp->maskindex; 3775 3776 /* If a mask was specified make the assignment conditional. */ 3777 if (mask) 3778 { 3779 tmp = gfc_build_array_ref (mask, maskindex, NULL); 3780 body = build3_v (COND_EXPR, tmp, body, 3781 build_empty_stmt (input_location)); 3782 } 3783 } 3784 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); 3785 forall_tmp = forall_tmp->prev_nest; 3786 mask_flag = 1; 3787 } 3788 3789 gfc_add_expr_to_block (&header, body); 3790 return gfc_finish_block (&header); 3791 } 3792 3793 3794 /* Allocate data for holding a temporary array. Returns either a local 3795 temporary array or a pointer variable. */ 3796 3797 static tree 3798 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, 3799 tree elem_type) 3800 { 3801 tree tmpvar; 3802 tree type; 3803 tree tmp; 3804 3805 if (INTEGER_CST_P (size)) 3806 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 3807 size, gfc_index_one_node); 3808 else 3809 tmp = NULL_TREE; 3810 3811 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); 3812 type = build_array_type (elem_type, type); 3813 if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size)) 3814 { 3815 tmpvar = gfc_create_var (type, "temp"); 3816 *pdata = NULL_TREE; 3817 } 3818 else 3819 { 3820 tmpvar = gfc_create_var (build_pointer_type (type), "temp"); 3821 *pdata = convert (pvoid_type_node, tmpvar); 3822 3823 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize); 3824 gfc_add_modify (pblock, tmpvar, tmp); 3825 } 3826 return tmpvar; 3827 } 3828 3829 3830 /* Generate codes to copy the temporary to the actual lhs. */ 3831 3832 static tree 3833 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, 3834 tree count1, 3835 gfc_ss *lss, gfc_ss *rss, 3836 tree wheremask, bool invert) 3837 { 3838 stmtblock_t block, body1; 3839 gfc_loopinfo loop; 3840 gfc_se lse; 3841 gfc_se rse; 3842 tree tmp; 3843 tree wheremaskexpr; 3844 3845 (void) rss; /* TODO: unused. */ 3846 3847 gfc_start_block (&block); 3848 3849 gfc_init_se (&rse, NULL); 3850 gfc_init_se (&lse, NULL); 3851 3852 if (lss == gfc_ss_terminator) 3853 { 3854 gfc_init_block (&body1); 3855 gfc_conv_expr (&lse, expr); 3856 rse.expr = gfc_build_array_ref (tmp1, count1, NULL); 3857 } 3858 else 3859 { 3860 /* Initialize the loop. */ 3861 gfc_init_loopinfo (&loop); 3862 3863 /* We may need LSS to determine the shape of the expression. */ 3864 gfc_add_ss_to_loop (&loop, lss); 3865 3866 gfc_conv_ss_startstride (&loop); 3867 gfc_conv_loop_setup (&loop, &expr->where); 3868 3869 gfc_mark_ss_chain_used (lss, 1); 3870 /* Start the loop body. */ 3871 gfc_start_scalarized_body (&loop, &body1); 3872 3873 /* Translate the expression. */ 3874 gfc_copy_loopinfo_to_se (&lse, &loop); 3875 lse.ss = lss; 3876 gfc_conv_expr (&lse, expr); 3877 3878 /* Form the expression of the temporary. */ 3879 rse.expr = gfc_build_array_ref (tmp1, count1, NULL); 3880 } 3881 3882 /* Use the scalar assignment. */ 3883 rse.string_length = lse.string_length; 3884 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, 3885 expr->expr_type == EXPR_VARIABLE, false); 3886 3887 /* Form the mask expression according to the mask tree list. */ 3888 if (wheremask) 3889 { 3890 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); 3891 if (invert) 3892 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, 3893 TREE_TYPE (wheremaskexpr), 3894 wheremaskexpr); 3895 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 3896 wheremaskexpr, tmp, 3897 build_empty_stmt (input_location)); 3898 } 3899 3900 gfc_add_expr_to_block (&body1, tmp); 3901 3902 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), 3903 count1, gfc_index_one_node); 3904 gfc_add_modify (&body1, count1, tmp); 3905 3906 if (lss == gfc_ss_terminator) 3907 gfc_add_block_to_block (&block, &body1); 3908 else 3909 { 3910 /* Increment count3. */ 3911 if (count3) 3912 { 3913 tmp = fold_build2_loc (input_location, PLUS_EXPR, 3914 gfc_array_index_type, 3915 count3, gfc_index_one_node); 3916 gfc_add_modify (&body1, count3, tmp); 3917 } 3918 3919 /* Generate the copying loops. */ 3920 gfc_trans_scalarizing_loops (&loop, &body1); 3921 3922 gfc_add_block_to_block (&block, &loop.pre); 3923 gfc_add_block_to_block (&block, &loop.post); 3924 3925 gfc_cleanup_loop (&loop); 3926 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful 3927 as tree nodes in SS may not be valid in different scope. */ 3928 } 3929 3930 tmp = gfc_finish_block (&block); 3931 return tmp; 3932 } 3933 3934 3935 /* Generate codes to copy rhs to the temporary. TMP1 is the address of 3936 temporary, LSS and RSS are formed in function compute_inner_temp_size(), 3937 and should not be freed. WHEREMASK is the conditional execution mask 3938 whose sense may be inverted by INVERT. */ 3939 3940 static tree 3941 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, 3942 tree count1, gfc_ss *lss, gfc_ss *rss, 3943 tree wheremask, bool invert) 3944 { 3945 stmtblock_t block, body1; 3946 gfc_loopinfo loop; 3947 gfc_se lse; 3948 gfc_se rse; 3949 tree tmp; 3950 tree wheremaskexpr; 3951 3952 gfc_start_block (&block); 3953 3954 gfc_init_se (&rse, NULL); 3955 gfc_init_se (&lse, NULL); 3956 3957 if (lss == gfc_ss_terminator) 3958 { 3959 gfc_init_block (&body1); 3960 gfc_conv_expr (&rse, expr2); 3961 lse.expr = gfc_build_array_ref (tmp1, count1, NULL); 3962 } 3963 else 3964 { 3965 /* Initialize the loop. */ 3966 gfc_init_loopinfo (&loop); 3967 3968 /* We may need LSS to determine the shape of the expression. */ 3969 gfc_add_ss_to_loop (&loop, lss); 3970 gfc_add_ss_to_loop (&loop, rss); 3971 3972 gfc_conv_ss_startstride (&loop); 3973 gfc_conv_loop_setup (&loop, &expr2->where); 3974 3975 gfc_mark_ss_chain_used (rss, 1); 3976 /* Start the loop body. */ 3977 gfc_start_scalarized_body (&loop, &body1); 3978 3979 /* Translate the expression. */ 3980 gfc_copy_loopinfo_to_se (&rse, &loop); 3981 rse.ss = rss; 3982 gfc_conv_expr (&rse, expr2); 3983 3984 /* Form the expression of the temporary. */ 3985 lse.expr = gfc_build_array_ref (tmp1, count1, NULL); 3986 } 3987 3988 /* Use the scalar assignment. */ 3989 lse.string_length = rse.string_length; 3990 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, 3991 expr2->expr_type == EXPR_VARIABLE, false); 3992 3993 /* Form the mask expression according to the mask tree list. */ 3994 if (wheremask) 3995 { 3996 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); 3997 if (invert) 3998 wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, 3999 TREE_TYPE (wheremaskexpr), 4000 wheremaskexpr); 4001 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 4002 wheremaskexpr, tmp, 4003 build_empty_stmt (input_location)); 4004 } 4005 4006 gfc_add_expr_to_block (&body1, tmp); 4007 4008 if (lss == gfc_ss_terminator) 4009 { 4010 gfc_add_block_to_block (&block, &body1); 4011 4012 /* Increment count1. */ 4013 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), 4014 count1, gfc_index_one_node); 4015 gfc_add_modify (&block, count1, tmp); 4016 } 4017 else 4018 { 4019 /* Increment count1. */ 4020 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4021 count1, gfc_index_one_node); 4022 gfc_add_modify (&body1, count1, tmp); 4023 4024 /* Increment count3. */ 4025 if (count3) 4026 { 4027 tmp = fold_build2_loc (input_location, PLUS_EXPR, 4028 gfc_array_index_type, 4029 count3, gfc_index_one_node); 4030 gfc_add_modify (&body1, count3, tmp); 4031 } 4032 4033 /* Generate the copying loops. */ 4034 gfc_trans_scalarizing_loops (&loop, &body1); 4035 4036 gfc_add_block_to_block (&block, &loop.pre); 4037 gfc_add_block_to_block (&block, &loop.post); 4038 4039 gfc_cleanup_loop (&loop); 4040 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful 4041 as tree nodes in SS may not be valid in different scope. */ 4042 } 4043 4044 tmp = gfc_finish_block (&block); 4045 return tmp; 4046 } 4047 4048 4049 /* Calculate the size of temporary needed in the assignment inside forall. 4050 LSS and RSS are filled in this function. */ 4051 4052 static tree 4053 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, 4054 stmtblock_t * pblock, 4055 gfc_ss **lss, gfc_ss **rss) 4056 { 4057 gfc_loopinfo loop; 4058 tree size; 4059 int i; 4060 int save_flag; 4061 tree tmp; 4062 4063 *lss = gfc_walk_expr (expr1); 4064 *rss = NULL; 4065 4066 size = gfc_index_one_node; 4067 if (*lss != gfc_ss_terminator) 4068 { 4069 gfc_init_loopinfo (&loop); 4070 4071 /* Walk the RHS of the expression. */ 4072 *rss = gfc_walk_expr (expr2); 4073 if (*rss == gfc_ss_terminator) 4074 /* The rhs is scalar. Add a ss for the expression. */ 4075 *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); 4076 4077 /* Associate the SS with the loop. */ 4078 gfc_add_ss_to_loop (&loop, *lss); 4079 /* We don't actually need to add the rhs at this point, but it might 4080 make guessing the loop bounds a bit easier. */ 4081 gfc_add_ss_to_loop (&loop, *rss); 4082 4083 /* We only want the shape of the expression, not rest of the junk 4084 generated by the scalarizer. */ 4085 loop.array_parameter = 1; 4086 4087 /* Calculate the bounds of the scalarization. */ 4088 save_flag = gfc_option.rtcheck; 4089 gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS; 4090 gfc_conv_ss_startstride (&loop); 4091 gfc_option.rtcheck = save_flag; 4092 gfc_conv_loop_setup (&loop, &expr2->where); 4093 4094 /* Figure out how many elements we need. */ 4095 for (i = 0; i < loop.dimen; i++) 4096 { 4097 tmp = fold_build2_loc (input_location, MINUS_EXPR, 4098 gfc_array_index_type, 4099 gfc_index_one_node, loop.from[i]); 4100 tmp = fold_build2_loc (input_location, PLUS_EXPR, 4101 gfc_array_index_type, tmp, loop.to[i]); 4102 size = fold_build2_loc (input_location, MULT_EXPR, 4103 gfc_array_index_type, size, tmp); 4104 } 4105 gfc_add_block_to_block (pblock, &loop.pre); 4106 size = gfc_evaluate_now (size, pblock); 4107 gfc_add_block_to_block (pblock, &loop.post); 4108 4109 /* TODO: write a function that cleans up a loopinfo without freeing 4110 the SS chains. Currently a NOP. */ 4111 } 4112 4113 return size; 4114 } 4115 4116 4117 /* Calculate the overall iterator number of the nested forall construct. 4118 This routine actually calculates the number of times the body of the 4119 nested forall specified by NESTED_FORALL_INFO is executed and multiplies 4120 that by the expression INNER_SIZE. The BLOCK argument specifies the 4121 block in which to calculate the result, and the optional INNER_SIZE_BODY 4122 argument contains any statements that need to executed (inside the loop) 4123 to initialize or calculate INNER_SIZE. */ 4124 4125 static tree 4126 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, 4127 stmtblock_t *inner_size_body, stmtblock_t *block) 4128 { 4129 forall_info *forall_tmp = nested_forall_info; 4130 tree tmp, number; 4131 stmtblock_t body; 4132 4133 /* We can eliminate the innermost unconditional loops with constant 4134 array bounds. */ 4135 if (INTEGER_CST_P (inner_size)) 4136 { 4137 while (forall_tmp 4138 && !forall_tmp->mask 4139 && INTEGER_CST_P (forall_tmp->size)) 4140 { 4141 inner_size = fold_build2_loc (input_location, MULT_EXPR, 4142 gfc_array_index_type, 4143 inner_size, forall_tmp->size); 4144 forall_tmp = forall_tmp->prev_nest; 4145 } 4146 4147 /* If there are no loops left, we have our constant result. */ 4148 if (!forall_tmp) 4149 return inner_size; 4150 } 4151 4152 /* Otherwise, create a temporary variable to compute the result. */ 4153 number = gfc_create_var (gfc_array_index_type, "num"); 4154 gfc_add_modify (block, number, gfc_index_zero_node); 4155 4156 gfc_start_block (&body); 4157 if (inner_size_body) 4158 gfc_add_block_to_block (&body, inner_size_body); 4159 if (forall_tmp) 4160 tmp = fold_build2_loc (input_location, PLUS_EXPR, 4161 gfc_array_index_type, number, inner_size); 4162 else 4163 tmp = inner_size; 4164 gfc_add_modify (&body, number, tmp); 4165 tmp = gfc_finish_block (&body); 4166 4167 /* Generate loops. */ 4168 if (forall_tmp != NULL) 4169 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1); 4170 4171 gfc_add_expr_to_block (block, tmp); 4172 4173 return number; 4174 } 4175 4176 4177 /* Allocate temporary for forall construct. SIZE is the size of temporary 4178 needed. PTEMP1 is returned for space free. */ 4179 4180 static tree 4181 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, 4182 tree * ptemp1) 4183 { 4184 tree bytesize; 4185 tree unit; 4186 tree tmp; 4187 4188 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); 4189 if (!integer_onep (unit)) 4190 bytesize = fold_build2_loc (input_location, MULT_EXPR, 4191 gfc_array_index_type, size, unit); 4192 else 4193 bytesize = size; 4194 4195 *ptemp1 = NULL; 4196 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); 4197 4198 if (*ptemp1) 4199 tmp = build_fold_indirect_ref_loc (input_location, tmp); 4200 return tmp; 4201 } 4202 4203 4204 /* Allocate temporary for forall construct according to the information in 4205 nested_forall_info. INNER_SIZE is the size of temporary needed in the 4206 assignment inside forall. PTEMP1 is returned for space free. */ 4207 4208 static tree 4209 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, 4210 tree inner_size, stmtblock_t * inner_size_body, 4211 stmtblock_t * block, tree * ptemp1) 4212 { 4213 tree size; 4214 4215 /* Calculate the total size of temporary needed in forall construct. */ 4216 size = compute_overall_iter_number (nested_forall_info, inner_size, 4217 inner_size_body, block); 4218 4219 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); 4220 } 4221 4222 4223 /* Handle assignments inside forall which need temporary. 4224 4225 forall (i=start:end:stride; maskexpr) 4226 e<i> = f<i> 4227 end forall 4228 (where e,f<i> are arbitrary expressions possibly involving i 4229 and there is a dependency between e<i> and f<i>) 4230 Translates to: 4231 masktmp(:) = maskexpr(:) 4232 4233 maskindex = 0; 4234 count1 = 0; 4235 num = 0; 4236 for (i = start; i <= end; i += stride) 4237 num += SIZE (f<i>) 4238 count1 = 0; 4239 ALLOCATE (tmp(num)) 4240 for (i = start; i <= end; i += stride) 4241 { 4242 if (masktmp[maskindex++]) 4243 tmp[count1++] = f<i> 4244 } 4245 maskindex = 0; 4246 count1 = 0; 4247 for (i = start; i <= end; i += stride) 4248 { 4249 if (masktmp[maskindex++]) 4250 e<i> = tmp[count1++] 4251 } 4252 DEALLOCATE (tmp) 4253 */ 4254 static void 4255 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, 4256 tree wheremask, bool invert, 4257 forall_info * nested_forall_info, 4258 stmtblock_t * block) 4259 { 4260 tree type; 4261 tree inner_size; 4262 gfc_ss *lss, *rss; 4263 tree count, count1; 4264 tree tmp, tmp1; 4265 tree ptemp1; 4266 stmtblock_t inner_size_body; 4267 4268 /* Create vars. count1 is the current iterator number of the nested 4269 forall. */ 4270 count1 = gfc_create_var (gfc_array_index_type, "count1"); 4271 4272 /* Count is the wheremask index. */ 4273 if (wheremask) 4274 { 4275 count = gfc_create_var (gfc_array_index_type, "count"); 4276 gfc_add_modify (block, count, gfc_index_zero_node); 4277 } 4278 else 4279 count = NULL; 4280 4281 /* Initialize count1. */ 4282 gfc_add_modify (block, count1, gfc_index_zero_node); 4283 4284 /* Calculate the size of temporary needed in the assignment. Return loop, lss 4285 and rss which are used in function generate_loop_for_rhs_to_temp(). */ 4286 /* The type of LHS. Used in function allocate_temp_for_forall_nest */ 4287 if (expr1->ts.type == BT_CHARACTER) 4288 { 4289 type = NULL; 4290 if (expr1->ref && expr1->ref->type == REF_SUBSTRING) 4291 { 4292 gfc_se ssse; 4293 gfc_init_se (&ssse, NULL); 4294 gfc_conv_expr (&ssse, expr1); 4295 type = gfc_get_character_type_len (gfc_default_character_kind, 4296 ssse.string_length); 4297 } 4298 else 4299 { 4300 if (!expr1->ts.u.cl->backend_decl) 4301 { 4302 gfc_se tse; 4303 gcc_assert (expr1->ts.u.cl->length); 4304 gfc_init_se (&tse, NULL); 4305 gfc_conv_expr (&tse, expr1->ts.u.cl->length); 4306 expr1->ts.u.cl->backend_decl = tse.expr; 4307 } 4308 type = gfc_get_character_type_len (gfc_default_character_kind, 4309 expr1->ts.u.cl->backend_decl); 4310 } 4311 } 4312 else 4313 type = gfc_typenode_for_spec (&expr1->ts); 4314 4315 gfc_init_block (&inner_size_body); 4316 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, 4317 &lss, &rss); 4318 4319 /* Allocate temporary for nested forall construct according to the 4320 information in nested_forall_info and inner_size. */ 4321 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, 4322 &inner_size_body, block, &ptemp1); 4323 4324 /* Generate codes to copy rhs to the temporary . */ 4325 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, 4326 wheremask, invert); 4327 4328 /* Generate body and loops according to the information in 4329 nested_forall_info. */ 4330 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4331 gfc_add_expr_to_block (block, tmp); 4332 4333 /* Reset count1. */ 4334 gfc_add_modify (block, count1, gfc_index_zero_node); 4335 4336 /* Reset count. */ 4337 if (wheremask) 4338 gfc_add_modify (block, count, gfc_index_zero_node); 4339 4340 /* TODO: Second call to compute_inner_temp_size to initialize lss and 4341 rss; there must be a better way. */ 4342 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, 4343 &lss, &rss); 4344 4345 /* Generate codes to copy the temporary to lhs. */ 4346 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, 4347 lss, rss, 4348 wheremask, invert); 4349 4350 /* Generate body and loops according to the information in 4351 nested_forall_info. */ 4352 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4353 gfc_add_expr_to_block (block, tmp); 4354 4355 if (ptemp1) 4356 { 4357 /* Free the temporary. */ 4358 tmp = gfc_call_free (ptemp1); 4359 gfc_add_expr_to_block (block, tmp); 4360 } 4361 } 4362 4363 4364 /* Translate pointer assignment inside FORALL which need temporary. */ 4365 4366 static void 4367 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, 4368 forall_info * nested_forall_info, 4369 stmtblock_t * block) 4370 { 4371 tree type; 4372 tree inner_size; 4373 gfc_ss *lss, *rss; 4374 gfc_se lse; 4375 gfc_se rse; 4376 gfc_array_info *info; 4377 gfc_loopinfo loop; 4378 tree desc; 4379 tree parm; 4380 tree parmtype; 4381 stmtblock_t body; 4382 tree count; 4383 tree tmp, tmp1, ptemp1; 4384 4385 count = gfc_create_var (gfc_array_index_type, "count"); 4386 gfc_add_modify (block, count, gfc_index_zero_node); 4387 4388 inner_size = gfc_index_one_node; 4389 lss = gfc_walk_expr (expr1); 4390 rss = gfc_walk_expr (expr2); 4391 if (lss == gfc_ss_terminator) 4392 { 4393 type = gfc_typenode_for_spec (&expr1->ts); 4394 type = build_pointer_type (type); 4395 4396 /* Allocate temporary for nested forall construct according to the 4397 information in nested_forall_info and inner_size. */ 4398 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, 4399 inner_size, NULL, block, &ptemp1); 4400 gfc_start_block (&body); 4401 gfc_init_se (&lse, NULL); 4402 lse.expr = gfc_build_array_ref (tmp1, count, NULL); 4403 gfc_init_se (&rse, NULL); 4404 rse.want_pointer = 1; 4405 gfc_conv_expr (&rse, expr2); 4406 gfc_add_block_to_block (&body, &rse.pre); 4407 gfc_add_modify (&body, lse.expr, 4408 fold_convert (TREE_TYPE (lse.expr), rse.expr)); 4409 gfc_add_block_to_block (&body, &rse.post); 4410 4411 /* Increment count. */ 4412 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4413 count, gfc_index_one_node); 4414 gfc_add_modify (&body, count, tmp); 4415 4416 tmp = gfc_finish_block (&body); 4417 4418 /* Generate body and loops according to the information in 4419 nested_forall_info. */ 4420 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4421 gfc_add_expr_to_block (block, tmp); 4422 4423 /* Reset count. */ 4424 gfc_add_modify (block, count, gfc_index_zero_node); 4425 4426 gfc_start_block (&body); 4427 gfc_init_se (&lse, NULL); 4428 gfc_init_se (&rse, NULL); 4429 rse.expr = gfc_build_array_ref (tmp1, count, NULL); 4430 lse.want_pointer = 1; 4431 gfc_conv_expr (&lse, expr1); 4432 gfc_add_block_to_block (&body, &lse.pre); 4433 gfc_add_modify (&body, lse.expr, rse.expr); 4434 gfc_add_block_to_block (&body, &lse.post); 4435 /* Increment count. */ 4436 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4437 count, gfc_index_one_node); 4438 gfc_add_modify (&body, count, tmp); 4439 tmp = gfc_finish_block (&body); 4440 4441 /* Generate body and loops according to the information in 4442 nested_forall_info. */ 4443 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4444 gfc_add_expr_to_block (block, tmp); 4445 } 4446 else 4447 { 4448 gfc_init_loopinfo (&loop); 4449 4450 /* Associate the SS with the loop. */ 4451 gfc_add_ss_to_loop (&loop, rss); 4452 4453 /* Setup the scalarizing loops and bounds. */ 4454 gfc_conv_ss_startstride (&loop); 4455 4456 gfc_conv_loop_setup (&loop, &expr2->where); 4457 4458 info = &rss->info->data.array; 4459 desc = info->descriptor; 4460 4461 /* Make a new descriptor. */ 4462 parmtype = gfc_get_element_type (TREE_TYPE (desc)); 4463 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, 4464 loop.from, loop.to, 1, 4465 GFC_ARRAY_UNKNOWN, true); 4466 4467 /* Allocate temporary for nested forall construct. */ 4468 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, 4469 inner_size, NULL, block, &ptemp1); 4470 gfc_start_block (&body); 4471 gfc_init_se (&lse, NULL); 4472 lse.expr = gfc_build_array_ref (tmp1, count, NULL); 4473 lse.direct_byref = 1; 4474 gfc_conv_expr_descriptor (&lse, expr2); 4475 4476 gfc_add_block_to_block (&body, &lse.pre); 4477 gfc_add_block_to_block (&body, &lse.post); 4478 4479 /* Increment count. */ 4480 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4481 count, gfc_index_one_node); 4482 gfc_add_modify (&body, count, tmp); 4483 4484 tmp = gfc_finish_block (&body); 4485 4486 /* Generate body and loops according to the information in 4487 nested_forall_info. */ 4488 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4489 gfc_add_expr_to_block (block, tmp); 4490 4491 /* Reset count. */ 4492 gfc_add_modify (block, count, gfc_index_zero_node); 4493 4494 parm = gfc_build_array_ref (tmp1, count, NULL); 4495 gfc_init_se (&lse, NULL); 4496 gfc_conv_expr_descriptor (&lse, expr1); 4497 gfc_add_modify (&lse.pre, lse.expr, parm); 4498 gfc_start_block (&body); 4499 gfc_add_block_to_block (&body, &lse.pre); 4500 gfc_add_block_to_block (&body, &lse.post); 4501 4502 /* Increment count. */ 4503 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4504 count, gfc_index_one_node); 4505 gfc_add_modify (&body, count, tmp); 4506 4507 tmp = gfc_finish_block (&body); 4508 4509 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4510 gfc_add_expr_to_block (block, tmp); 4511 } 4512 /* Free the temporary. */ 4513 if (ptemp1) 4514 { 4515 tmp = gfc_call_free (ptemp1); 4516 gfc_add_expr_to_block (block, tmp); 4517 } 4518 } 4519 4520 4521 /* FORALL and WHERE statements are really nasty, especially when you nest 4522 them. All the rhs of a forall assignment must be evaluated before the 4523 actual assignments are performed. Presumably this also applies to all the 4524 assignments in an inner where statement. */ 4525 4526 /* Generate code for a FORALL statement. Any temporaries are allocated as a 4527 linear array, relying on the fact that we process in the same order in all 4528 loops. 4529 4530 forall (i=start:end:stride; maskexpr) 4531 e<i> = f<i> 4532 g<i> = h<i> 4533 end forall 4534 (where e,f,g,h<i> are arbitrary expressions possibly involving i) 4535 Translates to: 4536 count = ((end + 1 - start) / stride) 4537 masktmp(:) = maskexpr(:) 4538 4539 maskindex = 0; 4540 for (i = start; i <= end; i += stride) 4541 { 4542 if (masktmp[maskindex++]) 4543 e<i> = f<i> 4544 } 4545 maskindex = 0; 4546 for (i = start; i <= end; i += stride) 4547 { 4548 if (masktmp[maskindex++]) 4549 g<i> = h<i> 4550 } 4551 4552 Note that this code only works when there are no dependencies. 4553 Forall loop with array assignments and data dependencies are a real pain, 4554 because the size of the temporary cannot always be determined before the 4555 loop is executed. This problem is compounded by the presence of nested 4556 FORALL constructs. 4557 */ 4558 4559 static tree 4560 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) 4561 { 4562 stmtblock_t pre; 4563 stmtblock_t post; 4564 stmtblock_t block; 4565 stmtblock_t body; 4566 tree *var; 4567 tree *start; 4568 tree *end; 4569 tree *step; 4570 gfc_expr **varexpr; 4571 tree tmp; 4572 tree assign; 4573 tree size; 4574 tree maskindex; 4575 tree mask; 4576 tree pmask; 4577 tree cycle_label = NULL_TREE; 4578 int n; 4579 int nvar; 4580 int need_temp; 4581 gfc_forall_iterator *fa; 4582 gfc_se se; 4583 gfc_code *c; 4584 gfc_saved_var *saved_vars; 4585 iter_info *this_forall; 4586 forall_info *info; 4587 bool need_mask; 4588 4589 /* Do nothing if the mask is false. */ 4590 if (code->expr1 4591 && code->expr1->expr_type == EXPR_CONSTANT 4592 && !code->expr1->value.logical) 4593 return build_empty_stmt (input_location); 4594 4595 n = 0; 4596 /* Count the FORALL index number. */ 4597 for (fa = code->ext.forall_iterator; fa; fa = fa->next) 4598 n++; 4599 nvar = n; 4600 4601 /* Allocate the space for var, start, end, step, varexpr. */ 4602 var = XCNEWVEC (tree, nvar); 4603 start = XCNEWVEC (tree, nvar); 4604 end = XCNEWVEC (tree, nvar); 4605 step = XCNEWVEC (tree, nvar); 4606 varexpr = XCNEWVEC (gfc_expr *, nvar); 4607 saved_vars = XCNEWVEC (gfc_saved_var, nvar); 4608 4609 /* Allocate the space for info. */ 4610 info = XCNEW (forall_info); 4611 4612 gfc_start_block (&pre); 4613 gfc_init_block (&post); 4614 gfc_init_block (&block); 4615 4616 n = 0; 4617 for (fa = code->ext.forall_iterator; fa; fa = fa->next) 4618 { 4619 gfc_symbol *sym = fa->var->symtree->n.sym; 4620 4621 /* Allocate space for this_forall. */ 4622 this_forall = XCNEW (iter_info); 4623 4624 /* Create a temporary variable for the FORALL index. */ 4625 tmp = gfc_typenode_for_spec (&sym->ts); 4626 var[n] = gfc_create_var (tmp, sym->name); 4627 gfc_shadow_sym (sym, var[n], &saved_vars[n]); 4628 4629 /* Record it in this_forall. */ 4630 this_forall->var = var[n]; 4631 4632 /* Replace the index symbol's backend_decl with the temporary decl. */ 4633 sym->backend_decl = var[n]; 4634 4635 /* Work out the start, end and stride for the loop. */ 4636 gfc_init_se (&se, NULL); 4637 gfc_conv_expr_val (&se, fa->start); 4638 /* Record it in this_forall. */ 4639 this_forall->start = se.expr; 4640 gfc_add_block_to_block (&block, &se.pre); 4641 start[n] = se.expr; 4642 4643 gfc_init_se (&se, NULL); 4644 gfc_conv_expr_val (&se, fa->end); 4645 /* Record it in this_forall. */ 4646 this_forall->end = se.expr; 4647 gfc_make_safe_expr (&se); 4648 gfc_add_block_to_block (&block, &se.pre); 4649 end[n] = se.expr; 4650 4651 gfc_init_se (&se, NULL); 4652 gfc_conv_expr_val (&se, fa->stride); 4653 /* Record it in this_forall. */ 4654 this_forall->step = se.expr; 4655 gfc_make_safe_expr (&se); 4656 gfc_add_block_to_block (&block, &se.pre); 4657 step[n] = se.expr; 4658 4659 /* Set the NEXT field of this_forall to NULL. */ 4660 this_forall->next = NULL; 4661 /* Link this_forall to the info construct. */ 4662 if (info->this_loop) 4663 { 4664 iter_info *iter_tmp = info->this_loop; 4665 while (iter_tmp->next != NULL) 4666 iter_tmp = iter_tmp->next; 4667 iter_tmp->next = this_forall; 4668 } 4669 else 4670 info->this_loop = this_forall; 4671 4672 n++; 4673 } 4674 nvar = n; 4675 4676 /* Calculate the size needed for the current forall level. */ 4677 size = gfc_index_one_node; 4678 for (n = 0; n < nvar; n++) 4679 { 4680 /* size = (end + step - start) / step. */ 4681 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), 4682 step[n], start[n]); 4683 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), 4684 end[n], tmp); 4685 tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), 4686 tmp, step[n]); 4687 tmp = convert (gfc_array_index_type, tmp); 4688 4689 size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 4690 size, tmp); 4691 } 4692 4693 /* Record the nvar and size of current forall level. */ 4694 info->nvar = nvar; 4695 info->size = size; 4696 4697 if (code->expr1) 4698 { 4699 /* If the mask is .true., consider the FORALL unconditional. */ 4700 if (code->expr1->expr_type == EXPR_CONSTANT 4701 && code->expr1->value.logical) 4702 need_mask = false; 4703 else 4704 need_mask = true; 4705 } 4706 else 4707 need_mask = false; 4708 4709 /* First we need to allocate the mask. */ 4710 if (need_mask) 4711 { 4712 /* As the mask array can be very big, prefer compact boolean types. */ 4713 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); 4714 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type, 4715 size, NULL, &block, &pmask); 4716 maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); 4717 4718 /* Record them in the info structure. */ 4719 info->maskindex = maskindex; 4720 info->mask = mask; 4721 } 4722 else 4723 { 4724 /* No mask was specified. */ 4725 maskindex = NULL_TREE; 4726 mask = pmask = NULL_TREE; 4727 } 4728 4729 /* Link the current forall level to nested_forall_info. */ 4730 info->prev_nest = nested_forall_info; 4731 nested_forall_info = info; 4732 4733 /* Copy the mask into a temporary variable if required. 4734 For now we assume a mask temporary is needed. */ 4735 if (need_mask) 4736 { 4737 /* As the mask array can be very big, prefer compact boolean types. */ 4738 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); 4739 4740 gfc_add_modify (&block, maskindex, gfc_index_zero_node); 4741 4742 /* Start of mask assignment loop body. */ 4743 gfc_start_block (&body); 4744 4745 /* Evaluate the mask expression. */ 4746 gfc_init_se (&se, NULL); 4747 gfc_conv_expr_val (&se, code->expr1); 4748 gfc_add_block_to_block (&body, &se.pre); 4749 4750 /* Store the mask. */ 4751 se.expr = convert (mask_type, se.expr); 4752 4753 tmp = gfc_build_array_ref (mask, maskindex, NULL); 4754 gfc_add_modify (&body, tmp, se.expr); 4755 4756 /* Advance to the next mask element. */ 4757 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 4758 maskindex, gfc_index_one_node); 4759 gfc_add_modify (&body, maskindex, tmp); 4760 4761 /* Generate the loops. */ 4762 tmp = gfc_finish_block (&body); 4763 tmp = gfc_trans_nested_forall_loop (info, tmp, 0); 4764 gfc_add_expr_to_block (&block, tmp); 4765 } 4766 4767 if (code->op == EXEC_DO_CONCURRENT) 4768 { 4769 gfc_init_block (&body); 4770 cycle_label = gfc_build_label_decl (NULL_TREE); 4771 code->cycle_label = cycle_label; 4772 tmp = gfc_trans_code (code->block->next); 4773 gfc_add_expr_to_block (&body, tmp); 4774 4775 if (TREE_USED (cycle_label)) 4776 { 4777 tmp = build1_v (LABEL_EXPR, cycle_label); 4778 gfc_add_expr_to_block (&body, tmp); 4779 } 4780 4781 tmp = gfc_finish_block (&body); 4782 nested_forall_info->do_concurrent = true; 4783 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); 4784 gfc_add_expr_to_block (&block, tmp); 4785 goto done; 4786 } 4787 4788 c = code->block->next; 4789 4790 /* TODO: loop merging in FORALL statements. */ 4791 /* Now that we've got a copy of the mask, generate the assignment loops. */ 4792 while (c) 4793 { 4794 switch (c->op) 4795 { 4796 case EXEC_ASSIGN: 4797 /* A scalar or array assignment. DO the simple check for 4798 lhs to rhs dependencies. These make a temporary for the 4799 rhs and form a second forall block to copy to variable. */ 4800 need_temp = check_forall_dependencies(c, &pre, &post); 4801 4802 /* Temporaries due to array assignment data dependencies introduce 4803 no end of problems. */ 4804 if (need_temp || flag_test_forall_temp) 4805 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false, 4806 nested_forall_info, &block); 4807 else 4808 { 4809 /* Use the normal assignment copying routines. */ 4810 assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); 4811 4812 /* Generate body and loops. */ 4813 tmp = gfc_trans_nested_forall_loop (nested_forall_info, 4814 assign, 1); 4815 gfc_add_expr_to_block (&block, tmp); 4816 } 4817 4818 /* Cleanup any temporary symtrees that have been made to deal 4819 with dependencies. */ 4820 if (new_symtree) 4821 cleanup_forall_symtrees (c); 4822 4823 break; 4824 4825 case EXEC_WHERE: 4826 /* Translate WHERE or WHERE construct nested in FORALL. */ 4827 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); 4828 break; 4829 4830 /* Pointer assignment inside FORALL. */ 4831 case EXEC_POINTER_ASSIGN: 4832 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); 4833 /* Avoid cases where a temporary would never be needed and where 4834 the temp code is guaranteed to fail. */ 4835 if (need_temp 4836 || (flag_test_forall_temp 4837 && c->expr2->expr_type != EXPR_CONSTANT 4838 && c->expr2->expr_type != EXPR_NULL)) 4839 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2, 4840 nested_forall_info, &block); 4841 else 4842 { 4843 /* Use the normal assignment copying routines. */ 4844 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2); 4845 4846 /* Generate body and loops. */ 4847 tmp = gfc_trans_nested_forall_loop (nested_forall_info, 4848 assign, 1); 4849 gfc_add_expr_to_block (&block, tmp); 4850 } 4851 break; 4852 4853 case EXEC_FORALL: 4854 tmp = gfc_trans_forall_1 (c, nested_forall_info); 4855 gfc_add_expr_to_block (&block, tmp); 4856 break; 4857 4858 /* Explicit subroutine calls are prevented by the frontend but interface 4859 assignments can legitimately produce them. */ 4860 case EXEC_ASSIGN_CALL: 4861 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); 4862 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); 4863 gfc_add_expr_to_block (&block, tmp); 4864 break; 4865 4866 default: 4867 gcc_unreachable (); 4868 } 4869 4870 c = c->next; 4871 } 4872 4873 done: 4874 /* Restore the original index variables. */ 4875 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) 4876 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); 4877 4878 /* Free the space for var, start, end, step, varexpr. */ 4879 free (var); 4880 free (start); 4881 free (end); 4882 free (step); 4883 free (varexpr); 4884 free (saved_vars); 4885 4886 for (this_forall = info->this_loop; this_forall;) 4887 { 4888 iter_info *next = this_forall->next; 4889 free (this_forall); 4890 this_forall = next; 4891 } 4892 4893 /* Free the space for this forall_info. */ 4894 free (info); 4895 4896 if (pmask) 4897 { 4898 /* Free the temporary for the mask. */ 4899 tmp = gfc_call_free (pmask); 4900 gfc_add_expr_to_block (&block, tmp); 4901 } 4902 if (maskindex) 4903 pushdecl (maskindex); 4904 4905 gfc_add_block_to_block (&pre, &block); 4906 gfc_add_block_to_block (&pre, &post); 4907 4908 return gfc_finish_block (&pre); 4909 } 4910 4911 4912 /* Translate the FORALL statement or construct. */ 4913 4914 tree gfc_trans_forall (gfc_code * code) 4915 { 4916 return gfc_trans_forall_1 (code, NULL); 4917 } 4918 4919 4920 /* Translate the DO CONCURRENT construct. */ 4921 4922 tree gfc_trans_do_concurrent (gfc_code * code) 4923 { 4924 return gfc_trans_forall_1 (code, NULL); 4925 } 4926 4927 4928 /* Evaluate the WHERE mask expression, copy its value to a temporary. 4929 If the WHERE construct is nested in FORALL, compute the overall temporary 4930 needed by the WHERE mask expression multiplied by the iterator number of 4931 the nested forall. 4932 ME is the WHERE mask expression. 4933 MASK is the current execution mask upon input, whose sense may or may 4934 not be inverted as specified by the INVERT argument. 4935 CMASK is the updated execution mask on output, or NULL if not required. 4936 PMASK is the pending execution mask on output, or NULL if not required. 4937 BLOCK is the block in which to place the condition evaluation loops. */ 4938 4939 static void 4940 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, 4941 tree mask, bool invert, tree cmask, tree pmask, 4942 tree mask_type, stmtblock_t * block) 4943 { 4944 tree tmp, tmp1; 4945 gfc_ss *lss, *rss; 4946 gfc_loopinfo loop; 4947 stmtblock_t body, body1; 4948 tree count, cond, mtmp; 4949 gfc_se lse, rse; 4950 4951 gfc_init_loopinfo (&loop); 4952 4953 lss = gfc_walk_expr (me); 4954 rss = gfc_walk_expr (me); 4955 4956 /* Variable to index the temporary. */ 4957 count = gfc_create_var (gfc_array_index_type, "count"); 4958 /* Initialize count. */ 4959 gfc_add_modify (block, count, gfc_index_zero_node); 4960 4961 gfc_start_block (&body); 4962 4963 gfc_init_se (&rse, NULL); 4964 gfc_init_se (&lse, NULL); 4965 4966 if (lss == gfc_ss_terminator) 4967 { 4968 gfc_init_block (&body1); 4969 } 4970 else 4971 { 4972 /* Initialize the loop. */ 4973 gfc_init_loopinfo (&loop); 4974 4975 /* We may need LSS to determine the shape of the expression. */ 4976 gfc_add_ss_to_loop (&loop, lss); 4977 gfc_add_ss_to_loop (&loop, rss); 4978 4979 gfc_conv_ss_startstride (&loop); 4980 gfc_conv_loop_setup (&loop, &me->where); 4981 4982 gfc_mark_ss_chain_used (rss, 1); 4983 /* Start the loop body. */ 4984 gfc_start_scalarized_body (&loop, &body1); 4985 4986 /* Translate the expression. */ 4987 gfc_copy_loopinfo_to_se (&rse, &loop); 4988 rse.ss = rss; 4989 gfc_conv_expr (&rse, me); 4990 } 4991 4992 /* Variable to evaluate mask condition. */ 4993 cond = gfc_create_var (mask_type, "cond"); 4994 if (mask && (cmask || pmask)) 4995 mtmp = gfc_create_var (mask_type, "mask"); 4996 else mtmp = NULL_TREE; 4997 4998 gfc_add_block_to_block (&body1, &lse.pre); 4999 gfc_add_block_to_block (&body1, &rse.pre); 5000 5001 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)); 5002 5003 if (mask && (cmask || pmask)) 5004 { 5005 tmp = gfc_build_array_ref (mask, count, NULL); 5006 if (invert) 5007 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); 5008 gfc_add_modify (&body1, mtmp, tmp); 5009 } 5010 5011 if (cmask) 5012 { 5013 tmp1 = gfc_build_array_ref (cmask, count, NULL); 5014 tmp = cond; 5015 if (mask) 5016 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, 5017 mtmp, tmp); 5018 gfc_add_modify (&body1, tmp1, tmp); 5019 } 5020 5021 if (pmask) 5022 { 5023 tmp1 = gfc_build_array_ref (pmask, count, NULL); 5024 tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); 5025 if (mask) 5026 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, 5027 tmp); 5028 gfc_add_modify (&body1, tmp1, tmp); 5029 } 5030 5031 gfc_add_block_to_block (&body1, &lse.post); 5032 gfc_add_block_to_block (&body1, &rse.post); 5033 5034 if (lss == gfc_ss_terminator) 5035 { 5036 gfc_add_block_to_block (&body, &body1); 5037 } 5038 else 5039 { 5040 /* Increment count. */ 5041 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 5042 count, gfc_index_one_node); 5043 gfc_add_modify (&body1, count, tmp1); 5044 5045 /* Generate the copying loops. */ 5046 gfc_trans_scalarizing_loops (&loop, &body1); 5047 5048 gfc_add_block_to_block (&body, &loop.pre); 5049 gfc_add_block_to_block (&body, &loop.post); 5050 5051 gfc_cleanup_loop (&loop); 5052 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful 5053 as tree nodes in SS may not be valid in different scope. */ 5054 } 5055 5056 tmp1 = gfc_finish_block (&body); 5057 /* If the WHERE construct is inside FORALL, fill the full temporary. */ 5058 if (nested_forall_info != NULL) 5059 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1); 5060 5061 gfc_add_expr_to_block (block, tmp1); 5062 } 5063 5064 5065 /* Translate an assignment statement in a WHERE statement or construct 5066 statement. The MASK expression is used to control which elements 5067 of EXPR1 shall be assigned. The sense of MASK is specified by 5068 INVERT. */ 5069 5070 static tree 5071 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, 5072 tree mask, bool invert, 5073 tree count1, tree count2, 5074 gfc_code *cnext) 5075 { 5076 gfc_se lse; 5077 gfc_se rse; 5078 gfc_ss *lss; 5079 gfc_ss *lss_section; 5080 gfc_ss *rss; 5081 5082 gfc_loopinfo loop; 5083 tree tmp; 5084 stmtblock_t block; 5085 stmtblock_t body; 5086 tree index, maskexpr; 5087 5088 /* A defined assignment. */ 5089 if (cnext && cnext->resolved_sym) 5090 return gfc_trans_call (cnext, true, mask, count1, invert); 5091 5092 #if 0 5093 /* TODO: handle this special case. 5094 Special case a single function returning an array. */ 5095 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) 5096 { 5097 tmp = gfc_trans_arrayfunc_assign (expr1, expr2); 5098 if (tmp) 5099 return tmp; 5100 } 5101 #endif 5102 5103 /* Assignment of the form lhs = rhs. */ 5104 gfc_start_block (&block); 5105 5106 gfc_init_se (&lse, NULL); 5107 gfc_init_se (&rse, NULL); 5108 5109 /* Walk the lhs. */ 5110 lss = gfc_walk_expr (expr1); 5111 rss = NULL; 5112 5113 /* In each where-assign-stmt, the mask-expr and the variable being 5114 defined shall be arrays of the same shape. */ 5115 gcc_assert (lss != gfc_ss_terminator); 5116 5117 /* The assignment needs scalarization. */ 5118 lss_section = lss; 5119 5120 /* Find a non-scalar SS from the lhs. */ 5121 while (lss_section != gfc_ss_terminator 5122 && lss_section->info->type != GFC_SS_SECTION) 5123 lss_section = lss_section->next; 5124 5125 gcc_assert (lss_section != gfc_ss_terminator); 5126 5127 /* Initialize the scalarizer. */ 5128 gfc_init_loopinfo (&loop); 5129 5130 /* Walk the rhs. */ 5131 rss = gfc_walk_expr (expr2); 5132 if (rss == gfc_ss_terminator) 5133 { 5134 /* The rhs is scalar. Add a ss for the expression. */ 5135 rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); 5136 rss->info->where = 1; 5137 } 5138 5139 /* Associate the SS with the loop. */ 5140 gfc_add_ss_to_loop (&loop, lss); 5141 gfc_add_ss_to_loop (&loop, rss); 5142 5143 /* Calculate the bounds of the scalarization. */ 5144 gfc_conv_ss_startstride (&loop); 5145 5146 /* Resolve any data dependencies in the statement. */ 5147 gfc_conv_resolve_dependencies (&loop, lss_section, rss); 5148 5149 /* Setup the scalarizing loops. */ 5150 gfc_conv_loop_setup (&loop, &expr2->where); 5151 5152 /* Setup the gfc_se structures. */ 5153 gfc_copy_loopinfo_to_se (&lse, &loop); 5154 gfc_copy_loopinfo_to_se (&rse, &loop); 5155 5156 rse.ss = rss; 5157 gfc_mark_ss_chain_used (rss, 1); 5158 if (loop.temp_ss == NULL) 5159 { 5160 lse.ss = lss; 5161 gfc_mark_ss_chain_used (lss, 1); 5162 } 5163 else 5164 { 5165 lse.ss = loop.temp_ss; 5166 gfc_mark_ss_chain_used (lss, 3); 5167 gfc_mark_ss_chain_used (loop.temp_ss, 3); 5168 } 5169 5170 /* Start the scalarized loop body. */ 5171 gfc_start_scalarized_body (&loop, &body); 5172 5173 /* Translate the expression. */ 5174 gfc_conv_expr (&rse, expr2); 5175 if (lss != gfc_ss_terminator && loop.temp_ss != NULL) 5176 gfc_conv_tmp_array_ref (&lse); 5177 else 5178 gfc_conv_expr (&lse, expr1); 5179 5180 /* Form the mask expression according to the mask. */ 5181 index = count1; 5182 maskexpr = gfc_build_array_ref (mask, index, NULL); 5183 if (invert) 5184 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, 5185 TREE_TYPE (maskexpr), maskexpr); 5186 5187 /* Use the scalar assignment as is. */ 5188 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, 5189 false, loop.temp_ss == NULL); 5190 5191 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); 5192 5193 gfc_add_expr_to_block (&body, tmp); 5194 5195 if (lss == gfc_ss_terminator) 5196 { 5197 /* Increment count1. */ 5198 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 5199 count1, gfc_index_one_node); 5200 gfc_add_modify (&body, count1, tmp); 5201 5202 /* Use the scalar assignment as is. */ 5203 gfc_add_block_to_block (&block, &body); 5204 } 5205 else 5206 { 5207 gcc_assert (lse.ss == gfc_ss_terminator 5208 && rse.ss == gfc_ss_terminator); 5209 5210 if (loop.temp_ss != NULL) 5211 { 5212 /* Increment count1 before finish the main body of a scalarized 5213 expression. */ 5214 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5215 gfc_array_index_type, count1, gfc_index_one_node); 5216 gfc_add_modify (&body, count1, tmp); 5217 gfc_trans_scalarized_loop_boundary (&loop, &body); 5218 5219 /* We need to copy the temporary to the actual lhs. */ 5220 gfc_init_se (&lse, NULL); 5221 gfc_init_se (&rse, NULL); 5222 gfc_copy_loopinfo_to_se (&lse, &loop); 5223 gfc_copy_loopinfo_to_se (&rse, &loop); 5224 5225 rse.ss = loop.temp_ss; 5226 lse.ss = lss; 5227 5228 gfc_conv_tmp_array_ref (&rse); 5229 gfc_conv_expr (&lse, expr1); 5230 5231 gcc_assert (lse.ss == gfc_ss_terminator 5232 && rse.ss == gfc_ss_terminator); 5233 5234 /* Form the mask expression according to the mask tree list. */ 5235 index = count2; 5236 maskexpr = gfc_build_array_ref (mask, index, NULL); 5237 if (invert) 5238 maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, 5239 TREE_TYPE (maskexpr), maskexpr); 5240 5241 /* Use the scalar assignment as is. */ 5242 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true); 5243 tmp = build3_v (COND_EXPR, maskexpr, tmp, 5244 build_empty_stmt (input_location)); 5245 gfc_add_expr_to_block (&body, tmp); 5246 5247 /* Increment count2. */ 5248 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5249 gfc_array_index_type, count2, 5250 gfc_index_one_node); 5251 gfc_add_modify (&body, count2, tmp); 5252 } 5253 else 5254 { 5255 /* Increment count1. */ 5256 tmp = fold_build2_loc (input_location, PLUS_EXPR, 5257 gfc_array_index_type, count1, 5258 gfc_index_one_node); 5259 gfc_add_modify (&body, count1, tmp); 5260 } 5261 5262 /* Generate the copying loops. */ 5263 gfc_trans_scalarizing_loops (&loop, &body); 5264 5265 /* Wrap the whole thing up. */ 5266 gfc_add_block_to_block (&block, &loop.pre); 5267 gfc_add_block_to_block (&block, &loop.post); 5268 gfc_cleanup_loop (&loop); 5269 } 5270 5271 return gfc_finish_block (&block); 5272 } 5273 5274 5275 /* Translate the WHERE construct or statement. 5276 This function can be called iteratively to translate the nested WHERE 5277 construct or statement. 5278 MASK is the control mask. */ 5279 5280 static void 5281 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, 5282 forall_info * nested_forall_info, stmtblock_t * block) 5283 { 5284 stmtblock_t inner_size_body; 5285 tree inner_size, size; 5286 gfc_ss *lss, *rss; 5287 tree mask_type; 5288 gfc_expr *expr1; 5289 gfc_expr *expr2; 5290 gfc_code *cblock; 5291 gfc_code *cnext; 5292 tree tmp; 5293 tree cond; 5294 tree count1, count2; 5295 bool need_cmask; 5296 bool need_pmask; 5297 int need_temp; 5298 tree pcmask = NULL_TREE; 5299 tree ppmask = NULL_TREE; 5300 tree cmask = NULL_TREE; 5301 tree pmask = NULL_TREE; 5302 gfc_actual_arglist *arg; 5303 5304 /* the WHERE statement or the WHERE construct statement. */ 5305 cblock = code->block; 5306 5307 /* As the mask array can be very big, prefer compact boolean types. */ 5308 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); 5309 5310 /* Determine which temporary masks are needed. */ 5311 if (!cblock->block) 5312 { 5313 /* One clause: No ELSEWHEREs. */ 5314 need_cmask = (cblock->next != 0); 5315 need_pmask = false; 5316 } 5317 else if (cblock->block->block) 5318 { 5319 /* Three or more clauses: Conditional ELSEWHEREs. */ 5320 need_cmask = true; 5321 need_pmask = true; 5322 } 5323 else if (cblock->next) 5324 { 5325 /* Two clauses, the first non-empty. */ 5326 need_cmask = true; 5327 need_pmask = (mask != NULL_TREE 5328 && cblock->block->next != 0); 5329 } 5330 else if (!cblock->block->next) 5331 { 5332 /* Two clauses, both empty. */ 5333 need_cmask = false; 5334 need_pmask = false; 5335 } 5336 /* Two clauses, the first empty, the second non-empty. */ 5337 else if (mask) 5338 { 5339 need_cmask = (cblock->block->expr1 != 0); 5340 need_pmask = true; 5341 } 5342 else 5343 { 5344 need_cmask = true; 5345 need_pmask = false; 5346 } 5347 5348 if (need_cmask || need_pmask) 5349 { 5350 /* Calculate the size of temporary needed by the mask-expr. */ 5351 gfc_init_block (&inner_size_body); 5352 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, 5353 &inner_size_body, &lss, &rss); 5354 5355 gfc_free_ss_chain (lss); 5356 gfc_free_ss_chain (rss); 5357 5358 /* Calculate the total size of temporary needed. */ 5359 size = compute_overall_iter_number (nested_forall_info, inner_size, 5360 &inner_size_body, block); 5361 5362 /* Check whether the size is negative. */ 5363 cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size, 5364 gfc_index_zero_node); 5365 size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, 5366 cond, gfc_index_zero_node, size); 5367 size = gfc_evaluate_now (size, block); 5368 5369 /* Allocate temporary for WHERE mask if needed. */ 5370 if (need_cmask) 5371 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, 5372 &pcmask); 5373 5374 /* Allocate temporary for !mask if needed. */ 5375 if (need_pmask) 5376 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, 5377 &ppmask); 5378 } 5379 5380 while (cblock) 5381 { 5382 /* Each time around this loop, the where clause is conditional 5383 on the value of mask and invert, which are updated at the 5384 bottom of the loop. */ 5385 5386 /* Has mask-expr. */ 5387 if (cblock->expr1) 5388 { 5389 /* Ensure that the WHERE mask will be evaluated exactly once. 5390 If there are no statements in this WHERE/ELSEWHERE clause, 5391 then we don't need to update the control mask (cmask). 5392 If this is the last clause of the WHERE construct, then 5393 we don't need to update the pending control mask (pmask). */ 5394 if (mask) 5395 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, 5396 mask, invert, 5397 cblock->next ? cmask : NULL_TREE, 5398 cblock->block ? pmask : NULL_TREE, 5399 mask_type, block); 5400 else 5401 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, 5402 NULL_TREE, false, 5403 (cblock->next || cblock->block) 5404 ? cmask : NULL_TREE, 5405 NULL_TREE, mask_type, block); 5406 5407 invert = false; 5408 } 5409 /* It's a final elsewhere-stmt. No mask-expr is present. */ 5410 else 5411 cmask = mask; 5412 5413 /* The body of this where clause are controlled by cmask with 5414 sense specified by invert. */ 5415 5416 /* Get the assignment statement of a WHERE statement, or the first 5417 statement in where-body-construct of a WHERE construct. */ 5418 cnext = cblock->next; 5419 while (cnext) 5420 { 5421 switch (cnext->op) 5422 { 5423 /* WHERE assignment statement. */ 5424 case EXEC_ASSIGN_CALL: 5425 5426 arg = cnext->ext.actual; 5427 expr1 = expr2 = NULL; 5428 for (; arg; arg = arg->next) 5429 { 5430 if (!arg->expr) 5431 continue; 5432 if (expr1 == NULL) 5433 expr1 = arg->expr; 5434 else 5435 expr2 = arg->expr; 5436 } 5437 goto evaluate; 5438 5439 case EXEC_ASSIGN: 5440 expr1 = cnext->expr1; 5441 expr2 = cnext->expr2; 5442 evaluate: 5443 if (nested_forall_info != NULL) 5444 { 5445 need_temp = gfc_check_dependency (expr1, expr2, 0); 5446 if ((need_temp || flag_test_forall_temp) 5447 && cnext->op != EXEC_ASSIGN_CALL) 5448 gfc_trans_assign_need_temp (expr1, expr2, 5449 cmask, invert, 5450 nested_forall_info, block); 5451 else 5452 { 5453 /* Variables to control maskexpr. */ 5454 count1 = gfc_create_var (gfc_array_index_type, "count1"); 5455 count2 = gfc_create_var (gfc_array_index_type, "count2"); 5456 gfc_add_modify (block, count1, gfc_index_zero_node); 5457 gfc_add_modify (block, count2, gfc_index_zero_node); 5458 5459 tmp = gfc_trans_where_assign (expr1, expr2, 5460 cmask, invert, 5461 count1, count2, 5462 cnext); 5463 5464 tmp = gfc_trans_nested_forall_loop (nested_forall_info, 5465 tmp, 1); 5466 gfc_add_expr_to_block (block, tmp); 5467 } 5468 } 5469 else 5470 { 5471 /* Variables to control maskexpr. */ 5472 count1 = gfc_create_var (gfc_array_index_type, "count1"); 5473 count2 = gfc_create_var (gfc_array_index_type, "count2"); 5474 gfc_add_modify (block, count1, gfc_index_zero_node); 5475 gfc_add_modify (block, count2, gfc_index_zero_node); 5476 5477 tmp = gfc_trans_where_assign (expr1, expr2, 5478 cmask, invert, 5479 count1, count2, 5480 cnext); 5481 gfc_add_expr_to_block (block, tmp); 5482 5483 } 5484 break; 5485 5486 /* WHERE or WHERE construct is part of a where-body-construct. */ 5487 case EXEC_WHERE: 5488 gfc_trans_where_2 (cnext, cmask, invert, 5489 nested_forall_info, block); 5490 break; 5491 5492 default: 5493 gcc_unreachable (); 5494 } 5495 5496 /* The next statement within the same where-body-construct. */ 5497 cnext = cnext->next; 5498 } 5499 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ 5500 cblock = cblock->block; 5501 if (mask == NULL_TREE) 5502 { 5503 /* If we're the initial WHERE, we can simply invert the sense 5504 of the current mask to obtain the "mask" for the remaining 5505 ELSEWHEREs. */ 5506 invert = true; 5507 mask = cmask; 5508 } 5509 else 5510 { 5511 /* Otherwise, for nested WHERE's we need to use the pending mask. */ 5512 invert = false; 5513 mask = pmask; 5514 } 5515 } 5516 5517 /* If we allocated a pending mask array, deallocate it now. */ 5518 if (ppmask) 5519 { 5520 tmp = gfc_call_free (ppmask); 5521 gfc_add_expr_to_block (block, tmp); 5522 } 5523 5524 /* If we allocated a current mask array, deallocate it now. */ 5525 if (pcmask) 5526 { 5527 tmp = gfc_call_free (pcmask); 5528 gfc_add_expr_to_block (block, tmp); 5529 } 5530 } 5531 5532 /* Translate a simple WHERE construct or statement without dependencies. 5533 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR 5534 is the mask condition, and EBLOCK if non-NULL is the "else" clause. 5535 Currently both CBLOCK and EBLOCK are restricted to single assignments. */ 5536 5537 static tree 5538 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) 5539 { 5540 stmtblock_t block, body; 5541 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; 5542 tree tmp, cexpr, tstmt, estmt; 5543 gfc_ss *css, *tdss, *tsss; 5544 gfc_se cse, tdse, tsse, edse, esse; 5545 gfc_loopinfo loop; 5546 gfc_ss *edss = 0; 5547 gfc_ss *esss = 0; 5548 bool maybe_workshare = false; 5549 5550 /* Allow the scalarizer to workshare simple where loops. */ 5551 if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY)) 5552 == OMPWS_WORKSHARE_FLAG) 5553 { 5554 maybe_workshare = true; 5555 ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; 5556 } 5557 5558 cond = cblock->expr1; 5559 tdst = cblock->next->expr1; 5560 tsrc = cblock->next->expr2; 5561 edst = eblock ? eblock->next->expr1 : NULL; 5562 esrc = eblock ? eblock->next->expr2 : NULL; 5563 5564 gfc_start_block (&block); 5565 gfc_init_loopinfo (&loop); 5566 5567 /* Handle the condition. */ 5568 gfc_init_se (&cse, NULL); 5569 css = gfc_walk_expr (cond); 5570 gfc_add_ss_to_loop (&loop, css); 5571 5572 /* Handle the then-clause. */ 5573 gfc_init_se (&tdse, NULL); 5574 gfc_init_se (&tsse, NULL); 5575 tdss = gfc_walk_expr (tdst); 5576 tsss = gfc_walk_expr (tsrc); 5577 if (tsss == gfc_ss_terminator) 5578 { 5579 tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc); 5580 tsss->info->where = 1; 5581 } 5582 gfc_add_ss_to_loop (&loop, tdss); 5583 gfc_add_ss_to_loop (&loop, tsss); 5584 5585 if (eblock) 5586 { 5587 /* Handle the else clause. */ 5588 gfc_init_se (&edse, NULL); 5589 gfc_init_se (&esse, NULL); 5590 edss = gfc_walk_expr (edst); 5591 esss = gfc_walk_expr (esrc); 5592 if (esss == gfc_ss_terminator) 5593 { 5594 esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc); 5595 esss->info->where = 1; 5596 } 5597 gfc_add_ss_to_loop (&loop, edss); 5598 gfc_add_ss_to_loop (&loop, esss); 5599 } 5600 5601 gfc_conv_ss_startstride (&loop); 5602 gfc_conv_loop_setup (&loop, &tdst->where); 5603 5604 gfc_mark_ss_chain_used (css, 1); 5605 gfc_mark_ss_chain_used (tdss, 1); 5606 gfc_mark_ss_chain_used (tsss, 1); 5607 if (eblock) 5608 { 5609 gfc_mark_ss_chain_used (edss, 1); 5610 gfc_mark_ss_chain_used (esss, 1); 5611 } 5612 5613 gfc_start_scalarized_body (&loop, &body); 5614 5615 gfc_copy_loopinfo_to_se (&cse, &loop); 5616 gfc_copy_loopinfo_to_se (&tdse, &loop); 5617 gfc_copy_loopinfo_to_se (&tsse, &loop); 5618 cse.ss = css; 5619 tdse.ss = tdss; 5620 tsse.ss = tsss; 5621 if (eblock) 5622 { 5623 gfc_copy_loopinfo_to_se (&edse, &loop); 5624 gfc_copy_loopinfo_to_se (&esse, &loop); 5625 edse.ss = edss; 5626 esse.ss = esss; 5627 } 5628 5629 gfc_conv_expr (&cse, cond); 5630 gfc_add_block_to_block (&body, &cse.pre); 5631 cexpr = cse.expr; 5632 5633 gfc_conv_expr (&tsse, tsrc); 5634 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) 5635 gfc_conv_tmp_array_ref (&tdse); 5636 else 5637 gfc_conv_expr (&tdse, tdst); 5638 5639 if (eblock) 5640 { 5641 gfc_conv_expr (&esse, esrc); 5642 if (edss != gfc_ss_terminator && loop.temp_ss != NULL) 5643 gfc_conv_tmp_array_ref (&edse); 5644 else 5645 gfc_conv_expr (&edse, edst); 5646 } 5647 5648 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true); 5649 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, 5650 false, true) 5651 : build_empty_stmt (input_location); 5652 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); 5653 gfc_add_expr_to_block (&body, tmp); 5654 gfc_add_block_to_block (&body, &cse.post); 5655 5656 if (maybe_workshare) 5657 ompws_flags &= ~OMPWS_SCALARIZER_BODY; 5658 gfc_trans_scalarizing_loops (&loop, &body); 5659 gfc_add_block_to_block (&block, &loop.pre); 5660 gfc_add_block_to_block (&block, &loop.post); 5661 gfc_cleanup_loop (&loop); 5662 5663 return gfc_finish_block (&block); 5664 } 5665 5666 /* As the WHERE or WHERE construct statement can be nested, we call 5667 gfc_trans_where_2 to do the translation, and pass the initial 5668 NULL values for both the control mask and the pending control mask. */ 5669 5670 tree 5671 gfc_trans_where (gfc_code * code) 5672 { 5673 stmtblock_t block; 5674 gfc_code *cblock; 5675 gfc_code *eblock; 5676 5677 cblock = code->block; 5678 if (cblock->next 5679 && cblock->next->op == EXEC_ASSIGN 5680 && !cblock->next->next) 5681 { 5682 eblock = cblock->block; 5683 if (!eblock) 5684 { 5685 /* A simple "WHERE (cond) x = y" statement or block is 5686 dependence free if cond is not dependent upon writing x, 5687 and the source y is unaffected by the destination x. */ 5688 if (!gfc_check_dependency (cblock->next->expr1, 5689 cblock->expr1, 0) 5690 && !gfc_check_dependency (cblock->next->expr1, 5691 cblock->next->expr2, 0)) 5692 return gfc_trans_where_3 (cblock, NULL); 5693 } 5694 else if (!eblock->expr1 5695 && !eblock->block 5696 && eblock->next 5697 && eblock->next->op == EXEC_ASSIGN 5698 && !eblock->next->next) 5699 { 5700 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" 5701 block is dependence free if cond is not dependent on writes 5702 to x1 and x2, y1 is not dependent on writes to x2, and y2 5703 is not dependent on writes to x1, and both y's are not 5704 dependent upon their own x's. In addition to this, the 5705 final two dependency checks below exclude all but the same 5706 array reference if the where and elswhere destinations 5707 are the same. In short, this is VERY conservative and this 5708 is needed because the two loops, required by the standard 5709 are coalesced in gfc_trans_where_3. */ 5710 if (!gfc_check_dependency (cblock->next->expr1, 5711 cblock->expr1, 0) 5712 && !gfc_check_dependency (eblock->next->expr1, 5713 cblock->expr1, 0) 5714 && !gfc_check_dependency (cblock->next->expr1, 5715 eblock->next->expr2, 1) 5716 && !gfc_check_dependency (eblock->next->expr1, 5717 cblock->next->expr2, 1) 5718 && !gfc_check_dependency (cblock->next->expr1, 5719 cblock->next->expr2, 1) 5720 && !gfc_check_dependency (eblock->next->expr1, 5721 eblock->next->expr2, 1) 5722 && !gfc_check_dependency (cblock->next->expr1, 5723 eblock->next->expr1, 0) 5724 && !gfc_check_dependency (eblock->next->expr1, 5725 cblock->next->expr1, 0)) 5726 return gfc_trans_where_3 (cblock, eblock); 5727 } 5728 } 5729 5730 gfc_start_block (&block); 5731 5732 gfc_trans_where_2 (code, NULL, false, NULL, &block); 5733 5734 return gfc_finish_block (&block); 5735 } 5736 5737 5738 /* CYCLE a DO loop. The label decl has already been created by 5739 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code 5740 node at the head of the loop. We must mark the label as used. */ 5741 5742 tree 5743 gfc_trans_cycle (gfc_code * code) 5744 { 5745 tree cycle_label; 5746 5747 cycle_label = code->ext.which_construct->cycle_label; 5748 gcc_assert (cycle_label); 5749 5750 TREE_USED (cycle_label) = 1; 5751 return build1_v (GOTO_EXPR, cycle_label); 5752 } 5753 5754 5755 /* EXIT a DO loop. Similar to CYCLE, but now the label is in 5756 TREE_VALUE (backend_decl) of the gfc_code node at the head of the 5757 loop. */ 5758 5759 tree 5760 gfc_trans_exit (gfc_code * code) 5761 { 5762 tree exit_label; 5763 5764 exit_label = code->ext.which_construct->exit_label; 5765 gcc_assert (exit_label); 5766 5767 TREE_USED (exit_label) = 1; 5768 return build1_v (GOTO_EXPR, exit_label); 5769 } 5770 5771 5772 /* Get the initializer expression for the code and expr of an allocate. 5773 When no initializer is needed return NULL. */ 5774 5775 static gfc_expr * 5776 allocate_get_initializer (gfc_code * code, gfc_expr * expr) 5777 { 5778 if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS) 5779 return NULL; 5780 5781 /* An explicit type was given in allocate ( T:: object). */ 5782 if (code->ext.alloc.ts.type == BT_DERIVED 5783 && (code->ext.alloc.ts.u.derived->attr.alloc_comp 5784 || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) 5785 return gfc_default_initializer (&code->ext.alloc.ts); 5786 5787 if (gfc_bt_struct (expr->ts.type) 5788 && (expr->ts.u.derived->attr.alloc_comp 5789 || gfc_has_default_initializer (expr->ts.u.derived))) 5790 return gfc_default_initializer (&expr->ts); 5791 5792 if (expr->ts.type == BT_CLASS 5793 && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp 5794 || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived))) 5795 return gfc_default_initializer (&CLASS_DATA (expr)->ts); 5796 5797 return NULL; 5798 } 5799 5800 /* Translate the ALLOCATE statement. */ 5801 5802 tree 5803 gfc_trans_allocate (gfc_code * code) 5804 { 5805 gfc_alloc *al; 5806 gfc_expr *expr, *e3rhs = NULL, *init_expr; 5807 gfc_se se, se_sz; 5808 tree tmp; 5809 tree parm; 5810 tree stat; 5811 tree errmsg; 5812 tree errlen; 5813 tree label_errmsg; 5814 tree label_finish; 5815 tree memsz; 5816 tree al_vptr, al_len; 5817 /* If an expr3 is present, then store the tree for accessing its 5818 _vptr, and _len components in the variables, respectively. The 5819 element size, i.e. _vptr%size, is stored in expr3_esize. Any of 5820 the trees may be the NULL_TREE indicating that this is not 5821 available for expr3's type. */ 5822 tree expr3, expr3_vptr, expr3_len, expr3_esize; 5823 /* Classify what expr3 stores. */ 5824 enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; 5825 stmtblock_t block; 5826 stmtblock_t post; 5827 stmtblock_t final_block; 5828 tree nelems; 5829 bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; 5830 bool needs_caf_sync, caf_refs_comp; 5831 bool e3_has_nodescriptor = false; 5832 gfc_symtree *newsym = NULL; 5833 symbol_attribute caf_attr; 5834 gfc_actual_arglist *param_list; 5835 5836 if (!code->ext.alloc.list) 5837 return NULL_TREE; 5838 5839 stat = tmp = memsz = al_vptr = al_len = NULL_TREE; 5840 expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; 5841 label_errmsg = label_finish = errmsg = errlen = NULL_TREE; 5842 e3_is = E3_UNSET; 5843 is_coarray = needs_caf_sync = false; 5844 5845 gfc_init_block (&block); 5846 gfc_init_block (&post); 5847 gfc_init_block (&final_block); 5848 5849 /* STAT= (and maybe ERRMSG=) is present. */ 5850 if (code->expr1) 5851 { 5852 /* STAT=. */ 5853 tree gfc_int4_type_node = gfc_get_int_type (4); 5854 stat = gfc_create_var (gfc_int4_type_node, "stat"); 5855 5856 /* ERRMSG= only makes sense with STAT=. */ 5857 if (code->expr2) 5858 { 5859 gfc_init_se (&se, NULL); 5860 se.want_pointer = 1; 5861 gfc_conv_expr_lhs (&se, code->expr2); 5862 errmsg = se.expr; 5863 errlen = se.string_length; 5864 } 5865 else 5866 { 5867 errmsg = null_pointer_node; 5868 errlen = build_int_cst (gfc_charlen_type_node, 0); 5869 } 5870 5871 /* GOTO destinations. */ 5872 label_errmsg = gfc_build_label_decl (NULL_TREE); 5873 label_finish = gfc_build_label_decl (NULL_TREE); 5874 TREE_USED (label_finish) = 0; 5875 } 5876 5877 /* When an expr3 is present evaluate it only once. The standards prevent a 5878 dependency of expr3 on the objects in the allocate list. An expr3 can 5879 be pre-evaluated in all cases. One just has to make sure, to use the 5880 correct way, i.e., to get the descriptor or to get a reference 5881 expression. */ 5882 if (code->expr3) 5883 { 5884 bool vtab_needed = false, temp_var_needed = false, 5885 temp_obj_created = false; 5886 5887 is_coarray = gfc_is_coarray (code->expr3); 5888 5889 if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold 5890 && (gfc_is_class_array_function (code->expr3) 5891 || gfc_is_alloc_class_scalar_function (code->expr3))) 5892 code->expr3->must_finalize = 1; 5893 5894 /* Figure whether we need the vtab from expr3. */ 5895 for (al = code->ext.alloc.list; !vtab_needed && al != NULL; 5896 al = al->next) 5897 vtab_needed = (al->expr->ts.type == BT_CLASS); 5898 5899 gfc_init_se (&se, NULL); 5900 /* When expr3 is a variable, i.e., a very simple expression, 5901 then convert it once here. */ 5902 if (code->expr3->expr_type == EXPR_VARIABLE 5903 || code->expr3->expr_type == EXPR_ARRAY 5904 || code->expr3->expr_type == EXPR_CONSTANT) 5905 { 5906 if (!code->expr3->mold 5907 || code->expr3->ts.type == BT_CHARACTER 5908 || vtab_needed 5909 || code->ext.alloc.arr_spec_from_expr3) 5910 { 5911 /* Convert expr3 to a tree. For all "simple" expression just 5912 get the descriptor or the reference, respectively, depending 5913 on the rank of the expr. */ 5914 if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) 5915 gfc_conv_expr_descriptor (&se, code->expr3); 5916 else 5917 { 5918 gfc_conv_expr_reference (&se, code->expr3); 5919 5920 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a 5921 NOP_EXPR, which prevents gfortran from getting the vptr 5922 from the source=-expression. Remove the NOP_EXPR and go 5923 with the POINTER_PLUS_EXPR in this case. */ 5924 if (code->expr3->ts.type == BT_CLASS 5925 && TREE_CODE (se.expr) == NOP_EXPR 5926 && (TREE_CODE (TREE_OPERAND (se.expr, 0)) 5927 == POINTER_PLUS_EXPR 5928 || is_coarray)) 5929 se.expr = TREE_OPERAND (se.expr, 0); 5930 } 5931 /* Create a temp variable only for component refs to prevent 5932 having to go through the full deref-chain each time and to 5933 simplfy computation of array properties. */ 5934 temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; 5935 } 5936 } 5937 else 5938 { 5939 /* In all other cases evaluate the expr3. */ 5940 symbol_attribute attr; 5941 /* Get the descriptor for all arrays, that are not allocatable or 5942 pointer, because the latter are descriptors already. 5943 The exception are function calls returning a class object: 5944 The descriptor is stored in their results _data component, which 5945 is easier to access, when first a temporary variable for the 5946 result is created and the descriptor retrieved from there. */ 5947 attr = gfc_expr_attr (code->expr3); 5948 if (code->expr3->rank != 0 5949 && ((!attr.allocatable && !attr.pointer) 5950 || (code->expr3->expr_type == EXPR_FUNCTION 5951 && (code->expr3->ts.type != BT_CLASS 5952 || (code->expr3->value.function.isym 5953 && code->expr3->value.function.isym 5954 ->transformational))))) 5955 gfc_conv_expr_descriptor (&se, code->expr3); 5956 else 5957 gfc_conv_expr_reference (&se, code->expr3); 5958 if (code->expr3->ts.type == BT_CLASS) 5959 gfc_conv_class_to_class (&se, code->expr3, 5960 code->expr3->ts, 5961 false, true, 5962 false, false); 5963 temp_obj_created = temp_var_needed = !VAR_P (se.expr); 5964 } 5965 gfc_add_block_to_block (&block, &se.pre); 5966 if (code->expr3->must_finalize) 5967 gfc_add_block_to_block (&final_block, &se.post); 5968 else 5969 gfc_add_block_to_block (&post, &se.post); 5970 5971 /* Special case when string in expr3 is zero. */ 5972 if (code->expr3->ts.type == BT_CHARACTER 5973 && integer_zerop (se.string_length)) 5974 { 5975 gfc_init_se (&se, NULL); 5976 temp_var_needed = false; 5977 expr3_len = build_zero_cst (gfc_charlen_type_node); 5978 e3_is = E3_MOLD; 5979 } 5980 /* Prevent aliasing, i.e., se.expr may be already a 5981 variable declaration. */ 5982 else if (se.expr != NULL_TREE && temp_var_needed) 5983 { 5984 tree var, desc; 5985 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ? 5986 se.expr 5987 : build_fold_indirect_ref_loc (input_location, se.expr); 5988 5989 /* Get the array descriptor and prepare it to be assigned to the 5990 temporary variable var. For classes the array descriptor is 5991 in the _data component and the object goes into the 5992 GFC_DECL_SAVED_DESCRIPTOR. */ 5993 if (code->expr3->ts.type == BT_CLASS 5994 && code->expr3->rank != 0) 5995 { 5996 /* When an array_ref was in expr3, then the descriptor is the 5997 first operand. */ 5998 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) 5999 { 6000 desc = TREE_OPERAND (tmp, 0); 6001 } 6002 else 6003 { 6004 desc = tmp; 6005 tmp = gfc_class_data_get (tmp); 6006 } 6007 if (code->ext.alloc.arr_spec_from_expr3) 6008 e3_is = E3_DESC; 6009 } 6010 else 6011 desc = !is_coarray ? se.expr 6012 : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0); 6013 /* We need a regular (non-UID) symbol here, therefore give a 6014 prefix. */ 6015 var = gfc_create_var (TREE_TYPE (tmp), "source"); 6016 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) 6017 { 6018 gfc_allocate_lang_decl (var); 6019 GFC_DECL_SAVED_DESCRIPTOR (var) = desc; 6020 } 6021 gfc_add_modify_loc (input_location, &block, var, tmp); 6022 6023 expr3 = var; 6024 if (se.string_length) 6025 /* Evaluate it assuming that it also is complicated like expr3. */ 6026 expr3_len = gfc_evaluate_now (se.string_length, &block); 6027 } 6028 else 6029 { 6030 expr3 = se.expr; 6031 expr3_len = se.string_length; 6032 } 6033 6034 /* Deallocate any allocatable components in expressions that use a 6035 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. 6036 E.g. temporaries of a function call need freeing of their components 6037 here. */ 6038 if ((code->expr3->ts.type == BT_DERIVED 6039 || code->expr3->ts.type == BT_CLASS) 6040 && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) 6041 && code->expr3->ts.u.derived->attr.alloc_comp 6042 && !code->expr3->must_finalize) 6043 { 6044 tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, 6045 expr3, code->expr3->rank); 6046 gfc_prepend_expr_to_block (&post, tmp); 6047 } 6048 6049 /* Store what the expr3 is to be used for. */ 6050 if (e3_is == E3_UNSET) 6051 e3_is = expr3 != NULL_TREE ? 6052 (code->ext.alloc.arr_spec_from_expr3 ? 6053 E3_DESC 6054 : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) 6055 : E3_UNSET; 6056 6057 /* Figure how to get the _vtab entry. This also obtains the tree 6058 expression for accessing the _len component, because only 6059 unlimited polymorphic objects, which are a subcategory of class 6060 types, have a _len component. */ 6061 if (code->expr3->ts.type == BT_CLASS) 6062 { 6063 gfc_expr *rhs; 6064 tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ? 6065 build_fold_indirect_ref (expr3): expr3; 6066 /* Polymorphic SOURCE: VPTR must be determined at run time. 6067 expr3 may be a temporary array declaration, therefore check for 6068 GFC_CLASS_TYPE_P before trying to get the _vptr component. */ 6069 if (tmp != NULL_TREE 6070 && (e3_is == E3_DESC 6071 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) 6072 && (VAR_P (tmp) || !code->expr3->ref)) 6073 || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp)))) 6074 tmp = gfc_class_vptr_get (expr3); 6075 else 6076 { 6077 rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); 6078 gfc_add_vptr_component (rhs); 6079 gfc_init_se (&se, NULL); 6080 se.want_pointer = 1; 6081 gfc_conv_expr (&se, rhs); 6082 tmp = se.expr; 6083 gfc_free_expr (rhs); 6084 } 6085 /* Set the element size. */ 6086 expr3_esize = gfc_vptr_size_get (tmp); 6087 if (vtab_needed) 6088 expr3_vptr = tmp; 6089 /* Initialize the ref to the _len component. */ 6090 if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) 6091 { 6092 /* Same like for retrieving the _vptr. */ 6093 if (expr3 != NULL_TREE && !code->expr3->ref) 6094 expr3_len = gfc_class_len_get (expr3); 6095 else 6096 { 6097 rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); 6098 gfc_add_len_component (rhs); 6099 gfc_init_se (&se, NULL); 6100 gfc_conv_expr (&se, rhs); 6101 expr3_len = se.expr; 6102 gfc_free_expr (rhs); 6103 } 6104 } 6105 } 6106 else 6107 { 6108 /* When the object to allocate is polymorphic type, then it 6109 needs its vtab set correctly, so deduce the required _vtab 6110 and _len from the source expression. */ 6111 if (vtab_needed) 6112 { 6113 /* VPTR is fixed at compile time. */ 6114 gfc_symbol *vtab; 6115 6116 vtab = gfc_find_vtab (&code->expr3->ts); 6117 gcc_assert (vtab); 6118 expr3_vptr = gfc_get_symbol_decl (vtab); 6119 expr3_vptr = gfc_build_addr_expr (NULL_TREE, 6120 expr3_vptr); 6121 } 6122 /* _len component needs to be set, when ts is a character 6123 array. */ 6124 if (expr3_len == NULL_TREE 6125 && code->expr3->ts.type == BT_CHARACTER) 6126 { 6127 if (code->expr3->ts.u.cl 6128 && code->expr3->ts.u.cl->length) 6129 { 6130 gfc_init_se (&se, NULL); 6131 gfc_conv_expr (&se, code->expr3->ts.u.cl->length); 6132 gfc_add_block_to_block (&block, &se.pre); 6133 expr3_len = gfc_evaluate_now (se.expr, &block); 6134 } 6135 gcc_assert (expr3_len); 6136 } 6137 /* For character arrays only the kind's size is needed, because 6138 the array mem_size is _len * (elem_size = kind_size). 6139 For all other get the element size in the normal way. */ 6140 if (code->expr3->ts.type == BT_CHARACTER) 6141 expr3_esize = TYPE_SIZE_UNIT ( 6142 gfc_get_char_type (code->expr3->ts.kind)); 6143 else 6144 expr3_esize = TYPE_SIZE_UNIT ( 6145 gfc_typenode_for_spec (&code->expr3->ts)); 6146 } 6147 gcc_assert (expr3_esize); 6148 expr3_esize = fold_convert (sizetype, expr3_esize); 6149 if (e3_is == E3_MOLD) 6150 /* The expr3 is no longer valid after this point. */ 6151 expr3 = NULL_TREE; 6152 } 6153 else if (code->ext.alloc.ts.type != BT_UNKNOWN) 6154 { 6155 /* Compute the explicit typespec given only once for all objects 6156 to allocate. */ 6157 if (code->ext.alloc.ts.type != BT_CHARACTER) 6158 expr3_esize = TYPE_SIZE_UNIT ( 6159 gfc_typenode_for_spec (&code->ext.alloc.ts)); 6160 else if (code->ext.alloc.ts.u.cl->length != NULL) 6161 { 6162 gfc_expr *sz; 6163 sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); 6164 gfc_init_se (&se_sz, NULL); 6165 gfc_conv_expr (&se_sz, sz); 6166 gfc_free_expr (sz); 6167 tmp = gfc_get_char_type (code->ext.alloc.ts.kind); 6168 tmp = TYPE_SIZE_UNIT (tmp); 6169 tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp); 6170 gfc_add_block_to_block (&block, &se_sz.pre); 6171 expr3_esize = fold_build2_loc (input_location, MULT_EXPR, 6172 TREE_TYPE (se_sz.expr), 6173 tmp, se_sz.expr); 6174 expr3_esize = gfc_evaluate_now (expr3_esize, &block); 6175 } 6176 else 6177 expr3_esize = NULL_TREE; 6178 } 6179 6180 /* The routine gfc_trans_assignment () already implements all 6181 techniques needed. Unfortunately we may have a temporary 6182 variable for the source= expression here. When that is the 6183 case convert this variable into a temporary gfc_expr of type 6184 EXPR_VARIABLE and used it as rhs for the assignment. The 6185 advantage is, that we get scalarizer support for free, 6186 don't have to take care about scalar to array treatment and 6187 will benefit of every enhancements gfc_trans_assignment () 6188 gets. 6189 No need to check whether e3_is is E3_UNSET, because that is 6190 done by expr3 != NULL_TREE. 6191 Exclude variables since the following block does not handle 6192 array sections. In any case, there is no harm in sending 6193 variables to gfc_trans_assignment because there is no 6194 evaluation of variables. */ 6195 if (code->expr3) 6196 { 6197 if (code->expr3->expr_type != EXPR_VARIABLE 6198 && e3_is != E3_MOLD && expr3 != NULL_TREE 6199 && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) 6200 { 6201 /* Build a temporary symtree and symbol. Do not add it to the current 6202 namespace to prevent accidently modifying a colliding 6203 symbol's as. */ 6204 newsym = XCNEW (gfc_symtree); 6205 /* The name of the symtree should be unique, because gfc_create_var () 6206 took care about generating the identifier. */ 6207 newsym->name 6208 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3))); 6209 newsym->n.sym = gfc_new_symbol (newsym->name, NULL); 6210 /* The backend_decl is known. It is expr3, which is inserted 6211 here. */ 6212 newsym->n.sym->backend_decl = expr3; 6213 e3rhs = gfc_get_expr (); 6214 e3rhs->rank = code->expr3->rank; 6215 e3rhs->symtree = newsym; 6216 /* Mark the symbol referenced or gfc_trans_assignment will bug. */ 6217 newsym->n.sym->attr.referenced = 1; 6218 e3rhs->expr_type = EXPR_VARIABLE; 6219 e3rhs->where = code->expr3->where; 6220 /* Set the symbols type, upto it was BT_UNKNOWN. */ 6221 if (IS_CLASS_ARRAY (code->expr3) 6222 && code->expr3->expr_type == EXPR_FUNCTION 6223 && code->expr3->value.function.isym 6224 && code->expr3->value.function.isym->transformational) 6225 { 6226 e3rhs->ts = CLASS_DATA (code->expr3)->ts; 6227 } 6228 else if (code->expr3->ts.type == BT_CLASS 6229 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3))) 6230 e3rhs->ts = CLASS_DATA (code->expr3)->ts; 6231 else 6232 e3rhs->ts = code->expr3->ts; 6233 newsym->n.sym->ts = e3rhs->ts; 6234 /* Check whether the expr3 is array valued. */ 6235 if (e3rhs->rank) 6236 { 6237 gfc_array_spec *arr; 6238 arr = gfc_get_array_spec (); 6239 arr->rank = e3rhs->rank; 6240 arr->type = AS_DEFERRED; 6241 /* Set the dimension and pointer attribute for arrays 6242 to be on the safe side. */ 6243 newsym->n.sym->attr.dimension = 1; 6244 newsym->n.sym->attr.pointer = 1; 6245 newsym->n.sym->as = arr; 6246 if (IS_CLASS_ARRAY (code->expr3) 6247 && code->expr3->expr_type == EXPR_FUNCTION 6248 && code->expr3->value.function.isym 6249 && code->expr3->value.function.isym->transformational) 6250 { 6251 gfc_array_spec *tarr; 6252 tarr = gfc_get_array_spec (); 6253 *tarr = *arr; 6254 e3rhs->ts.u.derived->as = tarr; 6255 } 6256 gfc_add_full_array_ref (e3rhs, arr); 6257 } 6258 else if (POINTER_TYPE_P (TREE_TYPE (expr3))) 6259 newsym->n.sym->attr.pointer = 1; 6260 /* The string length is known, too. Set it for char arrays. */ 6261 if (e3rhs->ts.type == BT_CHARACTER) 6262 newsym->n.sym->ts.u.cl->backend_decl = expr3_len; 6263 gfc_commit_symbol (newsym->n.sym); 6264 } 6265 else 6266 e3rhs = gfc_copy_expr (code->expr3); 6267 6268 // We need to propagate the bounds of the expr3 for source=/mold=; 6269 // however, for nondescriptor arrays, we use internally a lower bound 6270 // of zero instead of one, which needs to be corrected for the allocate obj 6271 if (e3_is == E3_DESC) 6272 { 6273 symbol_attribute attr = gfc_expr_attr (code->expr3); 6274 if (code->expr3->expr_type == EXPR_ARRAY || 6275 (!attr.allocatable && !attr.pointer)) 6276 e3_has_nodescriptor = true; 6277 } 6278 } 6279 6280 /* Loop over all objects to allocate. */ 6281 for (al = code->ext.alloc.list; al != NULL; al = al->next) 6282 { 6283 expr = gfc_copy_expr (al->expr); 6284 /* UNLIMITED_POLY () needs the _data component to be set, when 6285 expr is a unlimited polymorphic object. But the _data component 6286 has not been set yet, so check the derived type's attr for the 6287 unlimited polymorphic flag to be safe. */ 6288 upoly_expr = UNLIMITED_POLY (expr) 6289 || (expr->ts.type == BT_DERIVED 6290 && expr->ts.u.derived->attr.unlimited_polymorphic); 6291 gfc_init_se (&se, NULL); 6292 6293 /* For class types prepare the expressions to ref the _vptr 6294 and the _len component. The latter for unlimited polymorphic 6295 types only. */ 6296 if (expr->ts.type == BT_CLASS) 6297 { 6298 gfc_expr *expr_ref_vptr, *expr_ref_len; 6299 gfc_add_data_component (expr); 6300 /* Prep the vptr handle. */ 6301 expr_ref_vptr = gfc_copy_expr (al->expr); 6302 gfc_add_vptr_component (expr_ref_vptr); 6303 se.want_pointer = 1; 6304 gfc_conv_expr (&se, expr_ref_vptr); 6305 al_vptr = se.expr; 6306 se.want_pointer = 0; 6307 gfc_free_expr (expr_ref_vptr); 6308 /* Allocated unlimited polymorphic objects always have a _len 6309 component. */ 6310 if (upoly_expr) 6311 { 6312 expr_ref_len = gfc_copy_expr (al->expr); 6313 gfc_add_len_component (expr_ref_len); 6314 gfc_conv_expr (&se, expr_ref_len); 6315 al_len = se.expr; 6316 gfc_free_expr (expr_ref_len); 6317 } 6318 else 6319 /* In a loop ensure that all loop variable dependent variables 6320 are initialized at the same spot in all execution paths. */ 6321 al_len = NULL_TREE; 6322 } 6323 else 6324 al_vptr = al_len = NULL_TREE; 6325 6326 se.want_pointer = 1; 6327 se.descriptor_only = 1; 6328 6329 gfc_conv_expr (&se, expr); 6330 if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) 6331 /* se.string_length now stores the .string_length variable of expr 6332 needed to allocate character(len=:) arrays. */ 6333 al_len = se.string_length; 6334 6335 al_len_needs_set = al_len != NULL_TREE; 6336 /* When allocating an array one cannot use much of the 6337 pre-evaluated expr3 expressions, because for most of them the 6338 scalarizer is needed which is not available in the pre-evaluation 6339 step. Therefore gfc_array_allocate () is responsible (and able) 6340 to handle the complete array allocation. Only the element size 6341 needs to be provided, which is done most of the time by the 6342 pre-evaluation step. */ 6343 nelems = NULL_TREE; 6344 if (expr3_len && (code->expr3->ts.type == BT_CHARACTER 6345 || code->expr3->ts.type == BT_CLASS)) 6346 { 6347 /* When al is an array, then the element size for each element 6348 in the array is needed, which is the product of the len and 6349 esize for char arrays. For unlimited polymorphics len can be 6350 zero, therefore take the maximum of len and one. */ 6351 tmp = fold_build2_loc (input_location, MAX_EXPR, 6352 TREE_TYPE (expr3_len), 6353 expr3_len, fold_convert (TREE_TYPE (expr3_len), 6354 integer_one_node)); 6355 tmp = fold_build2_loc (input_location, MULT_EXPR, 6356 TREE_TYPE (expr3_esize), expr3_esize, 6357 fold_convert (TREE_TYPE (expr3_esize), tmp)); 6358 } 6359 else 6360 tmp = expr3_esize; 6361 6362 if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, 6363 label_finish, tmp, &nelems, 6364 e3rhs ? e3rhs : code->expr3, 6365 e3_is == E3_DESC ? expr3 : NULL_TREE, 6366 e3_has_nodescriptor)) 6367 { 6368 /* A scalar or derived type. First compute the size to 6369 allocate. 6370 6371 expr3_len is set when expr3 is an unlimited polymorphic 6372 object or a deferred length string. */ 6373 if (expr3_len != NULL_TREE) 6374 { 6375 tmp = fold_convert (TREE_TYPE (expr3_esize), expr3_len); 6376 tmp = fold_build2_loc (input_location, MULT_EXPR, 6377 TREE_TYPE (expr3_esize), 6378 expr3_esize, tmp); 6379 if (code->expr3->ts.type != BT_CLASS) 6380 /* expr3 is a deferred length string, i.e., we are 6381 done. */ 6382 memsz = tmp; 6383 else 6384 { 6385 /* For unlimited polymorphic enties build 6386 (len > 0) ? element_size * len : element_size 6387 to compute the number of bytes to allocate. 6388 This allows the allocation of unlimited polymorphic 6389 objects from an expr3 that is also unlimited 6390 polymorphic and stores a _len dependent object, 6391 e.g., a string. */ 6392 memsz = fold_build2_loc (input_location, GT_EXPR, 6393 logical_type_node, expr3_len, 6394 build_zero_cst 6395 (TREE_TYPE (expr3_len))); 6396 memsz = fold_build3_loc (input_location, COND_EXPR, 6397 TREE_TYPE (expr3_esize), 6398 memsz, tmp, expr3_esize); 6399 } 6400 } 6401 else if (expr3_esize != NULL_TREE) 6402 /* Any other object in expr3 just needs element size in 6403 bytes. */ 6404 memsz = expr3_esize; 6405 else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) 6406 || (upoly_expr 6407 && code->ext.alloc.ts.type == BT_CHARACTER)) 6408 { 6409 /* Allocating deferred length char arrays need the length 6410 to allocate in the alloc_type_spec. But also unlimited 6411 polymorphic objects may be allocated as char arrays. 6412 Both are handled here. */ 6413 gfc_init_se (&se_sz, NULL); 6414 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); 6415 gfc_add_block_to_block (&se.pre, &se_sz.pre); 6416 se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); 6417 gfc_add_block_to_block (&se.pre, &se_sz.post); 6418 expr3_len = se_sz.expr; 6419 tmp_expr3_len_flag = true; 6420 tmp = TYPE_SIZE_UNIT ( 6421 gfc_get_char_type (code->ext.alloc.ts.kind)); 6422 memsz = fold_build2_loc (input_location, MULT_EXPR, 6423 TREE_TYPE (tmp), 6424 fold_convert (TREE_TYPE (tmp), 6425 expr3_len), 6426 tmp); 6427 } 6428 else if (expr->ts.type == BT_CHARACTER) 6429 { 6430 /* Compute the number of bytes needed to allocate a fixed 6431 length char array. */ 6432 gcc_assert (se.string_length != NULL_TREE); 6433 tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); 6434 memsz = fold_build2_loc (input_location, MULT_EXPR, 6435 TREE_TYPE (tmp), tmp, 6436 fold_convert (TREE_TYPE (tmp), 6437 se.string_length)); 6438 } 6439 else if (code->ext.alloc.ts.type != BT_UNKNOWN) 6440 /* Handle all types, where the alloc_type_spec is set. */ 6441 memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); 6442 else 6443 /* Handle size computation of the type declared to alloc. */ 6444 memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); 6445 6446 /* Store the caf-attributes for latter use. */ 6447 if (flag_coarray == GFC_FCOARRAY_LIB 6448 && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) 6449 .codimension) 6450 { 6451 /* Scalar allocatable components in coarray'ed derived types make 6452 it here and are treated now. */ 6453 tree caf_decl, token; 6454 gfc_se caf_se; 6455 6456 is_coarray = true; 6457 /* Set flag, to add synchronize after the allocate. */ 6458 needs_caf_sync = needs_caf_sync 6459 || caf_attr.coarray_comp || !caf_refs_comp; 6460 6461 gfc_init_se (&caf_se, NULL); 6462 6463 caf_decl = gfc_get_tree_for_caf_expr (expr); 6464 gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, 6465 NULL_TREE, NULL); 6466 gfc_add_block_to_block (&se.pre, &caf_se.pre); 6467 gfc_allocate_allocatable (&se.pre, se.expr, memsz, 6468 gfc_build_addr_expr (NULL_TREE, token), 6469 NULL_TREE, NULL_TREE, NULL_TREE, 6470 label_finish, expr, 1); 6471 } 6472 /* Allocate - for non-pointers with re-alloc checking. */ 6473 else if (gfc_expr_attr (expr).allocatable) 6474 gfc_allocate_allocatable (&se.pre, se.expr, memsz, 6475 NULL_TREE, stat, errmsg, errlen, 6476 label_finish, expr, 0); 6477 else 6478 gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); 6479 } 6480 else 6481 { 6482 /* Allocating coarrays needs a sync after the allocate executed. 6483 Set the flag to add the sync after all objects are allocated. */ 6484 if (flag_coarray == GFC_FCOARRAY_LIB 6485 && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) 6486 .codimension) 6487 { 6488 is_coarray = true; 6489 needs_caf_sync = needs_caf_sync 6490 || caf_attr.coarray_comp || !caf_refs_comp; 6491 } 6492 6493 if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE 6494 && expr3_len != NULL_TREE) 6495 { 6496 /* Arrays need to have a _len set before the array 6497 descriptor is filled. */ 6498 gfc_add_modify (&block, al_len, 6499 fold_convert (TREE_TYPE (al_len), expr3_len)); 6500 /* Prevent setting the length twice. */ 6501 al_len_needs_set = false; 6502 } 6503 else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE 6504 && code->ext.alloc.ts.u.cl->length) 6505 { 6506 /* Cover the cases where a string length is explicitly 6507 specified by a type spec for deferred length character 6508 arrays or unlimited polymorphic objects without a 6509 source= or mold= expression. */ 6510 gfc_init_se (&se_sz, NULL); 6511 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); 6512 gfc_add_block_to_block (&block, &se_sz.pre); 6513 gfc_add_modify (&block, al_len, 6514 fold_convert (TREE_TYPE (al_len), 6515 se_sz.expr)); 6516 al_len_needs_set = false; 6517 } 6518 } 6519 6520 gfc_add_block_to_block (&block, &se.pre); 6521 6522 /* Error checking -- Note: ERRMSG only makes sense with STAT. */ 6523 if (code->expr1) 6524 { 6525 tmp = build1_v (GOTO_EXPR, label_errmsg); 6526 parm = fold_build2_loc (input_location, NE_EXPR, 6527 logical_type_node, stat, 6528 build_int_cst (TREE_TYPE (stat), 0)); 6529 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 6530 gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC), 6531 tmp, build_empty_stmt (input_location)); 6532 gfc_add_expr_to_block (&block, tmp); 6533 } 6534 6535 /* Set the vptr only when no source= is set. When source= is set, then 6536 the trans_assignment below will set the vptr. */ 6537 if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold)) 6538 { 6539 if (expr3_vptr != NULL_TREE) 6540 /* The vtab is already known, so just assign it. */ 6541 gfc_add_modify (&block, al_vptr, 6542 fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); 6543 else 6544 { 6545 /* VPTR is fixed at compile time. */ 6546 gfc_symbol *vtab; 6547 gfc_typespec *ts; 6548 6549 if (code->expr3) 6550 /* Although expr3 is pre-evaluated above, it may happen, 6551 that for arrays or in mold= cases the pre-evaluation 6552 was not successful. In these rare cases take the vtab 6553 from the typespec of expr3 here. */ 6554 ts = &code->expr3->ts; 6555 else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) 6556 /* The alloc_type_spec gives the type to allocate or the 6557 al is unlimited polymorphic, which enforces the use of 6558 an alloc_type_spec that is not necessarily a BT_DERIVED. */ 6559 ts = &code->ext.alloc.ts; 6560 else 6561 /* Prepare for setting the vtab as declared. */ 6562 ts = &expr->ts; 6563 6564 vtab = gfc_find_vtab (ts); 6565 gcc_assert (vtab); 6566 tmp = gfc_build_addr_expr (NULL_TREE, 6567 gfc_get_symbol_decl (vtab)); 6568 gfc_add_modify (&block, al_vptr, 6569 fold_convert (TREE_TYPE (al_vptr), tmp)); 6570 } 6571 } 6572 6573 /* Add assignment for string length. */ 6574 if (al_len != NULL_TREE && al_len_needs_set) 6575 { 6576 if (expr3_len != NULL_TREE) 6577 { 6578 gfc_add_modify (&block, al_len, 6579 fold_convert (TREE_TYPE (al_len), 6580 expr3_len)); 6581 /* When tmp_expr3_len_flag is set, then expr3_len is 6582 abused to carry the length information from the 6583 alloc_type. Clear it to prevent setting incorrect len 6584 information in future loop iterations. */ 6585 if (tmp_expr3_len_flag) 6586 /* No need to reset tmp_expr3_len_flag, because the 6587 presence of an expr3 cannot change within in the 6588 loop. */ 6589 expr3_len = NULL_TREE; 6590 } 6591 else if (code->ext.alloc.ts.type == BT_CHARACTER 6592 && code->ext.alloc.ts.u.cl->length) 6593 { 6594 /* Cover the cases where a string length is explicitly 6595 specified by a type spec for deferred length character 6596 arrays or unlimited polymorphic objects without a 6597 source= or mold= expression. */ 6598 if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1) 6599 { 6600 gfc_init_se (&se_sz, NULL); 6601 gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); 6602 gfc_add_block_to_block (&block, &se_sz.pre); 6603 gfc_add_modify (&block, al_len, 6604 fold_convert (TREE_TYPE (al_len), 6605 se_sz.expr)); 6606 } 6607 else 6608 gfc_add_modify (&block, al_len, 6609 fold_convert (TREE_TYPE (al_len), 6610 expr3_esize)); 6611 } 6612 else 6613 /* No length information needed, because type to allocate 6614 has no length. Set _len to 0. */ 6615 gfc_add_modify (&block, al_len, 6616 fold_convert (TREE_TYPE (al_len), 6617 integer_zero_node)); 6618 } 6619 6620 init_expr = NULL; 6621 if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) 6622 { 6623 /* Initialization via SOURCE block (or static default initializer). 6624 Switch off automatic reallocation since we have just done the 6625 ALLOCATE. */ 6626 int realloc_lhs = flag_realloc_lhs; 6627 gfc_expr *init_expr = gfc_expr_to_initialize (expr); 6628 gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); 6629 flag_realloc_lhs = 0; 6630 tmp = gfc_trans_assignment (init_expr, rhs, false, false, true, 6631 false); 6632 flag_realloc_lhs = realloc_lhs; 6633 /* Free the expression allocated for init_expr. */ 6634 gfc_free_expr (init_expr); 6635 if (rhs != e3rhs) 6636 gfc_free_expr (rhs); 6637 gfc_add_expr_to_block (&block, tmp); 6638 } 6639 /* Set KIND and LEN PDT components and allocate those that are 6640 parameterized. */ 6641 else if (expr->ts.type == BT_DERIVED 6642 && expr->ts.u.derived->attr.pdt_type) 6643 { 6644 if (code->expr3 && code->expr3->param_list) 6645 param_list = code->expr3->param_list; 6646 else if (expr->param_list) 6647 param_list = expr->param_list; 6648 else 6649 param_list = expr->symtree->n.sym->param_list; 6650 tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, 6651 expr->rank, param_list); 6652 gfc_add_expr_to_block (&block, tmp); 6653 } 6654 /* Ditto for CLASS expressions. */ 6655 else if (expr->ts.type == BT_CLASS 6656 && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type) 6657 { 6658 if (code->expr3 && code->expr3->param_list) 6659 param_list = code->expr3->param_list; 6660 else if (expr->param_list) 6661 param_list = expr->param_list; 6662 else 6663 param_list = expr->symtree->n.sym->param_list; 6664 tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, 6665 se.expr, expr->rank, param_list); 6666 gfc_add_expr_to_block (&block, tmp); 6667 } 6668 else if (code->expr3 && code->expr3->mold 6669 && code->expr3->ts.type == BT_CLASS) 6670 { 6671 /* Use class_init_assign to initialize expr. */ 6672 gfc_code *ini; 6673 ini = gfc_get_code (EXEC_INIT_ASSIGN); 6674 ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true); 6675 tmp = gfc_trans_class_init_assign (ini); 6676 gfc_free_statements (ini); 6677 gfc_add_expr_to_block (&block, tmp); 6678 } 6679 else if ((init_expr = allocate_get_initializer (code, expr))) 6680 { 6681 /* Use class_init_assign to initialize expr. */ 6682 gfc_code *ini; 6683 int realloc_lhs = flag_realloc_lhs; 6684 ini = gfc_get_code (EXEC_INIT_ASSIGN); 6685 ini->expr1 = gfc_expr_to_initialize (expr); 6686 ini->expr2 = init_expr; 6687 flag_realloc_lhs = 0; 6688 tmp= gfc_trans_init_assign (ini); 6689 flag_realloc_lhs = realloc_lhs; 6690 gfc_free_statements (ini); 6691 /* Init_expr is freeed by above free_statements, just need to null 6692 it here. */ 6693 init_expr = NULL; 6694 gfc_add_expr_to_block (&block, tmp); 6695 } 6696 6697 /* Nullify all pointers in derived type coarrays. This registers a 6698 token for them which allows their allocation. */ 6699 if (is_coarray) 6700 { 6701 gfc_symbol *type = NULL; 6702 symbol_attribute caf_attr; 6703 int rank = 0; 6704 if (code->ext.alloc.ts.type == BT_DERIVED 6705 && code->ext.alloc.ts.u.derived->attr.pointer_comp) 6706 { 6707 type = code->ext.alloc.ts.u.derived; 6708 rank = type->attr.dimension ? type->as->rank : 0; 6709 gfc_clear_attr (&caf_attr); 6710 } 6711 else if (expr->ts.type == BT_DERIVED 6712 && expr->ts.u.derived->attr.pointer_comp) 6713 { 6714 type = expr->ts.u.derived; 6715 rank = expr->rank; 6716 caf_attr = gfc_caf_attr (expr, true); 6717 } 6718 6719 /* Initialize the tokens of pointer components in derived type 6720 coarrays. */ 6721 if (type) 6722 { 6723 tmp = (caf_attr.codimension && !caf_attr.dimension) 6724 ? gfc_conv_descriptor_data_get (se.expr) : se.expr; 6725 tmp = gfc_nullify_alloc_comp (type, tmp, rank, 6726 GFC_STRUCTURE_CAF_MODE_IN_COARRAY); 6727 gfc_add_expr_to_block (&block, tmp); 6728 } 6729 } 6730 6731 gfc_free_expr (expr); 6732 } // for-loop 6733 6734 if (e3rhs) 6735 { 6736 if (newsym) 6737 { 6738 gfc_free_symbol (newsym->n.sym); 6739 XDELETE (newsym); 6740 } 6741 gfc_free_expr (e3rhs); 6742 } 6743 /* STAT. */ 6744 if (code->expr1) 6745 { 6746 tmp = build1_v (LABEL_EXPR, label_errmsg); 6747 gfc_add_expr_to_block (&block, tmp); 6748 } 6749 6750 /* ERRMSG - only useful if STAT is present. */ 6751 if (code->expr1 && code->expr2) 6752 { 6753 const char *msg = "Attempt to allocate an allocated object"; 6754 tree slen, dlen, errmsg_str; 6755 stmtblock_t errmsg_block; 6756 6757 gfc_init_block (&errmsg_block); 6758 6759 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); 6760 gfc_add_modify (&errmsg_block, errmsg_str, 6761 gfc_build_addr_expr (pchar_type_node, 6762 gfc_build_localized_cstring_const (msg))); 6763 6764 slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); 6765 dlen = gfc_get_expr_charlen (code->expr2); 6766 slen = fold_build2_loc (input_location, MIN_EXPR, 6767 TREE_TYPE (slen), dlen, slen); 6768 6769 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, 6770 code->expr2->ts.kind, 6771 slen, errmsg_str, 6772 gfc_default_character_kind); 6773 dlen = gfc_finish_block (&errmsg_block); 6774 6775 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 6776 stat, build_int_cst (TREE_TYPE (stat), 0)); 6777 6778 tmp = build3_v (COND_EXPR, tmp, 6779 dlen, build_empty_stmt (input_location)); 6780 6781 gfc_add_expr_to_block (&block, tmp); 6782 } 6783 6784 /* STAT block. */ 6785 if (code->expr1) 6786 { 6787 if (TREE_USED (label_finish)) 6788 { 6789 tmp = build1_v (LABEL_EXPR, label_finish); 6790 gfc_add_expr_to_block (&block, tmp); 6791 } 6792 6793 gfc_init_se (&se, NULL); 6794 gfc_conv_expr_lhs (&se, code->expr1); 6795 tmp = convert (TREE_TYPE (se.expr), stat); 6796 gfc_add_modify (&block, se.expr, tmp); 6797 } 6798 6799 if (needs_caf_sync) 6800 { 6801 /* Add a sync all after the allocation has been executed. */ 6802 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, 6803 3, null_pointer_node, null_pointer_node, 6804 integer_zero_node); 6805 gfc_add_expr_to_block (&post, tmp); 6806 } 6807 6808 gfc_add_block_to_block (&block, &se.post); 6809 gfc_add_block_to_block (&block, &post); 6810 if (code->expr3 && code->expr3->must_finalize) 6811 gfc_add_block_to_block (&block, &final_block); 6812 6813 return gfc_finish_block (&block); 6814 } 6815 6816 6817 /* Translate a DEALLOCATE statement. */ 6818 6819 tree 6820 gfc_trans_deallocate (gfc_code *code) 6821 { 6822 gfc_se se; 6823 gfc_alloc *al; 6824 tree apstat, pstat, stat, errmsg, errlen, tmp; 6825 tree label_finish, label_errmsg; 6826 stmtblock_t block; 6827 6828 pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; 6829 label_finish = label_errmsg = NULL_TREE; 6830 6831 gfc_start_block (&block); 6832 6833 /* Count the number of failed deallocations. If deallocate() was 6834 called with STAT= , then set STAT to the count. If deallocate 6835 was called with ERRMSG, then set ERRMG to a string. */ 6836 if (code->expr1) 6837 { 6838 tree gfc_int4_type_node = gfc_get_int_type (4); 6839 6840 stat = gfc_create_var (gfc_int4_type_node, "stat"); 6841 pstat = gfc_build_addr_expr (NULL_TREE, stat); 6842 6843 /* GOTO destinations. */ 6844 label_errmsg = gfc_build_label_decl (NULL_TREE); 6845 label_finish = gfc_build_label_decl (NULL_TREE); 6846 TREE_USED (label_finish) = 0; 6847 } 6848 6849 /* Set ERRMSG - only needed if STAT is available. */ 6850 if (code->expr1 && code->expr2) 6851 { 6852 gfc_init_se (&se, NULL); 6853 se.want_pointer = 1; 6854 gfc_conv_expr_lhs (&se, code->expr2); 6855 errmsg = se.expr; 6856 errlen = se.string_length; 6857 } 6858 6859 for (al = code->ext.alloc.list; al != NULL; al = al->next) 6860 { 6861 gfc_expr *expr = gfc_copy_expr (al->expr); 6862 bool is_coarray = false, is_coarray_array = false; 6863 int caf_mode = 0; 6864 6865 gcc_assert (expr->expr_type == EXPR_VARIABLE); 6866 6867 if (expr->ts.type == BT_CLASS) 6868 gfc_add_data_component (expr); 6869 6870 gfc_init_se (&se, NULL); 6871 gfc_start_block (&se.pre); 6872 6873 se.want_pointer = 1; 6874 se.descriptor_only = 1; 6875 gfc_conv_expr (&se, expr); 6876 6877 /* Deallocate PDT components that are parameterized. */ 6878 tmp = NULL; 6879 if (expr->ts.type == BT_DERIVED 6880 && expr->ts.u.derived->attr.pdt_type 6881 && expr->symtree->n.sym->param_list) 6882 tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); 6883 else if (expr->ts.type == BT_CLASS 6884 && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type 6885 && expr->symtree->n.sym->param_list) 6886 tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, 6887 se.expr, expr->rank); 6888 6889 if (tmp) 6890 gfc_add_expr_to_block (&block, tmp); 6891 6892 if (flag_coarray == GFC_FCOARRAY_LIB 6893 || flag_coarray == GFC_FCOARRAY_SINGLE) 6894 { 6895 bool comp_ref; 6896 symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref); 6897 if (caf_attr.codimension) 6898 { 6899 is_coarray = true; 6900 is_coarray_array = caf_attr.dimension || !comp_ref 6901 || caf_attr.coarray_comp; 6902 6903 if (flag_coarray == GFC_FCOARRAY_LIB) 6904 /* When the expression to deallocate is referencing a 6905 component, then only deallocate it, but do not 6906 deregister. */ 6907 caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY 6908 | (comp_ref && !caf_attr.coarray_comp 6909 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); 6910 } 6911 } 6912 6913 if (expr->rank || is_coarray_array) 6914 { 6915 gfc_ref *ref; 6916 6917 if (gfc_bt_struct (expr->ts.type) 6918 && expr->ts.u.derived->attr.alloc_comp 6919 && !gfc_is_finalizable (expr->ts.u.derived, NULL)) 6920 { 6921 gfc_ref *last = NULL; 6922 6923 for (ref = expr->ref; ref; ref = ref->next) 6924 if (ref->type == REF_COMPONENT) 6925 last = ref; 6926 6927 /* Do not deallocate the components of a derived type 6928 ultimate pointer component. */ 6929 if (!(last && last->u.c.component->attr.pointer) 6930 && !(!last && expr->symtree->n.sym->attr.pointer)) 6931 { 6932 if (is_coarray && expr->rank == 0 6933 && (!last || !last->u.c.component->attr.dimension) 6934 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) 6935 { 6936 /* Add the ref to the data member only, when this is not 6937 a regular array or deallocate_alloc_comp will try to 6938 add another one. */ 6939 tmp = gfc_conv_descriptor_data_get (se.expr); 6940 } 6941 else 6942 tmp = se.expr; 6943 tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, 6944 expr->rank, caf_mode); 6945 gfc_add_expr_to_block (&se.pre, tmp); 6946 } 6947 } 6948 6949 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) 6950 { 6951 gfc_coarray_deregtype caf_dtype; 6952 6953 if (is_coarray) 6954 caf_dtype = gfc_caf_is_dealloc_only (caf_mode) 6955 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY 6956 : GFC_CAF_COARRAY_DEREGISTER; 6957 else 6958 caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; 6959 tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, 6960 label_finish, false, expr, 6961 caf_dtype); 6962 gfc_add_expr_to_block (&se.pre, tmp); 6963 } 6964 else if (TREE_CODE (se.expr) == COMPONENT_REF 6965 && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE 6966 && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr))) 6967 == RECORD_TYPE) 6968 { 6969 /* class.c(finalize_component) generates these, when a 6970 finalizable entity has a non-allocatable derived type array 6971 component, which has allocatable components. Obtain the 6972 derived type of the array and deallocate the allocatable 6973 components. */ 6974 for (ref = expr->ref; ref; ref = ref->next) 6975 { 6976 if (ref->u.c.component->attr.dimension 6977 && ref->u.c.component->ts.type == BT_DERIVED) 6978 break; 6979 } 6980 6981 if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp 6982 && !gfc_is_finalizable (ref->u.c.component->ts.u.derived, 6983 NULL)) 6984 { 6985 tmp = gfc_deallocate_alloc_comp 6986 (ref->u.c.component->ts.u.derived, 6987 se.expr, expr->rank); 6988 gfc_add_expr_to_block (&se.pre, tmp); 6989 } 6990 } 6991 6992 if (al->expr->ts.type == BT_CLASS) 6993 { 6994 gfc_reset_vptr (&se.pre, al->expr); 6995 if (UNLIMITED_POLY (al->expr) 6996 || (al->expr->ts.type == BT_DERIVED 6997 && al->expr->ts.u.derived->attr.unlimited_polymorphic)) 6998 /* Clear _len, too. */ 6999 gfc_reset_len (&se.pre, al->expr); 7000 } 7001 } 7002 else 7003 { 7004 tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish, 7005 false, al->expr, 7006 al->expr->ts, is_coarray); 7007 gfc_add_expr_to_block (&se.pre, tmp); 7008 7009 /* Set to zero after deallocation. */ 7010 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 7011 se.expr, 7012 build_int_cst (TREE_TYPE (se.expr), 0)); 7013 gfc_add_expr_to_block (&se.pre, tmp); 7014 7015 if (al->expr->ts.type == BT_CLASS) 7016 { 7017 gfc_reset_vptr (&se.pre, al->expr); 7018 if (UNLIMITED_POLY (al->expr) 7019 || (al->expr->ts.type == BT_DERIVED 7020 && al->expr->ts.u.derived->attr.unlimited_polymorphic)) 7021 /* Clear _len, too. */ 7022 gfc_reset_len (&se.pre, al->expr); 7023 } 7024 } 7025 7026 if (code->expr1) 7027 { 7028 tree cond; 7029 7030 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, 7031 build_int_cst (TREE_TYPE (stat), 0)); 7032 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 7033 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), 7034 build1_v (GOTO_EXPR, label_errmsg), 7035 build_empty_stmt (input_location)); 7036 gfc_add_expr_to_block (&se.pre, tmp); 7037 } 7038 7039 tmp = gfc_finish_block (&se.pre); 7040 gfc_add_expr_to_block (&block, tmp); 7041 gfc_free_expr (expr); 7042 } 7043 7044 if (code->expr1) 7045 { 7046 tmp = build1_v (LABEL_EXPR, label_errmsg); 7047 gfc_add_expr_to_block (&block, tmp); 7048 } 7049 7050 /* Set ERRMSG - only needed if STAT is available. */ 7051 if (code->expr1 && code->expr2) 7052 { 7053 const char *msg = "Attempt to deallocate an unallocated object"; 7054 stmtblock_t errmsg_block; 7055 tree errmsg_str, slen, dlen, cond; 7056 7057 gfc_init_block (&errmsg_block); 7058 7059 errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); 7060 gfc_add_modify (&errmsg_block, errmsg_str, 7061 gfc_build_addr_expr (pchar_type_node, 7062 gfc_build_localized_cstring_const (msg))); 7063 slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); 7064 dlen = gfc_get_expr_charlen (code->expr2); 7065 7066 gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, 7067 slen, errmsg_str, gfc_default_character_kind); 7068 tmp = gfc_finish_block (&errmsg_block); 7069 7070 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, 7071 build_int_cst (TREE_TYPE (stat), 0)); 7072 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 7073 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp, 7074 build_empty_stmt (input_location)); 7075 7076 gfc_add_expr_to_block (&block, tmp); 7077 } 7078 7079 if (code->expr1 && TREE_USED (label_finish)) 7080 { 7081 tmp = build1_v (LABEL_EXPR, label_finish); 7082 gfc_add_expr_to_block (&block, tmp); 7083 } 7084 7085 /* Set STAT. */ 7086 if (code->expr1) 7087 { 7088 gfc_init_se (&se, NULL); 7089 gfc_conv_expr_lhs (&se, code->expr1); 7090 tmp = convert (TREE_TYPE (se.expr), stat); 7091 gfc_add_modify (&block, se.expr, tmp); 7092 } 7093 7094 return gfc_finish_block (&block); 7095 } 7096 7097 #include "gt-fortran-trans-stmt.h" 7098