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