1/* Code translation -- generate GCC trees from gfc_code. 2 Copyright (C) 2002-2020 Free Software Foundation, Inc. 3 Contributed by Paul Brook 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "options.h" 25#include "tree.h" 26#include "gfortran.h" 27#include "gimple-expr.h" /* For create_tmp_var_raw. */ 28#include "trans.h" 29#include "stringpool.h" 30#include "fold-const.h" 31#include "tree-iterator.h" 32#include "trans-stmt.h" 33#include "trans-array.h" 34#include "trans-types.h" 35#include "trans-const.h" 36 37/* Naming convention for backend interface code: 38 39 gfc_trans_* translate gfc_code into STMT trees. 40 41 gfc_conv_* expression conversion 42 43 gfc_get_* get a backend tree representation of a decl or type */ 44 45static gfc_file *gfc_current_backend_file; 46 47const char gfc_msg_fault[] = N_("Array reference out of bounds"); 48const char gfc_msg_wrong_return[] = N_("Incorrect function return value"); 49 50 51/* Return a location_t suitable for 'tree' for a gfortran locus. The way the 52 parser works in gfortran, loc->lb->location contains only the line number 53 and LOCATION_COLUMN is 0; hence, the column has to be added when generating 54 locations for 'tree'. Cf. error.c's gfc_format_decoder. */ 55 56location_t 57gfc_get_location (locus *loc) 58{ 59 return linemap_position_for_loc_and_offset (line_table, loc->lb->location, 60 loc->nextc - loc->lb->line); 61} 62 63/* Advance along TREE_CHAIN n times. */ 64 65tree 66gfc_advance_chain (tree t, int n) 67{ 68 for (; n > 0; n--) 69 { 70 gcc_assert (t != NULL_TREE); 71 t = DECL_CHAIN (t); 72 } 73 return t; 74} 75 76/* Creates a variable declaration with a given TYPE. */ 77 78tree 79gfc_create_var_np (tree type, const char *prefix) 80{ 81 tree t; 82 83 t = create_tmp_var_raw (type, prefix); 84 85 /* No warnings for anonymous variables. */ 86 if (prefix == NULL) 87 TREE_NO_WARNING (t) = 1; 88 89 return t; 90} 91 92 93/* Like above, but also adds it to the current scope. */ 94 95tree 96gfc_create_var (tree type, const char *prefix) 97{ 98 tree tmp; 99 100 tmp = gfc_create_var_np (type, prefix); 101 102 pushdecl (tmp); 103 104 return tmp; 105} 106 107 108/* If the expression is not constant, evaluate it now. We assign the 109 result of the expression to an artificially created variable VAR, and 110 return a pointer to the VAR_DECL node for this variable. */ 111 112tree 113gfc_evaluate_now_loc (location_t loc, tree expr, stmtblock_t * pblock) 114{ 115 tree var; 116 117 if (CONSTANT_CLASS_P (expr)) 118 return expr; 119 120 var = gfc_create_var (TREE_TYPE (expr), NULL); 121 gfc_add_modify_loc (loc, pblock, var, expr); 122 123 return var; 124} 125 126 127tree 128gfc_evaluate_now (tree expr, stmtblock_t * pblock) 129{ 130 return gfc_evaluate_now_loc (input_location, expr, pblock); 131} 132 133/* Like gfc_evaluate_now, but add the created variable to the 134 function scope. */ 135 136tree 137gfc_evaluate_now_function_scope (tree expr, stmtblock_t * pblock) 138{ 139 tree var; 140 var = gfc_create_var_np (TREE_TYPE (expr), NULL); 141 gfc_add_decl_to_function (var); 142 gfc_add_modify (pblock, var, expr); 143 144 return var; 145} 146 147/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. 148 A MODIFY_EXPR is an assignment: 149 LHS <- RHS. */ 150 151void 152gfc_add_modify_loc (location_t loc, stmtblock_t * pblock, tree lhs, tree rhs) 153{ 154 tree tmp; 155 156 tree t1, t2; 157 t1 = TREE_TYPE (rhs); 158 t2 = TREE_TYPE (lhs); 159 /* Make sure that the types of the rhs and the lhs are compatible 160 for scalar assignments. We should probably have something 161 similar for aggregates, but right now removing that check just 162 breaks everything. */ 163 gcc_checking_assert (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2) 164 || AGGREGATE_TYPE_P (TREE_TYPE (lhs))); 165 166 tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, lhs, 167 rhs); 168 gfc_add_expr_to_block (pblock, tmp); 169} 170 171 172void 173gfc_add_modify (stmtblock_t * pblock, tree lhs, tree rhs) 174{ 175 gfc_add_modify_loc (input_location, pblock, lhs, rhs); 176} 177 178 179/* Create a new scope/binding level and initialize a block. Care must be 180 taken when translating expressions as any temporaries will be placed in 181 the innermost scope. */ 182 183void 184gfc_start_block (stmtblock_t * block) 185{ 186 /* Start a new binding level. */ 187 pushlevel (); 188 block->has_scope = 1; 189 190 /* The block is empty. */ 191 block->head = NULL_TREE; 192} 193 194 195/* Initialize a block without creating a new scope. */ 196 197void 198gfc_init_block (stmtblock_t * block) 199{ 200 block->head = NULL_TREE; 201 block->has_scope = 0; 202} 203 204 205/* Sometimes we create a scope but it turns out that we don't actually 206 need it. This function merges the scope of BLOCK with its parent. 207 Only variable decls will be merged, you still need to add the code. */ 208 209void 210gfc_merge_block_scope (stmtblock_t * block) 211{ 212 tree decl; 213 tree next; 214 215 gcc_assert (block->has_scope); 216 block->has_scope = 0; 217 218 /* Remember the decls in this scope. */ 219 decl = getdecls (); 220 poplevel (0, 0); 221 222 /* Add them to the parent scope. */ 223 while (decl != NULL_TREE) 224 { 225 next = DECL_CHAIN (decl); 226 DECL_CHAIN (decl) = NULL_TREE; 227 228 pushdecl (decl); 229 decl = next; 230 } 231} 232 233 234/* Finish a scope containing a block of statements. */ 235 236tree 237gfc_finish_block (stmtblock_t * stmtblock) 238{ 239 tree decl; 240 tree expr; 241 tree block; 242 243 expr = stmtblock->head; 244 if (!expr) 245 expr = build_empty_stmt (input_location); 246 247 stmtblock->head = NULL_TREE; 248 249 if (stmtblock->has_scope) 250 { 251 decl = getdecls (); 252 253 if (decl) 254 { 255 block = poplevel (1, 0); 256 expr = build3_v (BIND_EXPR, decl, expr, block); 257 } 258 else 259 poplevel (0, 0); 260 } 261 262 return expr; 263} 264 265 266/* Build an ADDR_EXPR and cast the result to TYPE. If TYPE is NULL, the 267 natural type is used. */ 268 269tree 270gfc_build_addr_expr (tree type, tree t) 271{ 272 tree base_type = TREE_TYPE (t); 273 tree natural_type; 274 275 if (type && POINTER_TYPE_P (type) 276 && TREE_CODE (base_type) == ARRAY_TYPE 277 && TYPE_MAIN_VARIANT (TREE_TYPE (type)) 278 == TYPE_MAIN_VARIANT (TREE_TYPE (base_type))) 279 { 280 tree min_val = size_zero_node; 281 tree type_domain = TYPE_DOMAIN (base_type); 282 if (type_domain && TYPE_MIN_VALUE (type_domain)) 283 min_val = TYPE_MIN_VALUE (type_domain); 284 t = fold (build4_loc (input_location, ARRAY_REF, TREE_TYPE (type), 285 t, min_val, NULL_TREE, NULL_TREE)); 286 natural_type = type; 287 } 288 else 289 natural_type = build_pointer_type (base_type); 290 291 if (TREE_CODE (t) == INDIRECT_REF) 292 { 293 if (!type) 294 type = natural_type; 295 t = TREE_OPERAND (t, 0); 296 natural_type = TREE_TYPE (t); 297 } 298 else 299 { 300 tree base = get_base_address (t); 301 if (base && DECL_P (base)) 302 TREE_ADDRESSABLE (base) = 1; 303 t = fold_build1_loc (input_location, ADDR_EXPR, natural_type, t); 304 } 305 306 if (type && natural_type != type) 307 t = convert (type, t); 308 309 return t; 310} 311 312 313static tree 314get_array_span (tree type, tree decl) 315{ 316 tree span; 317 318 /* Component references are guaranteed to have a reliable value for 319 'span'. Likewise indirect references since they emerge from the 320 conversion of a CFI descriptor or the hidden dummy descriptor. */ 321 if (TREE_CODE (decl) == COMPONENT_REF 322 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 323 return gfc_conv_descriptor_span_get (decl); 324 else if (TREE_CODE (decl) == INDIRECT_REF 325 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 326 return gfc_conv_descriptor_span_get (decl); 327 328 /* Return the span for deferred character length array references. */ 329 if (type && TREE_CODE (type) == ARRAY_TYPE 330 && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE 331 && (VAR_P (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) 332 || TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF) 333 && (TREE_CODE (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) == INDIRECT_REF 334 || TREE_CODE (decl) == FUNCTION_DECL 335 || DECL_CONTEXT (TYPE_MAX_VALUE (TYPE_DOMAIN (type))) 336 == DECL_CONTEXT (decl))) 337 { 338 span = fold_convert (gfc_array_index_type, 339 TYPE_MAX_VALUE (TYPE_DOMAIN (type))); 340 span = fold_build2 (MULT_EXPR, gfc_array_index_type, 341 fold_convert (gfc_array_index_type, 342 TYPE_SIZE_UNIT (TREE_TYPE (type))), 343 span); 344 } 345 else if (type && TREE_CODE (type) == ARRAY_TYPE 346 && TYPE_MAX_VALUE (TYPE_DOMAIN (type)) != NULL_TREE 347 && integer_zerop (TYPE_MAX_VALUE (TYPE_DOMAIN (type)))) 348 { 349 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl))) 350 span = gfc_conv_descriptor_span_get (decl); 351 else 352 span = NULL_TREE; 353 } 354 /* Likewise for class array or pointer array references. */ 355 else if (TREE_CODE (decl) == FIELD_DECL 356 || VAR_OR_FUNCTION_DECL_P (decl) 357 || TREE_CODE (decl) == PARM_DECL) 358 { 359 if (GFC_DECL_CLASS (decl)) 360 { 361 /* When a temporary is in place for the class array, then the 362 original class' declaration is stored in the saved 363 descriptor. */ 364 if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl)) 365 decl = GFC_DECL_SAVED_DESCRIPTOR (decl); 366 else 367 { 368 /* Allow for dummy arguments and other good things. */ 369 if (POINTER_TYPE_P (TREE_TYPE (decl))) 370 decl = build_fold_indirect_ref_loc (input_location, decl); 371 372 /* Check if '_data' is an array descriptor. If it is not, 373 the array must be one of the components of the class 374 object, so return a null span. */ 375 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE ( 376 gfc_class_data_get (decl)))) 377 return NULL_TREE; 378 } 379 span = gfc_class_vtab_size_get (decl); 380 } 381 else if (GFC_DECL_PTR_ARRAY_P (decl)) 382 { 383 if (TREE_CODE (decl) == PARM_DECL) 384 decl = build_fold_indirect_ref_loc (input_location, decl); 385 span = gfc_conv_descriptor_span_get (decl); 386 } 387 else 388 span = NULL_TREE; 389 } 390 else 391 span = NULL_TREE; 392 393 return span; 394} 395 396 397/* Build an ARRAY_REF with its natural type. */ 398 399tree 400gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr) 401{ 402 tree type = TREE_TYPE (base); 403 tree tmp; 404 tree span = NULL_TREE; 405 406 if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) 407 { 408 gcc_assert (GFC_TYPE_ARRAY_CORANK (type) > 0); 409 410 return fold_convert (TYPE_MAIN_VARIANT (type), base); 411 } 412 413 /* Scalar coarray, there is nothing to do. */ 414 if (TREE_CODE (type) != ARRAY_TYPE) 415 { 416 gcc_assert (decl == NULL_TREE); 417 gcc_assert (integer_zerop (offset)); 418 return base; 419 } 420 421 type = TREE_TYPE (type); 422 423 if (DECL_P (base)) 424 TREE_ADDRESSABLE (base) = 1; 425 426 /* Strip NON_LVALUE_EXPR nodes. */ 427 STRIP_TYPE_NOPS (offset); 428 429 /* If decl or vptr are non-null, pointer arithmetic for the array reference 430 is likely. Generate the 'span' for the array reference. */ 431 if (vptr) 432 { 433 span = gfc_vptr_size_get (vptr); 434 435 /* Check if this is an unlimited polymorphic object carrying a character 436 payload. In this case, the 'len' field is non-zero. */ 437 if (decl && GFC_CLASS_TYPE_P (TREE_TYPE (decl))) 438 span = gfc_resize_class_size_with_len (NULL, decl, span); 439 } 440 else if (decl) 441 span = get_array_span (type, decl); 442 443 /* If a non-null span has been generated reference the element with 444 pointer arithmetic. */ 445 if (span != NULL_TREE) 446 { 447 offset = fold_build2_loc (input_location, MULT_EXPR, 448 gfc_array_index_type, 449 offset, span); 450 tmp = gfc_build_addr_expr (pvoid_type_node, base); 451 tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); 452 tmp = fold_convert (build_pointer_type (type), tmp); 453 if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE) 454 || !TYPE_STRING_FLAG (type)) 455 tmp = build_fold_indirect_ref_loc (input_location, tmp); 456 return tmp; 457 } 458 /* Otherwise use a straightforward array reference. */ 459 else 460 return build4_loc (input_location, ARRAY_REF, type, base, offset, 461 NULL_TREE, NULL_TREE); 462} 463 464 465/* Generate a call to print a runtime error possibly including multiple 466 arguments and a locus. */ 467 468static tree 469trans_runtime_error_vararg (tree errorfunc, locus* where, const char* msgid, 470 va_list ap) 471{ 472 stmtblock_t block; 473 tree tmp; 474 tree arg, arg2; 475 tree *argarray; 476 tree fntype; 477 char *message; 478 const char *p; 479 int line, nargs, i; 480 location_t loc; 481 482 /* Compute the number of extra arguments from the format string. */ 483 for (p = msgid, nargs = 0; *p; p++) 484 if (*p == '%') 485 { 486 p++; 487 if (*p != '%') 488 nargs++; 489 } 490 491 /* The code to generate the error. */ 492 gfc_start_block (&block); 493 494 if (where) 495 { 496 line = LOCATION_LINE (where->lb->location); 497 message = xasprintf ("At line %d of file %s", line, 498 where->lb->file->filename); 499 } 500 else 501 message = xasprintf ("In file '%s', around line %d", 502 gfc_source_file, LOCATION_LINE (input_location) + 1); 503 504 arg = gfc_build_addr_expr (pchar_type_node, 505 gfc_build_localized_cstring_const (message)); 506 free (message); 507 508 message = xasprintf ("%s", _(msgid)); 509 arg2 = gfc_build_addr_expr (pchar_type_node, 510 gfc_build_localized_cstring_const (message)); 511 free (message); 512 513 /* Build the argument array. */ 514 argarray = XALLOCAVEC (tree, nargs + 2); 515 argarray[0] = arg; 516 argarray[1] = arg2; 517 for (i = 0; i < nargs; i++) 518 argarray[2 + i] = va_arg (ap, tree); 519 520 /* Build the function call to runtime_(warning,error)_at; because of the 521 variable number of arguments, we can't use build_call_expr_loc dinput_location, 522 irectly. */ 523 fntype = TREE_TYPE (errorfunc); 524 525 loc = where ? gfc_get_location (where) : input_location; 526 tmp = fold_build_call_array_loc (loc, TREE_TYPE (fntype), 527 fold_build1_loc (loc, ADDR_EXPR, 528 build_pointer_type (fntype), 529 errorfunc), 530 nargs + 2, argarray); 531 gfc_add_expr_to_block (&block, tmp); 532 533 return gfc_finish_block (&block); 534} 535 536 537tree 538gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) 539{ 540 va_list ap; 541 tree result; 542 543 va_start (ap, msgid); 544 result = trans_runtime_error_vararg (error 545 ? gfor_fndecl_runtime_error_at 546 : gfor_fndecl_runtime_warning_at, 547 where, msgid, ap); 548 va_end (ap); 549 return result; 550} 551 552 553/* Generate a runtime error if COND is true. */ 554 555void 556gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, 557 locus * where, const char * msgid, ...) 558{ 559 va_list ap; 560 stmtblock_t block; 561 tree body; 562 tree tmp; 563 tree tmpvar = NULL; 564 565 if (integer_zerop (cond)) 566 return; 567 568 if (once) 569 { 570 tmpvar = gfc_create_var (logical_type_node, "print_warning"); 571 TREE_STATIC (tmpvar) = 1; 572 DECL_INITIAL (tmpvar) = logical_true_node; 573 gfc_add_expr_to_block (pblock, tmpvar); 574 } 575 576 gfc_start_block (&block); 577 578 /* For error, runtime_error_at already implies PRED_NORETURN. */ 579 if (!error && once) 580 gfc_add_expr_to_block (&block, build_predict_expr (PRED_FORTRAN_WARN_ONCE, 581 NOT_TAKEN)); 582 583 /* The code to generate the error. */ 584 va_start (ap, msgid); 585 gfc_add_expr_to_block (&block, 586 trans_runtime_error_vararg 587 (error ? gfor_fndecl_runtime_error_at 588 : gfor_fndecl_runtime_warning_at, 589 where, msgid, ap)); 590 va_end (ap); 591 592 if (once) 593 gfc_add_modify (&block, tmpvar, logical_false_node); 594 595 body = gfc_finish_block (&block); 596 597 if (integer_onep (cond)) 598 { 599 gfc_add_expr_to_block (pblock, body); 600 } 601 else 602 { 603 if (once) 604 cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR, 605 long_integer_type_node, tmpvar, cond); 606 else 607 cond = fold_convert (long_integer_type_node, cond); 608 609 tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node, 610 cond, body, 611 build_empty_stmt (gfc_get_location (where))); 612 gfc_add_expr_to_block (pblock, tmp); 613 } 614} 615 616 617static tree 618trans_os_error_at (locus* where, const char* msgid, ...) 619{ 620 va_list ap; 621 tree result; 622 623 va_start (ap, msgid); 624 result = trans_runtime_error_vararg (gfor_fndecl_os_error_at, 625 where, msgid, ap); 626 va_end (ap); 627 return result; 628} 629 630 631 632/* Call malloc to allocate size bytes of memory, with special conditions: 633 + if size == 0, return a malloced area of size 1, 634 + if malloc returns NULL, issue a runtime error. */ 635tree 636gfc_call_malloc (stmtblock_t * block, tree type, tree size) 637{ 638 tree tmp, malloc_result, null_result, res, malloc_tree; 639 stmtblock_t block2; 640 641 /* Create a variable to hold the result. */ 642 res = gfc_create_var (prvoid_type_node, NULL); 643 644 /* Call malloc. */ 645 gfc_start_block (&block2); 646 647 if (size == NULL_TREE) 648 size = build_int_cst (size_type_node, 1); 649 650 size = fold_convert (size_type_node, size); 651 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, size, 652 build_int_cst (size_type_node, 1)); 653 654 malloc_tree = builtin_decl_explicit (BUILT_IN_MALLOC); 655 gfc_add_modify (&block2, res, 656 fold_convert (prvoid_type_node, 657 build_call_expr_loc (input_location, 658 malloc_tree, 1, size))); 659 660 /* Optionally check whether malloc was successful. */ 661 if (gfc_option.rtcheck & GFC_RTCHECK_MEM) 662 { 663 null_result = fold_build2_loc (input_location, EQ_EXPR, 664 logical_type_node, res, 665 build_int_cst (pvoid_type_node, 0)); 666 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 667 null_result, 668 trans_os_error_at (NULL, 669 "Error allocating %lu bytes", 670 fold_convert 671 (long_unsigned_type_node, 672 size)), 673 build_empty_stmt (input_location)); 674 gfc_add_expr_to_block (&block2, tmp); 675 } 676 677 malloc_result = gfc_finish_block (&block2); 678 gfc_add_expr_to_block (block, malloc_result); 679 680 if (type != NULL) 681 res = fold_convert (type, res); 682 return res; 683} 684 685 686/* Allocate memory, using an optional status argument. 687 688 This function follows the following pseudo-code: 689 690 void * 691 allocate (size_t size, integer_type stat) 692 { 693 void *newmem; 694 695 if (stat requested) 696 stat = 0; 697 698 newmem = malloc (MAX (size, 1)); 699 if (newmem == NULL) 700 { 701 if (stat) 702 *stat = LIBERROR_ALLOCATION; 703 else 704 runtime_error ("Allocation would exceed memory limit"); 705 } 706 return newmem; 707 } */ 708void 709gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, 710 tree size, tree status) 711{ 712 tree tmp, error_cond; 713 stmtblock_t on_error; 714 tree status_type = status ? TREE_TYPE (status) : NULL_TREE; 715 716 /* If successful and stat= is given, set status to 0. */ 717 if (status != NULL_TREE) 718 gfc_add_expr_to_block (block, 719 fold_build2_loc (input_location, MODIFY_EXPR, status_type, 720 status, build_int_cst (status_type, 0))); 721 722 /* The allocation itself. */ 723 size = fold_convert (size_type_node, size); 724 gfc_add_modify (block, pointer, 725 fold_convert (TREE_TYPE (pointer), 726 build_call_expr_loc (input_location, 727 builtin_decl_explicit (BUILT_IN_MALLOC), 1, 728 fold_build2_loc (input_location, 729 MAX_EXPR, size_type_node, size, 730 build_int_cst (size_type_node, 1))))); 731 732 /* What to do in case of error. */ 733 gfc_start_block (&on_error); 734 if (status != NULL_TREE) 735 { 736 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, status, 737 build_int_cst (status_type, LIBERROR_ALLOCATION)); 738 gfc_add_expr_to_block (&on_error, tmp); 739 } 740 else 741 { 742 /* Here, os_error_at already implies PRED_NORETURN. */ 743 tree lusize = fold_convert (long_unsigned_type_node, size); 744 tmp = trans_os_error_at (NULL, "Error allocating %lu bytes", lusize); 745 gfc_add_expr_to_block (&on_error, tmp); 746 } 747 748 error_cond = fold_build2_loc (input_location, EQ_EXPR, 749 logical_type_node, pointer, 750 build_int_cst (prvoid_type_node, 0)); 751 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 752 gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), 753 gfc_finish_block (&on_error), 754 build_empty_stmt (input_location)); 755 756 gfc_add_expr_to_block (block, tmp); 757} 758 759 760/* Allocate memory, using an optional status argument. 761 762 This function follows the following pseudo-code: 763 764 void * 765 allocate (size_t size, void** token, int *stat, char* errmsg, int errlen) 766 { 767 void *newmem; 768 769 newmem = _caf_register (size, regtype, token, &stat, errmsg, errlen); 770 return newmem; 771 } */ 772void 773gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, 774 tree token, tree status, tree errmsg, tree errlen, 775 gfc_coarray_regtype alloc_type) 776{ 777 tree tmp, pstat; 778 779 gcc_assert (token != NULL_TREE); 780 781 /* The allocation itself. */ 782 if (status == NULL_TREE) 783 pstat = null_pointer_node; 784 else 785 pstat = gfc_build_addr_expr (NULL_TREE, status); 786 787 if (errmsg == NULL_TREE) 788 { 789 gcc_assert(errlen == NULL_TREE); 790 errmsg = null_pointer_node; 791 errlen = build_int_cst (integer_type_node, 0); 792 } 793 794 size = fold_convert (size_type_node, size); 795 tmp = build_call_expr_loc (input_location, 796 gfor_fndecl_caf_register, 7, 797 fold_build2_loc (input_location, 798 MAX_EXPR, size_type_node, size, size_one_node), 799 build_int_cst (integer_type_node, alloc_type), 800 token, gfc_build_addr_expr (pvoid_type_node, pointer), 801 pstat, errmsg, errlen); 802 803 gfc_add_expr_to_block (block, tmp); 804 805 /* It guarantees memory consistency within the same segment */ 806 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 807 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 808 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 809 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 810 ASM_VOLATILE_P (tmp) = 1; 811 gfc_add_expr_to_block (block, tmp); 812} 813 814 815/* Generate code for an ALLOCATE statement when the argument is an 816 allocatable variable. If the variable is currently allocated, it is an 817 error to allocate it again. 818 819 This function follows the following pseudo-code: 820 821 void * 822 allocate_allocatable (void *mem, size_t size, integer_type stat) 823 { 824 if (mem == NULL) 825 return allocate (size, stat); 826 else 827 { 828 if (stat) 829 stat = LIBERROR_ALLOCATION; 830 else 831 runtime_error ("Attempting to allocate already allocated variable"); 832 } 833 } 834 835 expr must be set to the original expression being allocated for its locus 836 and variable name in case a runtime error has to be printed. */ 837void 838gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, 839 tree token, tree status, tree errmsg, tree errlen, 840 tree label_finish, gfc_expr* expr, int corank) 841{ 842 stmtblock_t alloc_block; 843 tree tmp, null_mem, alloc, error; 844 tree type = TREE_TYPE (mem); 845 symbol_attribute caf_attr; 846 bool need_assign = false, refs_comp = false; 847 gfc_coarray_regtype caf_alloc_type = GFC_CAF_COARRAY_ALLOC; 848 849 size = fold_convert (size_type_node, size); 850 null_mem = gfc_unlikely (fold_build2_loc (input_location, NE_EXPR, 851 logical_type_node, mem, 852 build_int_cst (type, 0)), 853 PRED_FORTRAN_REALLOC); 854 855 /* If mem is NULL, we call gfc_allocate_using_malloc or 856 gfc_allocate_using_lib. */ 857 gfc_start_block (&alloc_block); 858 859 if (flag_coarray == GFC_FCOARRAY_LIB) 860 caf_attr = gfc_caf_attr (expr, true, &refs_comp); 861 862 if (flag_coarray == GFC_FCOARRAY_LIB 863 && (corank > 0 || caf_attr.codimension)) 864 { 865 tree cond, sub_caf_tree; 866 gfc_se se; 867 bool compute_special_caf_types_size = false; 868 869 if (expr->ts.type == BT_DERIVED 870 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 871 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 872 { 873 compute_special_caf_types_size = true; 874 caf_alloc_type = GFC_CAF_LOCK_ALLOC; 875 } 876 else if (expr->ts.type == BT_DERIVED 877 && expr->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 878 && expr->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 879 { 880 compute_special_caf_types_size = true; 881 caf_alloc_type = GFC_CAF_EVENT_ALLOC; 882 } 883 else if (!caf_attr.coarray_comp && refs_comp) 884 /* Only allocatable components in a derived type coarray can be 885 allocate only. */ 886 caf_alloc_type = GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY; 887 888 gfc_init_se (&se, NULL); 889 sub_caf_tree = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); 890 if (sub_caf_tree == NULL_TREE) 891 sub_caf_tree = token; 892 893 /* When mem is an array ref, then strip the .data-ref. */ 894 if (TREE_CODE (mem) == COMPONENT_REF 895 && !(GFC_ARRAY_TYPE_P (TREE_TYPE (mem)))) 896 tmp = TREE_OPERAND (mem, 0); 897 else 898 tmp = mem; 899 900 if (!(GFC_ARRAY_TYPE_P (TREE_TYPE (tmp)) 901 && TYPE_LANG_SPECIFIC (TREE_TYPE (tmp))->corank == 0) 902 && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) 903 { 904 symbol_attribute attr; 905 906 gfc_clear_attr (&attr); 907 tmp = gfc_conv_scalar_to_descriptor (&se, mem, attr); 908 need_assign = true; 909 } 910 gfc_add_block_to_block (&alloc_block, &se.pre); 911 912 /* In the front end, we represent the lock variable as pointer. However, 913 the FE only passes the pointer around and leaves the actual 914 representation to the library. Hence, we have to convert back to the 915 number of elements. */ 916 if (compute_special_caf_types_size) 917 size = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node, 918 size, TYPE_SIZE_UNIT (ptr_type_node)); 919 920 gfc_allocate_using_caf_lib (&alloc_block, tmp, size, sub_caf_tree, 921 status, errmsg, errlen, caf_alloc_type); 922 if (need_assign) 923 gfc_add_modify (&alloc_block, mem, fold_convert (TREE_TYPE (mem), 924 gfc_conv_descriptor_data_get (tmp))); 925 if (status != NULL_TREE) 926 { 927 TREE_USED (label_finish) = 1; 928 tmp = build1_v (GOTO_EXPR, label_finish); 929 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 930 status, build_zero_cst (TREE_TYPE (status))); 931 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 932 gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), 933 tmp, build_empty_stmt (input_location)); 934 gfc_add_expr_to_block (&alloc_block, tmp); 935 } 936 } 937 else 938 gfc_allocate_using_malloc (&alloc_block, mem, size, status); 939 940 alloc = gfc_finish_block (&alloc_block); 941 942 /* If mem is not NULL, we issue a runtime error or set the 943 status variable. */ 944 if (expr) 945 { 946 tree varname; 947 948 gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); 949 varname = gfc_build_cstring_const (expr->symtree->name); 950 varname = gfc_build_addr_expr (pchar_type_node, varname); 951 952 error = gfc_trans_runtime_error (true, &expr->where, 953 "Attempting to allocate already" 954 " allocated variable '%s'", 955 varname); 956 } 957 else 958 error = gfc_trans_runtime_error (true, NULL, 959 "Attempting to allocate already allocated" 960 " variable"); 961 962 if (status != NULL_TREE) 963 { 964 tree status_type = TREE_TYPE (status); 965 966 error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 967 status, build_int_cst (status_type, LIBERROR_ALLOCATION)); 968 } 969 970 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem, 971 error, alloc); 972 gfc_add_expr_to_block (block, tmp); 973} 974 975 976/* Free a given variable. */ 977 978tree 979gfc_call_free (tree var) 980{ 981 return build_call_expr_loc (input_location, 982 builtin_decl_explicit (BUILT_IN_FREE), 983 1, fold_convert (pvoid_type_node, var)); 984} 985 986 987/* Build a call to a FINAL procedure, which finalizes "var". */ 988 989static tree 990gfc_build_final_call (gfc_typespec ts, gfc_expr *final_wrapper, gfc_expr *var, 991 bool fini_coarray, gfc_expr *class_size) 992{ 993 stmtblock_t block; 994 gfc_se se; 995 tree final_fndecl, array, size, tmp; 996 symbol_attribute attr; 997 998 gcc_assert (final_wrapper->expr_type == EXPR_VARIABLE); 999 gcc_assert (var); 1000 1001 gfc_start_block (&block); 1002 gfc_init_se (&se, NULL); 1003 gfc_conv_expr (&se, final_wrapper); 1004 final_fndecl = se.expr; 1005 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) 1006 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); 1007 1008 if (ts.type == BT_DERIVED) 1009 { 1010 tree elem_size; 1011 1012 gcc_assert (!class_size); 1013 elem_size = gfc_typenode_for_spec (&ts); 1014 elem_size = TYPE_SIZE_UNIT (elem_size); 1015 size = fold_convert (gfc_array_index_type, elem_size); 1016 1017 gfc_init_se (&se, NULL); 1018 se.want_pointer = 1; 1019 if (var->rank) 1020 { 1021 se.descriptor_only = 1; 1022 gfc_conv_expr_descriptor (&se, var); 1023 array = se.expr; 1024 } 1025 else 1026 { 1027 gfc_conv_expr (&se, var); 1028 gcc_assert (se.pre.head == NULL_TREE && se.post.head == NULL_TREE); 1029 array = se.expr; 1030 1031 /* No copy back needed, hence set attr's allocatable/pointer 1032 to zero. */ 1033 gfc_clear_attr (&attr); 1034 gfc_init_se (&se, NULL); 1035 array = gfc_conv_scalar_to_descriptor (&se, array, attr); 1036 gcc_assert (se.post.head == NULL_TREE); 1037 } 1038 } 1039 else 1040 { 1041 gfc_expr *array_expr; 1042 gcc_assert (class_size); 1043 gfc_init_se (&se, NULL); 1044 gfc_conv_expr (&se, class_size); 1045 gfc_add_block_to_block (&block, &se.pre); 1046 gcc_assert (se.post.head == NULL_TREE); 1047 size = se.expr; 1048 1049 array_expr = gfc_copy_expr (var); 1050 gfc_init_se (&se, NULL); 1051 se.want_pointer = 1; 1052 if (array_expr->rank) 1053 { 1054 gfc_add_class_array_ref (array_expr); 1055 se.descriptor_only = 1; 1056 gfc_conv_expr_descriptor (&se, array_expr); 1057 array = se.expr; 1058 } 1059 else 1060 { 1061 gfc_add_data_component (array_expr); 1062 gfc_conv_expr (&se, array_expr); 1063 gfc_add_block_to_block (&block, &se.pre); 1064 gcc_assert (se.post.head == NULL_TREE); 1065 array = se.expr; 1066 1067 if (!gfc_is_coarray (array_expr)) 1068 { 1069 /* No copy back needed, hence set attr's allocatable/pointer 1070 to zero. */ 1071 gfc_clear_attr (&attr); 1072 gfc_init_se (&se, NULL); 1073 array = gfc_conv_scalar_to_descriptor (&se, array, attr); 1074 } 1075 gcc_assert (se.post.head == NULL_TREE); 1076 } 1077 gfc_free_expr (array_expr); 1078 } 1079 1080 if (!POINTER_TYPE_P (TREE_TYPE (array))) 1081 array = gfc_build_addr_expr (NULL, array); 1082 1083 gfc_add_block_to_block (&block, &se.pre); 1084 tmp = build_call_expr_loc (input_location, 1085 final_fndecl, 3, array, 1086 size, fini_coarray ? boolean_true_node 1087 : boolean_false_node); 1088 gfc_add_block_to_block (&block, &se.post); 1089 gfc_add_expr_to_block (&block, tmp); 1090 return gfc_finish_block (&block); 1091} 1092 1093 1094bool 1095gfc_add_comp_finalizer_call (stmtblock_t *block, tree decl, gfc_component *comp, 1096 bool fini_coarray) 1097{ 1098 gfc_se se; 1099 stmtblock_t block2; 1100 tree final_fndecl, size, array, tmp, cond; 1101 symbol_attribute attr; 1102 gfc_expr *final_expr = NULL; 1103 1104 if (comp->ts.type != BT_DERIVED && comp->ts.type != BT_CLASS) 1105 return false; 1106 1107 gfc_init_block (&block2); 1108 1109 if (comp->ts.type == BT_DERIVED) 1110 { 1111 if (comp->attr.pointer) 1112 return false; 1113 1114 gfc_is_finalizable (comp->ts.u.derived, &final_expr); 1115 if (!final_expr) 1116 return false; 1117 1118 gfc_init_se (&se, NULL); 1119 gfc_conv_expr (&se, final_expr); 1120 final_fndecl = se.expr; 1121 size = gfc_typenode_for_spec (&comp->ts); 1122 size = TYPE_SIZE_UNIT (size); 1123 size = fold_convert (gfc_array_index_type, size); 1124 1125 array = decl; 1126 } 1127 else /* comp->ts.type == BT_CLASS. */ 1128 { 1129 if (CLASS_DATA (comp)->attr.class_pointer) 1130 return false; 1131 1132 gfc_is_finalizable (CLASS_DATA (comp)->ts.u.derived, &final_expr); 1133 final_fndecl = gfc_class_vtab_final_get (decl); 1134 size = gfc_class_vtab_size_get (decl); 1135 array = gfc_class_data_get (decl); 1136 } 1137 1138 if (comp->attr.allocatable 1139 || (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.allocatable)) 1140 { 1141 tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array)) 1142 ? gfc_conv_descriptor_data_get (array) : array; 1143 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1144 tmp, fold_convert (TREE_TYPE (tmp), 1145 null_pointer_node)); 1146 } 1147 else 1148 cond = logical_true_node; 1149 1150 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (array))) 1151 { 1152 gfc_clear_attr (&attr); 1153 gfc_init_se (&se, NULL); 1154 array = gfc_conv_scalar_to_descriptor (&se, array, attr); 1155 gfc_add_block_to_block (&block2, &se.pre); 1156 gcc_assert (se.post.head == NULL_TREE); 1157 } 1158 1159 if (!POINTER_TYPE_P (TREE_TYPE (array))) 1160 array = gfc_build_addr_expr (NULL, array); 1161 1162 if (!final_expr) 1163 { 1164 tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1165 final_fndecl, 1166 fold_convert (TREE_TYPE (final_fndecl), 1167 null_pointer_node)); 1168 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1169 logical_type_node, cond, tmp); 1170 } 1171 1172 if (POINTER_TYPE_P (TREE_TYPE (final_fndecl))) 1173 final_fndecl = build_fold_indirect_ref_loc (input_location, final_fndecl); 1174 1175 tmp = build_call_expr_loc (input_location, 1176 final_fndecl, 3, array, 1177 size, fini_coarray ? boolean_true_node 1178 : boolean_false_node); 1179 gfc_add_expr_to_block (&block2, tmp); 1180 tmp = gfc_finish_block (&block2); 1181 1182 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp, 1183 build_empty_stmt (input_location)); 1184 gfc_add_expr_to_block (block, tmp); 1185 1186 return true; 1187} 1188 1189 1190/* Add a call to the finalizer, using the passed *expr. Returns 1191 true when a finalizer call has been inserted. */ 1192 1193bool 1194gfc_add_finalizer_call (stmtblock_t *block, gfc_expr *expr2) 1195{ 1196 tree tmp; 1197 gfc_ref *ref; 1198 gfc_expr *expr; 1199 gfc_expr *final_expr = NULL; 1200 gfc_expr *elem_size = NULL; 1201 bool has_finalizer = false; 1202 1203 if (!expr2 || (expr2->ts.type != BT_DERIVED && expr2->ts.type != BT_CLASS)) 1204 return false; 1205 1206 if (expr2->ts.type == BT_DERIVED) 1207 { 1208 gfc_is_finalizable (expr2->ts.u.derived, &final_expr); 1209 if (!final_expr) 1210 return false; 1211 } 1212 1213 /* If we have a class array, we need go back to the class 1214 container. */ 1215 expr = gfc_copy_expr (expr2); 1216 1217 if (expr->ref && expr->ref->next && !expr->ref->next->next 1218 && expr->ref->next->type == REF_ARRAY 1219 && expr->ref->type == REF_COMPONENT 1220 && strcmp (expr->ref->u.c.component->name, "_data") == 0) 1221 { 1222 gfc_free_ref_list (expr->ref); 1223 expr->ref = NULL; 1224 } 1225 else 1226 for (ref = expr->ref; ref; ref = ref->next) 1227 if (ref->next && ref->next->next && !ref->next->next->next 1228 && ref->next->next->type == REF_ARRAY 1229 && ref->next->type == REF_COMPONENT 1230 && strcmp (ref->next->u.c.component->name, "_data") == 0) 1231 { 1232 gfc_free_ref_list (ref->next); 1233 ref->next = NULL; 1234 } 1235 1236 if (expr->ts.type == BT_CLASS) 1237 { 1238 has_finalizer = gfc_is_finalizable (expr->ts.u.derived, NULL); 1239 1240 if (!expr2->rank && !expr2->ref && CLASS_DATA (expr2->symtree->n.sym)->as) 1241 expr->rank = CLASS_DATA (expr2->symtree->n.sym)->as->rank; 1242 1243 final_expr = gfc_copy_expr (expr); 1244 gfc_add_vptr_component (final_expr); 1245 gfc_add_final_component (final_expr); 1246 1247 elem_size = gfc_copy_expr (expr); 1248 gfc_add_vptr_component (elem_size); 1249 gfc_add_size_component (elem_size); 1250 } 1251 1252 gcc_assert (final_expr->expr_type == EXPR_VARIABLE); 1253 1254 tmp = gfc_build_final_call (expr->ts, final_expr, expr, 1255 false, elem_size); 1256 1257 if (expr->ts.type == BT_CLASS && !has_finalizer) 1258 { 1259 tree cond; 1260 gfc_se se; 1261 1262 gfc_init_se (&se, NULL); 1263 se.want_pointer = 1; 1264 gfc_conv_expr (&se, final_expr); 1265 cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1266 se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); 1267 1268 /* For CLASS(*) not only sym->_vtab->_final can be NULL 1269 but already sym->_vtab itself. */ 1270 if (UNLIMITED_POLY (expr)) 1271 { 1272 tree cond2; 1273 gfc_expr *vptr_expr; 1274 1275 vptr_expr = gfc_copy_expr (expr); 1276 gfc_add_vptr_component (vptr_expr); 1277 1278 gfc_init_se (&se, NULL); 1279 se.want_pointer = 1; 1280 gfc_conv_expr (&se, vptr_expr); 1281 gfc_free_expr (vptr_expr); 1282 1283 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1284 se.expr, 1285 build_int_cst (TREE_TYPE (se.expr), 0)); 1286 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 1287 logical_type_node, cond2, cond); 1288 } 1289 1290 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1291 cond, tmp, build_empty_stmt (input_location)); 1292 } 1293 1294 gfc_add_expr_to_block (block, tmp); 1295 1296 return true; 1297} 1298 1299 1300/* User-deallocate; we emit the code directly from the front-end, and the 1301 logic is the same as the previous library function: 1302 1303 void 1304 deallocate (void *pointer, GFC_INTEGER_4 * stat) 1305 { 1306 if (!pointer) 1307 { 1308 if (stat) 1309 *stat = 1; 1310 else 1311 runtime_error ("Attempt to DEALLOCATE unallocated memory."); 1312 } 1313 else 1314 { 1315 free (pointer); 1316 if (stat) 1317 *stat = 0; 1318 } 1319 } 1320 1321 In this front-end version, status doesn't have to be GFC_INTEGER_4. 1322 Moreover, if CAN_FAIL is true, then we will not emit a runtime error, 1323 even when no status variable is passed to us (this is used for 1324 unconditional deallocation generated by the front-end at end of 1325 each procedure). 1326 1327 If a runtime-message is possible, `expr' must point to the original 1328 expression being deallocated for its locus and variable name. 1329 1330 For coarrays, "pointer" must be the array descriptor and not its 1331 "data" component. 1332 1333 COARRAY_DEALLOC_MODE gives the mode unregister coarrays. Available modes are 1334 the ones of GFC_CAF_DEREGTYPE, -1 when the mode for deregistration is to be 1335 analyzed and set by this routine, and -2 to indicate that a non-coarray is to 1336 be deallocated. */ 1337tree 1338gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, 1339 tree errlen, tree label_finish, 1340 bool can_fail, gfc_expr* expr, 1341 int coarray_dealloc_mode, tree add_when_allocated, 1342 tree caf_token) 1343{ 1344 stmtblock_t null, non_null; 1345 tree cond, tmp, error; 1346 tree status_type = NULL_TREE; 1347 tree token = NULL_TREE; 1348 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; 1349 1350 if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) 1351 { 1352 if (flag_coarray == GFC_FCOARRAY_LIB) 1353 { 1354 if (caf_token) 1355 token = caf_token; 1356 else 1357 { 1358 tree caf_type, caf_decl = pointer; 1359 pointer = gfc_conv_descriptor_data_get (caf_decl); 1360 caf_type = TREE_TYPE (caf_decl); 1361 STRIP_NOPS (pointer); 1362 if (GFC_DESCRIPTOR_TYPE_P (caf_type)) 1363 token = gfc_conv_descriptor_token (caf_decl); 1364 else if (DECL_LANG_SPECIFIC (caf_decl) 1365 && GFC_DECL_TOKEN (caf_decl) != NULL_TREE) 1366 token = GFC_DECL_TOKEN (caf_decl); 1367 else 1368 { 1369 gcc_assert (GFC_ARRAY_TYPE_P (caf_type) 1370 && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) 1371 != NULL_TREE); 1372 token = GFC_TYPE_ARRAY_CAF_TOKEN (caf_type); 1373 } 1374 } 1375 1376 if (coarray_dealloc_mode == GFC_CAF_COARRAY_ANALYZE) 1377 { 1378 bool comp_ref; 1379 if (expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp 1380 && comp_ref) 1381 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; 1382 // else do a deregister as set by default. 1383 } 1384 else 1385 caf_dereg_type = (enum gfc_coarray_deregtype) coarray_dealloc_mode; 1386 } 1387 else if (flag_coarray == GFC_FCOARRAY_SINGLE) 1388 pointer = gfc_conv_descriptor_data_get (pointer); 1389 } 1390 else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) 1391 pointer = gfc_conv_descriptor_data_get (pointer); 1392 1393 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, 1394 build_int_cst (TREE_TYPE (pointer), 0)); 1395 1396 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise 1397 we emit a runtime error. */ 1398 gfc_start_block (&null); 1399 if (!can_fail) 1400 { 1401 tree varname; 1402 1403 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); 1404 1405 varname = gfc_build_cstring_const (expr->symtree->name); 1406 varname = gfc_build_addr_expr (pchar_type_node, varname); 1407 1408 error = gfc_trans_runtime_error (true, &expr->where, 1409 "Attempt to DEALLOCATE unallocated '%s'", 1410 varname); 1411 } 1412 else 1413 error = build_empty_stmt (input_location); 1414 1415 if (status != NULL_TREE && !integer_zerop (status)) 1416 { 1417 tree cond2; 1418 1419 status_type = TREE_TYPE (TREE_TYPE (status)); 1420 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1421 status, build_int_cst (TREE_TYPE (status), 0)); 1422 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1423 fold_build1_loc (input_location, INDIRECT_REF, 1424 status_type, status), 1425 build_int_cst (status_type, 1)); 1426 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1427 cond2, tmp, error); 1428 } 1429 1430 gfc_add_expr_to_block (&null, error); 1431 1432 /* When POINTER is not NULL, we free it. */ 1433 gfc_start_block (&non_null); 1434 if (add_when_allocated) 1435 gfc_add_expr_to_block (&non_null, add_when_allocated); 1436 gfc_add_finalizer_call (&non_null, expr); 1437 if (coarray_dealloc_mode == GFC_CAF_COARRAY_NOCOARRAY 1438 || flag_coarray != GFC_FCOARRAY_LIB) 1439 { 1440 tmp = build_call_expr_loc (input_location, 1441 builtin_decl_explicit (BUILT_IN_FREE), 1, 1442 fold_convert (pvoid_type_node, pointer)); 1443 gfc_add_expr_to_block (&non_null, tmp); 1444 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), 1445 0)); 1446 1447 if (status != NULL_TREE && !integer_zerop (status)) 1448 { 1449 /* We set STATUS to zero if it is present. */ 1450 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1451 tree cond2; 1452 1453 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1454 status, 1455 build_int_cst (TREE_TYPE (status), 0)); 1456 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1457 fold_build1_loc (input_location, INDIRECT_REF, 1458 status_type, status), 1459 build_int_cst (status_type, 0)); 1460 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1461 gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), 1462 tmp, build_empty_stmt (input_location)); 1463 gfc_add_expr_to_block (&non_null, tmp); 1464 } 1465 } 1466 else 1467 { 1468 tree cond2, pstat = null_pointer_node; 1469 1470 if (errmsg == NULL_TREE) 1471 { 1472 gcc_assert (errlen == NULL_TREE); 1473 errmsg = null_pointer_node; 1474 errlen = build_zero_cst (integer_type_node); 1475 } 1476 else 1477 { 1478 gcc_assert (errlen != NULL_TREE); 1479 if (!POINTER_TYPE_P (TREE_TYPE (errmsg))) 1480 errmsg = gfc_build_addr_expr (NULL_TREE, errmsg); 1481 } 1482 1483 if (status != NULL_TREE && !integer_zerop (status)) 1484 { 1485 gcc_assert (status_type == integer_type_node); 1486 pstat = status; 1487 } 1488 1489 token = gfc_build_addr_expr (NULL_TREE, token); 1490 gcc_assert (caf_dereg_type > GFC_CAF_COARRAY_ANALYZE); 1491 tmp = build_call_expr_loc (input_location, 1492 gfor_fndecl_caf_deregister, 5, 1493 token, build_int_cst (integer_type_node, 1494 caf_dereg_type), 1495 pstat, errmsg, errlen); 1496 gfc_add_expr_to_block (&non_null, tmp); 1497 1498 /* It guarantees memory consistency within the same segment */ 1499 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), 1500 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1501 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 1502 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 1503 ASM_VOLATILE_P (tmp) = 1; 1504 gfc_add_expr_to_block (&non_null, tmp); 1505 1506 if (status != NULL_TREE) 1507 { 1508 tree stat = build_fold_indirect_ref_loc (input_location, status); 1509 tree nullify = fold_build2_loc (input_location, MODIFY_EXPR, 1510 void_type_node, pointer, 1511 build_int_cst (TREE_TYPE (pointer), 1512 0)); 1513 1514 TREE_USED (label_finish) = 1; 1515 tmp = build1_v (GOTO_EXPR, label_finish); 1516 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1517 stat, build_zero_cst (TREE_TYPE (stat))); 1518 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1519 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), 1520 tmp, nullify); 1521 gfc_add_expr_to_block (&non_null, tmp); 1522 } 1523 else 1524 gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), 1525 0)); 1526 } 1527 1528 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 1529 gfc_finish_block (&null), 1530 gfc_finish_block (&non_null)); 1531} 1532 1533 1534/* Generate code for deallocation of allocatable scalars (variables or 1535 components). Before the object itself is freed, any allocatable 1536 subcomponents are being deallocated. */ 1537 1538tree 1539gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, 1540 bool can_fail, gfc_expr* expr, 1541 gfc_typespec ts, bool coarray) 1542{ 1543 stmtblock_t null, non_null; 1544 tree cond, tmp, error; 1545 bool finalizable, comp_ref; 1546 gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; 1547 1548 if (coarray && expr && !gfc_caf_attr (expr, false, &comp_ref).coarray_comp 1549 && comp_ref) 1550 caf_dereg_type = GFC_CAF_COARRAY_DEALLOCATE_ONLY; 1551 1552 cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, 1553 build_int_cst (TREE_TYPE (pointer), 0)); 1554 1555 /* When POINTER is NULL, we set STATUS to 1 if it's present, otherwise 1556 we emit a runtime error. */ 1557 gfc_start_block (&null); 1558 if (!can_fail) 1559 { 1560 tree varname; 1561 1562 gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); 1563 1564 varname = gfc_build_cstring_const (expr->symtree->name); 1565 varname = gfc_build_addr_expr (pchar_type_node, varname); 1566 1567 error = gfc_trans_runtime_error (true, &expr->where, 1568 "Attempt to DEALLOCATE unallocated '%s'", 1569 varname); 1570 } 1571 else 1572 error = build_empty_stmt (input_location); 1573 1574 if (status != NULL_TREE && !integer_zerop (status)) 1575 { 1576 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1577 tree cond2; 1578 1579 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1580 status, build_int_cst (TREE_TYPE (status), 0)); 1581 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1582 fold_build1_loc (input_location, INDIRECT_REF, 1583 status_type, status), 1584 build_int_cst (status_type, 1)); 1585 error = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1586 cond2, tmp, error); 1587 } 1588 gfc_add_expr_to_block (&null, error); 1589 1590 /* When POINTER is not NULL, we free it. */ 1591 gfc_start_block (&non_null); 1592 1593 /* Free allocatable components. */ 1594 finalizable = gfc_add_finalizer_call (&non_null, expr); 1595 if (!finalizable && ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) 1596 { 1597 int caf_mode = coarray 1598 ? ((caf_dereg_type == GFC_CAF_COARRAY_DEALLOCATE_ONLY 1599 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0) 1600 | GFC_STRUCTURE_CAF_MODE_ENABLE_COARRAY 1601 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY) 1602 : 0; 1603 if (coarray && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) 1604 tmp = gfc_conv_descriptor_data_get (pointer); 1605 else 1606 tmp = build_fold_indirect_ref_loc (input_location, pointer); 1607 tmp = gfc_deallocate_alloc_comp (ts.u.derived, tmp, 0, caf_mode); 1608 gfc_add_expr_to_block (&non_null, tmp); 1609 } 1610 1611 if (!coarray || flag_coarray == GFC_FCOARRAY_SINGLE) 1612 { 1613 tmp = build_call_expr_loc (input_location, 1614 builtin_decl_explicit (BUILT_IN_FREE), 1, 1615 fold_convert (pvoid_type_node, pointer)); 1616 gfc_add_expr_to_block (&non_null, tmp); 1617 1618 if (status != NULL_TREE && !integer_zerop (status)) 1619 { 1620 /* We set STATUS to zero if it is present. */ 1621 tree status_type = TREE_TYPE (TREE_TYPE (status)); 1622 tree cond2; 1623 1624 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1625 status, 1626 build_int_cst (TREE_TYPE (status), 0)); 1627 tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, 1628 fold_build1_loc (input_location, INDIRECT_REF, 1629 status_type, status), 1630 build_int_cst (status_type, 0)); 1631 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1632 cond2, tmp, build_empty_stmt (input_location)); 1633 gfc_add_expr_to_block (&non_null, tmp); 1634 } 1635 } 1636 else 1637 { 1638 tree token; 1639 tree pstat = null_pointer_node; 1640 gfc_se se; 1641 1642 gfc_init_se (&se, NULL); 1643 token = gfc_get_ultimate_alloc_ptr_comps_caf_token (&se, expr); 1644 gcc_assert (token != NULL_TREE); 1645 1646 if (status != NULL_TREE && !integer_zerop (status)) 1647 { 1648 gcc_assert (TREE_TYPE (TREE_TYPE (status)) == integer_type_node); 1649 pstat = status; 1650 } 1651 1652 tmp = build_call_expr_loc (input_location, 1653 gfor_fndecl_caf_deregister, 5, 1654 token, build_int_cst (integer_type_node, 1655 caf_dereg_type), 1656 pstat, null_pointer_node, integer_zero_node); 1657 gfc_add_expr_to_block (&non_null, tmp); 1658 1659 /* It guarantees memory consistency within the same segment. */ 1660 tmp = gfc_build_string_const (strlen ("memory")+1, "memory"); 1661 tmp = build5_loc (input_location, ASM_EXPR, void_type_node, 1662 gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, 1663 tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); 1664 ASM_VOLATILE_P (tmp) = 1; 1665 gfc_add_expr_to_block (&non_null, tmp); 1666 1667 if (status != NULL_TREE) 1668 { 1669 tree stat = build_fold_indirect_ref_loc (input_location, status); 1670 tree cond2; 1671 1672 TREE_USED (label_finish) = 1; 1673 tmp = build1_v (GOTO_EXPR, label_finish); 1674 cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, 1675 stat, build_zero_cst (TREE_TYPE (stat))); 1676 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1677 gfc_unlikely (cond2, PRED_FORTRAN_REALLOC), 1678 tmp, build_empty_stmt (input_location)); 1679 gfc_add_expr_to_block (&non_null, tmp); 1680 } 1681 } 1682 1683 return fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 1684 gfc_finish_block (&null), 1685 gfc_finish_block (&non_null)); 1686} 1687 1688/* Reallocate MEM so it has SIZE bytes of data. This behaves like the 1689 following pseudo-code: 1690 1691void * 1692internal_realloc (void *mem, size_t size) 1693{ 1694 res = realloc (mem, size); 1695 if (!res && size != 0) 1696 _gfortran_os_error ("Allocation would exceed memory limit"); 1697 1698 return res; 1699} */ 1700tree 1701gfc_call_realloc (stmtblock_t * block, tree mem, tree size) 1702{ 1703 tree res, nonzero, null_result, tmp; 1704 tree type = TREE_TYPE (mem); 1705 1706 /* Only evaluate the size once. */ 1707 size = save_expr (fold_convert (size_type_node, size)); 1708 1709 /* Create a variable to hold the result. */ 1710 res = gfc_create_var (type, NULL); 1711 1712 /* Call realloc and check the result. */ 1713 tmp = build_call_expr_loc (input_location, 1714 builtin_decl_explicit (BUILT_IN_REALLOC), 2, 1715 fold_convert (pvoid_type_node, mem), size); 1716 gfc_add_modify (block, res, fold_convert (type, tmp)); 1717 null_result = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, 1718 res, build_int_cst (pvoid_type_node, 0)); 1719 nonzero = fold_build2_loc (input_location, NE_EXPR, logical_type_node, size, 1720 build_int_cst (size_type_node, 0)); 1721 null_result = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node, 1722 null_result, nonzero); 1723 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, 1724 null_result, 1725 trans_os_error_at (NULL, 1726 "Error reallocating to %lu bytes", 1727 fold_convert 1728 (long_unsigned_type_node, size)), 1729 build_empty_stmt (input_location)); 1730 gfc_add_expr_to_block (block, tmp); 1731 1732 return res; 1733} 1734 1735 1736/* Add an expression to another one, either at the front or the back. */ 1737 1738static void 1739add_expr_to_chain (tree* chain, tree expr, bool front) 1740{ 1741 if (expr == NULL_TREE || IS_EMPTY_STMT (expr)) 1742 return; 1743 1744 if (*chain) 1745 { 1746 if (TREE_CODE (*chain) != STATEMENT_LIST) 1747 { 1748 tree tmp; 1749 1750 tmp = *chain; 1751 *chain = NULL_TREE; 1752 append_to_statement_list (tmp, chain); 1753 } 1754 1755 if (front) 1756 { 1757 tree_stmt_iterator i; 1758 1759 i = tsi_start (*chain); 1760 tsi_link_before (&i, expr, TSI_CONTINUE_LINKING); 1761 } 1762 else 1763 append_to_statement_list (expr, chain); 1764 } 1765 else 1766 *chain = expr; 1767} 1768 1769 1770/* Add a statement at the end of a block. */ 1771 1772void 1773gfc_add_expr_to_block (stmtblock_t * block, tree expr) 1774{ 1775 gcc_assert (block); 1776 add_expr_to_chain (&block->head, expr, false); 1777} 1778 1779 1780/* Add a statement at the beginning of a block. */ 1781 1782void 1783gfc_prepend_expr_to_block (stmtblock_t * block, tree expr) 1784{ 1785 gcc_assert (block); 1786 add_expr_to_chain (&block->head, expr, true); 1787} 1788 1789 1790/* Add a block the end of a block. */ 1791 1792void 1793gfc_add_block_to_block (stmtblock_t * block, stmtblock_t * append) 1794{ 1795 gcc_assert (append); 1796 gcc_assert (!append->has_scope); 1797 1798 gfc_add_expr_to_block (block, append->head); 1799 append->head = NULL_TREE; 1800} 1801 1802 1803/* Save the current locus. The structure may not be complete, and should 1804 only be used with gfc_restore_backend_locus. */ 1805 1806void 1807gfc_save_backend_locus (locus * loc) 1808{ 1809 loc->lb = XCNEW (gfc_linebuf); 1810 loc->lb->location = input_location; 1811 loc->lb->file = gfc_current_backend_file; 1812} 1813 1814 1815/* Set the current locus. */ 1816 1817void 1818gfc_set_backend_locus (locus * loc) 1819{ 1820 gfc_current_backend_file = loc->lb->file; 1821 input_location = gfc_get_location (loc); 1822} 1823 1824 1825/* Restore the saved locus. Only used in conjunction with 1826 gfc_save_backend_locus, to free the memory when we are done. */ 1827 1828void 1829gfc_restore_backend_locus (locus * loc) 1830{ 1831 /* This only restores the information captured by gfc_save_backend_locus, 1832 intentionally does not use gfc_get_location. */ 1833 input_location = loc->lb->location; 1834 gfc_current_backend_file = loc->lb->file; 1835 free (loc->lb); 1836} 1837 1838 1839/* Translate an executable statement. The tree cond is used by gfc_trans_do. 1840 This static function is wrapped by gfc_trans_code_cond and 1841 gfc_trans_code. */ 1842 1843static tree 1844trans_code (gfc_code * code, tree cond) 1845{ 1846 stmtblock_t block; 1847 tree res; 1848 1849 if (!code) 1850 return build_empty_stmt (input_location); 1851 1852 gfc_start_block (&block); 1853 1854 /* Translate statements one by one into GENERIC trees until we reach 1855 the end of this gfc_code branch. */ 1856 for (; code; code = code->next) 1857 { 1858 if (code->here != 0) 1859 { 1860 res = gfc_trans_label_here (code); 1861 gfc_add_expr_to_block (&block, res); 1862 } 1863 1864 gfc_current_locus = code->loc; 1865 gfc_set_backend_locus (&code->loc); 1866 1867 switch (code->op) 1868 { 1869 case EXEC_NOP: 1870 case EXEC_END_BLOCK: 1871 case EXEC_END_NESTED_BLOCK: 1872 case EXEC_END_PROCEDURE: 1873 res = NULL_TREE; 1874 break; 1875 1876 case EXEC_ASSIGN: 1877 res = gfc_trans_assign (code); 1878 break; 1879 1880 case EXEC_LABEL_ASSIGN: 1881 res = gfc_trans_label_assign (code); 1882 break; 1883 1884 case EXEC_POINTER_ASSIGN: 1885 res = gfc_trans_pointer_assign (code); 1886 break; 1887 1888 case EXEC_INIT_ASSIGN: 1889 if (code->expr1->ts.type == BT_CLASS) 1890 res = gfc_trans_class_init_assign (code); 1891 else 1892 res = gfc_trans_init_assign (code); 1893 break; 1894 1895 case EXEC_CONTINUE: 1896 res = NULL_TREE; 1897 break; 1898 1899 case EXEC_CRITICAL: 1900 res = gfc_trans_critical (code); 1901 break; 1902 1903 case EXEC_CYCLE: 1904 res = gfc_trans_cycle (code); 1905 break; 1906 1907 case EXEC_EXIT: 1908 res = gfc_trans_exit (code); 1909 break; 1910 1911 case EXEC_GOTO: 1912 res = gfc_trans_goto (code); 1913 break; 1914 1915 case EXEC_ENTRY: 1916 res = gfc_trans_entry (code); 1917 break; 1918 1919 case EXEC_PAUSE: 1920 res = gfc_trans_pause (code); 1921 break; 1922 1923 case EXEC_STOP: 1924 case EXEC_ERROR_STOP: 1925 res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); 1926 break; 1927 1928 case EXEC_CALL: 1929 /* For MVBITS we've got the special exception that we need a 1930 dependency check, too. */ 1931 { 1932 bool is_mvbits = false; 1933 1934 if (code->resolved_isym) 1935 { 1936 res = gfc_conv_intrinsic_subroutine (code); 1937 if (res != NULL_TREE) 1938 break; 1939 } 1940 1941 if (code->resolved_isym 1942 && code->resolved_isym->id == GFC_ISYM_MVBITS) 1943 is_mvbits = true; 1944 1945 res = gfc_trans_call (code, is_mvbits, NULL_TREE, 1946 NULL_TREE, false); 1947 } 1948 break; 1949 1950 case EXEC_CALL_PPC: 1951 res = gfc_trans_call (code, false, NULL_TREE, 1952 NULL_TREE, false); 1953 break; 1954 1955 case EXEC_ASSIGN_CALL: 1956 res = gfc_trans_call (code, true, NULL_TREE, 1957 NULL_TREE, false); 1958 break; 1959 1960 case EXEC_RETURN: 1961 res = gfc_trans_return (code); 1962 break; 1963 1964 case EXEC_IF: 1965 res = gfc_trans_if (code); 1966 break; 1967 1968 case EXEC_ARITHMETIC_IF: 1969 res = gfc_trans_arithmetic_if (code); 1970 break; 1971 1972 case EXEC_BLOCK: 1973 res = gfc_trans_block_construct (code); 1974 break; 1975 1976 case EXEC_DO: 1977 res = gfc_trans_do (code, cond); 1978 break; 1979 1980 case EXEC_DO_CONCURRENT: 1981 res = gfc_trans_do_concurrent (code); 1982 break; 1983 1984 case EXEC_DO_WHILE: 1985 res = gfc_trans_do_while (code); 1986 break; 1987 1988 case EXEC_SELECT: 1989 res = gfc_trans_select (code); 1990 break; 1991 1992 case EXEC_SELECT_TYPE: 1993 res = gfc_trans_select_type (code); 1994 break; 1995 1996 case EXEC_SELECT_RANK: 1997 res = gfc_trans_select_rank (code); 1998 break; 1999 2000 case EXEC_FLUSH: 2001 res = gfc_trans_flush (code); 2002 break; 2003 2004 case EXEC_SYNC_ALL: 2005 case EXEC_SYNC_IMAGES: 2006 case EXEC_SYNC_MEMORY: 2007 res = gfc_trans_sync (code, code->op); 2008 break; 2009 2010 case EXEC_LOCK: 2011 case EXEC_UNLOCK: 2012 res = gfc_trans_lock_unlock (code, code->op); 2013 break; 2014 2015 case EXEC_EVENT_POST: 2016 case EXEC_EVENT_WAIT: 2017 res = gfc_trans_event_post_wait (code, code->op); 2018 break; 2019 2020 case EXEC_FAIL_IMAGE: 2021 res = gfc_trans_fail_image (code); 2022 break; 2023 2024 case EXEC_FORALL: 2025 res = gfc_trans_forall (code); 2026 break; 2027 2028 case EXEC_FORM_TEAM: 2029 res = gfc_trans_form_team (code); 2030 break; 2031 2032 case EXEC_CHANGE_TEAM: 2033 res = gfc_trans_change_team (code); 2034 break; 2035 2036 case EXEC_END_TEAM: 2037 res = gfc_trans_end_team (code); 2038 break; 2039 2040 case EXEC_SYNC_TEAM: 2041 res = gfc_trans_sync_team (code); 2042 break; 2043 2044 case EXEC_WHERE: 2045 res = gfc_trans_where (code); 2046 break; 2047 2048 case EXEC_ALLOCATE: 2049 res = gfc_trans_allocate (code); 2050 break; 2051 2052 case EXEC_DEALLOCATE: 2053 res = gfc_trans_deallocate (code); 2054 break; 2055 2056 case EXEC_OPEN: 2057 res = gfc_trans_open (code); 2058 break; 2059 2060 case EXEC_CLOSE: 2061 res = gfc_trans_close (code); 2062 break; 2063 2064 case EXEC_READ: 2065 res = gfc_trans_read (code); 2066 break; 2067 2068 case EXEC_WRITE: 2069 res = gfc_trans_write (code); 2070 break; 2071 2072 case EXEC_IOLENGTH: 2073 res = gfc_trans_iolength (code); 2074 break; 2075 2076 case EXEC_BACKSPACE: 2077 res = gfc_trans_backspace (code); 2078 break; 2079 2080 case EXEC_ENDFILE: 2081 res = gfc_trans_endfile (code); 2082 break; 2083 2084 case EXEC_INQUIRE: 2085 res = gfc_trans_inquire (code); 2086 break; 2087 2088 case EXEC_WAIT: 2089 res = gfc_trans_wait (code); 2090 break; 2091 2092 case EXEC_REWIND: 2093 res = gfc_trans_rewind (code); 2094 break; 2095 2096 case EXEC_TRANSFER: 2097 res = gfc_trans_transfer (code); 2098 break; 2099 2100 case EXEC_DT_END: 2101 res = gfc_trans_dt_end (code); 2102 break; 2103 2104 case EXEC_OMP_ATOMIC: 2105 case EXEC_OMP_BARRIER: 2106 case EXEC_OMP_CANCEL: 2107 case EXEC_OMP_CANCELLATION_POINT: 2108 case EXEC_OMP_CRITICAL: 2109 case EXEC_OMP_DISTRIBUTE: 2110 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 2111 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 2112 case EXEC_OMP_DISTRIBUTE_SIMD: 2113 case EXEC_OMP_DO: 2114 case EXEC_OMP_DO_SIMD: 2115 case EXEC_OMP_FLUSH: 2116 case EXEC_OMP_MASTER: 2117 case EXEC_OMP_ORDERED: 2118 case EXEC_OMP_PARALLEL: 2119 case EXEC_OMP_PARALLEL_DO: 2120 case EXEC_OMP_PARALLEL_DO_SIMD: 2121 case EXEC_OMP_PARALLEL_SECTIONS: 2122 case EXEC_OMP_PARALLEL_WORKSHARE: 2123 case EXEC_OMP_SECTIONS: 2124 case EXEC_OMP_SIMD: 2125 case EXEC_OMP_SINGLE: 2126 case EXEC_OMP_TARGET: 2127 case EXEC_OMP_TARGET_DATA: 2128 case EXEC_OMP_TARGET_ENTER_DATA: 2129 case EXEC_OMP_TARGET_EXIT_DATA: 2130 case EXEC_OMP_TARGET_PARALLEL: 2131 case EXEC_OMP_TARGET_PARALLEL_DO: 2132 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 2133 case EXEC_OMP_TARGET_SIMD: 2134 case EXEC_OMP_TARGET_TEAMS: 2135 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 2136 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 2137 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2138 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 2139 case EXEC_OMP_TARGET_UPDATE: 2140 case EXEC_OMP_TASK: 2141 case EXEC_OMP_TASKGROUP: 2142 case EXEC_OMP_TASKLOOP: 2143 case EXEC_OMP_TASKLOOP_SIMD: 2144 case EXEC_OMP_TASKWAIT: 2145 case EXEC_OMP_TASKYIELD: 2146 case EXEC_OMP_TEAMS: 2147 case EXEC_OMP_TEAMS_DISTRIBUTE: 2148 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 2149 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 2150 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 2151 case EXEC_OMP_WORKSHARE: 2152 res = gfc_trans_omp_directive (code); 2153 break; 2154 2155 case EXEC_OACC_CACHE: 2156 case EXEC_OACC_WAIT: 2157 case EXEC_OACC_UPDATE: 2158 case EXEC_OACC_LOOP: 2159 case EXEC_OACC_HOST_DATA: 2160 case EXEC_OACC_DATA: 2161 case EXEC_OACC_KERNELS: 2162 case EXEC_OACC_KERNELS_LOOP: 2163 case EXEC_OACC_PARALLEL: 2164 case EXEC_OACC_PARALLEL_LOOP: 2165 case EXEC_OACC_SERIAL: 2166 case EXEC_OACC_SERIAL_LOOP: 2167 case EXEC_OACC_ENTER_DATA: 2168 case EXEC_OACC_EXIT_DATA: 2169 case EXEC_OACC_ATOMIC: 2170 case EXEC_OACC_DECLARE: 2171 res = gfc_trans_oacc_directive (code); 2172 break; 2173 2174 default: 2175 gfc_internal_error ("gfc_trans_code(): Bad statement code"); 2176 } 2177 2178 gfc_set_backend_locus (&code->loc); 2179 2180 if (res != NULL_TREE && ! IS_EMPTY_STMT (res)) 2181 { 2182 if (TREE_CODE (res) != STATEMENT_LIST) 2183 SET_EXPR_LOCATION (res, input_location); 2184 2185 /* Add the new statement to the block. */ 2186 gfc_add_expr_to_block (&block, res); 2187 } 2188 } 2189 2190 /* Return the finished block. */ 2191 return gfc_finish_block (&block); 2192} 2193 2194 2195/* Translate an executable statement with condition, cond. The condition is 2196 used by gfc_trans_do to test for IO result conditions inside implied 2197 DO loops of READ and WRITE statements. See build_dt in trans-io.c. */ 2198 2199tree 2200gfc_trans_code_cond (gfc_code * code, tree cond) 2201{ 2202 return trans_code (code, cond); 2203} 2204 2205/* Translate an executable statement without condition. */ 2206 2207tree 2208gfc_trans_code (gfc_code * code) 2209{ 2210 return trans_code (code, NULL_TREE); 2211} 2212 2213 2214/* This function is called after a complete program unit has been parsed 2215 and resolved. */ 2216 2217void 2218gfc_generate_code (gfc_namespace * ns) 2219{ 2220 ompws_flags = 0; 2221 if (ns->is_block_data) 2222 { 2223 gfc_generate_block_data (ns); 2224 return; 2225 } 2226 2227 gfc_generate_function_code (ns); 2228} 2229 2230 2231/* This function is called after a complete module has been parsed 2232 and resolved. */ 2233 2234void 2235gfc_generate_module_code (gfc_namespace * ns) 2236{ 2237 gfc_namespace *n; 2238 struct module_htab_entry *entry; 2239 2240 gcc_assert (ns->proc_name->backend_decl == NULL); 2241 ns->proc_name->backend_decl 2242 = build_decl (gfc_get_location (&ns->proc_name->declared_at), 2243 NAMESPACE_DECL, get_identifier (ns->proc_name->name), 2244 void_type_node); 2245 entry = gfc_find_module (ns->proc_name->name); 2246 if (entry->namespace_decl) 2247 /* Buggy sourcecode, using a module before defining it? */ 2248 entry->decls->empty (); 2249 entry->namespace_decl = ns->proc_name->backend_decl; 2250 2251 gfc_generate_module_vars (ns); 2252 2253 /* We need to generate all module function prototypes first, to allow 2254 sibling calls. */ 2255 for (n = ns->contained; n; n = n->sibling) 2256 { 2257 gfc_entry_list *el; 2258 2259 if (!n->proc_name) 2260 continue; 2261 2262 gfc_create_function_decl (n, false); 2263 DECL_CONTEXT (n->proc_name->backend_decl) = ns->proc_name->backend_decl; 2264 gfc_module_add_decl (entry, n->proc_name->backend_decl); 2265 for (el = ns->entries; el; el = el->next) 2266 { 2267 DECL_CONTEXT (el->sym->backend_decl) = ns->proc_name->backend_decl; 2268 gfc_module_add_decl (entry, el->sym->backend_decl); 2269 } 2270 } 2271 2272 for (n = ns->contained; n; n = n->sibling) 2273 { 2274 if (!n->proc_name) 2275 continue; 2276 2277 gfc_generate_function_code (n); 2278 } 2279} 2280 2281 2282/* Initialize an init/cleanup block with existing code. */ 2283 2284void 2285gfc_start_wrapped_block (gfc_wrapped_block* block, tree code) 2286{ 2287 gcc_assert (block); 2288 2289 block->init = NULL_TREE; 2290 block->code = code; 2291 block->cleanup = NULL_TREE; 2292} 2293 2294 2295/* Add a new pair of initializers/clean-up code. */ 2296 2297void 2298gfc_add_init_cleanup (gfc_wrapped_block* block, tree init, tree cleanup) 2299{ 2300 gcc_assert (block); 2301 2302 /* The new pair of init/cleanup should be "wrapped around" the existing 2303 block of code, thus the initialization is added to the front and the 2304 cleanup to the back. */ 2305 add_expr_to_chain (&block->init, init, true); 2306 add_expr_to_chain (&block->cleanup, cleanup, false); 2307} 2308 2309 2310/* Finish up a wrapped block by building a corresponding try-finally expr. */ 2311 2312tree 2313gfc_finish_wrapped_block (gfc_wrapped_block* block) 2314{ 2315 tree result; 2316 2317 gcc_assert (block); 2318 2319 /* Build the final expression. For this, just add init and body together, 2320 and put clean-up with that into a TRY_FINALLY_EXPR. */ 2321 result = block->init; 2322 add_expr_to_chain (&result, block->code, false); 2323 if (block->cleanup) 2324 result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, 2325 result, block->cleanup); 2326 2327 /* Clear the block. */ 2328 block->init = NULL_TREE; 2329 block->code = NULL_TREE; 2330 block->cleanup = NULL_TREE; 2331 2332 return result; 2333} 2334 2335 2336/* Helper function for marking a boolean expression tree as unlikely. */ 2337 2338tree 2339gfc_unlikely (tree cond, enum br_predictor predictor) 2340{ 2341 tree tmp; 2342 2343 if (optimize) 2344 { 2345 cond = fold_convert (long_integer_type_node, cond); 2346 tmp = build_zero_cst (long_integer_type_node); 2347 cond = build_call_expr_loc (input_location, 2348 builtin_decl_explicit (BUILT_IN_EXPECT), 2349 3, cond, tmp, 2350 build_int_cst (integer_type_node, 2351 predictor)); 2352 } 2353 return cond; 2354} 2355 2356 2357/* Helper function for marking a boolean expression tree as likely. */ 2358 2359tree 2360gfc_likely (tree cond, enum br_predictor predictor) 2361{ 2362 tree tmp; 2363 2364 if (optimize) 2365 { 2366 cond = fold_convert (long_integer_type_node, cond); 2367 tmp = build_one_cst (long_integer_type_node); 2368 cond = build_call_expr_loc (input_location, 2369 builtin_decl_explicit (BUILT_IN_EXPECT), 2370 3, cond, tmp, 2371 build_int_cst (integer_type_node, 2372 predictor)); 2373 } 2374 return cond; 2375} 2376 2377 2378/* Get the string length for a deferred character length component. */ 2379 2380bool 2381gfc_deferred_strlen (gfc_component *c, tree *decl) 2382{ 2383 char name[GFC_MAX_SYMBOL_LEN+9]; 2384 gfc_component *strlen; 2385 if (!(c->ts.type == BT_CHARACTER 2386 && (c->ts.deferred || c->attr.pdt_string))) 2387 return false; 2388 sprintf (name, "_%s_length", c->name); 2389 for (strlen = c; strlen; strlen = strlen->next) 2390 if (strcmp (strlen->name, name) == 0) 2391 break; 2392 *decl = strlen ? strlen->backend_decl : NULL_TREE; 2393 return strlen != NULL; 2394} 2395