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