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