trans-decl.cc revision 1.1
1 /* Backend function setup 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 /* trans-decl.cc -- Handling of backend function and variable decls, etc */ 22 23 #include "config.h" 24 #include "system.h" 25 #include "coretypes.h" 26 #include "target.h" 27 #include "function.h" 28 #include "tree.h" 29 #include "gfortran.h" 30 #include "gimple-expr.h" /* For create_tmp_var_raw. */ 31 #include "trans.h" 32 #include "stringpool.h" 33 #include "cgraph.h" 34 #include "fold-const.h" 35 #include "stor-layout.h" 36 #include "varasm.h" 37 #include "attribs.h" 38 #include "dumpfile.h" 39 #include "toplev.h" /* For announce_function. */ 40 #include "debug.h" 41 #include "constructor.h" 42 #include "trans-types.h" 43 #include "trans-array.h" 44 #include "trans-const.h" 45 /* Only for gfc_trans_code. Shouldn't need to include this. */ 46 #include "trans-stmt.h" 47 #include "gomp-constants.h" 48 #include "gimplify.h" 49 #include "omp-general.h" 50 #include "attr-fnspec.h" 51 52 #define MAX_LABEL_VALUE 99999 53 54 55 /* Holds the result of the function if no result variable specified. */ 56 57 static GTY(()) tree current_fake_result_decl; 58 static GTY(()) tree parent_fake_result_decl; 59 60 61 /* Holds the variable DECLs for the current function. */ 62 63 static GTY(()) tree saved_function_decls; 64 static GTY(()) tree saved_parent_function_decls; 65 66 /* Holds the variable DECLs that are locals. */ 67 68 static GTY(()) tree saved_local_decls; 69 70 /* The namespace of the module we're currently generating. Only used while 71 outputting decls for module variables. Do not rely on this being set. */ 72 73 static gfc_namespace *module_namespace; 74 75 /* The currently processed procedure symbol. */ 76 static gfc_symbol* current_procedure_symbol = NULL; 77 78 /* The currently processed module. */ 79 static struct module_htab_entry *cur_module; 80 81 /* With -fcoarray=lib: For generating the registering call 82 of static coarrays. */ 83 static bool has_coarray_vars; 84 static stmtblock_t caf_init_block; 85 86 87 /* List of static constructor functions. */ 88 89 tree gfc_static_ctors; 90 91 92 /* Whether we've seen a symbol from an IEEE module in the namespace. */ 93 static int seen_ieee_symbol; 94 95 /* Function declarations for builtin library functions. */ 96 97 tree gfor_fndecl_pause_numeric; 98 tree gfor_fndecl_pause_string; 99 tree gfor_fndecl_stop_numeric; 100 tree gfor_fndecl_stop_string; 101 tree gfor_fndecl_error_stop_numeric; 102 tree gfor_fndecl_error_stop_string; 103 tree gfor_fndecl_runtime_error; 104 tree gfor_fndecl_runtime_error_at; 105 tree gfor_fndecl_runtime_warning_at; 106 tree gfor_fndecl_os_error_at; 107 tree gfor_fndecl_generate_error; 108 tree gfor_fndecl_set_args; 109 tree gfor_fndecl_set_fpe; 110 tree gfor_fndecl_set_options; 111 tree gfor_fndecl_set_convert; 112 tree gfor_fndecl_set_record_marker; 113 tree gfor_fndecl_set_max_subrecord_length; 114 tree gfor_fndecl_ctime; 115 tree gfor_fndecl_fdate; 116 tree gfor_fndecl_ttynam; 117 tree gfor_fndecl_in_pack; 118 tree gfor_fndecl_in_unpack; 119 tree gfor_fndecl_associated; 120 tree gfor_fndecl_system_clock4; 121 tree gfor_fndecl_system_clock8; 122 tree gfor_fndecl_ieee_procedure_entry; 123 tree gfor_fndecl_ieee_procedure_exit; 124 125 /* Coarray run-time library function decls. */ 126 tree gfor_fndecl_caf_init; 127 tree gfor_fndecl_caf_finalize; 128 tree gfor_fndecl_caf_this_image; 129 tree gfor_fndecl_caf_num_images; 130 tree gfor_fndecl_caf_register; 131 tree gfor_fndecl_caf_deregister; 132 tree gfor_fndecl_caf_get; 133 tree gfor_fndecl_caf_send; 134 tree gfor_fndecl_caf_sendget; 135 tree gfor_fndecl_caf_get_by_ref; 136 tree gfor_fndecl_caf_send_by_ref; 137 tree gfor_fndecl_caf_sendget_by_ref; 138 tree gfor_fndecl_caf_sync_all; 139 tree gfor_fndecl_caf_sync_memory; 140 tree gfor_fndecl_caf_sync_images; 141 tree gfor_fndecl_caf_stop_str; 142 tree gfor_fndecl_caf_stop_numeric; 143 tree gfor_fndecl_caf_error_stop; 144 tree gfor_fndecl_caf_error_stop_str; 145 tree gfor_fndecl_caf_atomic_def; 146 tree gfor_fndecl_caf_atomic_ref; 147 tree gfor_fndecl_caf_atomic_cas; 148 tree gfor_fndecl_caf_atomic_op; 149 tree gfor_fndecl_caf_lock; 150 tree gfor_fndecl_caf_unlock; 151 tree gfor_fndecl_caf_event_post; 152 tree gfor_fndecl_caf_event_wait; 153 tree gfor_fndecl_caf_event_query; 154 tree gfor_fndecl_caf_fail_image; 155 tree gfor_fndecl_caf_failed_images; 156 tree gfor_fndecl_caf_image_status; 157 tree gfor_fndecl_caf_stopped_images; 158 tree gfor_fndecl_caf_form_team; 159 tree gfor_fndecl_caf_change_team; 160 tree gfor_fndecl_caf_end_team; 161 tree gfor_fndecl_caf_sync_team; 162 tree gfor_fndecl_caf_get_team; 163 tree gfor_fndecl_caf_team_number; 164 tree gfor_fndecl_co_broadcast; 165 tree gfor_fndecl_co_max; 166 tree gfor_fndecl_co_min; 167 tree gfor_fndecl_co_reduce; 168 tree gfor_fndecl_co_sum; 169 tree gfor_fndecl_caf_is_present; 170 tree gfor_fndecl_caf_random_init; 171 172 173 /* Math functions. Many other math functions are handled in 174 trans-intrinsic.cc. */ 175 176 gfc_powdecl_list gfor_fndecl_math_powi[4][3]; 177 tree gfor_fndecl_math_ishftc4; 178 tree gfor_fndecl_math_ishftc8; 179 tree gfor_fndecl_math_ishftc16; 180 181 182 /* String functions. */ 183 184 tree gfor_fndecl_compare_string; 185 tree gfor_fndecl_concat_string; 186 tree gfor_fndecl_string_len_trim; 187 tree gfor_fndecl_string_index; 188 tree gfor_fndecl_string_scan; 189 tree gfor_fndecl_string_verify; 190 tree gfor_fndecl_string_trim; 191 tree gfor_fndecl_string_minmax; 192 tree gfor_fndecl_adjustl; 193 tree gfor_fndecl_adjustr; 194 tree gfor_fndecl_select_string; 195 tree gfor_fndecl_compare_string_char4; 196 tree gfor_fndecl_concat_string_char4; 197 tree gfor_fndecl_string_len_trim_char4; 198 tree gfor_fndecl_string_index_char4; 199 tree gfor_fndecl_string_scan_char4; 200 tree gfor_fndecl_string_verify_char4; 201 tree gfor_fndecl_string_trim_char4; 202 tree gfor_fndecl_string_minmax_char4; 203 tree gfor_fndecl_adjustl_char4; 204 tree gfor_fndecl_adjustr_char4; 205 tree gfor_fndecl_select_string_char4; 206 207 208 /* Conversion between character kinds. */ 209 tree gfor_fndecl_convert_char1_to_char4; 210 tree gfor_fndecl_convert_char4_to_char1; 211 212 213 /* Other misc. runtime library functions. */ 214 tree gfor_fndecl_iargc; 215 tree gfor_fndecl_kill; 216 tree gfor_fndecl_kill_sub; 217 tree gfor_fndecl_is_contiguous0; 218 219 220 /* Intrinsic functions implemented in Fortran. */ 221 tree gfor_fndecl_sc_kind; 222 tree gfor_fndecl_si_kind; 223 tree gfor_fndecl_sr_kind; 224 225 /* BLAS gemm functions. */ 226 tree gfor_fndecl_sgemm; 227 tree gfor_fndecl_dgemm; 228 tree gfor_fndecl_cgemm; 229 tree gfor_fndecl_zgemm; 230 231 /* RANDOM_INIT function. */ 232 tree gfor_fndecl_random_init; /* libgfortran, 1 image only. */ 233 234 static void 235 gfc_add_decl_to_parent_function (tree decl) 236 { 237 gcc_assert (decl); 238 DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl); 239 DECL_NONLOCAL (decl) = 1; 240 DECL_CHAIN (decl) = saved_parent_function_decls; 241 saved_parent_function_decls = decl; 242 } 243 244 void 245 gfc_add_decl_to_function (tree decl) 246 { 247 gcc_assert (decl); 248 TREE_USED (decl) = 1; 249 DECL_CONTEXT (decl) = current_function_decl; 250 DECL_CHAIN (decl) = saved_function_decls; 251 saved_function_decls = decl; 252 } 253 254 static void 255 add_decl_as_local (tree decl) 256 { 257 gcc_assert (decl); 258 TREE_USED (decl) = 1; 259 DECL_CONTEXT (decl) = current_function_decl; 260 DECL_CHAIN (decl) = saved_local_decls; 261 saved_local_decls = decl; 262 } 263 264 265 /* Build a backend label declaration. Set TREE_USED for named labels. 266 The context of the label is always the current_function_decl. All 267 labels are marked artificial. */ 268 269 tree 270 gfc_build_label_decl (tree label_id) 271 { 272 /* 2^32 temporaries should be enough. */ 273 static unsigned int tmp_num = 1; 274 tree label_decl; 275 char *label_name; 276 277 if (label_id == NULL_TREE) 278 { 279 /* Build an internal label name. */ 280 ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++); 281 label_id = get_identifier (label_name); 282 } 283 else 284 label_name = NULL; 285 286 /* Build the LABEL_DECL node. Labels have no type. */ 287 label_decl = build_decl (input_location, 288 LABEL_DECL, label_id, void_type_node); 289 DECL_CONTEXT (label_decl) = current_function_decl; 290 SET_DECL_MODE (label_decl, VOIDmode); 291 292 /* We always define the label as used, even if the original source 293 file never references the label. We don't want all kinds of 294 spurious warnings for old-style Fortran code with too many 295 labels. */ 296 TREE_USED (label_decl) = 1; 297 298 DECL_ARTIFICIAL (label_decl) = 1; 299 return label_decl; 300 } 301 302 303 /* Set the backend source location of a decl. */ 304 305 void 306 gfc_set_decl_location (tree decl, locus * loc) 307 { 308 DECL_SOURCE_LOCATION (decl) = gfc_get_location (loc); 309 } 310 311 312 /* Return the backend label declaration for a given label structure, 313 or create it if it doesn't exist yet. */ 314 315 tree 316 gfc_get_label_decl (gfc_st_label * lp) 317 { 318 if (lp->backend_decl) 319 return lp->backend_decl; 320 else 321 { 322 char label_name[GFC_MAX_SYMBOL_LEN + 1]; 323 tree label_decl; 324 325 /* Validate the label declaration from the front end. */ 326 gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE); 327 328 /* Build a mangled name for the label. */ 329 sprintf (label_name, "__label_%.6d", lp->value); 330 331 /* Build the LABEL_DECL node. */ 332 label_decl = gfc_build_label_decl (get_identifier (label_name)); 333 334 /* Tell the debugger where the label came from. */ 335 if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */ 336 gfc_set_decl_location (label_decl, &lp->where); 337 else 338 DECL_ARTIFICIAL (label_decl) = 1; 339 340 /* Store the label in the label list and return the LABEL_DECL. */ 341 lp->backend_decl = label_decl; 342 return label_decl; 343 } 344 } 345 346 /* Return the name of an identifier. */ 347 348 static const char * 349 sym_identifier (gfc_symbol *sym) 350 { 351 if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0) 352 return "MAIN__"; 353 else 354 return sym->name; 355 } 356 357 /* Convert a gfc_symbol to an identifier of the same name. */ 358 359 static tree 360 gfc_sym_identifier (gfc_symbol * sym) 361 { 362 return get_identifier (sym_identifier (sym)); 363 } 364 365 /* Construct mangled name from symbol name. */ 366 367 static const char * 368 mangled_identifier (gfc_symbol *sym) 369 { 370 gfc_symbol *proc = sym->ns->proc_name; 371 static char name[3*GFC_MAX_MANGLED_SYMBOL_LEN + 14]; 372 /* Prevent the mangling of identifiers that have an assigned 373 binding label (mainly those that are bind(c)). */ 374 375 if (sym->attr.is_bind_c == 1 && sym->binding_label) 376 return sym->binding_label; 377 378 if (!sym->fn_result_spec 379 || (sym->module && !(proc && proc->attr.flavor == FL_PROCEDURE))) 380 { 381 if (sym->module == NULL) 382 return sym_identifier (sym); 383 else 384 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); 385 } 386 else 387 { 388 /* This is an entity that is actually local to a module procedure 389 that appears in the result specification expression. Since 390 sym->module will be a zero length string, we use ns->proc_name 391 to provide the module name instead. */ 392 if (proc && proc->module) 393 snprintf (name, sizeof name, "__%s_MOD__%s_PROC_%s", 394 proc->module, proc->name, sym->name); 395 else 396 snprintf (name, sizeof name, "__%s_PROC_%s", 397 proc->name, sym->name); 398 } 399 400 return name; 401 } 402 403 /* Get mangled identifier, adding the symbol to the global table if 404 it is not yet already there. */ 405 406 static tree 407 gfc_sym_mangled_identifier (gfc_symbol * sym) 408 { 409 tree result; 410 gfc_gsymbol *gsym; 411 const char *name; 412 413 name = mangled_identifier (sym); 414 result = get_identifier (name); 415 416 gsym = gfc_find_gsymbol (gfc_gsym_root, name); 417 if (gsym == NULL) 418 { 419 gsym = gfc_get_gsymbol (name, false); 420 gsym->ns = sym->ns; 421 gsym->sym_name = sym->name; 422 } 423 424 return result; 425 } 426 427 /* Construct mangled function name from symbol name. */ 428 429 static tree 430 gfc_sym_mangled_function_id (gfc_symbol * sym) 431 { 432 int has_underscore; 433 char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1]; 434 435 /* It may be possible to simply use the binding label if it's 436 provided, and remove the other checks. Then we could use it 437 for other things if we wished. */ 438 if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) && 439 sym->binding_label) 440 /* use the binding label rather than the mangled name */ 441 return get_identifier (sym->binding_label); 442 443 if ((sym->module == NULL || sym->attr.proc == PROC_EXTERNAL 444 || (sym->module != NULL && (sym->attr.external 445 || sym->attr.if_source == IFSRC_IFBODY))) 446 && !sym->attr.module_procedure) 447 { 448 /* Main program is mangled into MAIN__. */ 449 if (sym->attr.is_main_program) 450 return get_identifier ("MAIN__"); 451 452 /* Intrinsic procedures are never mangled. */ 453 if (sym->attr.proc == PROC_INTRINSIC) 454 return get_identifier (sym->name); 455 456 if (flag_underscoring) 457 { 458 has_underscore = strchr (sym->name, '_') != 0; 459 if (flag_second_underscore && has_underscore) 460 snprintf (name, sizeof name, "%s__", sym->name); 461 else 462 snprintf (name, sizeof name, "%s_", sym->name); 463 return get_identifier (name); 464 } 465 else 466 return get_identifier (sym->name); 467 } 468 else 469 { 470 snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name); 471 return get_identifier (name); 472 } 473 } 474 475 476 void 477 gfc_set_decl_assembler_name (tree decl, tree name) 478 { 479 tree target_mangled = targetm.mangle_decl_assembler_name (decl, name); 480 SET_DECL_ASSEMBLER_NAME (decl, target_mangled); 481 } 482 483 484 /* Returns true if a variable of specified size should go on the stack. */ 485 486 int 487 gfc_can_put_var_on_stack (tree size) 488 { 489 unsigned HOST_WIDE_INT low; 490 491 if (!INTEGER_CST_P (size)) 492 return 0; 493 494 if (flag_max_stack_var_size < 0) 495 return 1; 496 497 if (!tree_fits_uhwi_p (size)) 498 return 0; 499 500 low = TREE_INT_CST_LOW (size); 501 if (low > (unsigned HOST_WIDE_INT) flag_max_stack_var_size) 502 return 0; 503 504 /* TODO: Set a per-function stack size limit. */ 505 506 return 1; 507 } 508 509 510 /* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to 511 an expression involving its corresponding pointer. There are 512 2 cases; one for variable size arrays, and one for everything else, 513 because variable-sized arrays require one fewer level of 514 indirection. */ 515 516 static void 517 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym) 518 { 519 tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer); 520 tree value; 521 522 /* Parameters need to be dereferenced. */ 523 if (sym->cp_pointer->attr.dummy) 524 ptr_decl = build_fold_indirect_ref_loc (input_location, 525 ptr_decl); 526 527 /* Check to see if we're dealing with a variable-sized array. */ 528 if (sym->attr.dimension 529 && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) 530 { 531 /* These decls will be dereferenced later, so we don't dereference 532 them here. */ 533 value = convert (TREE_TYPE (decl), ptr_decl); 534 } 535 else 536 { 537 ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)), 538 ptr_decl); 539 value = build_fold_indirect_ref_loc (input_location, 540 ptr_decl); 541 } 542 543 SET_DECL_VALUE_EXPR (decl, value); 544 DECL_HAS_VALUE_EXPR_P (decl) = 1; 545 GFC_DECL_CRAY_POINTEE (decl) = 1; 546 } 547 548 549 /* Finish processing of a declaration without an initial value. */ 550 551 static void 552 gfc_finish_decl (tree decl) 553 { 554 gcc_assert (TREE_CODE (decl) == PARM_DECL 555 || DECL_INITIAL (decl) == NULL_TREE); 556 557 if (!VAR_P (decl)) 558 return; 559 560 if (DECL_SIZE (decl) == NULL_TREE 561 && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE) 562 layout_decl (decl, 0); 563 564 /* A few consistency checks. */ 565 /* A static variable with an incomplete type is an error if it is 566 initialized. Also if it is not file scope. Otherwise, let it 567 through, but if it is not `extern' then it may cause an error 568 message later. */ 569 /* An automatic variable with an incomplete type is an error. */ 570 571 /* We should know the storage size. */ 572 gcc_assert (DECL_SIZE (decl) != NULL_TREE 573 || (TREE_STATIC (decl) 574 ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl)) 575 : DECL_EXTERNAL (decl))); 576 577 /* The storage size should be constant. */ 578 gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl)) 579 || !DECL_SIZE (decl) 580 || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST); 581 } 582 583 584 /* Handle setting of GFC_DECL_SCALAR* on DECL. */ 585 586 void 587 gfc_finish_decl_attrs (tree decl, symbol_attribute *attr) 588 { 589 if (!attr->dimension && !attr->codimension) 590 { 591 /* Handle scalar allocatable variables. */ 592 if (attr->allocatable) 593 { 594 gfc_allocate_lang_decl (decl); 595 GFC_DECL_SCALAR_ALLOCATABLE (decl) = 1; 596 } 597 /* Handle scalar pointer variables. */ 598 if (attr->pointer) 599 { 600 gfc_allocate_lang_decl (decl); 601 GFC_DECL_SCALAR_POINTER (decl) = 1; 602 } 603 if (attr->target) 604 { 605 gfc_allocate_lang_decl (decl); 606 GFC_DECL_SCALAR_TARGET (decl) = 1; 607 } 608 } 609 } 610 611 612 /* Apply symbol attributes to a variable, and add it to the function scope. */ 613 614 static void 615 gfc_finish_var_decl (tree decl, gfc_symbol * sym) 616 { 617 tree new_type; 618 619 /* Set DECL_VALUE_EXPR for Cray Pointees. */ 620 if (sym->attr.cray_pointee) 621 gfc_finish_cray_pointee (decl, sym); 622 623 /* TREE_ADDRESSABLE means the address of this variable is actually needed. 624 This is the equivalent of the TARGET variables. 625 We also need to set this if the variable is passed by reference in a 626 CALL statement. */ 627 if (sym->attr.target) 628 TREE_ADDRESSABLE (decl) = 1; 629 630 /* If it wasn't used we wouldn't be getting it. */ 631 TREE_USED (decl) = 1; 632 633 if (sym->attr.flavor == FL_PARAMETER 634 && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) 635 TREE_READONLY (decl) = 1; 636 637 /* Chain this decl to the pending declarations. Don't do pushdecl() 638 because this would add them to the current scope rather than the 639 function scope. */ 640 if (current_function_decl != NULL_TREE) 641 { 642 if (sym->ns->proc_name 643 && (sym->ns->proc_name->backend_decl == current_function_decl 644 || sym->result == sym)) 645 gfc_add_decl_to_function (decl); 646 else if (sym->ns->proc_name 647 && sym->ns->proc_name->attr.flavor == FL_LABEL) 648 /* This is a BLOCK construct. */ 649 add_decl_as_local (decl); 650 else if (sym->ns->omp_affinity_iterators) 651 /* This is a block-local iterator. */ 652 add_decl_as_local (decl); 653 else 654 gfc_add_decl_to_parent_function (decl); 655 } 656 657 if (sym->attr.cray_pointee) 658 return; 659 660 if(sym->attr.is_bind_c == 1 && sym->binding_label) 661 { 662 /* We need to put variables that are bind(c) into the common 663 segment of the object file, because this is what C would do. 664 gfortran would typically put them in either the BSS or 665 initialized data segments, and only mark them as common if 666 they were part of common blocks. However, if they are not put 667 into common space, then C cannot initialize global Fortran 668 variables that it interoperates with and the draft says that 669 either Fortran or C should be able to initialize it (but not 670 both, of course.) (J3/04-007, section 15.3). */ 671 TREE_PUBLIC(decl) = 1; 672 DECL_COMMON(decl) = 1; 673 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) 674 { 675 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; 676 DECL_VISIBILITY_SPECIFIED (decl) = true; 677 } 678 } 679 680 /* If a variable is USE associated, it's always external. */ 681 if (sym->attr.use_assoc || sym->attr.used_in_submodule) 682 { 683 DECL_EXTERNAL (decl) = 1; 684 TREE_PUBLIC (decl) = 1; 685 } 686 else if (sym->fn_result_spec && !sym->ns->proc_name->module) 687 { 688 689 if (sym->ns->proc_name->attr.if_source != IFSRC_DECL) 690 DECL_EXTERNAL (decl) = 1; 691 else 692 TREE_STATIC (decl) = 1; 693 694 TREE_PUBLIC (decl) = 1; 695 } 696 else if (sym->module && !sym->attr.result && !sym->attr.dummy) 697 { 698 /* TODO: Don't set sym->module for result or dummy variables. */ 699 gcc_assert (current_function_decl == NULL_TREE || sym->result == sym); 700 701 TREE_PUBLIC (decl) = 1; 702 TREE_STATIC (decl) = 1; 703 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) 704 { 705 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; 706 DECL_VISIBILITY_SPECIFIED (decl) = true; 707 } 708 } 709 710 /* Derived types are a bit peculiar because of the possibility of 711 a default initializer; this must be applied each time the variable 712 comes into scope it therefore need not be static. These variables 713 are SAVE_NONE but have an initializer. Otherwise explicitly 714 initialized variables are SAVE_IMPLICIT and explicitly saved are 715 SAVE_EXPLICIT. */ 716 if (!sym->attr.use_assoc 717 && (sym->attr.save != SAVE_NONE || sym->attr.data 718 || (sym->value && sym->ns->proc_name->attr.is_main_program) 719 || (flag_coarray == GFC_FCOARRAY_LIB 720 && sym->attr.codimension && !sym->attr.allocatable))) 721 TREE_STATIC (decl) = 1; 722 723 /* If derived-type variables with DTIO procedures are not made static 724 some bits of code referencing them get optimized away. 725 TODO Understand why this is so and fix it. */ 726 if (!sym->attr.use_assoc 727 && ((sym->ts.type == BT_DERIVED 728 && sym->ts.u.derived->attr.has_dtio_procs) 729 || (sym->ts.type == BT_CLASS 730 && CLASS_DATA (sym)->ts.u.derived->attr.has_dtio_procs))) 731 TREE_STATIC (decl) = 1; 732 733 /* Treat asynchronous variables the same as volatile, for now. */ 734 if (sym->attr.volatile_ || sym->attr.asynchronous) 735 { 736 TREE_THIS_VOLATILE (decl) = 1; 737 TREE_SIDE_EFFECTS (decl) = 1; 738 new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE); 739 TREE_TYPE (decl) = new_type; 740 } 741 742 /* Keep variables larger than max-stack-var-size off stack. */ 743 if (!(sym->ns->proc_name && sym->ns->proc_name->attr.recursive) 744 && !sym->attr.automatic 745 && !sym->attr.associate_var 746 && sym->attr.save != SAVE_EXPLICIT 747 && sym->attr.save != SAVE_IMPLICIT 748 && INTEGER_CST_P (DECL_SIZE_UNIT (decl)) 749 && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) 750 /* Put variable length auto array pointers always into stack. */ 751 && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE 752 || sym->attr.dimension == 0 753 || sym->as->type != AS_EXPLICIT 754 || sym->attr.pointer 755 || sym->attr.allocatable) 756 && !DECL_ARTIFICIAL (decl)) 757 { 758 if (flag_max_stack_var_size > 0 759 && !(sym->ns->proc_name 760 && sym->ns->proc_name->attr.is_main_program)) 761 gfc_warning (OPT_Wsurprising, 762 "Array %qs at %L is larger than limit set by " 763 "%<-fmax-stack-var-size=%>, moved from stack to static " 764 "storage. This makes the procedure unsafe when called " 765 "recursively, or concurrently from multiple threads. " 766 "Consider increasing the %<-fmax-stack-var-size=%> " 767 "limit (or use %<-frecursive%>, which implies " 768 "unlimited %<-fmax-stack-var-size%>) - or change the " 769 "code to use an ALLOCATABLE array. If the variable is " 770 "never accessed concurrently, this warning can be " 771 "ignored, and the variable could also be declared with " 772 "the SAVE attribute.", 773 sym->name, &sym->declared_at); 774 775 TREE_STATIC (decl) = 1; 776 777 /* Because the size of this variable isn't known until now, we may have 778 greedily added an initializer to this variable (in build_init_assign) 779 even though the max-stack-var-size indicates the variable should be 780 static. Therefore we rip out the automatic initializer here and 781 replace it with a static one. */ 782 gfc_symtree *st = gfc_find_symtree (sym->ns->sym_root, sym->name); 783 gfc_code *prev = NULL; 784 gfc_code *code = sym->ns->code; 785 while (code && code->op == EXEC_INIT_ASSIGN) 786 { 787 /* Look for an initializer meant for this symbol. */ 788 if (code->expr1->symtree == st) 789 { 790 if (prev) 791 prev->next = code->next; 792 else 793 sym->ns->code = code->next; 794 795 break; 796 } 797 798 prev = code; 799 code = code->next; 800 } 801 if (code && code->op == EXEC_INIT_ASSIGN) 802 { 803 /* Keep the init expression for a static initializer. */ 804 sym->value = code->expr2; 805 /* Cleanup the defunct code object, without freeing the init expr. */ 806 code->expr2 = NULL; 807 gfc_free_statement (code); 808 free (code); 809 } 810 } 811 812 /* Handle threadprivate variables. */ 813 if (sym->attr.threadprivate 814 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) 815 set_decl_tls_model (decl, decl_default_tls_model (decl)); 816 817 gfc_finish_decl_attrs (decl, &sym->attr); 818 } 819 820 821 /* Allocate the lang-specific part of a decl. */ 822 823 void 824 gfc_allocate_lang_decl (tree decl) 825 { 826 if (DECL_LANG_SPECIFIC (decl) == NULL) 827 DECL_LANG_SPECIFIC (decl) = ggc_cleared_alloc<struct lang_decl> (); 828 } 829 830 /* Remember a symbol to generate initialization/cleanup code at function 831 entry/exit. */ 832 833 static void 834 gfc_defer_symbol_init (gfc_symbol * sym) 835 { 836 gfc_symbol *p; 837 gfc_symbol *last; 838 gfc_symbol *head; 839 840 /* Don't add a symbol twice. */ 841 if (sym->tlink) 842 return; 843 844 last = head = sym->ns->proc_name; 845 p = last->tlink; 846 847 /* Make sure that setup code for dummy variables which are used in the 848 setup of other variables is generated first. */ 849 if (sym->attr.dummy) 850 { 851 /* Find the first dummy arg seen after us, or the first non-dummy arg. 852 This is a circular list, so don't go past the head. */ 853 while (p != head 854 && (!p->attr.dummy || p->dummy_order > sym->dummy_order)) 855 { 856 last = p; 857 p = p->tlink; 858 } 859 } 860 /* Insert in between last and p. */ 861 last->tlink = sym; 862 sym->tlink = p; 863 } 864 865 866 /* Used in gfc_get_symbol_decl and gfc_get_derived_type to obtain the 867 backend_decl for a module symbol, if it all ready exists. If the 868 module gsymbol does not exist, it is created. If the symbol does 869 not exist, it is added to the gsymbol namespace. Returns true if 870 an existing backend_decl is found. */ 871 872 bool 873 gfc_get_module_backend_decl (gfc_symbol *sym) 874 { 875 gfc_gsymbol *gsym; 876 gfc_symbol *s; 877 gfc_symtree *st; 878 879 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); 880 881 if (!gsym || (gsym->ns && gsym->type == GSYM_MODULE)) 882 { 883 st = NULL; 884 s = NULL; 885 886 /* Check for a symbol with the same name. */ 887 if (gsym) 888 gfc_find_symbol (sym->name, gsym->ns, 0, &s); 889 890 if (!s) 891 { 892 if (!gsym) 893 { 894 gsym = gfc_get_gsymbol (sym->module, false); 895 gsym->type = GSYM_MODULE; 896 gsym->ns = gfc_get_namespace (NULL, 0); 897 } 898 899 st = gfc_new_symtree (&gsym->ns->sym_root, sym->name); 900 st->n.sym = sym; 901 sym->refs++; 902 } 903 else if (gfc_fl_struct (sym->attr.flavor)) 904 { 905 if (s && s->attr.flavor == FL_PROCEDURE) 906 { 907 gfc_interface *intr; 908 gcc_assert (s->attr.generic); 909 for (intr = s->generic; intr; intr = intr->next) 910 if (gfc_fl_struct (intr->sym->attr.flavor)) 911 { 912 s = intr->sym; 913 break; 914 } 915 } 916 917 /* Normally we can assume that s is a derived-type symbol since it 918 shares a name with the derived-type sym. However if sym is a 919 STRUCTURE, it may in fact share a name with any other basic type 920 variable. If s is in fact of derived type then we can continue 921 looking for a duplicate type declaration. */ 922 if (sym->attr.flavor == FL_STRUCT && s->ts.type == BT_DERIVED) 923 { 924 s = s->ts.u.derived; 925 } 926 927 if (gfc_fl_struct (s->attr.flavor) && !s->backend_decl) 928 { 929 if (s->attr.flavor == FL_UNION) 930 s->backend_decl = gfc_get_union_type (s); 931 else 932 s->backend_decl = gfc_get_derived_type (s); 933 } 934 gfc_copy_dt_decls_ifequal (s, sym, true); 935 return true; 936 } 937 else if (s->backend_decl) 938 { 939 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 940 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, 941 true); 942 else if (sym->ts.type == BT_CHARACTER) 943 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; 944 sym->backend_decl = s->backend_decl; 945 return true; 946 } 947 } 948 return false; 949 } 950 951 952 /* Create an array index type variable with function scope. */ 953 954 static tree 955 create_index_var (const char * pfx, int nest) 956 { 957 tree decl; 958 959 decl = gfc_create_var_np (gfc_array_index_type, pfx); 960 if (nest) 961 gfc_add_decl_to_parent_function (decl); 962 else 963 gfc_add_decl_to_function (decl); 964 return decl; 965 } 966 967 968 /* Create variables to hold all the non-constant bits of info for a 969 descriptorless array. Remember these in the lang-specific part of the 970 type. */ 971 972 static void 973 gfc_build_qualified_array (tree decl, gfc_symbol * sym) 974 { 975 tree type; 976 int dim; 977 int nest; 978 gfc_namespace* procns; 979 symbol_attribute *array_attr; 980 gfc_array_spec *as; 981 bool is_classarray = IS_CLASS_ARRAY (sym); 982 983 type = TREE_TYPE (decl); 984 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; 985 as = is_classarray ? CLASS_DATA (sym)->as : sym->as; 986 987 /* We just use the descriptor, if there is one. */ 988 if (GFC_DESCRIPTOR_TYPE_P (type)) 989 return; 990 991 gcc_assert (GFC_ARRAY_TYPE_P (type)); 992 procns = gfc_find_proc_namespace (sym->ns); 993 nest = (procns->proc_name->backend_decl != current_function_decl) 994 && !sym->attr.contained; 995 996 if (array_attr->codimension && flag_coarray == GFC_FCOARRAY_LIB 997 && as->type != AS_ASSUMED_SHAPE 998 && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE) 999 { 1000 tree token; 1001 tree token_type = build_qualified_type (pvoid_type_node, 1002 TYPE_QUAL_RESTRICT); 1003 1004 if (sym->module && (sym->attr.use_assoc 1005 || sym->ns->proc_name->attr.flavor == FL_MODULE)) 1006 { 1007 tree token_name 1008 = get_identifier (gfc_get_string (GFC_PREFIX ("caf_token%s"), 1009 IDENTIFIER_POINTER (gfc_sym_mangled_identifier (sym)))); 1010 token = build_decl (DECL_SOURCE_LOCATION (decl), VAR_DECL, token_name, 1011 token_type); 1012 if (sym->attr.use_assoc) 1013 DECL_EXTERNAL (token) = 1; 1014 else 1015 TREE_STATIC (token) = 1; 1016 1017 TREE_PUBLIC (token) = 1; 1018 1019 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) 1020 { 1021 DECL_VISIBILITY (token) = VISIBILITY_HIDDEN; 1022 DECL_VISIBILITY_SPECIFIED (token) = true; 1023 } 1024 } 1025 else 1026 { 1027 token = gfc_create_var_np (token_type, "caf_token"); 1028 TREE_STATIC (token) = 1; 1029 } 1030 1031 GFC_TYPE_ARRAY_CAF_TOKEN (type) = token; 1032 DECL_ARTIFICIAL (token) = 1; 1033 DECL_NONALIASED (token) = 1; 1034 1035 if (sym->module && !sym->attr.use_assoc) 1036 { 1037 pushdecl (token); 1038 DECL_CONTEXT (token) = sym->ns->proc_name->backend_decl; 1039 gfc_module_add_decl (cur_module, token); 1040 } 1041 else if (sym->attr.host_assoc 1042 && TREE_CODE (DECL_CONTEXT (current_function_decl)) 1043 != TRANSLATION_UNIT_DECL) 1044 gfc_add_decl_to_parent_function (token); 1045 else 1046 gfc_add_decl_to_function (token); 1047 } 1048 1049 for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) 1050 { 1051 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) 1052 { 1053 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); 1054 suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); 1055 } 1056 /* Don't try to use the unknown bound for assumed shape arrays. */ 1057 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE 1058 && (as->type != AS_ASSUMED_SIZE 1059 || dim < GFC_TYPE_ARRAY_RANK (type) - 1)) 1060 { 1061 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); 1062 suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); 1063 } 1064 1065 if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE) 1066 { 1067 GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest); 1068 suppress_warning (GFC_TYPE_ARRAY_STRIDE (type, dim)); 1069 } 1070 } 1071 for (dim = GFC_TYPE_ARRAY_RANK (type); 1072 dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type); dim++) 1073 { 1074 if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE) 1075 { 1076 GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest); 1077 suppress_warning (GFC_TYPE_ARRAY_LBOUND (type, dim)); 1078 } 1079 /* Don't try to use the unknown ubound for the last coarray dimension. */ 1080 if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE 1081 && dim < GFC_TYPE_ARRAY_RANK (type) + GFC_TYPE_ARRAY_CORANK (type) - 1) 1082 { 1083 GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest); 1084 suppress_warning (GFC_TYPE_ARRAY_UBOUND (type, dim)); 1085 } 1086 } 1087 if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE) 1088 { 1089 GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type, 1090 "offset"); 1091 suppress_warning (GFC_TYPE_ARRAY_OFFSET (type)); 1092 1093 if (nest) 1094 gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type)); 1095 else 1096 gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type)); 1097 } 1098 1099 if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE 1100 && as->type != AS_ASSUMED_SIZE) 1101 { 1102 GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest); 1103 suppress_warning (GFC_TYPE_ARRAY_SIZE (type)); 1104 } 1105 1106 if (POINTER_TYPE_P (type)) 1107 { 1108 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type))); 1109 gcc_assert (TYPE_LANG_SPECIFIC (type) 1110 == TYPE_LANG_SPECIFIC (TREE_TYPE (type))); 1111 type = TREE_TYPE (type); 1112 } 1113 1114 if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type)) 1115 { 1116 tree size, range; 1117 1118 size = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 1119 GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node); 1120 range = build_range_type (gfc_array_index_type, gfc_index_zero_node, 1121 size); 1122 TYPE_DOMAIN (type) = range; 1123 layout_type (type); 1124 } 1125 1126 if (TYPE_NAME (type) != NULL_TREE && as->rank > 0 1127 && GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1) != NULL_TREE 1128 && VAR_P (GFC_TYPE_ARRAY_UBOUND (type, as->rank - 1))) 1129 { 1130 tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type)); 1131 1132 for (dim = 0; dim < as->rank - 1; dim++) 1133 { 1134 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); 1135 gtype = TREE_TYPE (gtype); 1136 } 1137 gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE); 1138 if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL) 1139 TYPE_NAME (type) = NULL_TREE; 1140 } 1141 1142 if (TYPE_NAME (type) == NULL_TREE) 1143 { 1144 tree gtype = TREE_TYPE (type), rtype, type_decl; 1145 1146 for (dim = as->rank - 1; dim >= 0; dim--) 1147 { 1148 tree lbound, ubound; 1149 lbound = GFC_TYPE_ARRAY_LBOUND (type, dim); 1150 ubound = GFC_TYPE_ARRAY_UBOUND (type, dim); 1151 rtype = build_range_type (gfc_array_index_type, lbound, ubound); 1152 gtype = build_array_type (gtype, rtype); 1153 /* Ensure the bound variables aren't optimized out at -O0. 1154 For -O1 and above they often will be optimized out, but 1155 can be tracked by VTA. Also set DECL_NAMELESS, so that 1156 the artificial lbound.N or ubound.N DECL_NAME doesn't 1157 end up in debug info. */ 1158 if (lbound 1159 && VAR_P (lbound) 1160 && DECL_ARTIFICIAL (lbound) 1161 && DECL_IGNORED_P (lbound)) 1162 { 1163 if (DECL_NAME (lbound) 1164 && strstr (IDENTIFIER_POINTER (DECL_NAME (lbound)), 1165 "lbound") != 0) 1166 DECL_NAMELESS (lbound) = 1; 1167 DECL_IGNORED_P (lbound) = 0; 1168 } 1169 if (ubound 1170 && VAR_P (ubound) 1171 && DECL_ARTIFICIAL (ubound) 1172 && DECL_IGNORED_P (ubound)) 1173 { 1174 if (DECL_NAME (ubound) 1175 && strstr (IDENTIFIER_POINTER (DECL_NAME (ubound)), 1176 "ubound") != 0) 1177 DECL_NAMELESS (ubound) = 1; 1178 DECL_IGNORED_P (ubound) = 0; 1179 } 1180 } 1181 TYPE_NAME (type) = type_decl = build_decl (input_location, 1182 TYPE_DECL, NULL, gtype); 1183 DECL_ORIGINAL_TYPE (type_decl) = gtype; 1184 } 1185 } 1186 1187 1188 /* For some dummy arguments we don't use the actual argument directly. 1189 Instead we create a local decl and use that. This allows us to perform 1190 initialization, and construct full type information. */ 1191 1192 static tree 1193 gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) 1194 { 1195 tree decl; 1196 tree type; 1197 gfc_array_spec *as; 1198 symbol_attribute *array_attr; 1199 char *name; 1200 gfc_packed packed; 1201 int n; 1202 bool known_size; 1203 bool is_classarray = IS_CLASS_ARRAY (sym); 1204 1205 /* Use the array as and attr. */ 1206 as = is_classarray ? CLASS_DATA (sym)->as : sym->as; 1207 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; 1208 1209 /* The dummy is returned for pointer, allocatable or assumed rank arrays. 1210 For class arrays the information if sym is an allocatable or pointer 1211 object needs to be checked explicitly (IS_CLASS_ARRAY can be false for 1212 too many reasons to be of use here). */ 1213 if ((sym->ts.type != BT_CLASS && sym->attr.pointer) 1214 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer) 1215 || array_attr->allocatable 1216 || (as && as->type == AS_ASSUMED_RANK)) 1217 return dummy; 1218 1219 /* Add to list of variables if not a fake result variable. 1220 These symbols are set on the symbol only, not on the class component. */ 1221 if (sym->attr.result || sym->attr.dummy) 1222 gfc_defer_symbol_init (sym); 1223 1224 /* For a class array the array descriptor is in the _data component, while 1225 for a regular array the TREE_TYPE of the dummy is a pointer to the 1226 descriptor. */ 1227 type = TREE_TYPE (is_classarray ? gfc_class_data_get (dummy) 1228 : TREE_TYPE (dummy)); 1229 /* type now is the array descriptor w/o any indirection. */ 1230 gcc_assert (TREE_CODE (dummy) == PARM_DECL 1231 && POINTER_TYPE_P (TREE_TYPE (dummy))); 1232 1233 /* Do we know the element size? */ 1234 known_size = sym->ts.type != BT_CHARACTER 1235 || INTEGER_CST_P (sym->ts.u.cl->backend_decl); 1236 1237 if (known_size && !GFC_DESCRIPTOR_TYPE_P (type)) 1238 { 1239 /* For descriptorless arrays with known element size the actual 1240 argument is sufficient. */ 1241 gfc_build_qualified_array (dummy, sym); 1242 return dummy; 1243 } 1244 1245 if (GFC_DESCRIPTOR_TYPE_P (type)) 1246 { 1247 /* Create a descriptorless array pointer. */ 1248 packed = PACKED_NO; 1249 1250 /* Even when -frepack-arrays is used, symbols with TARGET attribute 1251 are not repacked. */ 1252 if (!flag_repack_arrays || sym->attr.target) 1253 { 1254 if (as->type == AS_ASSUMED_SIZE) 1255 packed = PACKED_FULL; 1256 } 1257 else 1258 { 1259 if (as->type == AS_EXPLICIT) 1260 { 1261 packed = PACKED_FULL; 1262 for (n = 0; n < as->rank; n++) 1263 { 1264 if (!(as->upper[n] 1265 && as->lower[n] 1266 && as->upper[n]->expr_type == EXPR_CONSTANT 1267 && as->lower[n]->expr_type == EXPR_CONSTANT)) 1268 { 1269 packed = PACKED_PARTIAL; 1270 break; 1271 } 1272 } 1273 } 1274 else 1275 packed = PACKED_PARTIAL; 1276 } 1277 1278 /* For classarrays the element type is required, but 1279 gfc_typenode_for_spec () returns the array descriptor. */ 1280 type = is_classarray ? gfc_get_element_type (type) 1281 : gfc_typenode_for_spec (&sym->ts); 1282 type = gfc_get_nodesc_array_type (type, as, packed, 1283 !sym->attr.target); 1284 } 1285 else 1286 { 1287 /* We now have an expression for the element size, so create a fully 1288 qualified type. Reset sym->backend decl or this will just return the 1289 old type. */ 1290 DECL_ARTIFICIAL (sym->backend_decl) = 1; 1291 sym->backend_decl = NULL_TREE; 1292 type = gfc_sym_type (sym); 1293 packed = PACKED_FULL; 1294 } 1295 1296 ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0); 1297 decl = build_decl (input_location, 1298 VAR_DECL, get_identifier (name), type); 1299 1300 DECL_ARTIFICIAL (decl) = 1; 1301 DECL_NAMELESS (decl) = 1; 1302 TREE_PUBLIC (decl) = 0; 1303 TREE_STATIC (decl) = 0; 1304 DECL_EXTERNAL (decl) = 0; 1305 1306 /* Avoid uninitialized warnings for optional dummy arguments. */ 1307 if ((sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.optional) 1308 || sym->attr.optional) 1309 suppress_warning (decl); 1310 1311 /* We should never get deferred shape arrays here. We used to because of 1312 frontend bugs. */ 1313 gcc_assert (as->type != AS_DEFERRED); 1314 1315 if (packed == PACKED_PARTIAL) 1316 GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1; 1317 else if (packed == PACKED_FULL) 1318 GFC_DECL_PACKED_ARRAY (decl) = 1; 1319 1320 gfc_build_qualified_array (decl, sym); 1321 1322 if (DECL_LANG_SPECIFIC (dummy)) 1323 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy); 1324 else 1325 gfc_allocate_lang_decl (decl); 1326 1327 GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy; 1328 1329 if (sym->ns->proc_name->backend_decl == current_function_decl 1330 || sym->attr.contained) 1331 gfc_add_decl_to_function (decl); 1332 else 1333 gfc_add_decl_to_parent_function (decl); 1334 1335 return decl; 1336 } 1337 1338 /* Return a constant or a variable to use as a string length. Does not 1339 add the decl to the current scope. */ 1340 1341 static tree 1342 gfc_create_string_length (gfc_symbol * sym) 1343 { 1344 gcc_assert (sym->ts.u.cl); 1345 gfc_conv_const_charlen (sym->ts.u.cl); 1346 1347 if (sym->ts.u.cl->backend_decl == NULL_TREE) 1348 { 1349 tree length; 1350 const char *name; 1351 1352 /* The string length variable shall be in static memory if it is either 1353 explicitly SAVED, a module variable or with -fno-automatic. Only 1354 relevant is "len=:" - otherwise, it is either a constant length or 1355 it is an automatic variable. */ 1356 bool static_length = sym->attr.save 1357 || sym->ns->proc_name->attr.flavor == FL_MODULE 1358 || (flag_max_stack_var_size == 0 1359 && sym->ts.deferred && !sym->attr.dummy 1360 && !sym->attr.result && !sym->attr.function); 1361 1362 /* Also prefix the mangled name. We need to call GFC_PREFIX for static 1363 variables as some systems do not support the "." in the assembler name. 1364 For nonstatic variables, the "." does not appear in assembler. */ 1365 if (static_length) 1366 { 1367 if (sym->module) 1368 name = gfc_get_string (GFC_PREFIX ("%s_MOD_%s"), sym->module, 1369 sym->name); 1370 else 1371 name = gfc_get_string (GFC_PREFIX ("%s"), sym->name); 1372 } 1373 else if (sym->module) 1374 name = gfc_get_string (".__%s_MOD_%s", sym->module, sym->name); 1375 else 1376 name = gfc_get_string (".%s", sym->name); 1377 1378 length = build_decl (input_location, 1379 VAR_DECL, get_identifier (name), 1380 gfc_charlen_type_node); 1381 DECL_ARTIFICIAL (length) = 1; 1382 TREE_USED (length) = 1; 1383 if (sym->ns->proc_name->tlink != NULL) 1384 gfc_defer_symbol_init (sym); 1385 1386 sym->ts.u.cl->backend_decl = length; 1387 1388 if (static_length) 1389 TREE_STATIC (length) = 1; 1390 1391 if (sym->ns->proc_name->attr.flavor == FL_MODULE 1392 && (sym->attr.access != ACCESS_PRIVATE || sym->attr.public_used)) 1393 TREE_PUBLIC (length) = 1; 1394 } 1395 1396 gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE); 1397 return sym->ts.u.cl->backend_decl; 1398 } 1399 1400 /* If a variable is assigned a label, we add another two auxiliary 1401 variables. */ 1402 1403 static void 1404 gfc_add_assign_aux_vars (gfc_symbol * sym) 1405 { 1406 tree addr; 1407 tree length; 1408 tree decl; 1409 1410 gcc_assert (sym->backend_decl); 1411 1412 decl = sym->backend_decl; 1413 gfc_allocate_lang_decl (decl); 1414 GFC_DECL_ASSIGN (decl) = 1; 1415 length = build_decl (input_location, 1416 VAR_DECL, create_tmp_var_name (sym->name), 1417 gfc_charlen_type_node); 1418 addr = build_decl (input_location, 1419 VAR_DECL, create_tmp_var_name (sym->name), 1420 pvoid_type_node); 1421 gfc_finish_var_decl (length, sym); 1422 gfc_finish_var_decl (addr, sym); 1423 /* STRING_LENGTH is also used as flag. Less than -1 means that 1424 ASSIGN_ADDR cannot be used. Equal -1 means that ASSIGN_ADDR is the 1425 target label's address. Otherwise, value is the length of a format string 1426 and ASSIGN_ADDR is its address. */ 1427 if (TREE_STATIC (length)) 1428 DECL_INITIAL (length) = build_int_cst (gfc_charlen_type_node, -2); 1429 else 1430 gfc_defer_symbol_init (sym); 1431 1432 GFC_DECL_STRING_LEN (decl) = length; 1433 GFC_DECL_ASSIGN_ADDR (decl) = addr; 1434 } 1435 1436 1437 static tree 1438 add_attributes_to_decl (symbol_attribute sym_attr, tree list) 1439 { 1440 unsigned id; 1441 tree attr; 1442 1443 for (id = 0; id < EXT_ATTR_NUM; id++) 1444 if (sym_attr.ext_attr & (1 << id) && ext_attr_list[id].middle_end_name) 1445 { 1446 attr = build_tree_list ( 1447 get_identifier (ext_attr_list[id].middle_end_name), 1448 NULL_TREE); 1449 list = chainon (list, attr); 1450 } 1451 1452 tree clauses = NULL_TREE; 1453 1454 if (sym_attr.oacc_routine_lop != OACC_ROUTINE_LOP_NONE) 1455 { 1456 omp_clause_code code; 1457 switch (sym_attr.oacc_routine_lop) 1458 { 1459 case OACC_ROUTINE_LOP_GANG: 1460 code = OMP_CLAUSE_GANG; 1461 break; 1462 case OACC_ROUTINE_LOP_WORKER: 1463 code = OMP_CLAUSE_WORKER; 1464 break; 1465 case OACC_ROUTINE_LOP_VECTOR: 1466 code = OMP_CLAUSE_VECTOR; 1467 break; 1468 case OACC_ROUTINE_LOP_SEQ: 1469 code = OMP_CLAUSE_SEQ; 1470 break; 1471 case OACC_ROUTINE_LOP_NONE: 1472 case OACC_ROUTINE_LOP_ERROR: 1473 default: 1474 gcc_unreachable (); 1475 } 1476 tree c = build_omp_clause (UNKNOWN_LOCATION, code); 1477 OMP_CLAUSE_CHAIN (c) = clauses; 1478 clauses = c; 1479 1480 tree dims = oacc_build_routine_dims (clauses); 1481 list = oacc_replace_fn_attrib_attr (list, dims); 1482 } 1483 1484 if (sym_attr.oacc_routine_nohost) 1485 { 1486 tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_NOHOST); 1487 OMP_CLAUSE_CHAIN (c) = clauses; 1488 clauses = c; 1489 } 1490 1491 if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET) 1492 { 1493 tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE); 1494 switch (sym_attr.omp_device_type) 1495 { 1496 case OMP_DEVICE_TYPE_HOST: 1497 OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST; 1498 break; 1499 case OMP_DEVICE_TYPE_NOHOST: 1500 OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST; 1501 break; 1502 case OMP_DEVICE_TYPE_ANY: 1503 OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY; 1504 break; 1505 default: 1506 gcc_unreachable (); 1507 } 1508 OMP_CLAUSE_CHAIN (c) = clauses; 1509 clauses = c; 1510 } 1511 1512 if (sym_attr.omp_declare_target_link 1513 || sym_attr.oacc_declare_link) 1514 list = tree_cons (get_identifier ("omp declare target link"), 1515 clauses, list); 1516 else if (sym_attr.omp_declare_target 1517 || sym_attr.oacc_declare_create 1518 || sym_attr.oacc_declare_copyin 1519 || sym_attr.oacc_declare_deviceptr 1520 || sym_attr.oacc_declare_device_resident) 1521 list = tree_cons (get_identifier ("omp declare target"), 1522 clauses, list); 1523 1524 return list; 1525 } 1526 1527 1528 static void build_function_decl (gfc_symbol * sym, bool global); 1529 1530 1531 /* Return the decl for a gfc_symbol, create it if it doesn't already 1532 exist. */ 1533 1534 tree 1535 gfc_get_symbol_decl (gfc_symbol * sym) 1536 { 1537 tree decl; 1538 tree length = NULL_TREE; 1539 tree attributes; 1540 int byref; 1541 bool intrinsic_array_parameter = false; 1542 bool fun_or_res; 1543 1544 gcc_assert (sym->attr.referenced 1545 || sym->attr.flavor == FL_PROCEDURE 1546 || sym->attr.use_assoc 1547 || sym->attr.used_in_submodule 1548 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY 1549 || (sym->module && sym->attr.if_source != IFSRC_DECL 1550 && sym->backend_decl)); 1551 1552 if (sym->attr.dummy && sym->ns->proc_name->attr.is_bind_c 1553 && is_CFI_desc (sym, NULL)) 1554 { 1555 gcc_assert (sym->backend_decl && (sym->ts.type != BT_CHARACTER 1556 || sym->ts.u.cl->backend_decl)); 1557 return sym->backend_decl; 1558 } 1559 1560 if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function) 1561 byref = gfc_return_by_reference (sym->ns->proc_name); 1562 else 1563 byref = 0; 1564 1565 /* Make sure that the vtab for the declared type is completed. */ 1566 if (sym->ts.type == BT_CLASS) 1567 { 1568 gfc_component *c = CLASS_DATA (sym); 1569 if (!c->ts.u.derived->backend_decl) 1570 { 1571 gfc_find_derived_vtab (c->ts.u.derived); 1572 gfc_get_derived_type (sym->ts.u.derived); 1573 } 1574 } 1575 1576 /* PDT parameterized array components and string_lengths must have the 1577 'len' parameters substituted for the expressions appearing in the 1578 declaration of the entity and memory allocated/deallocated. */ 1579 if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 1580 && sym->param_list != NULL 1581 && gfc_current_ns == sym->ns 1582 && !(sym->attr.use_assoc || sym->attr.dummy)) 1583 gfc_defer_symbol_init (sym); 1584 1585 /* Dummy PDT 'len' parameters should be checked when they are explicit. */ 1586 if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 1587 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 1588 && sym->param_list != NULL 1589 && sym->attr.dummy) 1590 gfc_defer_symbol_init (sym); 1591 1592 /* All deferred character length procedures need to retain the backend 1593 decl, which is a pointer to the character length in the caller's 1594 namespace and to declare a local character length. */ 1595 if (!byref && sym->attr.function 1596 && sym->ts.type == BT_CHARACTER 1597 && sym->ts.deferred 1598 && sym->ts.u.cl->passed_length == NULL 1599 && sym->ts.u.cl->backend_decl 1600 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) 1601 { 1602 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; 1603 gcc_assert (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))); 1604 sym->ts.u.cl->backend_decl = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); 1605 } 1606 1607 fun_or_res = byref && (sym->attr.result 1608 || (sym->attr.function && sym->ts.deferred)); 1609 if ((sym->attr.dummy && ! sym->attr.function) || fun_or_res) 1610 { 1611 /* Return via extra parameter. */ 1612 if (sym->attr.result && byref 1613 && !sym->backend_decl) 1614 { 1615 sym->backend_decl = 1616 DECL_ARGUMENTS (sym->ns->proc_name->backend_decl); 1617 /* For entry master function skip over the __entry 1618 argument. */ 1619 if (sym->ns->proc_name->attr.entry_master) 1620 sym->backend_decl = DECL_CHAIN (sym->backend_decl); 1621 } 1622 1623 /* Dummy variables should already have been created. */ 1624 gcc_assert (sym->backend_decl); 1625 1626 /* However, the string length of deferred arrays must be set. */ 1627 if (sym->ts.type == BT_CHARACTER 1628 && sym->ts.deferred 1629 && sym->attr.dimension 1630 && sym->attr.allocatable) 1631 gfc_defer_symbol_init (sym); 1632 1633 if (sym->attr.pointer && sym->attr.dimension && sym->ts.type != BT_CLASS) 1634 GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; 1635 1636 /* Create a character length variable. */ 1637 if (sym->ts.type == BT_CHARACTER) 1638 { 1639 /* For a deferred dummy, make a new string length variable. */ 1640 if (sym->ts.deferred 1641 && 1642 (sym->ts.u.cl->passed_length == sym->ts.u.cl->backend_decl)) 1643 sym->ts.u.cl->backend_decl = NULL_TREE; 1644 1645 if (sym->ts.deferred && byref) 1646 { 1647 /* The string length of a deferred char array is stored in the 1648 parameter at sym->ts.u.cl->backend_decl as a reference and 1649 marked as a result. Exempt this variable from generating a 1650 temporary for it. */ 1651 if (sym->attr.result) 1652 { 1653 /* We need to insert a indirect ref for param decls. */ 1654 if (sym->ts.u.cl->backend_decl 1655 && TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL) 1656 { 1657 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; 1658 sym->ts.u.cl->backend_decl = 1659 build_fold_indirect_ref (sym->ts.u.cl->backend_decl); 1660 } 1661 } 1662 /* For all other parameters make sure, that they are copied so 1663 that the value and any modifications are local to the routine 1664 by generating a temporary variable. */ 1665 else if (sym->attr.function 1666 && sym->ts.u.cl->passed_length == NULL 1667 && sym->ts.u.cl->backend_decl) 1668 { 1669 sym->ts.u.cl->passed_length = sym->ts.u.cl->backend_decl; 1670 if (POINTER_TYPE_P (TREE_TYPE (sym->ts.u.cl->passed_length))) 1671 sym->ts.u.cl->backend_decl 1672 = build_fold_indirect_ref (sym->ts.u.cl->backend_decl); 1673 else 1674 sym->ts.u.cl->backend_decl = NULL_TREE; 1675 } 1676 } 1677 1678 if (sym->ts.u.cl->backend_decl == NULL_TREE) 1679 length = gfc_create_string_length (sym); 1680 else 1681 length = sym->ts.u.cl->backend_decl; 1682 if (VAR_P (length) && DECL_FILE_SCOPE_P (length)) 1683 { 1684 /* Add the string length to the same context as the symbol. */ 1685 if (DECL_CONTEXT (length) == NULL_TREE) 1686 { 1687 if (sym->backend_decl == current_function_decl 1688 || (DECL_CONTEXT (sym->backend_decl) 1689 == current_function_decl)) 1690 gfc_add_decl_to_function (length); 1691 else 1692 gfc_add_decl_to_parent_function (length); 1693 } 1694 1695 gcc_assert (sym->backend_decl == current_function_decl 1696 ? DECL_CONTEXT (length) == current_function_decl 1697 : (DECL_CONTEXT (sym->backend_decl) 1698 == DECL_CONTEXT (length))); 1699 1700 gfc_defer_symbol_init (sym); 1701 } 1702 } 1703 1704 /* Use a copy of the descriptor for dummy arrays. */ 1705 if ((sym->attr.dimension || sym->attr.codimension) 1706 && !TREE_USED (sym->backend_decl)) 1707 { 1708 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); 1709 /* Prevent the dummy from being detected as unused if it is copied. */ 1710 if (sym->backend_decl != NULL && decl != sym->backend_decl) 1711 DECL_ARTIFICIAL (sym->backend_decl) = 1; 1712 sym->backend_decl = decl; 1713 } 1714 1715 /* Returning the descriptor for dummy class arrays is hazardous, because 1716 some caller is expecting an expression to apply the component refs to. 1717 Therefore the descriptor is only created and stored in 1718 sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR. The caller is then 1719 responsible to extract it from there, when the descriptor is 1720 desired. */ 1721 if (IS_CLASS_ARRAY (sym) 1722 && (!DECL_LANG_SPECIFIC (sym->backend_decl) 1723 || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl))) 1724 { 1725 decl = gfc_build_dummy_array_decl (sym, sym->backend_decl); 1726 /* Prevent the dummy from being detected as unused if it is copied. */ 1727 if (sym->backend_decl != NULL && decl != sym->backend_decl) 1728 DECL_ARTIFICIAL (sym->backend_decl) = 1; 1729 sym->backend_decl = decl; 1730 } 1731 1732 TREE_USED (sym->backend_decl) = 1; 1733 if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0) 1734 gfc_add_assign_aux_vars (sym); 1735 1736 if (sym->ts.type == BT_CLASS && sym->backend_decl) 1737 GFC_DECL_CLASS(sym->backend_decl) = 1; 1738 1739 return sym->backend_decl; 1740 } 1741 1742 if (sym->result == sym && sym->attr.assign 1743 && GFC_DECL_ASSIGN (sym->backend_decl) == 0) 1744 gfc_add_assign_aux_vars (sym); 1745 1746 if (sym->backend_decl) 1747 return sym->backend_decl; 1748 1749 /* Special case for array-valued named constants from intrinsic 1750 procedures; those are inlined. */ 1751 if (sym->attr.use_assoc && sym->attr.flavor == FL_PARAMETER 1752 && (sym->from_intmod == INTMOD_ISO_FORTRAN_ENV 1753 || sym->from_intmod == INTMOD_ISO_C_BINDING)) 1754 intrinsic_array_parameter = true; 1755 1756 /* If use associated compilation, use the module 1757 declaration. */ 1758 if ((sym->attr.flavor == FL_VARIABLE 1759 || sym->attr.flavor == FL_PARAMETER) 1760 && (sym->attr.use_assoc || sym->attr.used_in_submodule) 1761 && !intrinsic_array_parameter 1762 && sym->module 1763 && gfc_get_module_backend_decl (sym)) 1764 { 1765 if (sym->ts.type == BT_CLASS && sym->backend_decl) 1766 GFC_DECL_CLASS(sym->backend_decl) = 1; 1767 return sym->backend_decl; 1768 } 1769 1770 if (sym->attr.flavor == FL_PROCEDURE) 1771 { 1772 /* Catch functions. Only used for actual parameters, 1773 procedure pointers and procptr initialization targets. */ 1774 if (sym->attr.use_assoc 1775 || sym->attr.used_in_submodule 1776 || sym->attr.intrinsic 1777 || sym->attr.if_source != IFSRC_DECL) 1778 { 1779 decl = gfc_get_extern_function_decl (sym); 1780 } 1781 else 1782 { 1783 if (!sym->backend_decl) 1784 build_function_decl (sym, false); 1785 decl = sym->backend_decl; 1786 } 1787 return decl; 1788 } 1789 1790 if (sym->attr.intrinsic) 1791 gfc_internal_error ("intrinsic variable which isn't a procedure"); 1792 1793 /* Create string length decl first so that they can be used in the 1794 type declaration. For associate names, the target character 1795 length is used. Set 'length' to a constant so that if the 1796 string length is a variable, it is not finished a second time. */ 1797 if (sym->ts.type == BT_CHARACTER) 1798 { 1799 if (sym->attr.associate_var 1800 && sym->ts.deferred 1801 && sym->assoc && sym->assoc->target 1802 && ((sym->assoc->target->expr_type == EXPR_VARIABLE 1803 && sym->assoc->target->symtree->n.sym->ts.type != BT_CHARACTER) 1804 || sym->assoc->target->expr_type != EXPR_VARIABLE)) 1805 sym->ts.u.cl->backend_decl = NULL_TREE; 1806 1807 if (sym->attr.associate_var 1808 && sym->ts.u.cl->backend_decl 1809 && (VAR_P (sym->ts.u.cl->backend_decl) 1810 || TREE_CODE (sym->ts.u.cl->backend_decl) == PARM_DECL)) 1811 length = gfc_index_zero_node; 1812 else 1813 length = gfc_create_string_length (sym); 1814 } 1815 1816 /* Create the decl for the variable. */ 1817 decl = build_decl (gfc_get_location (&sym->declared_at), 1818 VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym)); 1819 1820 /* Add attributes to variables. Functions are handled elsewhere. */ 1821 attributes = add_attributes_to_decl (sym->attr, NULL_TREE); 1822 decl_attributes (&decl, attributes, 0); 1823 1824 /* Symbols from modules should have their assembler names mangled. 1825 This is done here rather than in gfc_finish_var_decl because it 1826 is different for string length variables. */ 1827 if (sym->module || sym->fn_result_spec) 1828 { 1829 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); 1830 if (sym->attr.use_assoc && !intrinsic_array_parameter) 1831 DECL_IGNORED_P (decl) = 1; 1832 } 1833 1834 if (sym->attr.select_type_temporary) 1835 { 1836 DECL_ARTIFICIAL (decl) = 1; 1837 DECL_IGNORED_P (decl) = 1; 1838 } 1839 1840 if (sym->attr.dimension || sym->attr.codimension) 1841 { 1842 /* Create variables to hold the non-constant bits of array info. */ 1843 gfc_build_qualified_array (decl, sym); 1844 1845 if (sym->attr.contiguous 1846 || ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)) 1847 GFC_DECL_PACKED_ARRAY (decl) = 1; 1848 } 1849 1850 /* Remember this variable for allocation/cleanup. */ 1851 if (sym->attr.dimension || sym->attr.allocatable || sym->attr.codimension 1852 || (sym->ts.type == BT_CLASS && 1853 (CLASS_DATA (sym)->attr.dimension 1854 || CLASS_DATA (sym)->attr.allocatable)) 1855 || (sym->ts.type == BT_DERIVED 1856 && (sym->ts.u.derived->attr.alloc_comp 1857 || (!sym->attr.pointer && !sym->attr.artificial && !sym->attr.save 1858 && !sym->ns->proc_name->attr.is_main_program 1859 && gfc_is_finalizable (sym->ts.u.derived, NULL)))) 1860 /* This applies a derived type default initializer. */ 1861 || (sym->ts.type == BT_DERIVED 1862 && sym->attr.save == SAVE_NONE 1863 && !sym->attr.data 1864 && !sym->attr.allocatable 1865 && (sym->value && !sym->ns->proc_name->attr.is_main_program) 1866 && !(sym->attr.use_assoc && !intrinsic_array_parameter))) 1867 gfc_defer_symbol_init (sym); 1868 1869 if (sym->ts.type == BT_CHARACTER 1870 && sym->attr.allocatable 1871 && !sym->attr.dimension 1872 && sym->ts.u.cl && sym->ts.u.cl->length 1873 && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) 1874 gfc_defer_symbol_init (sym); 1875 1876 /* Associate names can use the hidden string length variable 1877 of their associated target. */ 1878 if (sym->ts.type == BT_CHARACTER 1879 && TREE_CODE (length) != INTEGER_CST 1880 && TREE_CODE (sym->ts.u.cl->backend_decl) != INDIRECT_REF) 1881 { 1882 length = fold_convert (gfc_charlen_type_node, length); 1883 gfc_finish_var_decl (length, sym); 1884 if (!sym->attr.associate_var 1885 && TREE_CODE (length) == VAR_DECL 1886 && sym->value && sym->value->expr_type != EXPR_NULL 1887 && sym->value->ts.u.cl->length) 1888 { 1889 gfc_expr *len = sym->value->ts.u.cl->length; 1890 DECL_INITIAL (length) = gfc_conv_initializer (len, &len->ts, 1891 TREE_TYPE (length), 1892 false, false, false); 1893 DECL_INITIAL (length) = fold_convert (gfc_charlen_type_node, 1894 DECL_INITIAL (length)); 1895 } 1896 else 1897 gcc_assert (!sym->value || sym->value->expr_type == EXPR_NULL); 1898 } 1899 1900 gfc_finish_var_decl (decl, sym); 1901 1902 if (sym->ts.type == BT_CHARACTER) 1903 /* Character variables need special handling. */ 1904 gfc_allocate_lang_decl (decl); 1905 1906 if (sym->assoc && sym->attr.subref_array_pointer) 1907 sym->attr.pointer = 1; 1908 1909 if (sym->attr.pointer && sym->attr.dimension 1910 && !sym->ts.deferred 1911 && !(sym->attr.select_type_temporary 1912 && !sym->attr.subref_array_pointer)) 1913 GFC_DECL_PTR_ARRAY_P (decl) = 1; 1914 1915 if (sym->ts.type == BT_CLASS) 1916 GFC_DECL_CLASS(decl) = 1; 1917 1918 sym->backend_decl = decl; 1919 1920 if (sym->attr.assign) 1921 gfc_add_assign_aux_vars (sym); 1922 1923 if (intrinsic_array_parameter) 1924 { 1925 TREE_STATIC (decl) = 1; 1926 DECL_EXTERNAL (decl) = 0; 1927 } 1928 1929 if (TREE_STATIC (decl) 1930 && !(sym->attr.use_assoc && !intrinsic_array_parameter) 1931 && (sym->attr.save || sym->ns->proc_name->attr.is_main_program 1932 || !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)) 1933 || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE) 1934 && (flag_coarray != GFC_FCOARRAY_LIB 1935 || !sym->attr.codimension || sym->attr.allocatable) 1936 && !(sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) 1937 && !(sym->ts.type == BT_CLASS 1938 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type)) 1939 { 1940 /* Add static initializer. For procedures, it is only needed if 1941 SAVE is specified otherwise they need to be reinitialized 1942 every time the procedure is entered. The TREE_STATIC is 1943 in this case due to -fmax-stack-var-size=. */ 1944 1945 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, 1946 TREE_TYPE (decl), sym->attr.dimension 1947 || (sym->attr.codimension 1948 && sym->attr.allocatable), 1949 sym->attr.pointer || sym->attr.allocatable 1950 || sym->ts.type == BT_CLASS, 1951 sym->attr.proc_pointer); 1952 } 1953 1954 if (!TREE_STATIC (decl) 1955 && POINTER_TYPE_P (TREE_TYPE (decl)) 1956 && !sym->attr.pointer 1957 && !sym->attr.allocatable 1958 && !sym->attr.proc_pointer 1959 && !sym->attr.select_type_temporary) 1960 DECL_BY_REFERENCE (decl) = 1; 1961 1962 if (sym->attr.associate_var) 1963 GFC_DECL_ASSOCIATE_VAR_P (decl) = 1; 1964 1965 /* We only longer mark __def_init as read-only if it actually has an 1966 initializer, it does not needlessly take up space in the 1967 read-only section and can go into the BSS instead, see PR 84487. 1968 Marking this as artificial means that OpenMP will treat this as 1969 predetermined shared. */ 1970 1971 bool def_init = startswith (sym->name, "__def_init"); 1972 1973 if (sym->attr.vtab || def_init) 1974 { 1975 DECL_ARTIFICIAL (decl) = 1; 1976 if (def_init && sym->value) 1977 TREE_READONLY (decl) = 1; 1978 } 1979 1980 return decl; 1981 } 1982 1983 1984 /* Substitute a temporary variable in place of the real one. */ 1985 1986 void 1987 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save) 1988 { 1989 save->attr = sym->attr; 1990 save->decl = sym->backend_decl; 1991 1992 gfc_clear_attr (&sym->attr); 1993 sym->attr.referenced = 1; 1994 sym->attr.flavor = FL_VARIABLE; 1995 1996 sym->backend_decl = decl; 1997 } 1998 1999 2000 /* Restore the original variable. */ 2001 2002 void 2003 gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save) 2004 { 2005 sym->attr = save->attr; 2006 sym->backend_decl = save->decl; 2007 } 2008 2009 2010 /* Declare a procedure pointer. */ 2011 2012 static tree 2013 get_proc_pointer_decl (gfc_symbol *sym) 2014 { 2015 tree decl; 2016 tree attributes; 2017 2018 if (sym->module || sym->fn_result_spec) 2019 { 2020 const char *name; 2021 gfc_gsymbol *gsym; 2022 2023 name = mangled_identifier (sym); 2024 gsym = gfc_find_gsymbol (gfc_gsym_root, name); 2025 if (gsym != NULL) 2026 { 2027 gfc_symbol *s; 2028 gfc_find_symbol (sym->name, gsym->ns, 0, &s); 2029 if (s && s->backend_decl) 2030 return s->backend_decl; 2031 } 2032 } 2033 2034 decl = sym->backend_decl; 2035 if (decl) 2036 return decl; 2037 2038 decl = build_decl (input_location, 2039 VAR_DECL, get_identifier (sym->name), 2040 build_pointer_type (gfc_get_function_type (sym))); 2041 2042 if (sym->module) 2043 { 2044 /* Apply name mangling. */ 2045 gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym)); 2046 if (sym->attr.use_assoc) 2047 DECL_IGNORED_P (decl) = 1; 2048 } 2049 2050 if ((sym->ns->proc_name 2051 && sym->ns->proc_name->backend_decl == current_function_decl) 2052 || sym->attr.contained) 2053 gfc_add_decl_to_function (decl); 2054 else if (sym->ns->proc_name->attr.flavor != FL_MODULE) 2055 gfc_add_decl_to_parent_function (decl); 2056 2057 sym->backend_decl = decl; 2058 2059 /* If a variable is USE associated, it's always external. */ 2060 if (sym->attr.use_assoc) 2061 { 2062 DECL_EXTERNAL (decl) = 1; 2063 TREE_PUBLIC (decl) = 1; 2064 } 2065 else if (sym->module && sym->ns->proc_name->attr.flavor == FL_MODULE) 2066 { 2067 /* This is the declaration of a module variable. */ 2068 TREE_PUBLIC (decl) = 1; 2069 if (sym->attr.access == ACCESS_PRIVATE && !sym->attr.public_used) 2070 { 2071 DECL_VISIBILITY (decl) = VISIBILITY_HIDDEN; 2072 DECL_VISIBILITY_SPECIFIED (decl) = true; 2073 } 2074 TREE_STATIC (decl) = 1; 2075 } 2076 2077 if (!sym->attr.use_assoc 2078 && (sym->attr.save != SAVE_NONE || sym->attr.data 2079 || (sym->value && sym->ns->proc_name->attr.is_main_program))) 2080 TREE_STATIC (decl) = 1; 2081 2082 if (TREE_STATIC (decl) && sym->value) 2083 { 2084 /* Add static initializer. */ 2085 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, 2086 TREE_TYPE (decl), 2087 sym->attr.dimension, 2088 false, true); 2089 } 2090 2091 /* Handle threadprivate procedure pointers. */ 2092 if (sym->attr.threadprivate 2093 && (TREE_STATIC (decl) || DECL_EXTERNAL (decl))) 2094 set_decl_tls_model (decl, decl_default_tls_model (decl)); 2095 2096 attributes = add_attributes_to_decl (sym->attr, NULL_TREE); 2097 decl_attributes (&decl, attributes, 0); 2098 2099 return decl; 2100 } 2101 2102 2103 /* Get a basic decl for an external function. */ 2104 2105 tree 2106 gfc_get_extern_function_decl (gfc_symbol * sym, gfc_actual_arglist *actual_args, 2107 const char *fnspec) 2108 { 2109 tree type; 2110 tree fndecl; 2111 tree attributes; 2112 gfc_expr e; 2113 gfc_intrinsic_sym *isym; 2114 gfc_expr argexpr; 2115 char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */ 2116 tree name; 2117 tree mangled_name; 2118 gfc_gsymbol *gsym; 2119 2120 if (sym->backend_decl) 2121 return sym->backend_decl; 2122 2123 /* We should never be creating external decls for alternate entry points. 2124 The procedure may be an alternate entry point, but we don't want/need 2125 to know that. */ 2126 gcc_assert (!(sym->attr.entry || sym->attr.entry_master)); 2127 2128 if (sym->attr.proc_pointer) 2129 return get_proc_pointer_decl (sym); 2130 2131 /* See if this is an external procedure from the same file. If so, 2132 return the backend_decl. If we are looking at a BIND(C) 2133 procedure and the symbol is not BIND(C), or vice versa, we 2134 haven't found the right procedure. */ 2135 2136 if (sym->binding_label) 2137 { 2138 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->binding_label); 2139 if (gsym && !gsym->bind_c) 2140 gsym = NULL; 2141 } 2142 else if (sym->module == NULL) 2143 { 2144 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); 2145 if (gsym && gsym->bind_c) 2146 gsym = NULL; 2147 } 2148 else 2149 { 2150 /* Procedure from a different module. */ 2151 gsym = NULL; 2152 } 2153 2154 if (gsym && !gsym->defined) 2155 gsym = NULL; 2156 2157 /* This can happen because of C binding. */ 2158 if (gsym && gsym->ns && gsym->ns->proc_name 2159 && gsym->ns->proc_name->attr.flavor == FL_MODULE) 2160 goto module_sym; 2161 2162 if ((!sym->attr.use_assoc || sym->attr.if_source != IFSRC_DECL) 2163 && !sym->backend_decl 2164 && gsym && gsym->ns 2165 && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) 2166 && (gsym->ns->proc_name->backend_decl || !sym->attr.intrinsic)) 2167 { 2168 if (!gsym->ns->proc_name->backend_decl) 2169 { 2170 /* By construction, the external function cannot be 2171 a contained procedure. */ 2172 locus old_loc; 2173 2174 gfc_save_backend_locus (&old_loc); 2175 push_cfun (NULL); 2176 2177 gfc_create_function_decl (gsym->ns, true); 2178 2179 pop_cfun (); 2180 gfc_restore_backend_locus (&old_loc); 2181 } 2182 2183 /* If the namespace has entries, the proc_name is the 2184 entry master. Find the entry and use its backend_decl. 2185 otherwise, use the proc_name backend_decl. */ 2186 if (gsym->ns->entries) 2187 { 2188 gfc_entry_list *entry = gsym->ns->entries; 2189 2190 for (; entry; entry = entry->next) 2191 { 2192 if (strcmp (gsym->name, entry->sym->name) == 0) 2193 { 2194 sym->backend_decl = entry->sym->backend_decl; 2195 break; 2196 } 2197 } 2198 } 2199 else 2200 sym->backend_decl = gsym->ns->proc_name->backend_decl; 2201 2202 if (sym->backend_decl) 2203 { 2204 /* Avoid problems of double deallocation of the backend declaration 2205 later in gfc_trans_use_stmts; cf. PR 45087. */ 2206 if (sym->attr.if_source != IFSRC_DECL && sym->attr.use_assoc) 2207 sym->attr.use_assoc = 0; 2208 2209 return sym->backend_decl; 2210 } 2211 } 2212 2213 /* See if this is a module procedure from the same file. If so, 2214 return the backend_decl. */ 2215 if (sym->module) 2216 gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); 2217 2218 module_sym: 2219 if (gsym && gsym->ns 2220 && (gsym->type == GSYM_MODULE 2221 || (gsym->ns->proc_name && gsym->ns->proc_name->attr.flavor == FL_MODULE))) 2222 { 2223 gfc_symbol *s; 2224 2225 s = NULL; 2226 if (gsym->type == GSYM_MODULE) 2227 gfc_find_symbol (sym->name, gsym->ns, 0, &s); 2228 else 2229 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &s); 2230 2231 if (s && s->backend_decl) 2232 { 2233 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 2234 gfc_copy_dt_decls_ifequal (s->ts.u.derived, sym->ts.u.derived, 2235 true); 2236 else if (sym->ts.type == BT_CHARACTER) 2237 sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl; 2238 sym->backend_decl = s->backend_decl; 2239 return sym->backend_decl; 2240 } 2241 } 2242 2243 if (sym->attr.intrinsic) 2244 { 2245 /* Call the resolution function to get the actual name. This is 2246 a nasty hack which relies on the resolution functions only looking 2247 at the first argument. We pass NULL for the second argument 2248 otherwise things like AINT get confused. */ 2249 isym = gfc_find_function (sym->name); 2250 gcc_assert (isym->resolve.f0 != NULL); 2251 2252 memset (&e, 0, sizeof (e)); 2253 e.expr_type = EXPR_FUNCTION; 2254 2255 memset (&argexpr, 0, sizeof (argexpr)); 2256 gcc_assert (isym->formal); 2257 argexpr.ts = isym->formal->ts; 2258 2259 if (isym->formal->next == NULL) 2260 isym->resolve.f1 (&e, &argexpr); 2261 else 2262 { 2263 if (isym->formal->next->next == NULL) 2264 isym->resolve.f2 (&e, &argexpr, NULL); 2265 else 2266 { 2267 if (isym->formal->next->next->next == NULL) 2268 isym->resolve.f3 (&e, &argexpr, NULL, NULL); 2269 else 2270 { 2271 /* All specific intrinsics take less than 5 arguments. */ 2272 gcc_assert (isym->formal->next->next->next->next == NULL); 2273 isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL); 2274 } 2275 } 2276 } 2277 2278 if (flag_f2c 2279 && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind) 2280 || e.ts.type == BT_COMPLEX)) 2281 { 2282 /* Specific which needs a different implementation if f2c 2283 calling conventions are used. */ 2284 sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name); 2285 } 2286 else 2287 sprintf (s, "_gfortran_specific%s", e.value.function.name); 2288 2289 name = get_identifier (s); 2290 mangled_name = name; 2291 } 2292 else 2293 { 2294 name = gfc_sym_identifier (sym); 2295 mangled_name = gfc_sym_mangled_function_id (sym); 2296 } 2297 2298 type = gfc_get_function_type (sym, actual_args, fnspec); 2299 2300 fndecl = build_decl (input_location, 2301 FUNCTION_DECL, name, type); 2302 2303 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; 2304 TREE_PUBLIC specifies whether a function is globally addressable (i.e. 2305 the opposite of declaring a function as static in C). */ 2306 DECL_EXTERNAL (fndecl) = 1; 2307 TREE_PUBLIC (fndecl) = 1; 2308 2309 attributes = add_attributes_to_decl (sym->attr, NULL_TREE); 2310 decl_attributes (&fndecl, attributes, 0); 2311 2312 gfc_set_decl_assembler_name (fndecl, mangled_name); 2313 2314 /* Set the context of this decl. */ 2315 if (0 && sym->ns && sym->ns->proc_name) 2316 { 2317 /* TODO: Add external decls to the appropriate scope. */ 2318 DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl; 2319 } 2320 else 2321 { 2322 /* Global declaration, e.g. intrinsic subroutine. */ 2323 DECL_CONTEXT (fndecl) = NULL_TREE; 2324 } 2325 2326 /* Set attributes for PURE functions. A call to PURE function in the 2327 Fortran 95 sense is both pure and without side effects in the C 2328 sense. */ 2329 if (sym->attr.pure || sym->attr.implicit_pure) 2330 { 2331 if (sym->attr.function && !gfc_return_by_reference (sym)) 2332 DECL_PURE_P (fndecl) = 1; 2333 /* TODO: check if pure SUBROUTINEs don't have INTENT(OUT) 2334 parameters and don't use alternate returns (is this 2335 allowed?). In that case, calls to them are meaningless, and 2336 can be optimized away. See also in build_function_decl(). */ 2337 TREE_SIDE_EFFECTS (fndecl) = 0; 2338 } 2339 2340 /* Mark non-returning functions. */ 2341 if (sym->attr.noreturn) 2342 TREE_THIS_VOLATILE(fndecl) = 1; 2343 2344 sym->backend_decl = fndecl; 2345 2346 if (DECL_CONTEXT (fndecl) == NULL_TREE) 2347 pushdecl_top_level (fndecl); 2348 2349 if (sym->formal_ns 2350 && sym->formal_ns->proc_name == sym) 2351 { 2352 if (sym->formal_ns->omp_declare_simd) 2353 gfc_trans_omp_declare_simd (sym->formal_ns); 2354 if (flag_openmp) 2355 gfc_trans_omp_declare_variant (sym->formal_ns); 2356 } 2357 2358 return fndecl; 2359 } 2360 2361 2362 /* Create a declaration for a procedure. For external functions (in the C 2363 sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is 2364 a master function with alternate entry points. */ 2365 2366 static void 2367 build_function_decl (gfc_symbol * sym, bool global) 2368 { 2369 tree fndecl, type, attributes; 2370 symbol_attribute attr; 2371 tree result_decl; 2372 gfc_formal_arglist *f; 2373 2374 bool module_procedure = sym->attr.module_procedure 2375 && sym->ns 2376 && sym->ns->proc_name 2377 && sym->ns->proc_name->attr.flavor == FL_MODULE; 2378 2379 gcc_assert (!sym->attr.external || module_procedure); 2380 2381 if (sym->backend_decl) 2382 return; 2383 2384 /* Set the line and filename. sym->declared_at seems to point to the 2385 last statement for subroutines, but it'll do for now. */ 2386 gfc_set_backend_locus (&sym->declared_at); 2387 2388 /* Allow only one nesting level. Allow public declarations. */ 2389 gcc_assert (current_function_decl == NULL_TREE 2390 || DECL_FILE_SCOPE_P (current_function_decl) 2391 || (TREE_CODE (DECL_CONTEXT (current_function_decl)) 2392 == NAMESPACE_DECL)); 2393 2394 type = gfc_get_function_type (sym); 2395 fndecl = build_decl (input_location, 2396 FUNCTION_DECL, gfc_sym_identifier (sym), type); 2397 2398 attr = sym->attr; 2399 2400 /* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes; 2401 TREE_PUBLIC specifies whether a function is globally addressable (i.e. 2402 the opposite of declaring a function as static in C). */ 2403 DECL_EXTERNAL (fndecl) = 0; 2404 2405 if (sym->attr.access == ACCESS_UNKNOWN && sym->module 2406 && (sym->ns->default_access == ACCESS_PRIVATE 2407 || (sym->ns->default_access == ACCESS_UNKNOWN 2408 && flag_module_private))) 2409 sym->attr.access = ACCESS_PRIVATE; 2410 2411 if (!current_function_decl 2412 && !sym->attr.entry_master && !sym->attr.is_main_program 2413 && (sym->attr.access != ACCESS_PRIVATE || sym->binding_label 2414 || sym->attr.public_used)) 2415 TREE_PUBLIC (fndecl) = 1; 2416 2417 if (sym->attr.referenced || sym->attr.entry_master) 2418 TREE_USED (fndecl) = 1; 2419 2420 attributes = add_attributes_to_decl (attr, NULL_TREE); 2421 decl_attributes (&fndecl, attributes, 0); 2422 2423 /* Figure out the return type of the declared function, and build a 2424 RESULT_DECL for it. If this is a subroutine with alternate 2425 returns, build a RESULT_DECL for it. */ 2426 result_decl = NULL_TREE; 2427 /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */ 2428 if (attr.function) 2429 { 2430 if (gfc_return_by_reference (sym)) 2431 type = void_type_node; 2432 else 2433 { 2434 if (sym->result != sym) 2435 result_decl = gfc_sym_identifier (sym->result); 2436 2437 type = TREE_TYPE (TREE_TYPE (fndecl)); 2438 } 2439 } 2440 else 2441 { 2442 /* Look for alternate return placeholders. */ 2443 int has_alternate_returns = 0; 2444 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2445 { 2446 if (f->sym == NULL) 2447 { 2448 has_alternate_returns = 1; 2449 break; 2450 } 2451 } 2452 2453 if (has_alternate_returns) 2454 type = integer_type_node; 2455 else 2456 type = void_type_node; 2457 } 2458 2459 result_decl = build_decl (input_location, 2460 RESULT_DECL, result_decl, type); 2461 DECL_ARTIFICIAL (result_decl) = 1; 2462 DECL_IGNORED_P (result_decl) = 1; 2463 DECL_CONTEXT (result_decl) = fndecl; 2464 DECL_RESULT (fndecl) = result_decl; 2465 2466 /* Don't call layout_decl for a RESULT_DECL. 2467 layout_decl (result_decl, 0); */ 2468 2469 /* TREE_STATIC means the function body is defined here. */ 2470 TREE_STATIC (fndecl) = 1; 2471 2472 /* Set attributes for PURE functions. A call to a PURE function in the 2473 Fortran 95 sense is both pure and without side effects in the C 2474 sense. */ 2475 if (attr.pure || attr.implicit_pure) 2476 { 2477 /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments 2478 including an alternate return. In that case it can also be 2479 marked as PURE. See also in gfc_get_extern_function_decl(). */ 2480 if (attr.function && !gfc_return_by_reference (sym)) 2481 DECL_PURE_P (fndecl) = 1; 2482 TREE_SIDE_EFFECTS (fndecl) = 0; 2483 } 2484 2485 2486 /* Layout the function declaration and put it in the binding level 2487 of the current function. */ 2488 2489 if (global) 2490 pushdecl_top_level (fndecl); 2491 else 2492 pushdecl (fndecl); 2493 2494 /* Perform name mangling if this is a top level or module procedure. */ 2495 if (current_function_decl == NULL_TREE) 2496 gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym)); 2497 2498 sym->backend_decl = fndecl; 2499 } 2500 2501 2502 /* Create the DECL_ARGUMENTS for a procedure. 2503 NOTE: The arguments added here must match the argument type created by 2504 gfc_get_function_type (). */ 2505 2506 static void 2507 create_function_arglist (gfc_symbol * sym) 2508 { 2509 tree fndecl; 2510 gfc_formal_arglist *f; 2511 tree typelist, hidden_typelist; 2512 tree arglist, hidden_arglist; 2513 tree type; 2514 tree parm; 2515 2516 fndecl = sym->backend_decl; 2517 2518 /* Build formal argument list. Make sure that their TREE_CONTEXT is 2519 the new FUNCTION_DECL node. */ 2520 arglist = NULL_TREE; 2521 hidden_arglist = NULL_TREE; 2522 typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl)); 2523 2524 if (sym->attr.entry_master) 2525 { 2526 type = TREE_VALUE (typelist); 2527 parm = build_decl (input_location, 2528 PARM_DECL, get_identifier ("__entry"), type); 2529 2530 DECL_CONTEXT (parm) = fndecl; 2531 DECL_ARG_TYPE (parm) = type; 2532 TREE_READONLY (parm) = 1; 2533 gfc_finish_decl (parm); 2534 DECL_ARTIFICIAL (parm) = 1; 2535 2536 arglist = chainon (arglist, parm); 2537 typelist = TREE_CHAIN (typelist); 2538 } 2539 2540 if (gfc_return_by_reference (sym)) 2541 { 2542 tree type = TREE_VALUE (typelist), length = NULL; 2543 2544 if (sym->ts.type == BT_CHARACTER) 2545 { 2546 /* Length of character result. */ 2547 tree len_type = TREE_VALUE (TREE_CHAIN (typelist)); 2548 2549 length = build_decl (input_location, 2550 PARM_DECL, 2551 get_identifier (".__result"), 2552 len_type); 2553 if (POINTER_TYPE_P (len_type)) 2554 { 2555 sym->ts.u.cl->passed_length = length; 2556 TREE_USED (length) = 1; 2557 } 2558 else if (!sym->ts.u.cl->length) 2559 { 2560 sym->ts.u.cl->backend_decl = length; 2561 TREE_USED (length) = 1; 2562 } 2563 gcc_assert (TREE_CODE (length) == PARM_DECL); 2564 DECL_CONTEXT (length) = fndecl; 2565 DECL_ARG_TYPE (length) = len_type; 2566 TREE_READONLY (length) = 1; 2567 DECL_ARTIFICIAL (length) = 1; 2568 gfc_finish_decl (length); 2569 if (sym->ts.u.cl->backend_decl == NULL 2570 || sym->ts.u.cl->backend_decl == length) 2571 { 2572 gfc_symbol *arg; 2573 tree backend_decl; 2574 2575 if (sym->ts.u.cl->backend_decl == NULL) 2576 { 2577 tree len = build_decl (input_location, 2578 VAR_DECL, 2579 get_identifier ("..__result"), 2580 gfc_charlen_type_node); 2581 DECL_ARTIFICIAL (len) = 1; 2582 TREE_USED (len) = 1; 2583 sym->ts.u.cl->backend_decl = len; 2584 } 2585 2586 /* Make sure PARM_DECL type doesn't point to incomplete type. */ 2587 arg = sym->result ? sym->result : sym; 2588 backend_decl = arg->backend_decl; 2589 /* Temporary clear it, so that gfc_sym_type creates complete 2590 type. */ 2591 arg->backend_decl = NULL; 2592 type = gfc_sym_type (arg); 2593 arg->backend_decl = backend_decl; 2594 type = build_reference_type (type); 2595 } 2596 } 2597 2598 parm = build_decl (input_location, 2599 PARM_DECL, get_identifier ("__result"), type); 2600 2601 DECL_CONTEXT (parm) = fndecl; 2602 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); 2603 TREE_READONLY (parm) = 1; 2604 DECL_ARTIFICIAL (parm) = 1; 2605 gfc_finish_decl (parm); 2606 2607 arglist = chainon (arglist, parm); 2608 typelist = TREE_CHAIN (typelist); 2609 2610 if (sym->ts.type == BT_CHARACTER) 2611 { 2612 gfc_allocate_lang_decl (parm); 2613 arglist = chainon (arglist, length); 2614 typelist = TREE_CHAIN (typelist); 2615 } 2616 } 2617 2618 hidden_typelist = typelist; 2619 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2620 if (f->sym != NULL) /* Ignore alternate returns. */ 2621 hidden_typelist = TREE_CHAIN (hidden_typelist); 2622 2623 for (f = gfc_sym_get_dummy_args (sym); f; f = f->next) 2624 { 2625 char name[GFC_MAX_SYMBOL_LEN + 2]; 2626 2627 /* Ignore alternate returns. */ 2628 if (f->sym == NULL) 2629 continue; 2630 2631 type = TREE_VALUE (typelist); 2632 2633 if (f->sym->ts.type == BT_CHARACTER 2634 && (!sym->attr.is_bind_c || sym->attr.entry_master)) 2635 { 2636 tree len_type = TREE_VALUE (hidden_typelist); 2637 tree length = NULL_TREE; 2638 if (!f->sym->ts.deferred) 2639 gcc_assert (len_type == gfc_charlen_type_node); 2640 else 2641 gcc_assert (POINTER_TYPE_P (len_type)); 2642 2643 strcpy (&name[1], f->sym->name); 2644 name[0] = '_'; 2645 length = build_decl (input_location, 2646 PARM_DECL, get_identifier (name), len_type); 2647 2648 hidden_arglist = chainon (hidden_arglist, length); 2649 DECL_CONTEXT (length) = fndecl; 2650 DECL_ARTIFICIAL (length) = 1; 2651 DECL_ARG_TYPE (length) = len_type; 2652 TREE_READONLY (length) = 1; 2653 gfc_finish_decl (length); 2654 2655 /* Marking the length DECL_HIDDEN_STRING_LENGTH will lead 2656 to tail calls being disabled. Only do that if we 2657 potentially have broken callers. */ 2658 if (flag_tail_call_workaround 2659 && f->sym->ts.u.cl 2660 && f->sym->ts.u.cl->length 2661 && f->sym->ts.u.cl->length->expr_type == EXPR_CONSTANT 2662 && (flag_tail_call_workaround == 2 2663 || f->sym->ns->implicit_interface_calls)) 2664 DECL_HIDDEN_STRING_LENGTH (length) = 1; 2665 2666 /* Remember the passed value. */ 2667 if (!f->sym->ts.u.cl || f->sym->ts.u.cl->passed_length) 2668 { 2669 /* This can happen if the same type is used for multiple 2670 arguments. We need to copy cl as otherwise 2671 cl->passed_length gets overwritten. */ 2672 f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl); 2673 } 2674 f->sym->ts.u.cl->passed_length = length; 2675 2676 /* Use the passed value for assumed length variables. */ 2677 if (!f->sym->ts.u.cl->length) 2678 { 2679 TREE_USED (length) = 1; 2680 gcc_assert (!f->sym->ts.u.cl->backend_decl); 2681 f->sym->ts.u.cl->backend_decl = length; 2682 } 2683 2684 hidden_typelist = TREE_CHAIN (hidden_typelist); 2685 2686 if (f->sym->ts.u.cl->backend_decl == NULL 2687 || f->sym->ts.u.cl->backend_decl == length) 2688 { 2689 if (POINTER_TYPE_P (len_type)) 2690 f->sym->ts.u.cl->backend_decl 2691 = build_fold_indirect_ref_loc (input_location, length); 2692 else if (f->sym->ts.u.cl->backend_decl == NULL) 2693 gfc_create_string_length (f->sym); 2694 2695 /* Make sure PARM_DECL type doesn't point to incomplete type. */ 2696 if (f->sym->attr.flavor == FL_PROCEDURE) 2697 type = build_pointer_type (gfc_get_function_type (f->sym)); 2698 else 2699 type = gfc_sym_type (f->sym); 2700 } 2701 } 2702 /* For noncharacter scalar intrinsic types, VALUE passes the value, 2703 hence, the optional status cannot be transferred via a NULL pointer. 2704 Thus, we will use a hidden argument in that case. */ 2705 else if (f->sym->attr.optional && f->sym->attr.value 2706 && !f->sym->attr.dimension && f->sym->ts.type != BT_CLASS 2707 && !gfc_bt_struct (f->sym->ts.type)) 2708 { 2709 tree tmp; 2710 strcpy (&name[1], f->sym->name); 2711 name[0] = '_'; 2712 tmp = build_decl (input_location, 2713 PARM_DECL, get_identifier (name), 2714 boolean_type_node); 2715 2716 hidden_arglist = chainon (hidden_arglist, tmp); 2717 DECL_CONTEXT (tmp) = fndecl; 2718 DECL_ARTIFICIAL (tmp) = 1; 2719 DECL_ARG_TYPE (tmp) = boolean_type_node; 2720 TREE_READONLY (tmp) = 1; 2721 gfc_finish_decl (tmp); 2722 2723 hidden_typelist = TREE_CHAIN (hidden_typelist); 2724 } 2725 2726 /* For non-constant length array arguments, make sure they use 2727 a different type node from TYPE_ARG_TYPES type. */ 2728 if (f->sym->attr.dimension 2729 && type == TREE_VALUE (typelist) 2730 && TREE_CODE (type) == POINTER_TYPE 2731 && GFC_ARRAY_TYPE_P (type) 2732 && f->sym->as->type != AS_ASSUMED_SIZE 2733 && ! COMPLETE_TYPE_P (TREE_TYPE (type))) 2734 { 2735 if (f->sym->attr.flavor == FL_PROCEDURE) 2736 type = build_pointer_type (gfc_get_function_type (f->sym)); 2737 else 2738 type = gfc_sym_type (f->sym); 2739 } 2740 2741 if (f->sym->attr.proc_pointer) 2742 type = build_pointer_type (type); 2743 2744 if (f->sym->attr.volatile_) 2745 type = build_qualified_type (type, TYPE_QUAL_VOLATILE); 2746 2747 /* Build the argument declaration. For C descriptors, we use a 2748 '_'-prefixed name for the parm_decl and inside the proc the 2749 sym->name. */ 2750 tree parm_name; 2751 if (sym->attr.is_bind_c && is_CFI_desc (f->sym, NULL)) 2752 { 2753 strcpy (&name[1], f->sym->name); 2754 name[0] = '_'; 2755 parm_name = get_identifier (name); 2756 } 2757 else 2758 parm_name = gfc_sym_identifier (f->sym); 2759 parm = build_decl (input_location, PARM_DECL, parm_name, type); 2760 2761 if (f->sym->attr.volatile_) 2762 { 2763 TREE_THIS_VOLATILE (parm) = 1; 2764 TREE_SIDE_EFFECTS (parm) = 1; 2765 } 2766 2767 /* Fill in arg stuff. */ 2768 DECL_CONTEXT (parm) = fndecl; 2769 DECL_ARG_TYPE (parm) = TREE_VALUE (typelist); 2770 /* All implementation args except for VALUE are read-only. */ 2771 if (!f->sym->attr.value) 2772 TREE_READONLY (parm) = 1; 2773 if (POINTER_TYPE_P (type) 2774 && (!f->sym->attr.proc_pointer 2775 && f->sym->attr.flavor != FL_PROCEDURE)) 2776 DECL_BY_REFERENCE (parm) = 1; 2777 if (f->sym->attr.optional) 2778 { 2779 gfc_allocate_lang_decl (parm); 2780 GFC_DECL_OPTIONAL_ARGUMENT (parm) = 1; 2781 } 2782 2783 gfc_finish_decl (parm); 2784 gfc_finish_decl_attrs (parm, &f->sym->attr); 2785 2786 f->sym->backend_decl = parm; 2787 2788 /* Coarrays which are descriptorless or assumed-shape pass with 2789 -fcoarray=lib the token and the offset as hidden arguments. */ 2790 if (flag_coarray == GFC_FCOARRAY_LIB 2791 && ((f->sym->ts.type != BT_CLASS && f->sym->attr.codimension 2792 && !f->sym->attr.allocatable) 2793 || (f->sym->ts.type == BT_CLASS 2794 && CLASS_DATA (f->sym)->attr.codimension 2795 && !CLASS_DATA (f->sym)->attr.allocatable))) 2796 { 2797 tree caf_type; 2798 tree token; 2799 tree offset; 2800 2801 gcc_assert (f->sym->backend_decl != NULL_TREE 2802 && !sym->attr.is_bind_c); 2803 caf_type = f->sym->ts.type == BT_CLASS 2804 ? TREE_TYPE (CLASS_DATA (f->sym)->backend_decl) 2805 : TREE_TYPE (f->sym->backend_decl); 2806 2807 token = build_decl (input_location, PARM_DECL, 2808 create_tmp_var_name ("caf_token"), 2809 build_qualified_type (pvoid_type_node, 2810 TYPE_QUAL_RESTRICT)); 2811 if ((f->sym->ts.type != BT_CLASS 2812 && f->sym->as->type != AS_DEFERRED) 2813 || (f->sym->ts.type == BT_CLASS 2814 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) 2815 { 2816 gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL 2817 || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE); 2818 if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL) 2819 gfc_allocate_lang_decl (f->sym->backend_decl); 2820 GFC_DECL_TOKEN (f->sym->backend_decl) = token; 2821 } 2822 else 2823 { 2824 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE); 2825 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token; 2826 } 2827 2828 DECL_CONTEXT (token) = fndecl; 2829 DECL_ARTIFICIAL (token) = 1; 2830 DECL_ARG_TYPE (token) = TREE_VALUE (typelist); 2831 TREE_READONLY (token) = 1; 2832 hidden_arglist = chainon (hidden_arglist, token); 2833 hidden_typelist = TREE_CHAIN (hidden_typelist); 2834 gfc_finish_decl (token); 2835 2836 offset = build_decl (input_location, PARM_DECL, 2837 create_tmp_var_name ("caf_offset"), 2838 gfc_array_index_type); 2839 2840 if ((f->sym->ts.type != BT_CLASS 2841 && f->sym->as->type != AS_DEFERRED) 2842 || (f->sym->ts.type == BT_CLASS 2843 && CLASS_DATA (f->sym)->as->type != AS_DEFERRED)) 2844 { 2845 gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl) 2846 == NULL_TREE); 2847 GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset; 2848 } 2849 else 2850 { 2851 gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE); 2852 GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset; 2853 } 2854 DECL_CONTEXT (offset) = fndecl; 2855 DECL_ARTIFICIAL (offset) = 1; 2856 DECL_ARG_TYPE (offset) = TREE_VALUE (typelist); 2857 TREE_READONLY (offset) = 1; 2858 hidden_arglist = chainon (hidden_arglist, offset); 2859 hidden_typelist = TREE_CHAIN (hidden_typelist); 2860 gfc_finish_decl (offset); 2861 } 2862 2863 arglist = chainon (arglist, parm); 2864 typelist = TREE_CHAIN (typelist); 2865 } 2866 2867 /* Add the hidden string length parameters, unless the procedure 2868 is bind(C). */ 2869 if (!sym->attr.is_bind_c) 2870 arglist = chainon (arglist, hidden_arglist); 2871 2872 gcc_assert (hidden_typelist == NULL_TREE 2873 || TREE_VALUE (hidden_typelist) == void_type_node); 2874 DECL_ARGUMENTS (fndecl) = arglist; 2875 } 2876 2877 /* Do the setup necessary before generating the body of a function. */ 2878 2879 static void 2880 trans_function_start (gfc_symbol * sym) 2881 { 2882 tree fndecl; 2883 2884 fndecl = sym->backend_decl; 2885 2886 /* Let GCC know the current scope is this function. */ 2887 current_function_decl = fndecl; 2888 2889 /* Let the world know what we're about to do. */ 2890 announce_function (fndecl); 2891 2892 if (DECL_FILE_SCOPE_P (fndecl)) 2893 { 2894 /* Create RTL for function declaration. */ 2895 rest_of_decl_compilation (fndecl, 1, 0); 2896 } 2897 2898 /* Create RTL for function definition. */ 2899 make_decl_rtl (fndecl); 2900 2901 allocate_struct_function (fndecl, false); 2902 2903 /* function.cc requires a push at the start of the function. */ 2904 pushlevel (); 2905 } 2906 2907 /* Create thunks for alternate entry points. */ 2908 2909 static void 2910 build_entry_thunks (gfc_namespace * ns, bool global) 2911 { 2912 gfc_formal_arglist *formal; 2913 gfc_formal_arglist *thunk_formal; 2914 gfc_entry_list *el; 2915 gfc_symbol *thunk_sym; 2916 stmtblock_t body; 2917 tree thunk_fndecl; 2918 tree tmp; 2919 locus old_loc; 2920 2921 /* This should always be a toplevel function. */ 2922 gcc_assert (current_function_decl == NULL_TREE); 2923 2924 gfc_save_backend_locus (&old_loc); 2925 for (el = ns->entries; el; el = el->next) 2926 { 2927 vec<tree, va_gc> *args = NULL; 2928 vec<tree, va_gc> *string_args = NULL; 2929 2930 thunk_sym = el->sym; 2931 2932 build_function_decl (thunk_sym, global); 2933 create_function_arglist (thunk_sym); 2934 2935 trans_function_start (thunk_sym); 2936 2937 thunk_fndecl = thunk_sym->backend_decl; 2938 2939 gfc_init_block (&body); 2940 2941 /* Pass extra parameter identifying this entry point. */ 2942 tmp = build_int_cst (gfc_array_index_type, el->id); 2943 vec_safe_push (args, tmp); 2944 2945 if (thunk_sym->attr.function) 2946 { 2947 if (gfc_return_by_reference (ns->proc_name)) 2948 { 2949 tree ref = DECL_ARGUMENTS (current_function_decl); 2950 vec_safe_push (args, ref); 2951 if (ns->proc_name->ts.type == BT_CHARACTER) 2952 vec_safe_push (args, DECL_CHAIN (ref)); 2953 } 2954 } 2955 2956 for (formal = gfc_sym_get_dummy_args (ns->proc_name); formal; 2957 formal = formal->next) 2958 { 2959 /* Ignore alternate returns. */ 2960 if (formal->sym == NULL) 2961 continue; 2962 2963 /* We don't have a clever way of identifying arguments, so resort to 2964 a brute-force search. */ 2965 for (thunk_formal = gfc_sym_get_dummy_args (thunk_sym); 2966 thunk_formal; 2967 thunk_formal = thunk_formal->next) 2968 { 2969 if (thunk_formal->sym == formal->sym) 2970 break; 2971 } 2972 2973 if (thunk_formal) 2974 { 2975 /* Pass the argument. */ 2976 DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1; 2977 vec_safe_push (args, thunk_formal->sym->backend_decl); 2978 if (formal->sym->ts.type == BT_CHARACTER) 2979 { 2980 tmp = thunk_formal->sym->ts.u.cl->backend_decl; 2981 vec_safe_push (string_args, tmp); 2982 } 2983 } 2984 else 2985 { 2986 /* Pass NULL for a missing argument. */ 2987 vec_safe_push (args, null_pointer_node); 2988 if (formal->sym->ts.type == BT_CHARACTER) 2989 { 2990 tmp = build_int_cst (gfc_charlen_type_node, 0); 2991 vec_safe_push (string_args, tmp); 2992 } 2993 } 2994 } 2995 2996 /* Call the master function. */ 2997 vec_safe_splice (args, string_args); 2998 tmp = ns->proc_name->backend_decl; 2999 tmp = build_call_expr_loc_vec (input_location, tmp, args); 3000 if (ns->proc_name->attr.mixed_entry_master) 3001 { 3002 tree union_decl, field; 3003 tree master_type = TREE_TYPE (ns->proc_name->backend_decl); 3004 3005 union_decl = build_decl (input_location, 3006 VAR_DECL, get_identifier ("__result"), 3007 TREE_TYPE (master_type)); 3008 DECL_ARTIFICIAL (union_decl) = 1; 3009 DECL_EXTERNAL (union_decl) = 0; 3010 TREE_PUBLIC (union_decl) = 0; 3011 TREE_USED (union_decl) = 1; 3012 layout_decl (union_decl, 0); 3013 pushdecl (union_decl); 3014 3015 DECL_CONTEXT (union_decl) = current_function_decl; 3016 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 3017 TREE_TYPE (union_decl), union_decl, tmp); 3018 gfc_add_expr_to_block (&body, tmp); 3019 3020 for (field = TYPE_FIELDS (TREE_TYPE (union_decl)); 3021 field; field = DECL_CHAIN (field)) 3022 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), 3023 thunk_sym->result->name) == 0) 3024 break; 3025 gcc_assert (field != NULL_TREE); 3026 tmp = fold_build3_loc (input_location, COMPONENT_REF, 3027 TREE_TYPE (field), union_decl, field, 3028 NULL_TREE); 3029 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 3030 TREE_TYPE (DECL_RESULT (current_function_decl)), 3031 DECL_RESULT (current_function_decl), tmp); 3032 tmp = build1_v (RETURN_EXPR, tmp); 3033 } 3034 else if (TREE_TYPE (DECL_RESULT (current_function_decl)) 3035 != void_type_node) 3036 { 3037 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 3038 TREE_TYPE (DECL_RESULT (current_function_decl)), 3039 DECL_RESULT (current_function_decl), tmp); 3040 tmp = build1_v (RETURN_EXPR, tmp); 3041 } 3042 gfc_add_expr_to_block (&body, tmp); 3043 3044 /* Finish off this function and send it for code generation. */ 3045 DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body); 3046 tmp = getdecls (); 3047 poplevel (1, 1); 3048 BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl; 3049 DECL_SAVED_TREE (thunk_fndecl) 3050 = fold_build3_loc (DECL_SOURCE_LOCATION (thunk_fndecl), BIND_EXPR, 3051 void_type_node, tmp, DECL_SAVED_TREE (thunk_fndecl), 3052 DECL_INITIAL (thunk_fndecl)); 3053 3054 /* Output the GENERIC tree. */ 3055 dump_function (TDI_original, thunk_fndecl); 3056 3057 /* Store the end of the function, so that we get good line number 3058 info for the epilogue. */ 3059 cfun->function_end_locus = input_location; 3060 3061 /* We're leaving the context of this function, so zap cfun. 3062 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in 3063 tree_rest_of_compilation. */ 3064 set_cfun (NULL); 3065 3066 current_function_decl = NULL_TREE; 3067 3068 cgraph_node::finalize_function (thunk_fndecl, true); 3069 3070 /* We share the symbols in the formal argument list with other entry 3071 points and the master function. Clear them so that they are 3072 recreated for each function. */ 3073 for (formal = gfc_sym_get_dummy_args (thunk_sym); formal; 3074 formal = formal->next) 3075 if (formal->sym != NULL) /* Ignore alternate returns. */ 3076 { 3077 formal->sym->backend_decl = NULL_TREE; 3078 if (formal->sym->ts.type == BT_CHARACTER) 3079 formal->sym->ts.u.cl->backend_decl = NULL_TREE; 3080 } 3081 3082 if (thunk_sym->attr.function) 3083 { 3084 if (thunk_sym->ts.type == BT_CHARACTER) 3085 thunk_sym->ts.u.cl->backend_decl = NULL_TREE; 3086 if (thunk_sym->result->ts.type == BT_CHARACTER) 3087 thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE; 3088 } 3089 } 3090 3091 gfc_restore_backend_locus (&old_loc); 3092 } 3093 3094 3095 /* Create a decl for a function, and create any thunks for alternate entry 3096 points. If global is true, generate the function in the global binding 3097 level, otherwise in the current binding level (which can be global). */ 3098 3099 void 3100 gfc_create_function_decl (gfc_namespace * ns, bool global) 3101 { 3102 /* Create a declaration for the master function. */ 3103 build_function_decl (ns->proc_name, global); 3104 3105 /* Compile the entry thunks. */ 3106 if (ns->entries) 3107 build_entry_thunks (ns, global); 3108 3109 /* Now create the read argument list. */ 3110 create_function_arglist (ns->proc_name); 3111 3112 if (ns->omp_declare_simd) 3113 gfc_trans_omp_declare_simd (ns); 3114 3115 /* Handle 'declare variant' directives. The applicable directives might 3116 be declared in a parent namespace, so this needs to be called even if 3117 there are no local directives. */ 3118 if (flag_openmp) 3119 gfc_trans_omp_declare_variant (ns); 3120 } 3121 3122 /* Return the decl used to hold the function return value. If 3123 parent_flag is set, the context is the parent_scope. */ 3124 3125 tree 3126 gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag) 3127 { 3128 tree decl; 3129 tree length; 3130 tree this_fake_result_decl; 3131 tree this_function_decl; 3132 3133 char name[GFC_MAX_SYMBOL_LEN + 10]; 3134 3135 if (parent_flag) 3136 { 3137 this_fake_result_decl = parent_fake_result_decl; 3138 this_function_decl = DECL_CONTEXT (current_function_decl); 3139 } 3140 else 3141 { 3142 this_fake_result_decl = current_fake_result_decl; 3143 this_function_decl = current_function_decl; 3144 } 3145 3146 if (sym 3147 && sym->ns->proc_name->backend_decl == this_function_decl 3148 && sym->ns->proc_name->attr.entry_master 3149 && sym != sym->ns->proc_name) 3150 { 3151 tree t = NULL, var; 3152 if (this_fake_result_decl != NULL) 3153 for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t)) 3154 if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0) 3155 break; 3156 if (t) 3157 return TREE_VALUE (t); 3158 decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag); 3159 3160 if (parent_flag) 3161 this_fake_result_decl = parent_fake_result_decl; 3162 else 3163 this_fake_result_decl = current_fake_result_decl; 3164 3165 if (decl && sym->ns->proc_name->attr.mixed_entry_master) 3166 { 3167 tree field; 3168 3169 for (field = TYPE_FIELDS (TREE_TYPE (decl)); 3170 field; field = DECL_CHAIN (field)) 3171 if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)), 3172 sym->name) == 0) 3173 break; 3174 3175 gcc_assert (field != NULL_TREE); 3176 decl = fold_build3_loc (input_location, COMPONENT_REF, 3177 TREE_TYPE (field), decl, field, NULL_TREE); 3178 } 3179 3180 var = create_tmp_var_raw (TREE_TYPE (decl), sym->name); 3181 if (parent_flag) 3182 gfc_add_decl_to_parent_function (var); 3183 else 3184 gfc_add_decl_to_function (var); 3185 3186 SET_DECL_VALUE_EXPR (var, decl); 3187 DECL_HAS_VALUE_EXPR_P (var) = 1; 3188 GFC_DECL_RESULT (var) = 1; 3189 3190 TREE_CHAIN (this_fake_result_decl) 3191 = tree_cons (get_identifier (sym->name), var, 3192 TREE_CHAIN (this_fake_result_decl)); 3193 return var; 3194 } 3195 3196 if (this_fake_result_decl != NULL_TREE) 3197 return TREE_VALUE (this_fake_result_decl); 3198 3199 /* Only when gfc_get_fake_result_decl is called by gfc_trans_return, 3200 sym is NULL. */ 3201 if (!sym) 3202 return NULL_TREE; 3203 3204 if (sym->ts.type == BT_CHARACTER) 3205 { 3206 if (sym->ts.u.cl->backend_decl == NULL_TREE) 3207 length = gfc_create_string_length (sym); 3208 else 3209 length = sym->ts.u.cl->backend_decl; 3210 if (VAR_P (length) && DECL_CONTEXT (length) == NULL_TREE) 3211 gfc_add_decl_to_function (length); 3212 } 3213 3214 if (gfc_return_by_reference (sym)) 3215 { 3216 decl = DECL_ARGUMENTS (this_function_decl); 3217 3218 if (sym->ns->proc_name->backend_decl == this_function_decl 3219 && sym->ns->proc_name->attr.entry_master) 3220 decl = DECL_CHAIN (decl); 3221 3222 TREE_USED (decl) = 1; 3223 if (sym->as) 3224 decl = gfc_build_dummy_array_decl (sym, decl); 3225 } 3226 else 3227 { 3228 sprintf (name, "__result_%.20s", 3229 IDENTIFIER_POINTER (DECL_NAME (this_function_decl))); 3230 3231 if (!sym->attr.mixed_entry_master && sym->attr.function) 3232 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), 3233 VAR_DECL, get_identifier (name), 3234 gfc_sym_type (sym)); 3235 else 3236 decl = build_decl (DECL_SOURCE_LOCATION (this_function_decl), 3237 VAR_DECL, get_identifier (name), 3238 TREE_TYPE (TREE_TYPE (this_function_decl))); 3239 DECL_ARTIFICIAL (decl) = 1; 3240 DECL_EXTERNAL (decl) = 0; 3241 TREE_PUBLIC (decl) = 0; 3242 TREE_USED (decl) = 1; 3243 GFC_DECL_RESULT (decl) = 1; 3244 TREE_ADDRESSABLE (decl) = 1; 3245 3246 layout_decl (decl, 0); 3247 gfc_finish_decl_attrs (decl, &sym->attr); 3248 3249 if (parent_flag) 3250 gfc_add_decl_to_parent_function (decl); 3251 else 3252 gfc_add_decl_to_function (decl); 3253 } 3254 3255 if (parent_flag) 3256 parent_fake_result_decl = build_tree_list (NULL, decl); 3257 else 3258 current_fake_result_decl = build_tree_list (NULL, decl); 3259 3260 if (sym->attr.assign) 3261 DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl); 3262 3263 return decl; 3264 } 3265 3266 3267 /* Builds a function decl. The remaining parameters are the types of the 3268 function arguments. Negative nargs indicates a varargs function. */ 3269 3270 static tree 3271 build_library_function_decl_1 (tree name, const char *spec, 3272 tree rettype, int nargs, va_list p) 3273 { 3274 vec<tree, va_gc> *arglist; 3275 tree fntype; 3276 tree fndecl; 3277 int n; 3278 3279 /* Library functions must be declared with global scope. */ 3280 gcc_assert (current_function_decl == NULL_TREE); 3281 3282 /* Create a list of the argument types. */ 3283 vec_alloc (arglist, abs (nargs)); 3284 for (n = abs (nargs); n > 0; n--) 3285 { 3286 tree argtype = va_arg (p, tree); 3287 arglist->quick_push (argtype); 3288 } 3289 3290 /* Build the function type and decl. */ 3291 if (nargs >= 0) 3292 fntype = build_function_type_vec (rettype, arglist); 3293 else 3294 fntype = build_varargs_function_type_vec (rettype, arglist); 3295 if (spec) 3296 { 3297 tree attr_args = build_tree_list (NULL_TREE, 3298 build_string (strlen (spec), spec)); 3299 tree attrs = tree_cons (get_identifier ("fn spec"), 3300 attr_args, TYPE_ATTRIBUTES (fntype)); 3301 fntype = build_type_attribute_variant (fntype, attrs); 3302 } 3303 fndecl = build_decl (input_location, 3304 FUNCTION_DECL, name, fntype); 3305 3306 /* Mark this decl as external. */ 3307 DECL_EXTERNAL (fndecl) = 1; 3308 TREE_PUBLIC (fndecl) = 1; 3309 3310 pushdecl (fndecl); 3311 3312 rest_of_decl_compilation (fndecl, 1, 0); 3313 3314 return fndecl; 3315 } 3316 3317 /* Builds a function decl. The remaining parameters are the types of the 3318 function arguments. Negative nargs indicates a varargs function. */ 3319 3320 tree 3321 gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...) 3322 { 3323 tree ret; 3324 va_list args; 3325 va_start (args, nargs); 3326 ret = build_library_function_decl_1 (name, NULL, rettype, nargs, args); 3327 va_end (args); 3328 return ret; 3329 } 3330 3331 /* Builds a function decl. The remaining parameters are the types of the 3332 function arguments. Negative nargs indicates a varargs function. 3333 The SPEC parameter specifies the function argument and return type 3334 specification according to the fnspec function type attribute. */ 3335 3336 tree 3337 gfc_build_library_function_decl_with_spec (tree name, const char *spec, 3338 tree rettype, int nargs, ...) 3339 { 3340 tree ret; 3341 va_list args; 3342 va_start (args, nargs); 3343 if (flag_checking) 3344 { 3345 attr_fnspec fnspec (spec, strlen (spec)); 3346 fnspec.verify (); 3347 } 3348 ret = build_library_function_decl_1 (name, spec, rettype, nargs, args); 3349 va_end (args); 3350 return ret; 3351 } 3352 3353 static void 3354 gfc_build_intrinsic_function_decls (void) 3355 { 3356 tree gfc_int4_type_node = gfc_get_int_type (4); 3357 tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node); 3358 tree gfc_int8_type_node = gfc_get_int_type (8); 3359 tree gfc_pint8_type_node = build_pointer_type (gfc_int8_type_node); 3360 tree gfc_int16_type_node = gfc_get_int_type (16); 3361 tree gfc_logical4_type_node = gfc_get_logical_type (4); 3362 tree pchar1_type_node = gfc_get_pchar_type (1); 3363 tree pchar4_type_node = gfc_get_pchar_type (4); 3364 3365 /* String functions. */ 3366 gfor_fndecl_compare_string = gfc_build_library_function_decl_with_spec ( 3367 get_identifier (PREFIX("compare_string")), ". . R . R ", 3368 integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node, 3369 gfc_charlen_type_node, pchar1_type_node); 3370 DECL_PURE_P (gfor_fndecl_compare_string) = 1; 3371 TREE_NOTHROW (gfor_fndecl_compare_string) = 1; 3372 3373 gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec ( 3374 get_identifier (PREFIX("concat_string")), ". . W . R . R ", 3375 void_type_node, 6, gfc_charlen_type_node, pchar1_type_node, 3376 gfc_charlen_type_node, pchar1_type_node, 3377 gfc_charlen_type_node, pchar1_type_node); 3378 TREE_NOTHROW (gfor_fndecl_concat_string) = 1; 3379 3380 gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec ( 3381 get_identifier (PREFIX("string_len_trim")), ". . R ", 3382 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node); 3383 DECL_PURE_P (gfor_fndecl_string_len_trim) = 1; 3384 TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1; 3385 3386 gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec ( 3387 get_identifier (PREFIX("string_index")), ". . R . R . ", 3388 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, 3389 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); 3390 DECL_PURE_P (gfor_fndecl_string_index) = 1; 3391 TREE_NOTHROW (gfor_fndecl_string_index) = 1; 3392 3393 gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec ( 3394 get_identifier (PREFIX("string_scan")), ". . R . R . ", 3395 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, 3396 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); 3397 DECL_PURE_P (gfor_fndecl_string_scan) = 1; 3398 TREE_NOTHROW (gfor_fndecl_string_scan) = 1; 3399 3400 gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec ( 3401 get_identifier (PREFIX("string_verify")), ". . R . R . ", 3402 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node, 3403 gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node); 3404 DECL_PURE_P (gfor_fndecl_string_verify) = 1; 3405 TREE_NOTHROW (gfor_fndecl_string_verify) = 1; 3406 3407 gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec ( 3408 get_identifier (PREFIX("string_trim")), ". W w . R ", 3409 void_type_node, 4, build_pointer_type (gfc_charlen_type_node), 3410 build_pointer_type (pchar1_type_node), gfc_charlen_type_node, 3411 pchar1_type_node); 3412 3413 gfor_fndecl_string_minmax = gfc_build_library_function_decl_with_spec ( 3414 get_identifier (PREFIX("string_minmax")), ". W w . R ", 3415 void_type_node, -4, build_pointer_type (gfc_charlen_type_node), 3416 build_pointer_type (pchar1_type_node), integer_type_node, 3417 integer_type_node); 3418 3419 gfor_fndecl_adjustl = gfc_build_library_function_decl_with_spec ( 3420 get_identifier (PREFIX("adjustl")), ". W . R ", 3421 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, 3422 pchar1_type_node); 3423 TREE_NOTHROW (gfor_fndecl_adjustl) = 1; 3424 3425 gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec ( 3426 get_identifier (PREFIX("adjustr")), ". W . R ", 3427 void_type_node, 3, pchar1_type_node, gfc_charlen_type_node, 3428 pchar1_type_node); 3429 TREE_NOTHROW (gfor_fndecl_adjustr) = 1; 3430 3431 gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec ( 3432 get_identifier (PREFIX("select_string")), ". R . R . ", 3433 integer_type_node, 4, pvoid_type_node, integer_type_node, 3434 pchar1_type_node, gfc_charlen_type_node); 3435 DECL_PURE_P (gfor_fndecl_select_string) = 1; 3436 TREE_NOTHROW (gfor_fndecl_select_string) = 1; 3437 3438 gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec ( 3439 get_identifier (PREFIX("compare_string_char4")), ". . R . R ", 3440 integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node, 3441 gfc_charlen_type_node, pchar4_type_node); 3442 DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1; 3443 TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1; 3444 3445 gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec ( 3446 get_identifier (PREFIX("concat_string_char4")), ". . W . R . R ", 3447 void_type_node, 6, gfc_charlen_type_node, pchar4_type_node, 3448 gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node, 3449 pchar4_type_node); 3450 TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1; 3451 3452 gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec ( 3453 get_identifier (PREFIX("string_len_trim_char4")), ". . R ", 3454 gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node); 3455 DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1; 3456 TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1; 3457 3458 gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec ( 3459 get_identifier (PREFIX("string_index_char4")), ". . R . R . ", 3460 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, 3461 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); 3462 DECL_PURE_P (gfor_fndecl_string_index_char4) = 1; 3463 TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1; 3464 3465 gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec ( 3466 get_identifier (PREFIX("string_scan_char4")), ". . R . R . ", 3467 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, 3468 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); 3469 DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1; 3470 TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1; 3471 3472 gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec ( 3473 get_identifier (PREFIX("string_verify_char4")), ". . R . R . ", 3474 gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node, 3475 gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node); 3476 DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1; 3477 TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1; 3478 3479 gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec ( 3480 get_identifier (PREFIX("string_trim_char4")), ". W w . R ", 3481 void_type_node, 4, build_pointer_type (gfc_charlen_type_node), 3482 build_pointer_type (pchar4_type_node), gfc_charlen_type_node, 3483 pchar4_type_node); 3484 3485 gfor_fndecl_string_minmax_char4 = gfc_build_library_function_decl_with_spec ( 3486 get_identifier (PREFIX("string_minmax_char4")), ". W w . R ", 3487 void_type_node, -4, build_pointer_type (gfc_charlen_type_node), 3488 build_pointer_type (pchar4_type_node), integer_type_node, 3489 integer_type_node); 3490 3491 gfor_fndecl_adjustl_char4 = gfc_build_library_function_decl_with_spec ( 3492 get_identifier (PREFIX("adjustl_char4")), ". W . R ", 3493 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, 3494 pchar4_type_node); 3495 TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1; 3496 3497 gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec ( 3498 get_identifier (PREFIX("adjustr_char4")), ". W . R ", 3499 void_type_node, 3, pchar4_type_node, gfc_charlen_type_node, 3500 pchar4_type_node); 3501 TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1; 3502 3503 gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec ( 3504 get_identifier (PREFIX("select_string_char4")), ". R . R . ", 3505 integer_type_node, 4, pvoid_type_node, integer_type_node, 3506 pvoid_type_node, gfc_charlen_type_node); 3507 DECL_PURE_P (gfor_fndecl_select_string_char4) = 1; 3508 TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1; 3509 3510 3511 /* Conversion between character kinds. */ 3512 3513 gfor_fndecl_convert_char1_to_char4 = gfc_build_library_function_decl_with_spec ( 3514 get_identifier (PREFIX("convert_char1_to_char4")), ". w . R ", 3515 void_type_node, 3, build_pointer_type (pchar4_type_node), 3516 gfc_charlen_type_node, pchar1_type_node); 3517 3518 gfor_fndecl_convert_char4_to_char1 = gfc_build_library_function_decl_with_spec ( 3519 get_identifier (PREFIX("convert_char4_to_char1")), ". w . R ", 3520 void_type_node, 3, build_pointer_type (pchar1_type_node), 3521 gfc_charlen_type_node, pchar4_type_node); 3522 3523 /* Misc. functions. */ 3524 3525 gfor_fndecl_ttynam = gfc_build_library_function_decl_with_spec ( 3526 get_identifier (PREFIX("ttynam")), ". W . . ", 3527 void_type_node, 3, pchar_type_node, gfc_charlen_type_node, 3528 integer_type_node); 3529 3530 gfor_fndecl_fdate = gfc_build_library_function_decl_with_spec ( 3531 get_identifier (PREFIX("fdate")), ". W . ", 3532 void_type_node, 2, pchar_type_node, gfc_charlen_type_node); 3533 3534 gfor_fndecl_ctime = gfc_build_library_function_decl_with_spec ( 3535 get_identifier (PREFIX("ctime")), ". W . . ", 3536 void_type_node, 3, pchar_type_node, gfc_charlen_type_node, 3537 gfc_int8_type_node); 3538 3539 gfor_fndecl_random_init = gfc_build_library_function_decl ( 3540 get_identifier (PREFIX("random_init")), 3541 void_type_node, 3, gfc_logical4_type_node, gfc_logical4_type_node, 3542 gfc_int4_type_node); 3543 3544 // gfor_fndecl_caf_rand_init is defined in the lib-coarray section below. 3545 3546 gfor_fndecl_sc_kind = gfc_build_library_function_decl_with_spec ( 3547 get_identifier (PREFIX("selected_char_kind")), ". . R ", 3548 gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node); 3549 DECL_PURE_P (gfor_fndecl_sc_kind) = 1; 3550 TREE_NOTHROW (gfor_fndecl_sc_kind) = 1; 3551 3552 gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec ( 3553 get_identifier (PREFIX("selected_int_kind")), ". R ", 3554 gfc_int4_type_node, 1, pvoid_type_node); 3555 DECL_PURE_P (gfor_fndecl_si_kind) = 1; 3556 TREE_NOTHROW (gfor_fndecl_si_kind) = 1; 3557 3558 gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec ( 3559 get_identifier (PREFIX("selected_real_kind2008")), ". R R ", 3560 gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node, 3561 pvoid_type_node); 3562 DECL_PURE_P (gfor_fndecl_sr_kind) = 1; 3563 TREE_NOTHROW (gfor_fndecl_sr_kind) = 1; 3564 3565 gfor_fndecl_system_clock4 = gfc_build_library_function_decl ( 3566 get_identifier (PREFIX("system_clock_4")), 3567 void_type_node, 3, gfc_pint4_type_node, gfc_pint4_type_node, 3568 gfc_pint4_type_node); 3569 3570 gfor_fndecl_system_clock8 = gfc_build_library_function_decl ( 3571 get_identifier (PREFIX("system_clock_8")), 3572 void_type_node, 3, gfc_pint8_type_node, gfc_pint8_type_node, 3573 gfc_pint8_type_node); 3574 3575 /* Power functions. */ 3576 { 3577 tree ctype, rtype, itype, jtype; 3578 int rkind, ikind, jkind; 3579 #define NIKINDS 3 3580 #define NRKINDS 4 3581 static int ikinds[NIKINDS] = {4, 8, 16}; 3582 static int rkinds[NRKINDS] = {4, 8, 10, 16}; 3583 char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */ 3584 3585 for (ikind=0; ikind < NIKINDS; ikind++) 3586 { 3587 itype = gfc_get_int_type (ikinds[ikind]); 3588 3589 for (jkind=0; jkind < NIKINDS; jkind++) 3590 { 3591 jtype = gfc_get_int_type (ikinds[jkind]); 3592 if (itype && jtype) 3593 { 3594 sprintf (name, PREFIX("pow_i%d_i%d"), ikinds[ikind], 3595 ikinds[jkind]); 3596 gfor_fndecl_math_powi[jkind][ikind].integer = 3597 gfc_build_library_function_decl (get_identifier (name), 3598 jtype, 2, jtype, itype); 3599 TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; 3600 TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1; 3601 } 3602 } 3603 3604 for (rkind = 0; rkind < NRKINDS; rkind ++) 3605 { 3606 rtype = gfc_get_real_type (rkinds[rkind]); 3607 if (rtype && itype) 3608 { 3609 sprintf (name, PREFIX("pow_r%d_i%d"), 3610 gfc_type_abi_kind (BT_REAL, rkinds[rkind]), 3611 ikinds[ikind]); 3612 gfor_fndecl_math_powi[rkind][ikind].real = 3613 gfc_build_library_function_decl (get_identifier (name), 3614 rtype, 2, rtype, itype); 3615 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1; 3616 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1; 3617 } 3618 3619 ctype = gfc_get_complex_type (rkinds[rkind]); 3620 if (ctype && itype) 3621 { 3622 sprintf (name, PREFIX("pow_c%d_i%d"), 3623 gfc_type_abi_kind (BT_REAL, rkinds[rkind]), 3624 ikinds[ikind]); 3625 gfor_fndecl_math_powi[rkind][ikind].cmplx = 3626 gfc_build_library_function_decl (get_identifier (name), 3627 ctype, 2,ctype, itype); 3628 TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; 3629 TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1; 3630 } 3631 } 3632 } 3633 #undef NIKINDS 3634 #undef NRKINDS 3635 } 3636 3637 gfor_fndecl_math_ishftc4 = gfc_build_library_function_decl ( 3638 get_identifier (PREFIX("ishftc4")), 3639 gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node, 3640 gfc_int4_type_node); 3641 TREE_READONLY (gfor_fndecl_math_ishftc4) = 1; 3642 TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1; 3643 3644 gfor_fndecl_math_ishftc8 = gfc_build_library_function_decl ( 3645 get_identifier (PREFIX("ishftc8")), 3646 gfc_int8_type_node, 3, gfc_int8_type_node, gfc_int4_type_node, 3647 gfc_int4_type_node); 3648 TREE_READONLY (gfor_fndecl_math_ishftc8) = 1; 3649 TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1; 3650 3651 if (gfc_int16_type_node) 3652 { 3653 gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl ( 3654 get_identifier (PREFIX("ishftc16")), 3655 gfc_int16_type_node, 3, gfc_int16_type_node, gfc_int4_type_node, 3656 gfc_int4_type_node); 3657 TREE_READONLY (gfor_fndecl_math_ishftc16) = 1; 3658 TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1; 3659 } 3660 3661 /* BLAS functions. */ 3662 { 3663 tree pint = build_pointer_type (integer_type_node); 3664 tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind)); 3665 tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind)); 3666 tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind)); 3667 tree pz = build_pointer_type 3668 (gfc_get_complex_type (gfc_default_double_kind)); 3669 3670 gfor_fndecl_sgemm = gfc_build_library_function_decl 3671 (get_identifier 3672 (flag_underscoring ? "sgemm_" : "sgemm"), 3673 void_type_node, 15, pchar_type_node, 3674 pchar_type_node, pint, pint, pint, ps, ps, pint, 3675 ps, pint, ps, ps, pint, integer_type_node, 3676 integer_type_node); 3677 gfor_fndecl_dgemm = gfc_build_library_function_decl 3678 (get_identifier 3679 (flag_underscoring ? "dgemm_" : "dgemm"), 3680 void_type_node, 15, pchar_type_node, 3681 pchar_type_node, pint, pint, pint, pd, pd, pint, 3682 pd, pint, pd, pd, pint, integer_type_node, 3683 integer_type_node); 3684 gfor_fndecl_cgemm = gfc_build_library_function_decl 3685 (get_identifier 3686 (flag_underscoring ? "cgemm_" : "cgemm"), 3687 void_type_node, 15, pchar_type_node, 3688 pchar_type_node, pint, pint, pint, pc, pc, pint, 3689 pc, pint, pc, pc, pint, integer_type_node, 3690 integer_type_node); 3691 gfor_fndecl_zgemm = gfc_build_library_function_decl 3692 (get_identifier 3693 (flag_underscoring ? "zgemm_" : "zgemm"), 3694 void_type_node, 15, pchar_type_node, 3695 pchar_type_node, pint, pint, pint, pz, pz, pint, 3696 pz, pint, pz, pz, pint, integer_type_node, 3697 integer_type_node); 3698 } 3699 3700 /* Other functions. */ 3701 gfor_fndecl_iargc = gfc_build_library_function_decl ( 3702 get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0); 3703 TREE_NOTHROW (gfor_fndecl_iargc) = 1; 3704 3705 gfor_fndecl_kill_sub = gfc_build_library_function_decl ( 3706 get_identifier (PREFIX ("kill_sub")), void_type_node, 3707 3, gfc_int4_type_node, gfc_int4_type_node, gfc_pint4_type_node); 3708 3709 gfor_fndecl_kill = gfc_build_library_function_decl ( 3710 get_identifier (PREFIX ("kill")), gfc_int4_type_node, 3711 2, gfc_int4_type_node, gfc_int4_type_node); 3712 3713 gfor_fndecl_is_contiguous0 = gfc_build_library_function_decl_with_spec ( 3714 get_identifier (PREFIX("is_contiguous0")), ". R ", 3715 gfc_int4_type_node, 1, pvoid_type_node); 3716 DECL_PURE_P (gfor_fndecl_is_contiguous0) = 1; 3717 TREE_NOTHROW (gfor_fndecl_is_contiguous0) = 1; 3718 } 3719 3720 3721 /* Make prototypes for runtime library functions. */ 3722 3723 void 3724 gfc_build_builtin_function_decls (void) 3725 { 3726 tree gfc_int8_type_node = gfc_get_int_type (8); 3727 3728 gfor_fndecl_stop_numeric = gfc_build_library_function_decl ( 3729 get_identifier (PREFIX("stop_numeric")), 3730 void_type_node, 2, integer_type_node, boolean_type_node); 3731 /* STOP doesn't return. */ 3732 TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1; 3733 3734 gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec ( 3735 get_identifier (PREFIX("stop_string")), ". R . . ", 3736 void_type_node, 3, pchar_type_node, size_type_node, 3737 boolean_type_node); 3738 /* STOP doesn't return. */ 3739 TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; 3740 3741 gfor_fndecl_error_stop_numeric = gfc_build_library_function_decl ( 3742 get_identifier (PREFIX("error_stop_numeric")), 3743 void_type_node, 2, integer_type_node, boolean_type_node); 3744 /* ERROR STOP doesn't return. */ 3745 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_numeric) = 1; 3746 3747 gfor_fndecl_error_stop_string = gfc_build_library_function_decl_with_spec ( 3748 get_identifier (PREFIX("error_stop_string")), ". R . . ", 3749 void_type_node, 3, pchar_type_node, size_type_node, 3750 boolean_type_node); 3751 /* ERROR STOP doesn't return. */ 3752 TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; 3753 3754 gfor_fndecl_pause_numeric = gfc_build_library_function_decl ( 3755 get_identifier (PREFIX("pause_numeric")), 3756 void_type_node, 1, gfc_int8_type_node); 3757 3758 gfor_fndecl_pause_string = gfc_build_library_function_decl_with_spec ( 3759 get_identifier (PREFIX("pause_string")), ". R . ", 3760 void_type_node, 2, pchar_type_node, size_type_node); 3761 3762 gfor_fndecl_runtime_error = gfc_build_library_function_decl_with_spec ( 3763 get_identifier (PREFIX("runtime_error")), ". R ", 3764 void_type_node, -1, pchar_type_node); 3765 /* The runtime_error function does not return. */ 3766 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1; 3767 3768 gfor_fndecl_runtime_error_at = gfc_build_library_function_decl_with_spec ( 3769 get_identifier (PREFIX("runtime_error_at")), ". R R ", 3770 void_type_node, -2, pchar_type_node, pchar_type_node); 3771 /* The runtime_error_at function does not return. */ 3772 TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1; 3773 3774 gfor_fndecl_runtime_warning_at = gfc_build_library_function_decl_with_spec ( 3775 get_identifier (PREFIX("runtime_warning_at")), ". R R ", 3776 void_type_node, -2, pchar_type_node, pchar_type_node); 3777 3778 gfor_fndecl_generate_error = gfc_build_library_function_decl_with_spec ( 3779 get_identifier (PREFIX("generate_error")), ". R . R ", 3780 void_type_node, 3, pvoid_type_node, integer_type_node, 3781 pchar_type_node); 3782 3783 gfor_fndecl_os_error_at = gfc_build_library_function_decl_with_spec ( 3784 get_identifier (PREFIX("os_error_at")), ". R R ", 3785 void_type_node, -2, pchar_type_node, pchar_type_node); 3786 /* The os_error_at function does not return. */ 3787 TREE_THIS_VOLATILE (gfor_fndecl_os_error_at) = 1; 3788 3789 gfor_fndecl_set_args = gfc_build_library_function_decl ( 3790 get_identifier (PREFIX("set_args")), 3791 void_type_node, 2, integer_type_node, 3792 build_pointer_type (pchar_type_node)); 3793 3794 gfor_fndecl_set_fpe = gfc_build_library_function_decl ( 3795 get_identifier (PREFIX("set_fpe")), 3796 void_type_node, 1, integer_type_node); 3797 3798 gfor_fndecl_ieee_procedure_entry = gfc_build_library_function_decl ( 3799 get_identifier (PREFIX("ieee_procedure_entry")), 3800 void_type_node, 1, pvoid_type_node); 3801 3802 gfor_fndecl_ieee_procedure_exit = gfc_build_library_function_decl ( 3803 get_identifier (PREFIX("ieee_procedure_exit")), 3804 void_type_node, 1, pvoid_type_node); 3805 3806 /* Keep the array dimension in sync with the call, later in this file. */ 3807 gfor_fndecl_set_options = gfc_build_library_function_decl_with_spec ( 3808 get_identifier (PREFIX("set_options")), ". . R ", 3809 void_type_node, 2, integer_type_node, 3810 build_pointer_type (integer_type_node)); 3811 3812 gfor_fndecl_set_convert = gfc_build_library_function_decl ( 3813 get_identifier (PREFIX("set_convert")), 3814 void_type_node, 1, integer_type_node); 3815 3816 gfor_fndecl_set_record_marker = gfc_build_library_function_decl ( 3817 get_identifier (PREFIX("set_record_marker")), 3818 void_type_node, 1, integer_type_node); 3819 3820 gfor_fndecl_set_max_subrecord_length = gfc_build_library_function_decl ( 3821 get_identifier (PREFIX("set_max_subrecord_length")), 3822 void_type_node, 1, integer_type_node); 3823 3824 gfor_fndecl_in_pack = gfc_build_library_function_decl_with_spec ( 3825 get_identifier (PREFIX("internal_pack")), ". r ", 3826 pvoid_type_node, 1, pvoid_type_node); 3827 3828 gfor_fndecl_in_unpack = gfc_build_library_function_decl_with_spec ( 3829 get_identifier (PREFIX("internal_unpack")), ". w R ", 3830 void_type_node, 2, pvoid_type_node, pvoid_type_node); 3831 3832 gfor_fndecl_associated = gfc_build_library_function_decl_with_spec ( 3833 get_identifier (PREFIX("associated")), ". R R ", 3834 integer_type_node, 2, ppvoid_type_node, ppvoid_type_node); 3835 DECL_PURE_P (gfor_fndecl_associated) = 1; 3836 TREE_NOTHROW (gfor_fndecl_associated) = 1; 3837 3838 /* Coarray library calls. */ 3839 if (flag_coarray == GFC_FCOARRAY_LIB) 3840 { 3841 tree pint_type, pppchar_type; 3842 3843 pint_type = build_pointer_type (integer_type_node); 3844 pppchar_type 3845 = build_pointer_type (build_pointer_type (pchar_type_node)); 3846 3847 gfor_fndecl_caf_init = gfc_build_library_function_decl_with_spec ( 3848 get_identifier (PREFIX("caf_init")), ". W W ", 3849 void_type_node, 2, pint_type, pppchar_type); 3850 3851 gfor_fndecl_caf_finalize = gfc_build_library_function_decl ( 3852 get_identifier (PREFIX("caf_finalize")), void_type_node, 0); 3853 3854 gfor_fndecl_caf_this_image = gfc_build_library_function_decl ( 3855 get_identifier (PREFIX("caf_this_image")), integer_type_node, 3856 1, integer_type_node); 3857 3858 gfor_fndecl_caf_num_images = gfc_build_library_function_decl ( 3859 get_identifier (PREFIX("caf_num_images")), integer_type_node, 3860 2, integer_type_node, integer_type_node); 3861 3862 gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec ( 3863 get_identifier (PREFIX("caf_register")), ". . . W w w w . ", 3864 void_type_node, 7, 3865 size_type_node, integer_type_node, ppvoid_type_node, pvoid_type_node, 3866 pint_type, pchar_type_node, size_type_node); 3867 3868 gfor_fndecl_caf_deregister = gfc_build_library_function_decl_with_spec ( 3869 get_identifier (PREFIX("caf_deregister")), ". W . w w . ", 3870 void_type_node, 5, 3871 ppvoid_type_node, integer_type_node, pint_type, pchar_type_node, 3872 size_type_node); 3873 3874 gfor_fndecl_caf_get = gfc_build_library_function_decl_with_spec ( 3875 get_identifier (PREFIX("caf_get")), ". r . . r r w . . . w ", 3876 void_type_node, 10, 3877 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, 3878 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, 3879 boolean_type_node, pint_type); 3880 3881 gfor_fndecl_caf_send = gfc_build_library_function_decl_with_spec ( 3882 get_identifier (PREFIX("caf_send")), ". r . . w r r . . . w ", 3883 void_type_node, 11, 3884 pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node, 3885 pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node, 3886 boolean_type_node, pint_type, pvoid_type_node); 3887 3888 gfor_fndecl_caf_sendget = gfc_build_library_function_decl_with_spec ( 3889 get_identifier (PREFIX("caf_sendget")), ". r . . w r r . . r r . . . w ", 3890 void_type_node, 14, pvoid_type_node, size_type_node, integer_type_node, 3891 pvoid_type_node, pvoid_type_node, pvoid_type_node, size_type_node, 3892 integer_type_node, pvoid_type_node, pvoid_type_node, integer_type_node, 3893 integer_type_node, boolean_type_node, integer_type_node); 3894 3895 gfor_fndecl_caf_get_by_ref = gfc_build_library_function_decl_with_spec ( 3896 get_identifier (PREFIX("caf_get_by_ref")), ". r . w r . . . . w . ", 3897 void_type_node, 3898 10, pvoid_type_node, integer_type_node, pvoid_type_node, 3899 pvoid_type_node, integer_type_node, integer_type_node, 3900 boolean_type_node, boolean_type_node, pint_type, integer_type_node); 3901 3902 gfor_fndecl_caf_send_by_ref = gfc_build_library_function_decl_with_spec ( 3903 get_identifier (PREFIX("caf_send_by_ref")), ". r . r r . . . . w . ", 3904 void_type_node, 10, pvoid_type_node, integer_type_node, pvoid_type_node, 3905 pvoid_type_node, integer_type_node, integer_type_node, 3906 boolean_type_node, boolean_type_node, pint_type, integer_type_node); 3907 3908 gfor_fndecl_caf_sendget_by_ref 3909 = gfc_build_library_function_decl_with_spec ( 3910 get_identifier (PREFIX("caf_sendget_by_ref")), 3911 ". r . r r . r . . . w w . . ", 3912 void_type_node, 13, pvoid_type_node, integer_type_node, 3913 pvoid_type_node, pvoid_type_node, integer_type_node, 3914 pvoid_type_node, integer_type_node, integer_type_node, 3915 boolean_type_node, pint_type, pint_type, integer_type_node, 3916 integer_type_node); 3917 3918 gfor_fndecl_caf_sync_all = gfc_build_library_function_decl_with_spec ( 3919 get_identifier (PREFIX("caf_sync_all")), ". w w . ", void_type_node, 3920 3, pint_type, pchar_type_node, size_type_node); 3921 3922 gfor_fndecl_caf_sync_memory = gfc_build_library_function_decl_with_spec ( 3923 get_identifier (PREFIX("caf_sync_memory")), ". w w . ", void_type_node, 3924 3, pint_type, pchar_type_node, size_type_node); 3925 3926 gfor_fndecl_caf_sync_images = gfc_build_library_function_decl_with_spec ( 3927 get_identifier (PREFIX("caf_sync_images")), ". . r w w . ", void_type_node, 3928 5, integer_type_node, pint_type, pint_type, 3929 pchar_type_node, size_type_node); 3930 3931 gfor_fndecl_caf_error_stop = gfc_build_library_function_decl ( 3932 get_identifier (PREFIX("caf_error_stop")), 3933 void_type_node, 1, integer_type_node); 3934 /* CAF's ERROR STOP doesn't return. */ 3935 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop) = 1; 3936 3937 gfor_fndecl_caf_error_stop_str = gfc_build_library_function_decl_with_spec ( 3938 get_identifier (PREFIX("caf_error_stop_str")), ". r . ", 3939 void_type_node, 2, pchar_type_node, size_type_node); 3940 /* CAF's ERROR STOP doesn't return. */ 3941 TREE_THIS_VOLATILE (gfor_fndecl_caf_error_stop_str) = 1; 3942 3943 gfor_fndecl_caf_stop_numeric = gfc_build_library_function_decl ( 3944 get_identifier (PREFIX("caf_stop_numeric")), 3945 void_type_node, 1, integer_type_node); 3946 /* CAF's STOP doesn't return. */ 3947 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_numeric) = 1; 3948 3949 gfor_fndecl_caf_stop_str = gfc_build_library_function_decl_with_spec ( 3950 get_identifier (PREFIX("caf_stop_str")), ". r . ", 3951 void_type_node, 2, pchar_type_node, size_type_node); 3952 /* CAF's STOP doesn't return. */ 3953 TREE_THIS_VOLATILE (gfor_fndecl_caf_stop_str) = 1; 3954 3955 gfor_fndecl_caf_atomic_def = gfc_build_library_function_decl_with_spec ( 3956 get_identifier (PREFIX("caf_atomic_define")), ". r . . w w . . ", 3957 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, 3958 pvoid_type_node, pint_type, integer_type_node, integer_type_node); 3959 3960 gfor_fndecl_caf_atomic_ref = gfc_build_library_function_decl_with_spec ( 3961 get_identifier (PREFIX("caf_atomic_ref")), ". r . . w w . . ", 3962 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, 3963 pvoid_type_node, pint_type, integer_type_node, integer_type_node); 3964 3965 gfor_fndecl_caf_atomic_cas = gfc_build_library_function_decl_with_spec ( 3966 get_identifier (PREFIX("caf_atomic_cas")), ". r . . w r r w . . ", 3967 void_type_node, 9, pvoid_type_node, size_type_node, integer_type_node, 3968 pvoid_type_node, pvoid_type_node, pvoid_type_node, pint_type, 3969 integer_type_node, integer_type_node); 3970 3971 gfor_fndecl_caf_atomic_op = gfc_build_library_function_decl_with_spec ( 3972 get_identifier (PREFIX("caf_atomic_op")), ". . r . . r w w . . ", 3973 void_type_node, 9, integer_type_node, pvoid_type_node, size_type_node, 3974 integer_type_node, pvoid_type_node, pvoid_type_node, pint_type, 3975 integer_type_node, integer_type_node); 3976 3977 gfor_fndecl_caf_lock = gfc_build_library_function_decl_with_spec ( 3978 get_identifier (PREFIX("caf_lock")), ". r . . w w w . ", 3979 void_type_node, 7, pvoid_type_node, size_type_node, integer_type_node, 3980 pint_type, pint_type, pchar_type_node, size_type_node); 3981 3982 gfor_fndecl_caf_unlock = gfc_build_library_function_decl_with_spec ( 3983 get_identifier (PREFIX("caf_unlock")), ". r . . w w . ", 3984 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3985 pint_type, pchar_type_node, size_type_node); 3986 3987 gfor_fndecl_caf_event_post = gfc_build_library_function_decl_with_spec ( 3988 get_identifier (PREFIX("caf_event_post")), ". r . . w w . ", 3989 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3990 pint_type, pchar_type_node, size_type_node); 3991 3992 gfor_fndecl_caf_event_wait = gfc_build_library_function_decl_with_spec ( 3993 get_identifier (PREFIX("caf_event_wait")), ". r . . w w . ", 3994 void_type_node, 6, pvoid_type_node, size_type_node, integer_type_node, 3995 pint_type, pchar_type_node, size_type_node); 3996 3997 gfor_fndecl_caf_event_query = gfc_build_library_function_decl_with_spec ( 3998 get_identifier (PREFIX("caf_event_query")), ". r . . w w ", 3999 void_type_node, 5, pvoid_type_node, size_type_node, integer_type_node, 4000 pint_type, pint_type); 4001 4002 gfor_fndecl_caf_fail_image = gfc_build_library_function_decl ( 4003 get_identifier (PREFIX("caf_fail_image")), void_type_node, 0); 4004 /* CAF's FAIL doesn't return. */ 4005 TREE_THIS_VOLATILE (gfor_fndecl_caf_fail_image) = 1; 4006 4007 gfor_fndecl_caf_failed_images 4008 = gfc_build_library_function_decl_with_spec ( 4009 get_identifier (PREFIX("caf_failed_images")), ". w . r ", 4010 void_type_node, 3, pvoid_type_node, ppvoid_type_node, 4011 integer_type_node); 4012 4013 gfor_fndecl_caf_form_team 4014 = gfc_build_library_function_decl_with_spec ( 4015 get_identifier (PREFIX("caf_form_team")), ". . W . ", 4016 void_type_node, 3, integer_type_node, ppvoid_type_node, 4017 integer_type_node); 4018 4019 gfor_fndecl_caf_change_team 4020 = gfc_build_library_function_decl_with_spec ( 4021 get_identifier (PREFIX("caf_change_team")), ". w . ", 4022 void_type_node, 2, ppvoid_type_node, 4023 integer_type_node); 4024 4025 gfor_fndecl_caf_end_team 4026 = gfc_build_library_function_decl ( 4027 get_identifier (PREFIX("caf_end_team")), void_type_node, 0); 4028 4029 gfor_fndecl_caf_get_team 4030 = gfc_build_library_function_decl ( 4031 get_identifier (PREFIX("caf_get_team")), 4032 void_type_node, 1, integer_type_node); 4033 4034 gfor_fndecl_caf_sync_team 4035 = gfc_build_library_function_decl_with_spec ( 4036 get_identifier (PREFIX("caf_sync_team")), ". r . ", 4037 void_type_node, 2, ppvoid_type_node, 4038 integer_type_node); 4039 4040 gfor_fndecl_caf_team_number 4041 = gfc_build_library_function_decl_with_spec ( 4042 get_identifier (PREFIX("caf_team_number")), ". r ", 4043 integer_type_node, 1, integer_type_node); 4044 4045 gfor_fndecl_caf_image_status 4046 = gfc_build_library_function_decl_with_spec ( 4047 get_identifier (PREFIX("caf_image_status")), ". . r ", 4048 integer_type_node, 2, integer_type_node, ppvoid_type_node); 4049 4050 gfor_fndecl_caf_stopped_images 4051 = gfc_build_library_function_decl_with_spec ( 4052 get_identifier (PREFIX("caf_stopped_images")), ". w r r ", 4053 void_type_node, 3, pvoid_type_node, ppvoid_type_node, 4054 integer_type_node); 4055 4056 gfor_fndecl_co_broadcast = gfc_build_library_function_decl_with_spec ( 4057 get_identifier (PREFIX("caf_co_broadcast")), ". w . w w . ", 4058 void_type_node, 5, pvoid_type_node, integer_type_node, 4059 pint_type, pchar_type_node, size_type_node); 4060 4061 gfor_fndecl_co_max = gfc_build_library_function_decl_with_spec ( 4062 get_identifier (PREFIX("caf_co_max")), ". w . w w . . ", 4063 void_type_node, 6, pvoid_type_node, integer_type_node, 4064 pint_type, pchar_type_node, integer_type_node, size_type_node); 4065 4066 gfor_fndecl_co_min = gfc_build_library_function_decl_with_spec ( 4067 get_identifier (PREFIX("caf_co_min")), ". w . w w . . ", 4068 void_type_node, 6, pvoid_type_node, integer_type_node, 4069 pint_type, pchar_type_node, integer_type_node, size_type_node); 4070 4071 gfor_fndecl_co_reduce = gfc_build_library_function_decl_with_spec ( 4072 get_identifier (PREFIX("caf_co_reduce")), ". w r . . w w . . ", 4073 void_type_node, 8, pvoid_type_node, 4074 build_pointer_type (build_varargs_function_type_list (void_type_node, 4075 NULL_TREE)), 4076 integer_type_node, integer_type_node, pint_type, pchar_type_node, 4077 integer_type_node, size_type_node); 4078 4079 gfor_fndecl_co_sum = gfc_build_library_function_decl_with_spec ( 4080 get_identifier (PREFIX("caf_co_sum")), ". w . w w . ", 4081 void_type_node, 5, pvoid_type_node, integer_type_node, 4082 pint_type, pchar_type_node, size_type_node); 4083 4084 gfor_fndecl_caf_is_present = gfc_build_library_function_decl_with_spec ( 4085 get_identifier (PREFIX("caf_is_present")), ". r . r ", 4086 integer_type_node, 3, pvoid_type_node, integer_type_node, 4087 pvoid_type_node); 4088 4089 gfor_fndecl_caf_random_init = gfc_build_library_function_decl ( 4090 get_identifier (PREFIX("caf_random_init")), 4091 void_type_node, 2, logical_type_node, logical_type_node); 4092 } 4093 4094 gfc_build_intrinsic_function_decls (); 4095 gfc_build_intrinsic_lib_fndecls (); 4096 gfc_build_io_library_fndecls (); 4097 } 4098 4099 4100 /* Evaluate the length of dummy character variables. */ 4101 4102 static void 4103 gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, 4104 gfc_wrapped_block *block) 4105 { 4106 stmtblock_t init; 4107 4108 gfc_finish_decl (cl->backend_decl); 4109 4110 gfc_start_block (&init); 4111 4112 /* Evaluate the string length expression. */ 4113 gfc_conv_string_length (cl, NULL, &init); 4114 4115 gfc_trans_vla_type_sizes (sym, &init); 4116 4117 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 4118 } 4119 4120 4121 /* Allocate and cleanup an automatic character variable. */ 4122 4123 static void 4124 gfc_trans_auto_character_variable (gfc_symbol * sym, gfc_wrapped_block * block) 4125 { 4126 stmtblock_t init; 4127 tree decl; 4128 tree tmp; 4129 4130 gcc_assert (sym->backend_decl); 4131 gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length); 4132 4133 gfc_init_block (&init); 4134 4135 /* Evaluate the string length expression. */ 4136 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 4137 4138 gfc_trans_vla_type_sizes (sym, &init); 4139 4140 decl = sym->backend_decl; 4141 4142 /* Emit a DECL_EXPR for this variable, which will cause the 4143 gimplifier to allocate storage, and all that good stuff. */ 4144 tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl); 4145 gfc_add_expr_to_block (&init, tmp); 4146 4147 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 4148 } 4149 4150 /* Set the initial value of ASSIGN statement auxiliary variable explicitly. */ 4151 4152 static void 4153 gfc_trans_assign_aux_var (gfc_symbol * sym, gfc_wrapped_block * block) 4154 { 4155 stmtblock_t init; 4156 4157 gcc_assert (sym->backend_decl); 4158 gfc_start_block (&init); 4159 4160 /* Set the initial value to length. See the comments in 4161 function gfc_add_assign_aux_vars in this file. */ 4162 gfc_add_modify (&init, GFC_DECL_STRING_LEN (sym->backend_decl), 4163 build_int_cst (gfc_charlen_type_node, -2)); 4164 4165 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 4166 } 4167 4168 static void 4169 gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body) 4170 { 4171 tree t = *tp, var, val; 4172 4173 if (t == NULL || t == error_mark_node) 4174 return; 4175 if (TREE_CONSTANT (t) || DECL_P (t)) 4176 return; 4177 4178 if (TREE_CODE (t) == SAVE_EXPR) 4179 { 4180 if (SAVE_EXPR_RESOLVED_P (t)) 4181 { 4182 *tp = TREE_OPERAND (t, 0); 4183 return; 4184 } 4185 val = TREE_OPERAND (t, 0); 4186 } 4187 else 4188 val = t; 4189 4190 var = gfc_create_var_np (TREE_TYPE (t), NULL); 4191 gfc_add_decl_to_function (var); 4192 gfc_add_modify (body, var, unshare_expr (val)); 4193 if (TREE_CODE (t) == SAVE_EXPR) 4194 TREE_OPERAND (t, 0) = var; 4195 *tp = var; 4196 } 4197 4198 static void 4199 gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body) 4200 { 4201 tree t; 4202 4203 if (type == NULL || type == error_mark_node) 4204 return; 4205 4206 type = TYPE_MAIN_VARIANT (type); 4207 4208 if (TREE_CODE (type) == INTEGER_TYPE) 4209 { 4210 gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body); 4211 gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body); 4212 4213 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) 4214 { 4215 TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type); 4216 TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type); 4217 } 4218 } 4219 else if (TREE_CODE (type) == ARRAY_TYPE) 4220 { 4221 gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body); 4222 gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body); 4223 gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body); 4224 gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body); 4225 4226 for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t)) 4227 { 4228 TYPE_SIZE (t) = TYPE_SIZE (type); 4229 TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type); 4230 } 4231 } 4232 } 4233 4234 /* Make sure all type sizes and array domains are either constant, 4235 or variable or parameter decls. This is a simplified variant 4236 of gimplify_type_sizes, but we can't use it here, as none of the 4237 variables in the expressions have been gimplified yet. 4238 As type sizes and domains for various variable length arrays 4239 contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars 4240 time, without this routine gimplify_type_sizes in the middle-end 4241 could result in the type sizes being gimplified earlier than where 4242 those variables are initialized. */ 4243 4244 void 4245 gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body) 4246 { 4247 tree type = TREE_TYPE (sym->backend_decl); 4248 4249 if (TREE_CODE (type) == FUNCTION_TYPE 4250 && (sym->attr.function || sym->attr.result || sym->attr.entry)) 4251 { 4252 if (! current_fake_result_decl) 4253 return; 4254 4255 type = TREE_TYPE (TREE_VALUE (current_fake_result_decl)); 4256 } 4257 4258 while (POINTER_TYPE_P (type)) 4259 type = TREE_TYPE (type); 4260 4261 if (GFC_DESCRIPTOR_TYPE_P (type)) 4262 { 4263 tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type); 4264 4265 while (POINTER_TYPE_P (etype)) 4266 etype = TREE_TYPE (etype); 4267 4268 gfc_trans_vla_type_sizes_1 (etype, body); 4269 } 4270 4271 gfc_trans_vla_type_sizes_1 (type, body); 4272 } 4273 4274 4275 /* Initialize a derived type by building an lvalue from the symbol 4276 and using trans_assignment to do the work. Set dealloc to false 4277 if no deallocation prior the assignment is needed. */ 4278 void 4279 gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) 4280 { 4281 gfc_expr *e; 4282 tree tmp; 4283 tree present; 4284 4285 gcc_assert (block); 4286 4287 /* Initialization of PDTs is done elsewhere. */ 4288 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) 4289 return; 4290 4291 gcc_assert (!sym->attr.allocatable); 4292 gfc_set_sym_referenced (sym); 4293 e = gfc_lval_expr_from_sym (sym); 4294 tmp = gfc_trans_assignment (e, sym->value, false, dealloc); 4295 if (sym->attr.dummy && (sym->attr.optional 4296 || sym->ns->proc_name->attr.entry_master)) 4297 { 4298 present = gfc_conv_expr_present (sym); 4299 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present, 4300 tmp, build_empty_stmt (input_location)); 4301 } 4302 gfc_add_expr_to_block (block, tmp); 4303 gfc_free_expr (e); 4304 } 4305 4306 4307 /* Initialize INTENT(OUT) derived type dummies. As well as giving 4308 them their default initializer, if they do not have allocatable 4309 components, they have their allocatable components deallocated. */ 4310 4311 static void 4312 init_intent_out_dt (gfc_symbol * proc_sym, gfc_wrapped_block * block) 4313 { 4314 stmtblock_t init; 4315 gfc_formal_arglist *f; 4316 tree tmp; 4317 tree present; 4318 4319 gfc_init_block (&init); 4320 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) 4321 if (f->sym && f->sym->attr.intent == INTENT_OUT 4322 && !f->sym->attr.pointer 4323 && f->sym->ts.type == BT_DERIVED) 4324 { 4325 tmp = NULL_TREE; 4326 4327 /* Note: Allocatables are excluded as they are already handled 4328 by the caller. */ 4329 if (!f->sym->attr.allocatable 4330 && gfc_is_finalizable (f->sym->ts.u.derived, NULL)) 4331 { 4332 stmtblock_t block; 4333 gfc_expr *e; 4334 4335 gfc_init_block (&block); 4336 f->sym->attr.referenced = 1; 4337 e = gfc_lval_expr_from_sym (f->sym); 4338 gfc_add_finalizer_call (&block, e); 4339 gfc_free_expr (e); 4340 tmp = gfc_finish_block (&block); 4341 } 4342 4343 if (tmp == NULL_TREE && !f->sym->attr.allocatable 4344 && f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value) 4345 tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived, 4346 f->sym->backend_decl, 4347 f->sym->as ? f->sym->as->rank : 0); 4348 4349 if (tmp != NULL_TREE && (f->sym->attr.optional 4350 || f->sym->ns->proc_name->attr.entry_master)) 4351 { 4352 present = gfc_conv_expr_present (f->sym); 4353 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), 4354 present, tmp, build_empty_stmt (input_location)); 4355 } 4356 4357 if (tmp != NULL_TREE) 4358 gfc_add_expr_to_block (&init, tmp); 4359 else if (f->sym->value && !f->sym->attr.allocatable) 4360 gfc_init_default_dt (f->sym, &init, true); 4361 } 4362 else if (f->sym && f->sym->attr.intent == INTENT_OUT 4363 && f->sym->ts.type == BT_CLASS 4364 && !CLASS_DATA (f->sym)->attr.class_pointer 4365 && !CLASS_DATA (f->sym)->attr.allocatable) 4366 { 4367 stmtblock_t block; 4368 gfc_expr *e; 4369 4370 gfc_init_block (&block); 4371 f->sym->attr.referenced = 1; 4372 e = gfc_lval_expr_from_sym (f->sym); 4373 gfc_add_finalizer_call (&block, e); 4374 gfc_free_expr (e); 4375 tmp = gfc_finish_block (&block); 4376 4377 if (f->sym->attr.optional || f->sym->ns->proc_name->attr.entry_master) 4378 { 4379 present = gfc_conv_expr_present (f->sym); 4380 tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), 4381 present, tmp, 4382 build_empty_stmt (input_location)); 4383 } 4384 4385 gfc_add_expr_to_block (&init, tmp); 4386 } 4387 4388 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 4389 } 4390 4391 4392 /* Helper function to manage deferred string lengths. */ 4393 4394 static tree 4395 gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init, 4396 locus *loc) 4397 { 4398 tree tmp; 4399 4400 /* Character length passed by reference. */ 4401 tmp = sym->ts.u.cl->passed_length; 4402 tmp = build_fold_indirect_ref_loc (input_location, tmp); 4403 tmp = fold_convert (gfc_charlen_type_node, tmp); 4404 4405 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) 4406 /* Zero the string length when entering the scope. */ 4407 gfc_add_modify (init, sym->ts.u.cl->backend_decl, 4408 build_int_cst (gfc_charlen_type_node, 0)); 4409 else 4410 { 4411 tree tmp2; 4412 4413 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, 4414 gfc_charlen_type_node, 4415 sym->ts.u.cl->backend_decl, tmp); 4416 if (sym->attr.optional) 4417 { 4418 tree present = gfc_conv_expr_present (sym); 4419 tmp2 = build3_loc (input_location, COND_EXPR, 4420 void_type_node, present, tmp2, 4421 build_empty_stmt (input_location)); 4422 } 4423 gfc_add_expr_to_block (init, tmp2); 4424 } 4425 4426 gfc_restore_backend_locus (loc); 4427 4428 /* Pass the final character length back. */ 4429 if (sym->attr.intent != INTENT_IN) 4430 { 4431 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 4432 gfc_charlen_type_node, tmp, 4433 sym->ts.u.cl->backend_decl); 4434 if (sym->attr.optional) 4435 { 4436 tree present = gfc_conv_expr_present (sym); 4437 tmp = build3_loc (input_location, COND_EXPR, 4438 void_type_node, present, tmp, 4439 build_empty_stmt (input_location)); 4440 } 4441 } 4442 else 4443 tmp = NULL_TREE; 4444 4445 return tmp; 4446 } 4447 4448 4449 /* Get the result expression for a procedure. */ 4450 4451 static tree 4452 get_proc_result (gfc_symbol* sym) 4453 { 4454 if (sym->attr.subroutine || sym == sym->result) 4455 { 4456 if (current_fake_result_decl != NULL) 4457 return TREE_VALUE (current_fake_result_decl); 4458 4459 return NULL_TREE; 4460 } 4461 4462 return sym->result->backend_decl; 4463 } 4464 4465 4466 /* Generate function entry and exit code, and add it to the function body. 4467 This includes: 4468 Allocation and initialization of array variables. 4469 Allocation of character string variables. 4470 Initialization and possibly repacking of dummy arrays. 4471 Initialization of ASSIGN statement auxiliary variable. 4472 Initialization of ASSOCIATE names. 4473 Automatic deallocation. */ 4474 4475 void 4476 gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block) 4477 { 4478 locus loc; 4479 gfc_symbol *sym; 4480 gfc_formal_arglist *f; 4481 stmtblock_t tmpblock; 4482 bool seen_trans_deferred_array = false; 4483 bool is_pdt_type = false; 4484 tree tmp = NULL; 4485 gfc_expr *e; 4486 gfc_se se; 4487 stmtblock_t init; 4488 4489 /* Deal with implicit return variables. Explicit return variables will 4490 already have been added. */ 4491 if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym) 4492 { 4493 if (!current_fake_result_decl) 4494 { 4495 gfc_entry_list *el = NULL; 4496 if (proc_sym->attr.entry_master) 4497 { 4498 for (el = proc_sym->ns->entries; el; el = el->next) 4499 if (el->sym != el->sym->result) 4500 break; 4501 } 4502 /* TODO: move to the appropriate place in resolve.cc. */ 4503 if (warn_return_type > 0 && el == NULL) 4504 gfc_warning (OPT_Wreturn_type, 4505 "Return value of function %qs at %L not set", 4506 proc_sym->name, &proc_sym->declared_at); 4507 } 4508 else if (proc_sym->as) 4509 { 4510 tree result = TREE_VALUE (current_fake_result_decl); 4511 gfc_save_backend_locus (&loc); 4512 gfc_set_backend_locus (&proc_sym->declared_at); 4513 gfc_trans_dummy_array_bias (proc_sym, result, block); 4514 4515 /* An automatic character length, pointer array result. */ 4516 if (proc_sym->ts.type == BT_CHARACTER 4517 && VAR_P (proc_sym->ts.u.cl->backend_decl)) 4518 { 4519 tmp = NULL; 4520 if (proc_sym->ts.deferred) 4521 { 4522 gfc_start_block (&init); 4523 tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc); 4524 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4525 } 4526 else 4527 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); 4528 } 4529 } 4530 else if (proc_sym->ts.type == BT_CHARACTER) 4531 { 4532 if (proc_sym->ts.deferred) 4533 { 4534 tmp = NULL; 4535 gfc_save_backend_locus (&loc); 4536 gfc_set_backend_locus (&proc_sym->declared_at); 4537 gfc_start_block (&init); 4538 /* Zero the string length on entry. */ 4539 gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl, 4540 build_int_cst (gfc_charlen_type_node, 0)); 4541 /* Null the pointer. */ 4542 e = gfc_lval_expr_from_sym (proc_sym); 4543 gfc_init_se (&se, NULL); 4544 se.want_pointer = 1; 4545 gfc_conv_expr (&se, e); 4546 gfc_free_expr (e); 4547 tmp = se.expr; 4548 gfc_add_modify (&init, tmp, 4549 fold_convert (TREE_TYPE (se.expr), 4550 null_pointer_node)); 4551 gfc_restore_backend_locus (&loc); 4552 4553 /* Pass back the string length on exit. */ 4554 tmp = proc_sym->ts.u.cl->backend_decl; 4555 if (TREE_CODE (tmp) != INDIRECT_REF 4556 && proc_sym->ts.u.cl->passed_length) 4557 { 4558 tmp = proc_sym->ts.u.cl->passed_length; 4559 tmp = build_fold_indirect_ref_loc (input_location, tmp); 4560 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 4561 TREE_TYPE (tmp), tmp, 4562 fold_convert 4563 (TREE_TYPE (tmp), 4564 proc_sym->ts.u.cl->backend_decl)); 4565 } 4566 else 4567 tmp = NULL_TREE; 4568 4569 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4570 } 4571 else if (VAR_P (proc_sym->ts.u.cl->backend_decl)) 4572 gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl, block); 4573 } 4574 else 4575 gcc_assert (flag_f2c && proc_sym->ts.type == BT_COMPLEX); 4576 } 4577 else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym)) 4578 { 4579 /* Nullify explicit return class arrays on entry. */ 4580 tree type; 4581 tmp = get_proc_result (proc_sym); 4582 if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp))) 4583 { 4584 gfc_start_block (&init); 4585 tmp = gfc_class_data_get (tmp); 4586 type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp)); 4587 gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0)); 4588 gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE); 4589 } 4590 } 4591 4592 4593 /* Initialize the INTENT(OUT) derived type dummy arguments. This 4594 should be done here so that the offsets and lbounds of arrays 4595 are available. */ 4596 gfc_save_backend_locus (&loc); 4597 gfc_set_backend_locus (&proc_sym->declared_at); 4598 init_intent_out_dt (proc_sym, block); 4599 gfc_restore_backend_locus (&loc); 4600 4601 for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink) 4602 { 4603 bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED) 4604 && (sym->ts.u.derived->attr.alloc_comp 4605 || gfc_is_finalizable (sym->ts.u.derived, 4606 NULL)); 4607 if (sym->assoc) 4608 continue; 4609 4610 if (sym->ts.type == BT_DERIVED 4611 && sym->ts.u.derived 4612 && sym->ts.u.derived->attr.pdt_type) 4613 { 4614 is_pdt_type = true; 4615 gfc_init_block (&tmpblock); 4616 if (!(sym->attr.dummy 4617 || sym->attr.pointer 4618 || sym->attr.allocatable)) 4619 { 4620 tmp = gfc_allocate_pdt_comp (sym->ts.u.derived, 4621 sym->backend_decl, 4622 sym->as ? sym->as->rank : 0, 4623 sym->param_list); 4624 gfc_add_expr_to_block (&tmpblock, tmp); 4625 if (!sym->attr.result) 4626 tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, 4627 sym->backend_decl, 4628 sym->as ? sym->as->rank : 0); 4629 else 4630 tmp = NULL_TREE; 4631 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); 4632 } 4633 else if (sym->attr.dummy) 4634 { 4635 tmp = gfc_check_pdt_dummy (sym->ts.u.derived, 4636 sym->backend_decl, 4637 sym->as ? sym->as->rank : 0, 4638 sym->param_list); 4639 gfc_add_expr_to_block (&tmpblock, tmp); 4640 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); 4641 } 4642 } 4643 else if (sym->ts.type == BT_CLASS 4644 && CLASS_DATA (sym)->ts.u.derived 4645 && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) 4646 { 4647 gfc_component *data = CLASS_DATA (sym); 4648 is_pdt_type = true; 4649 gfc_init_block (&tmpblock); 4650 if (!(sym->attr.dummy 4651 || CLASS_DATA (sym)->attr.pointer 4652 || CLASS_DATA (sym)->attr.allocatable)) 4653 { 4654 tmp = gfc_class_data_get (sym->backend_decl); 4655 tmp = gfc_allocate_pdt_comp (data->ts.u.derived, tmp, 4656 data->as ? data->as->rank : 0, 4657 sym->param_list); 4658 gfc_add_expr_to_block (&tmpblock, tmp); 4659 tmp = gfc_class_data_get (sym->backend_decl); 4660 if (!sym->attr.result) 4661 tmp = gfc_deallocate_pdt_comp (data->ts.u.derived, tmp, 4662 data->as ? data->as->rank : 0); 4663 else 4664 tmp = NULL_TREE; 4665 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), tmp); 4666 } 4667 else if (sym->attr.dummy) 4668 { 4669 tmp = gfc_class_data_get (sym->backend_decl); 4670 tmp = gfc_check_pdt_dummy (data->ts.u.derived, tmp, 4671 data->as ? data->as->rank : 0, 4672 sym->param_list); 4673 gfc_add_expr_to_block (&tmpblock, tmp); 4674 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL); 4675 } 4676 } 4677 4678 if (sym->attr.pointer && sym->attr.dimension 4679 && sym->attr.save == SAVE_NONE 4680 && !sym->attr.use_assoc 4681 && !sym->attr.host_assoc 4682 && !sym->attr.dummy 4683 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))) 4684 { 4685 gfc_init_block (&tmpblock); 4686 gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl, 4687 build_int_cst (gfc_array_index_type, 0)); 4688 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), 4689 NULL_TREE); 4690 } 4691 4692 if (sym->ts.type == BT_CLASS 4693 && (sym->attr.save || flag_max_stack_var_size == 0) 4694 && CLASS_DATA (sym)->attr.allocatable) 4695 { 4696 tree vptr; 4697 4698 if (UNLIMITED_POLY (sym)) 4699 vptr = null_pointer_node; 4700 else 4701 { 4702 gfc_symbol *vsym; 4703 vsym = gfc_find_derived_vtab (sym->ts.u.derived); 4704 vptr = gfc_get_symbol_decl (vsym); 4705 vptr = gfc_build_addr_expr (NULL, vptr); 4706 } 4707 4708 if (CLASS_DATA (sym)->attr.dimension 4709 || (CLASS_DATA (sym)->attr.codimension 4710 && flag_coarray != GFC_FCOARRAY_LIB)) 4711 { 4712 tmp = gfc_class_data_get (sym->backend_decl); 4713 tmp = gfc_build_null_descriptor (TREE_TYPE (tmp)); 4714 } 4715 else 4716 tmp = null_pointer_node; 4717 4718 DECL_INITIAL (sym->backend_decl) 4719 = gfc_class_set_static_fields (sym->backend_decl, vptr, tmp); 4720 TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1; 4721 } 4722 else if ((sym->attr.dimension || sym->attr.codimension 4723 || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable))) 4724 { 4725 bool is_classarray = IS_CLASS_ARRAY (sym); 4726 symbol_attribute *array_attr; 4727 gfc_array_spec *as; 4728 array_type type_of_array; 4729 4730 array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr; 4731 as = is_classarray ? CLASS_DATA (sym)->as : sym->as; 4732 /* Assumed-size Cray pointees need to be treated as AS_EXPLICIT. */ 4733 type_of_array = as->type; 4734 if (type_of_array == AS_ASSUMED_SIZE && as->cp_was_assumed) 4735 type_of_array = AS_EXPLICIT; 4736 switch (type_of_array) 4737 { 4738 case AS_EXPLICIT: 4739 if (sym->attr.dummy || sym->attr.result) 4740 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); 4741 /* Allocatable and pointer arrays need to processed 4742 explicitly. */ 4743 else if ((sym->ts.type != BT_CLASS && sym->attr.pointer) 4744 || (sym->ts.type == BT_CLASS 4745 && CLASS_DATA (sym)->attr.class_pointer) 4746 || array_attr->allocatable) 4747 { 4748 if (TREE_STATIC (sym->backend_decl)) 4749 { 4750 gfc_save_backend_locus (&loc); 4751 gfc_set_backend_locus (&sym->declared_at); 4752 gfc_trans_static_array_pointer (sym); 4753 gfc_restore_backend_locus (&loc); 4754 } 4755 else 4756 { 4757 seen_trans_deferred_array = true; 4758 gfc_trans_deferred_array (sym, block); 4759 } 4760 } 4761 else if (sym->attr.codimension 4762 && TREE_STATIC (sym->backend_decl)) 4763 { 4764 gfc_init_block (&tmpblock); 4765 gfc_trans_array_cobounds (TREE_TYPE (sym->backend_decl), 4766 &tmpblock, sym); 4767 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), 4768 NULL_TREE); 4769 continue; 4770 } 4771 else 4772 { 4773 gfc_save_backend_locus (&loc); 4774 gfc_set_backend_locus (&sym->declared_at); 4775 4776 if (alloc_comp_or_fini) 4777 { 4778 seen_trans_deferred_array = true; 4779 gfc_trans_deferred_array (sym, block); 4780 } 4781 else if (sym->ts.type == BT_DERIVED 4782 && sym->value 4783 && !sym->attr.data 4784 && sym->attr.save == SAVE_NONE) 4785 { 4786 gfc_start_block (&tmpblock); 4787 gfc_init_default_dt (sym, &tmpblock, false); 4788 gfc_add_init_cleanup (block, 4789 gfc_finish_block (&tmpblock), 4790 NULL_TREE); 4791 } 4792 4793 gfc_trans_auto_array_allocation (sym->backend_decl, 4794 sym, block); 4795 gfc_restore_backend_locus (&loc); 4796 } 4797 break; 4798 4799 case AS_ASSUMED_SIZE: 4800 /* Must be a dummy parameter. */ 4801 gcc_assert (sym->attr.dummy || as->cp_was_assumed); 4802 4803 /* We should always pass assumed size arrays the g77 way. */ 4804 if (sym->attr.dummy) 4805 gfc_trans_g77_array (sym, block); 4806 break; 4807 4808 case AS_ASSUMED_SHAPE: 4809 /* Must be a dummy parameter. */ 4810 gcc_assert (sym->attr.dummy); 4811 4812 gfc_trans_dummy_array_bias (sym, sym->backend_decl, block); 4813 break; 4814 4815 case AS_ASSUMED_RANK: 4816 case AS_DEFERRED: 4817 seen_trans_deferred_array = true; 4818 gfc_trans_deferred_array (sym, block); 4819 if (sym->ts.type == BT_CHARACTER && sym->ts.deferred 4820 && sym->attr.result) 4821 { 4822 gfc_start_block (&init); 4823 gfc_save_backend_locus (&loc); 4824 gfc_set_backend_locus (&sym->declared_at); 4825 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); 4826 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4827 } 4828 break; 4829 4830 default: 4831 gcc_unreachable (); 4832 } 4833 if (alloc_comp_or_fini && !seen_trans_deferred_array) 4834 gfc_trans_deferred_array (sym, block); 4835 } 4836 else if ((!sym->attr.dummy || sym->ts.deferred) 4837 && (sym->ts.type == BT_CLASS 4838 && CLASS_DATA (sym)->attr.class_pointer)) 4839 gfc_trans_class_array (sym, block); 4840 else if ((!sym->attr.dummy || sym->ts.deferred) 4841 && (sym->attr.allocatable 4842 || (sym->attr.pointer && sym->attr.result) 4843 || (sym->ts.type == BT_CLASS 4844 && CLASS_DATA (sym)->attr.allocatable))) 4845 { 4846 if (!sym->attr.save && flag_max_stack_var_size != 0) 4847 { 4848 tree descriptor = NULL_TREE; 4849 4850 gfc_save_backend_locus (&loc); 4851 gfc_set_backend_locus (&sym->declared_at); 4852 gfc_start_block (&init); 4853 4854 if (sym->ts.type == BT_CHARACTER 4855 && sym->attr.allocatable 4856 && !sym->attr.dimension 4857 && sym->ts.u.cl && sym->ts.u.cl->length 4858 && sym->ts.u.cl->length->expr_type == EXPR_VARIABLE) 4859 gfc_conv_string_length (sym->ts.u.cl, NULL, &init); 4860 4861 if (!sym->attr.pointer) 4862 { 4863 /* Nullify and automatic deallocation of allocatable 4864 scalars. */ 4865 e = gfc_lval_expr_from_sym (sym); 4866 if (sym->ts.type == BT_CLASS) 4867 gfc_add_data_component (e); 4868 4869 gfc_init_se (&se, NULL); 4870 if (sym->ts.type != BT_CLASS 4871 || sym->ts.u.derived->attr.dimension 4872 || sym->ts.u.derived->attr.codimension) 4873 { 4874 se.want_pointer = 1; 4875 gfc_conv_expr (&se, e); 4876 } 4877 else if (sym->ts.type == BT_CLASS 4878 && !CLASS_DATA (sym)->attr.dimension 4879 && !CLASS_DATA (sym)->attr.codimension) 4880 { 4881 se.want_pointer = 1; 4882 gfc_conv_expr (&se, e); 4883 } 4884 else 4885 { 4886 se.descriptor_only = 1; 4887 gfc_conv_expr (&se, e); 4888 descriptor = se.expr; 4889 se.expr = gfc_conv_descriptor_data_addr (se.expr); 4890 se.expr = build_fold_indirect_ref_loc (input_location, se.expr); 4891 } 4892 gfc_free_expr (e); 4893 4894 if (!sym->attr.dummy || sym->attr.intent == INTENT_OUT) 4895 { 4896 /* Nullify when entering the scope. */ 4897 tmp = fold_build2_loc (input_location, MODIFY_EXPR, 4898 TREE_TYPE (se.expr), se.expr, 4899 fold_convert (TREE_TYPE (se.expr), 4900 null_pointer_node)); 4901 if (sym->attr.optional) 4902 { 4903 tree present = gfc_conv_expr_present (sym); 4904 tmp = build3_loc (input_location, COND_EXPR, 4905 void_type_node, present, tmp, 4906 build_empty_stmt (input_location)); 4907 } 4908 gfc_add_expr_to_block (&init, tmp); 4909 } 4910 } 4911 4912 if ((sym->attr.dummy || sym->attr.result) 4913 && sym->ts.type == BT_CHARACTER 4914 && sym->ts.deferred 4915 && sym->ts.u.cl->passed_length) 4916 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); 4917 else 4918 { 4919 gfc_restore_backend_locus (&loc); 4920 tmp = NULL_TREE; 4921 } 4922 4923 /* Initialize descriptor's TKR information. */ 4924 if (sym->ts.type == BT_CLASS) 4925 gfc_trans_class_array (sym, block); 4926 4927 /* Deallocate when leaving the scope. Nullifying is not 4928 needed. */ 4929 if (!sym->attr.result && !sym->attr.dummy && !sym->attr.pointer 4930 && !sym->ns->proc_name->attr.is_main_program) 4931 { 4932 if (sym->ts.type == BT_CLASS 4933 && CLASS_DATA (sym)->attr.codimension) 4934 tmp = gfc_deallocate_with_status (descriptor, NULL_TREE, 4935 NULL_TREE, NULL_TREE, 4936 NULL_TREE, true, NULL, 4937 GFC_CAF_COARRAY_ANALYZE); 4938 else 4939 { 4940 gfc_expr *expr = gfc_lval_expr_from_sym (sym); 4941 tmp = gfc_deallocate_scalar_with_status (se.expr, 4942 NULL_TREE, 4943 NULL_TREE, 4944 true, expr, 4945 sym->ts); 4946 gfc_free_expr (expr); 4947 } 4948 } 4949 4950 if (sym->ts.type == BT_CLASS) 4951 { 4952 /* Initialize _vptr to declared type. */ 4953 gfc_symbol *vtab; 4954 tree rhs; 4955 4956 gfc_save_backend_locus (&loc); 4957 gfc_set_backend_locus (&sym->declared_at); 4958 e = gfc_lval_expr_from_sym (sym); 4959 gfc_add_vptr_component (e); 4960 gfc_init_se (&se, NULL); 4961 se.want_pointer = 1; 4962 gfc_conv_expr (&se, e); 4963 gfc_free_expr (e); 4964 if (UNLIMITED_POLY (sym)) 4965 rhs = build_int_cst (TREE_TYPE (se.expr), 0); 4966 else 4967 { 4968 vtab = gfc_find_derived_vtab (sym->ts.u.derived); 4969 rhs = gfc_build_addr_expr (TREE_TYPE (se.expr), 4970 gfc_get_symbol_decl (vtab)); 4971 } 4972 gfc_add_modify (&init, se.expr, rhs); 4973 gfc_restore_backend_locus (&loc); 4974 } 4975 4976 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4977 } 4978 } 4979 else if (sym->ts.type == BT_CHARACTER && sym->ts.deferred) 4980 { 4981 tree tmp = NULL; 4982 stmtblock_t init; 4983 4984 /* If we get to here, all that should be left are pointers. */ 4985 gcc_assert (sym->attr.pointer); 4986 4987 if (sym->attr.dummy) 4988 { 4989 gfc_start_block (&init); 4990 gfc_save_backend_locus (&loc); 4991 gfc_set_backend_locus (&sym->declared_at); 4992 tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc); 4993 gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp); 4994 } 4995 } 4996 else if (sym->ts.deferred) 4997 gfc_fatal_error ("Deferred type parameter not yet supported"); 4998 else if (alloc_comp_or_fini) 4999 gfc_trans_deferred_array (sym, block); 5000 else if (sym->ts.type == BT_CHARACTER) 5001 { 5002 gfc_save_backend_locus (&loc); 5003 gfc_set_backend_locus (&sym->declared_at); 5004 if (sym->attr.dummy || sym->attr.result) 5005 gfc_trans_dummy_character (sym, sym->ts.u.cl, block); 5006 else 5007 gfc_trans_auto_character_variable (sym, block); 5008 gfc_restore_backend_locus (&loc); 5009 } 5010 else if (sym->attr.assign) 5011 { 5012 gfc_save_backend_locus (&loc); 5013 gfc_set_backend_locus (&sym->declared_at); 5014 gfc_trans_assign_aux_var (sym, block); 5015 gfc_restore_backend_locus (&loc); 5016 } 5017 else if (sym->ts.type == BT_DERIVED 5018 && sym->value 5019 && !sym->attr.data 5020 && sym->attr.save == SAVE_NONE) 5021 { 5022 gfc_start_block (&tmpblock); 5023 gfc_init_default_dt (sym, &tmpblock, false); 5024 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), 5025 NULL_TREE); 5026 } 5027 else if (!(UNLIMITED_POLY(sym)) && !is_pdt_type) 5028 gcc_unreachable (); 5029 } 5030 5031 gfc_init_block (&tmpblock); 5032 5033 for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next) 5034 { 5035 if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER 5036 && f->sym->ts.u.cl->backend_decl) 5037 { 5038 if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL) 5039 gfc_trans_vla_type_sizes (f->sym, &tmpblock); 5040 } 5041 } 5042 5043 if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER 5044 && current_fake_result_decl != NULL) 5045 { 5046 gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL); 5047 if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL) 5048 gfc_trans_vla_type_sizes (proc_sym, &tmpblock); 5049 } 5050 5051 gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock), NULL_TREE); 5052 } 5053 5054 5055 struct module_hasher : ggc_ptr_hash<module_htab_entry> 5056 { 5057 typedef const char *compare_type; 5058 5059 static hashval_t hash (module_htab_entry *s) 5060 { 5061 return htab_hash_string (s->name); 5062 } 5063 5064 static bool 5065 equal (module_htab_entry *a, const char *b) 5066 { 5067 return !strcmp (a->name, b); 5068 } 5069 }; 5070 5071 static GTY (()) hash_table<module_hasher> *module_htab; 5072 5073 /* Hash and equality functions for module_htab's decls. */ 5074 5075 hashval_t 5076 module_decl_hasher::hash (tree t) 5077 { 5078 const_tree n = DECL_NAME (t); 5079 if (n == NULL_TREE) 5080 n = TYPE_NAME (TREE_TYPE (t)); 5081 return htab_hash_string (IDENTIFIER_POINTER (n)); 5082 } 5083 5084 bool 5085 module_decl_hasher::equal (tree t1, const char *x2) 5086 { 5087 const_tree n1 = DECL_NAME (t1); 5088 if (n1 == NULL_TREE) 5089 n1 = TYPE_NAME (TREE_TYPE (t1)); 5090 return strcmp (IDENTIFIER_POINTER (n1), x2) == 0; 5091 } 5092 5093 struct module_htab_entry * 5094 gfc_find_module (const char *name) 5095 { 5096 if (! module_htab) 5097 module_htab = hash_table<module_hasher>::create_ggc (10); 5098 5099 module_htab_entry **slot 5100 = module_htab->find_slot_with_hash (name, htab_hash_string (name), INSERT); 5101 if (*slot == NULL) 5102 { 5103 module_htab_entry *entry = ggc_cleared_alloc<module_htab_entry> (); 5104 5105 entry->name = gfc_get_string ("%s", name); 5106 entry->decls = hash_table<module_decl_hasher>::create_ggc (10); 5107 *slot = entry; 5108 } 5109 return *slot; 5110 } 5111 5112 void 5113 gfc_module_add_decl (struct module_htab_entry *entry, tree decl) 5114 { 5115 const char *name; 5116 5117 if (DECL_NAME (decl)) 5118 name = IDENTIFIER_POINTER (DECL_NAME (decl)); 5119 else 5120 { 5121 gcc_assert (TREE_CODE (decl) == TYPE_DECL); 5122 name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl))); 5123 } 5124 tree *slot 5125 = entry->decls->find_slot_with_hash (name, htab_hash_string (name), 5126 INSERT); 5127 if (*slot == NULL) 5128 *slot = decl; 5129 } 5130 5131 5132 /* Generate debugging symbols for namelists. This function must come after 5133 generate_local_decl to ensure that the variables in the namelist are 5134 already declared. */ 5135 5136 static tree 5137 generate_namelist_decl (gfc_symbol * sym) 5138 { 5139 gfc_namelist *nml; 5140 tree decl; 5141 vec<constructor_elt, va_gc> *nml_decls = NULL; 5142 5143 gcc_assert (sym->attr.flavor == FL_NAMELIST); 5144 for (nml = sym->namelist; nml; nml = nml->next) 5145 { 5146 if (nml->sym->backend_decl == NULL_TREE) 5147 { 5148 nml->sym->attr.referenced = 1; 5149 nml->sym->backend_decl = gfc_get_symbol_decl (nml->sym); 5150 } 5151 DECL_IGNORED_P (nml->sym->backend_decl) = 0; 5152 CONSTRUCTOR_APPEND_ELT (nml_decls, NULL_TREE, nml->sym->backend_decl); 5153 } 5154 5155 decl = make_node (NAMELIST_DECL); 5156 TREE_TYPE (decl) = void_type_node; 5157 NAMELIST_DECL_ASSOCIATED_DECL (decl) = build_constructor (NULL_TREE, nml_decls); 5158 DECL_NAME (decl) = get_identifier (sym->name); 5159 return decl; 5160 } 5161 5162 5163 /* Output an initialized decl for a module variable. */ 5164 5165 static void 5166 gfc_create_module_variable (gfc_symbol * sym) 5167 { 5168 tree decl; 5169 5170 /* Module functions with alternate entries are dealt with later and 5171 would get caught by the next condition. */ 5172 if (sym->attr.entry) 5173 return; 5174 5175 /* Make sure we convert the types of the derived types from iso_c_binding 5176 into (void *). */ 5177 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c 5178 && sym->ts.type == BT_DERIVED) 5179 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); 5180 5181 if (gfc_fl_struct (sym->attr.flavor) 5182 && sym->backend_decl 5183 && TREE_CODE (sym->backend_decl) == RECORD_TYPE) 5184 { 5185 decl = sym->backend_decl; 5186 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); 5187 5188 if (!sym->attr.use_assoc && !sym->attr.used_in_submodule) 5189 { 5190 gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE 5191 || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl); 5192 gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE 5193 || DECL_CONTEXT (TYPE_STUB_DECL (decl)) 5194 == sym->ns->proc_name->backend_decl); 5195 } 5196 TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl; 5197 DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl; 5198 gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl)); 5199 } 5200 5201 /* Only output variables, procedure pointers and array valued, 5202 or derived type, parameters. */ 5203 if (sym->attr.flavor != FL_VARIABLE 5204 && !(sym->attr.flavor == FL_PARAMETER 5205 && (sym->attr.dimension || sym->ts.type == BT_DERIVED)) 5206 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer)) 5207 return; 5208 5209 if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl) 5210 { 5211 decl = sym->backend_decl; 5212 gcc_assert (DECL_FILE_SCOPE_P (decl)); 5213 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); 5214 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; 5215 gfc_module_add_decl (cur_module, decl); 5216 } 5217 5218 /* Don't generate variables from other modules. Variables from 5219 COMMONs and Cray pointees will already have been generated. */ 5220 if (sym->attr.use_assoc || sym->attr.used_in_submodule 5221 || sym->attr.in_common || sym->attr.cray_pointee) 5222 return; 5223 5224 /* Equivalenced variables arrive here after creation. */ 5225 if (sym->backend_decl 5226 && (sym->equiv_built || sym->attr.in_equivalence)) 5227 return; 5228 5229 if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target) 5230 gfc_internal_error ("backend decl for module variable %qs already exists", 5231 sym->name); 5232 5233 if (sym->module && !sym->attr.result && !sym->attr.dummy 5234 && (sym->attr.access == ACCESS_UNKNOWN 5235 && (sym->ns->default_access == ACCESS_PRIVATE 5236 || (sym->ns->default_access == ACCESS_UNKNOWN 5237 && flag_module_private)))) 5238 sym->attr.access = ACCESS_PRIVATE; 5239 5240 if (warn_unused_variable && !sym->attr.referenced 5241 && sym->attr.access == ACCESS_PRIVATE) 5242 gfc_warning (OPT_Wunused_value, 5243 "Unused PRIVATE module variable %qs declared at %L", 5244 sym->name, &sym->declared_at); 5245 5246 /* We always want module variables to be created. */ 5247 sym->attr.referenced = 1; 5248 /* Create the decl. */ 5249 decl = gfc_get_symbol_decl (sym); 5250 5251 /* Create the variable. */ 5252 pushdecl (decl); 5253 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE 5254 || ((sym->ns->parent->proc_name->attr.flavor == FL_MODULE 5255 || sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE) 5256 && sym->fn_result_spec)); 5257 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; 5258 rest_of_decl_compilation (decl, 1, 0); 5259 gfc_module_add_decl (cur_module, decl); 5260 5261 /* Also add length of strings. */ 5262 if (sym->ts.type == BT_CHARACTER) 5263 { 5264 tree length; 5265 5266 length = sym->ts.u.cl->backend_decl; 5267 gcc_assert (length || sym->attr.proc_pointer); 5268 if (length && !INTEGER_CST_P (length)) 5269 { 5270 pushdecl (length); 5271 rest_of_decl_compilation (length, 1, 0); 5272 } 5273 } 5274 5275 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable 5276 && sym->attr.referenced && !sym->attr.use_assoc) 5277 has_coarray_vars = true; 5278 } 5279 5280 /* Emit debug information for USE statements. */ 5281 5282 static void 5283 gfc_trans_use_stmts (gfc_namespace * ns) 5284 { 5285 gfc_use_list *use_stmt; 5286 for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next) 5287 { 5288 struct module_htab_entry *entry 5289 = gfc_find_module (use_stmt->module_name); 5290 gfc_use_rename *rent; 5291 5292 if (entry->namespace_decl == NULL) 5293 { 5294 entry->namespace_decl 5295 = build_decl (input_location, 5296 NAMESPACE_DECL, 5297 get_identifier (use_stmt->module_name), 5298 void_type_node); 5299 DECL_EXTERNAL (entry->namespace_decl) = 1; 5300 } 5301 gfc_set_backend_locus (&use_stmt->where); 5302 if (!use_stmt->only_flag) 5303 (*debug_hooks->imported_module_or_decl) (entry->namespace_decl, 5304 NULL_TREE, 5305 ns->proc_name->backend_decl, 5306 false, false); 5307 for (rent = use_stmt->rename; rent; rent = rent->next) 5308 { 5309 tree decl, local_name; 5310 5311 if (rent->op != INTRINSIC_NONE) 5312 continue; 5313 5314 hashval_t hash = htab_hash_string (rent->use_name); 5315 tree *slot = entry->decls->find_slot_with_hash (rent->use_name, hash, 5316 INSERT); 5317 if (*slot == NULL) 5318 { 5319 gfc_symtree *st; 5320 5321 st = gfc_find_symtree (ns->sym_root, 5322 rent->local_name[0] 5323 ? rent->local_name : rent->use_name); 5324 5325 /* The following can happen if a derived type is renamed. */ 5326 if (!st) 5327 { 5328 char *name; 5329 name = xstrdup (rent->local_name[0] 5330 ? rent->local_name : rent->use_name); 5331 name[0] = (char) TOUPPER ((unsigned char) name[0]); 5332 st = gfc_find_symtree (ns->sym_root, name); 5333 free (name); 5334 gcc_assert (st); 5335 } 5336 5337 /* Sometimes, generic interfaces wind up being over-ruled by a 5338 local symbol (see PR41062). */ 5339 if (!st->n.sym->attr.use_assoc) 5340 { 5341 *slot = error_mark_node; 5342 entry->decls->clear_slot (slot); 5343 continue; 5344 } 5345 5346 if (st->n.sym->backend_decl 5347 && DECL_P (st->n.sym->backend_decl) 5348 && st->n.sym->module 5349 && strcmp (st->n.sym->module, use_stmt->module_name) == 0) 5350 { 5351 gcc_assert (DECL_EXTERNAL (entry->namespace_decl) 5352 || !VAR_P (st->n.sym->backend_decl)); 5353 decl = copy_node (st->n.sym->backend_decl); 5354 DECL_CONTEXT (decl) = entry->namespace_decl; 5355 DECL_EXTERNAL (decl) = 1; 5356 DECL_IGNORED_P (decl) = 0; 5357 DECL_INITIAL (decl) = NULL_TREE; 5358 } 5359 else if (st->n.sym->attr.flavor == FL_NAMELIST 5360 && st->n.sym->attr.use_only 5361 && st->n.sym->module 5362 && strcmp (st->n.sym->module, use_stmt->module_name) 5363 == 0) 5364 { 5365 decl = generate_namelist_decl (st->n.sym); 5366 DECL_CONTEXT (decl) = entry->namespace_decl; 5367 DECL_EXTERNAL (decl) = 1; 5368 DECL_IGNORED_P (decl) = 0; 5369 DECL_INITIAL (decl) = NULL_TREE; 5370 } 5371 else 5372 { 5373 *slot = error_mark_node; 5374 entry->decls->clear_slot (slot); 5375 continue; 5376 } 5377 *slot = decl; 5378 } 5379 decl = (tree) *slot; 5380 if (rent->local_name[0]) 5381 local_name = get_identifier (rent->local_name); 5382 else 5383 local_name = NULL_TREE; 5384 gfc_set_backend_locus (&rent->where); 5385 (*debug_hooks->imported_module_or_decl) (decl, local_name, 5386 ns->proc_name->backend_decl, 5387 !use_stmt->only_flag, 5388 false); 5389 } 5390 } 5391 } 5392 5393 5394 /* Return true if expr is a constant initializer that gfc_conv_initializer 5395 will handle. */ 5396 5397 static bool 5398 check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array, 5399 bool pointer) 5400 { 5401 gfc_constructor *c; 5402 gfc_component *cm; 5403 5404 if (pointer) 5405 return true; 5406 else if (array) 5407 { 5408 if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL) 5409 return true; 5410 else if (expr->expr_type == EXPR_STRUCTURE) 5411 return check_constant_initializer (expr, ts, false, false); 5412 else if (expr->expr_type != EXPR_ARRAY) 5413 return false; 5414 for (c = gfc_constructor_first (expr->value.constructor); 5415 c; c = gfc_constructor_next (c)) 5416 { 5417 if (c->iterator) 5418 return false; 5419 if (c->expr->expr_type == EXPR_STRUCTURE) 5420 { 5421 if (!check_constant_initializer (c->expr, ts, false, false)) 5422 return false; 5423 } 5424 else if (c->expr->expr_type != EXPR_CONSTANT) 5425 return false; 5426 } 5427 return true; 5428 } 5429 else switch (ts->type) 5430 { 5431 case_bt_struct: 5432 if (expr->expr_type != EXPR_STRUCTURE) 5433 return false; 5434 cm = expr->ts.u.derived->components; 5435 for (c = gfc_constructor_first (expr->value.constructor); 5436 c; c = gfc_constructor_next (c), cm = cm->next) 5437 { 5438 if (!c->expr || cm->attr.allocatable) 5439 continue; 5440 if (!check_constant_initializer (c->expr, &cm->ts, 5441 cm->attr.dimension, 5442 cm->attr.pointer)) 5443 return false; 5444 } 5445 return true; 5446 default: 5447 return expr->expr_type == EXPR_CONSTANT; 5448 } 5449 } 5450 5451 /* Emit debug info for parameters and unreferenced variables with 5452 initializers. */ 5453 5454 static void 5455 gfc_emit_parameter_debug_info (gfc_symbol *sym) 5456 { 5457 tree decl; 5458 5459 if (sym->attr.flavor != FL_PARAMETER 5460 && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced)) 5461 return; 5462 5463 if (sym->backend_decl != NULL 5464 || sym->value == NULL 5465 || sym->attr.use_assoc 5466 || sym->attr.dummy 5467 || sym->attr.result 5468 || sym->attr.function 5469 || sym->attr.intrinsic 5470 || sym->attr.pointer 5471 || sym->attr.allocatable 5472 || sym->attr.cray_pointee 5473 || sym->attr.threadprivate 5474 || sym->attr.is_bind_c 5475 || sym->attr.subref_array_pointer 5476 || sym->attr.assign) 5477 return; 5478 5479 if (sym->ts.type == BT_CHARACTER) 5480 { 5481 gfc_conv_const_charlen (sym->ts.u.cl); 5482 if (sym->ts.u.cl->backend_decl == NULL 5483 || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST) 5484 return; 5485 } 5486 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp) 5487 return; 5488 5489 if (sym->as) 5490 { 5491 int n; 5492 5493 if (sym->as->type != AS_EXPLICIT) 5494 return; 5495 for (n = 0; n < sym->as->rank; n++) 5496 if (sym->as->lower[n]->expr_type != EXPR_CONSTANT 5497 || sym->as->upper[n] == NULL 5498 || sym->as->upper[n]->expr_type != EXPR_CONSTANT) 5499 return; 5500 } 5501 5502 if (!check_constant_initializer (sym->value, &sym->ts, 5503 sym->attr.dimension, false)) 5504 return; 5505 5506 if (flag_coarray == GFC_FCOARRAY_LIB && sym->attr.codimension) 5507 return; 5508 5509 /* Create the decl for the variable or constant. */ 5510 decl = build_decl (input_location, 5511 sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL, 5512 gfc_sym_identifier (sym), gfc_sym_type (sym)); 5513 if (sym->attr.flavor == FL_PARAMETER) 5514 TREE_READONLY (decl) = 1; 5515 gfc_set_decl_location (decl, &sym->declared_at); 5516 if (sym->attr.dimension) 5517 GFC_DECL_PACKED_ARRAY (decl) = 1; 5518 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; 5519 TREE_STATIC (decl) = 1; 5520 TREE_USED (decl) = 1; 5521 if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL) 5522 TREE_PUBLIC (decl) = 1; 5523 DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts, 5524 TREE_TYPE (decl), 5525 sym->attr.dimension, 5526 false, false); 5527 debug_hooks->early_global_decl (decl); 5528 } 5529 5530 5531 static void 5532 generate_coarray_sym_init (gfc_symbol *sym) 5533 { 5534 tree tmp, size, decl, token, desc; 5535 bool is_lock_type, is_event_type; 5536 int reg_type; 5537 gfc_se se; 5538 symbol_attribute attr; 5539 5540 if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension 5541 || sym->attr.use_assoc || !sym->attr.referenced 5542 || sym->attr.associate_var 5543 || sym->attr.select_type_temporary) 5544 return; 5545 5546 decl = sym->backend_decl; 5547 TREE_USED(decl) = 1; 5548 gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl))); 5549 5550 is_lock_type = sym->ts.type == BT_DERIVED 5551 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 5552 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE; 5553 5554 is_event_type = sym->ts.type == BT_DERIVED 5555 && sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 5556 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE; 5557 5558 /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108 5559 to make sure the variable is not optimized away. */ 5560 DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1; 5561 5562 /* For lock types, we pass the array size as only the library knows the 5563 size of the variable. */ 5564 if (is_lock_type || is_event_type) 5565 size = gfc_index_one_node; 5566 else 5567 size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl))); 5568 5569 /* Ensure that we do not have size=0 for zero-sized arrays. */ 5570 size = fold_build2_loc (input_location, MAX_EXPR, size_type_node, 5571 fold_convert (size_type_node, size), 5572 build_int_cst (size_type_node, 1)); 5573 5574 if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl))) 5575 { 5576 tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl)); 5577 size = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 5578 fold_convert (size_type_node, tmp), size); 5579 } 5580 5581 gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE); 5582 token = gfc_build_addr_expr (ppvoid_type_node, 5583 GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl))); 5584 if (is_lock_type) 5585 reg_type = sym->attr.artificial ? GFC_CAF_CRITICAL : GFC_CAF_LOCK_STATIC; 5586 else if (is_event_type) 5587 reg_type = GFC_CAF_EVENT_STATIC; 5588 else 5589 reg_type = GFC_CAF_COARRAY_STATIC; 5590 5591 /* Compile the symbol attribute. */ 5592 if (sym->ts.type == BT_CLASS) 5593 { 5594 attr = CLASS_DATA (sym)->attr; 5595 /* The pointer attribute is always set on classes, overwrite it with the 5596 class_pointer attribute, which denotes the pointer for classes. */ 5597 attr.pointer = attr.class_pointer; 5598 } 5599 else 5600 attr = sym->attr; 5601 gfc_init_se (&se, NULL); 5602 desc = gfc_conv_scalar_to_descriptor (&se, decl, attr); 5603 gfc_add_block_to_block (&caf_init_block, &se.pre); 5604 5605 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 7, size, 5606 build_int_cst (integer_type_node, reg_type), 5607 token, gfc_build_addr_expr (pvoid_type_node, desc), 5608 null_pointer_node, /* stat. */ 5609 null_pointer_node, /* errgmsg. */ 5610 build_zero_cst (size_type_node)); /* errmsg_len. */ 5611 gfc_add_expr_to_block (&caf_init_block, tmp); 5612 gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), 5613 gfc_conv_descriptor_data_get (desc))); 5614 5615 /* Handle "static" initializer. */ 5616 if (sym->value) 5617 { 5618 if (sym->value->expr_type == EXPR_ARRAY) 5619 { 5620 gfc_constructor *c, *cnext; 5621 5622 /* Test if the array has more than one element. */ 5623 c = gfc_constructor_first (sym->value->value.constructor); 5624 gcc_assert (c); /* Empty constructor should not happen here. */ 5625 cnext = gfc_constructor_next (c); 5626 5627 if (cnext) 5628 { 5629 /* An EXPR_ARRAY with a rank > 1 here has to come from a 5630 DATA statement. Set its rank here as not to confuse 5631 the following steps. */ 5632 sym->value->rank = 1; 5633 } 5634 else 5635 { 5636 /* There is only a single value in the constructor, use 5637 it directly for the assignment. */ 5638 gfc_expr *new_expr; 5639 new_expr = gfc_copy_expr (c->expr); 5640 gfc_free_expr (sym->value); 5641 sym->value = new_expr; 5642 } 5643 } 5644 5645 sym->attr.pointer = 1; 5646 tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value, 5647 true, false); 5648 sym->attr.pointer = 0; 5649 gfc_add_expr_to_block (&caf_init_block, tmp); 5650 } 5651 else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pointer_comp) 5652 { 5653 tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, decl, sym->as 5654 ? sym->as->rank : 0, 5655 GFC_STRUCTURE_CAF_MODE_IN_COARRAY); 5656 gfc_add_expr_to_block (&caf_init_block, tmp); 5657 } 5658 } 5659 5660 5661 /* Generate constructor function to initialize static, nonallocatable 5662 coarrays. */ 5663 5664 static void 5665 generate_coarray_init (gfc_namespace * ns __attribute((unused))) 5666 { 5667 tree fndecl, tmp, decl, save_fn_decl; 5668 5669 save_fn_decl = current_function_decl; 5670 push_function_context (); 5671 5672 tmp = build_function_type_list (void_type_node, NULL_TREE); 5673 fndecl = build_decl (input_location, FUNCTION_DECL, 5674 create_tmp_var_name ("_caf_init"), tmp); 5675 5676 DECL_STATIC_CONSTRUCTOR (fndecl) = 1; 5677 SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY); 5678 5679 decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node); 5680 DECL_ARTIFICIAL (decl) = 1; 5681 DECL_IGNORED_P (decl) = 1; 5682 DECL_CONTEXT (decl) = fndecl; 5683 DECL_RESULT (fndecl) = decl; 5684 5685 pushdecl (fndecl); 5686 current_function_decl = fndecl; 5687 announce_function (fndecl); 5688 5689 rest_of_decl_compilation (fndecl, 0, 0); 5690 make_decl_rtl (fndecl); 5691 allocate_struct_function (fndecl, false); 5692 5693 pushlevel (); 5694 gfc_init_block (&caf_init_block); 5695 5696 gfc_traverse_ns (ns, generate_coarray_sym_init); 5697 5698 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block); 5699 decl = getdecls (); 5700 5701 poplevel (1, 1); 5702 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; 5703 5704 DECL_SAVED_TREE (fndecl) 5705 = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, 5706 decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); 5707 dump_function (TDI_original, fndecl); 5708 5709 cfun->function_end_locus = input_location; 5710 set_cfun (NULL); 5711 5712 if (decl_function_context (fndecl)) 5713 (void) cgraph_node::create (fndecl); 5714 else 5715 cgraph_node::finalize_function (fndecl, true); 5716 5717 pop_function_context (); 5718 current_function_decl = save_fn_decl; 5719 } 5720 5721 5722 static void 5723 create_module_nml_decl (gfc_symbol *sym) 5724 { 5725 if (sym->attr.flavor == FL_NAMELIST) 5726 { 5727 tree decl = generate_namelist_decl (sym); 5728 pushdecl (decl); 5729 gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE); 5730 DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl; 5731 rest_of_decl_compilation (decl, 1, 0); 5732 gfc_module_add_decl (cur_module, decl); 5733 } 5734 } 5735 5736 5737 /* Generate all the required code for module variables. */ 5738 5739 void 5740 gfc_generate_module_vars (gfc_namespace * ns) 5741 { 5742 module_namespace = ns; 5743 cur_module = gfc_find_module (ns->proc_name->name); 5744 5745 /* Check if the frontend left the namespace in a reasonable state. */ 5746 gcc_assert (ns->proc_name && !ns->proc_name->tlink); 5747 5748 /* Generate COMMON blocks. */ 5749 gfc_trans_common (ns); 5750 5751 has_coarray_vars = false; 5752 5753 /* Create decls for all the module variables. */ 5754 gfc_traverse_ns (ns, gfc_create_module_variable); 5755 gfc_traverse_ns (ns, create_module_nml_decl); 5756 5757 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) 5758 generate_coarray_init (ns); 5759 5760 cur_module = NULL; 5761 5762 gfc_trans_use_stmts (ns); 5763 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); 5764 } 5765 5766 5767 static void 5768 gfc_generate_contained_functions (gfc_namespace * parent) 5769 { 5770 gfc_namespace *ns; 5771 5772 /* We create all the prototypes before generating any code. */ 5773 for (ns = parent->contained; ns; ns = ns->sibling) 5774 { 5775 /* Skip namespaces from used modules. */ 5776 if (ns->parent != parent) 5777 continue; 5778 5779 gfc_create_function_decl (ns, false); 5780 } 5781 5782 for (ns = parent->contained; ns; ns = ns->sibling) 5783 { 5784 /* Skip namespaces from used modules. */ 5785 if (ns->parent != parent) 5786 continue; 5787 5788 gfc_generate_function_code (ns); 5789 } 5790 } 5791 5792 5793 /* Drill down through expressions for the array specification bounds and 5794 character length calling generate_local_decl for all those variables 5795 that have not already been declared. */ 5796 5797 static void 5798 generate_local_decl (gfc_symbol *); 5799 5800 /* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */ 5801 5802 static bool 5803 expr_decls (gfc_expr *e, gfc_symbol *sym, 5804 int *f ATTRIBUTE_UNUSED) 5805 { 5806 if (e->expr_type != EXPR_VARIABLE 5807 || sym == e->symtree->n.sym 5808 || e->symtree->n.sym->mark 5809 || e->symtree->n.sym->ns != sym->ns) 5810 return false; 5811 5812 generate_local_decl (e->symtree->n.sym); 5813 return false; 5814 } 5815 5816 static void 5817 generate_expr_decls (gfc_symbol *sym, gfc_expr *e) 5818 { 5819 gfc_traverse_expr (e, sym, expr_decls, 0); 5820 } 5821 5822 5823 /* Check for dependencies in the character length and array spec. */ 5824 5825 static void 5826 generate_dependency_declarations (gfc_symbol *sym) 5827 { 5828 int i; 5829 5830 if (sym->ts.type == BT_CHARACTER 5831 && sym->ts.u.cl 5832 && sym->ts.u.cl->length 5833 && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) 5834 generate_expr_decls (sym, sym->ts.u.cl->length); 5835 5836 if (sym->as && sym->as->rank) 5837 { 5838 for (i = 0; i < sym->as->rank; i++) 5839 { 5840 generate_expr_decls (sym, sym->as->lower[i]); 5841 generate_expr_decls (sym, sym->as->upper[i]); 5842 } 5843 } 5844 } 5845 5846 5847 /* Generate decls for all local variables. We do this to ensure correct 5848 handling of expressions which only appear in the specification of 5849 other functions. */ 5850 5851 static void 5852 generate_local_decl (gfc_symbol * sym) 5853 { 5854 if (sym->attr.flavor == FL_VARIABLE) 5855 { 5856 if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable 5857 && sym->attr.referenced && !sym->attr.use_assoc) 5858 has_coarray_vars = true; 5859 5860 if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master) 5861 generate_dependency_declarations (sym); 5862 5863 if (sym->attr.referenced) 5864 gfc_get_symbol_decl (sym); 5865 5866 /* Warnings for unused dummy arguments. */ 5867 else if (sym->attr.dummy && !sym->attr.in_namelist) 5868 { 5869 /* INTENT(out) dummy arguments are likely meant to be set. */ 5870 if (warn_unused_dummy_argument && sym->attr.intent == INTENT_OUT) 5871 { 5872 if (sym->ts.type != BT_DERIVED) 5873 gfc_warning (OPT_Wunused_dummy_argument, 5874 "Dummy argument %qs at %L was declared " 5875 "INTENT(OUT) but was not set", sym->name, 5876 &sym->declared_at); 5877 else if (!gfc_has_default_initializer (sym->ts.u.derived) 5878 && !sym->ts.u.derived->attr.zero_comp) 5879 gfc_warning (OPT_Wunused_dummy_argument, 5880 "Derived-type dummy argument %qs at %L was " 5881 "declared INTENT(OUT) but was not set and " 5882 "does not have a default initializer", 5883 sym->name, &sym->declared_at); 5884 if (sym->backend_decl != NULL_TREE) 5885 suppress_warning (sym->backend_decl); 5886 } 5887 else if (warn_unused_dummy_argument) 5888 { 5889 if (!sym->attr.artificial) 5890 gfc_warning (OPT_Wunused_dummy_argument, 5891 "Unused dummy argument %qs at %L", sym->name, 5892 &sym->declared_at); 5893 5894 if (sym->backend_decl != NULL_TREE) 5895 suppress_warning (sym->backend_decl); 5896 } 5897 } 5898 5899 /* Warn for unused variables, but not if they're inside a common 5900 block or a namelist. */ 5901 else if (warn_unused_variable 5902 && !(sym->attr.in_common || sym->mark || sym->attr.in_namelist)) 5903 { 5904 if (sym->attr.use_only) 5905 { 5906 gfc_warning (OPT_Wunused_variable, 5907 "Unused module variable %qs which has been " 5908 "explicitly imported at %L", sym->name, 5909 &sym->declared_at); 5910 if (sym->backend_decl != NULL_TREE) 5911 suppress_warning (sym->backend_decl); 5912 } 5913 else if (!sym->attr.use_assoc) 5914 { 5915 /* Corner case: the symbol may be an entry point. At this point, 5916 it may appear to be an unused variable. Suppress warning. */ 5917 bool enter = false; 5918 gfc_entry_list *el; 5919 5920 for (el = sym->ns->entries; el; el=el->next) 5921 if (strcmp(sym->name, el->sym->name) == 0) 5922 enter = true; 5923 5924 if (!enter) 5925 gfc_warning (OPT_Wunused_variable, 5926 "Unused variable %qs declared at %L", 5927 sym->name, &sym->declared_at); 5928 if (sym->backend_decl != NULL_TREE) 5929 suppress_warning (sym->backend_decl); 5930 } 5931 } 5932 5933 /* For variable length CHARACTER parameters, the PARM_DECL already 5934 references the length variable, so force gfc_get_symbol_decl 5935 even when not referenced. If optimize > 0, it will be optimized 5936 away anyway. But do this only after emitting -Wunused-parameter 5937 warning if requested. */ 5938 if (sym->attr.dummy && !sym->attr.referenced 5939 && sym->ts.type == BT_CHARACTER 5940 && sym->ts.u.cl->backend_decl != NULL 5941 && VAR_P (sym->ts.u.cl->backend_decl)) 5942 { 5943 sym->attr.referenced = 1; 5944 gfc_get_symbol_decl (sym); 5945 } 5946 5947 /* INTENT(out) dummy arguments and result variables with allocatable 5948 components are reset by default and need to be set referenced to 5949 generate the code for nullification and automatic lengths. */ 5950 if (!sym->attr.referenced 5951 && sym->ts.type == BT_DERIVED 5952 && sym->ts.u.derived->attr.alloc_comp 5953 && !sym->attr.pointer 5954 && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT) 5955 || 5956 (sym->attr.result && sym != sym->result))) 5957 { 5958 sym->attr.referenced = 1; 5959 gfc_get_symbol_decl (sym); 5960 } 5961 5962 /* Check for dependencies in the array specification and string 5963 length, adding the necessary declarations to the function. We 5964 mark the symbol now, as well as in traverse_ns, to prevent 5965 getting stuck in a circular dependency. */ 5966 sym->mark = 1; 5967 } 5968 else if (sym->attr.flavor == FL_PARAMETER) 5969 { 5970 if (warn_unused_parameter 5971 && !sym->attr.referenced) 5972 { 5973 if (!sym->attr.use_assoc) 5974 gfc_warning (OPT_Wunused_parameter, 5975 "Unused parameter %qs declared at %L", sym->name, 5976 &sym->declared_at); 5977 else if (sym->attr.use_only) 5978 gfc_warning (OPT_Wunused_parameter, 5979 "Unused parameter %qs which has been explicitly " 5980 "imported at %L", sym->name, &sym->declared_at); 5981 } 5982 5983 if (sym->ns && sym->ns->construct_entities) 5984 { 5985 /* Construction of the intrinsic modules within a BLOCK 5986 construct, where ONLY and RENAMED entities are included, 5987 seems to be bogus. This is a workaround that can be removed 5988 if someone ever takes on the task to creating full-fledge 5989 modules. See PR 69455. */ 5990 if (sym->attr.referenced 5991 && sym->from_intmod != INTMOD_ISO_C_BINDING 5992 && sym->from_intmod != INTMOD_ISO_FORTRAN_ENV) 5993 gfc_get_symbol_decl (sym); 5994 sym->mark = 1; 5995 } 5996 } 5997 else if (sym->attr.flavor == FL_PROCEDURE) 5998 { 5999 /* TODO: move to the appropriate place in resolve.cc. */ 6000 if (warn_return_type > 0 6001 && sym->attr.function 6002 && sym->result 6003 && sym != sym->result 6004 && !sym->result->attr.referenced 6005 && !sym->attr.use_assoc 6006 && sym->attr.if_source != IFSRC_IFBODY) 6007 { 6008 gfc_warning (OPT_Wreturn_type, 6009 "Return value %qs of function %qs declared at " 6010 "%L not set", sym->result->name, sym->name, 6011 &sym->result->declared_at); 6012 6013 /* Prevents "Unused variable" warning for RESULT variables. */ 6014 sym->result->mark = 1; 6015 } 6016 } 6017 6018 if (sym->attr.dummy == 1) 6019 { 6020 /* The tree type for scalar character dummy arguments of BIND(C) 6021 procedures, if they are passed by value, should be unsigned char. 6022 The value attribute implies the dummy is a scalar. */ 6023 if (sym->attr.value == 1 && sym->backend_decl != NULL 6024 && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop 6025 && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c) 6026 { 6027 /* We used to modify the tree here. Now it is done earlier in 6028 the front-end, so we only check it here to avoid regressions. */ 6029 gcc_assert (TREE_CODE (TREE_TYPE (sym->backend_decl)) == INTEGER_TYPE); 6030 gcc_assert (TYPE_UNSIGNED (TREE_TYPE (sym->backend_decl)) == 1); 6031 gcc_assert (TYPE_PRECISION (TREE_TYPE (sym->backend_decl)) == CHAR_TYPE_SIZE); 6032 gcc_assert (DECL_BY_REFERENCE (sym->backend_decl) == 0); 6033 } 6034 6035 /* Unused procedure passed as dummy argument. */ 6036 if (sym->attr.flavor == FL_PROCEDURE) 6037 { 6038 if (!sym->attr.referenced && !sym->attr.artificial) 6039 { 6040 if (warn_unused_dummy_argument) 6041 gfc_warning (OPT_Wunused_dummy_argument, 6042 "Unused dummy argument %qs at %L", sym->name, 6043 &sym->declared_at); 6044 } 6045 6046 /* Silence bogus "unused parameter" warnings from the 6047 middle end. */ 6048 if (sym->backend_decl != NULL_TREE) 6049 suppress_warning (sym->backend_decl); 6050 } 6051 } 6052 6053 /* Make sure we convert the types of the derived types from iso_c_binding 6054 into (void *). */ 6055 if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c 6056 && sym->ts.type == BT_DERIVED) 6057 sym->backend_decl = gfc_typenode_for_spec (&(sym->ts)); 6058 } 6059 6060 6061 static void 6062 generate_local_nml_decl (gfc_symbol * sym) 6063 { 6064 if (sym->attr.flavor == FL_NAMELIST && !sym->attr.use_assoc) 6065 { 6066 tree decl = generate_namelist_decl (sym); 6067 pushdecl (decl); 6068 } 6069 } 6070 6071 6072 static void 6073 generate_local_vars (gfc_namespace * ns) 6074 { 6075 gfc_traverse_ns (ns, generate_local_decl); 6076 gfc_traverse_ns (ns, generate_local_nml_decl); 6077 } 6078 6079 6080 /* Generate a switch statement to jump to the correct entry point. Also 6081 creates the label decls for the entry points. */ 6082 6083 static tree 6084 gfc_trans_entry_master_switch (gfc_entry_list * el) 6085 { 6086 stmtblock_t block; 6087 tree label; 6088 tree tmp; 6089 tree val; 6090 6091 gfc_init_block (&block); 6092 for (; el; el = el->next) 6093 { 6094 /* Add the case label. */ 6095 label = gfc_build_label_decl (NULL_TREE); 6096 val = build_int_cst (gfc_array_index_type, el->id); 6097 tmp = build_case_label (val, NULL_TREE, label); 6098 gfc_add_expr_to_block (&block, tmp); 6099 6100 /* And jump to the actual entry point. */ 6101 label = gfc_build_label_decl (NULL_TREE); 6102 tmp = build1_v (GOTO_EXPR, label); 6103 gfc_add_expr_to_block (&block, tmp); 6104 6105 /* Save the label decl. */ 6106 el->label = label; 6107 } 6108 tmp = gfc_finish_block (&block); 6109 /* The first argument selects the entry point. */ 6110 val = DECL_ARGUMENTS (current_function_decl); 6111 tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, val, tmp); 6112 return tmp; 6113 } 6114 6115 6116 /* Add code to string lengths of actual arguments passed to a function against 6117 the expected lengths of the dummy arguments. */ 6118 6119 static void 6120 add_argument_checking (stmtblock_t *block, gfc_symbol *sym) 6121 { 6122 gfc_formal_arglist *formal; 6123 6124 for (formal = gfc_sym_get_dummy_args (sym); formal; formal = formal->next) 6125 if (formal->sym && formal->sym->ts.type == BT_CHARACTER 6126 && !formal->sym->ts.deferred) 6127 { 6128 enum tree_code comparison; 6129 tree cond; 6130 tree argname; 6131 gfc_symbol *fsym; 6132 gfc_charlen *cl; 6133 const char *message; 6134 6135 fsym = formal->sym; 6136 cl = fsym->ts.u.cl; 6137 6138 gcc_assert (cl); 6139 gcc_assert (cl->passed_length != NULL_TREE); 6140 gcc_assert (cl->backend_decl != NULL_TREE); 6141 6142 /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the 6143 string lengths must match exactly. Otherwise, it is only required 6144 that the actual string length is *at least* the expected one. 6145 Sequence association allows for a mismatch of the string length 6146 if the actual argument is (part of) an array, but only if the 6147 dummy argument is an array. (See "Sequence association" in 6148 Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */ 6149 if (fsym->attr.pointer || fsym->attr.allocatable 6150 || (fsym->as && (fsym->as->type == AS_ASSUMED_SHAPE 6151 || fsym->as->type == AS_ASSUMED_RANK))) 6152 { 6153 comparison = NE_EXPR; 6154 message = _("Actual string length does not match the declared one" 6155 " for dummy argument '%s' (%ld/%ld)"); 6156 } 6157 else if (fsym->as && fsym->as->rank != 0) 6158 continue; 6159 else 6160 { 6161 comparison = LT_EXPR; 6162 message = _("Actual string length is shorter than the declared one" 6163 " for dummy argument '%s' (%ld/%ld)"); 6164 } 6165 6166 /* Build the condition. For optional arguments, an actual length 6167 of 0 is also acceptable if the associated string is NULL, which 6168 means the argument was not passed. */ 6169 cond = fold_build2_loc (input_location, comparison, logical_type_node, 6170 cl->passed_length, cl->backend_decl); 6171 if (fsym->attr.optional) 6172 { 6173 tree not_absent; 6174 tree not_0length; 6175 tree absent_failed; 6176 6177 not_0length = fold_build2_loc (input_location, NE_EXPR, 6178 logical_type_node, 6179 cl->passed_length, 6180 build_zero_cst 6181 (TREE_TYPE (cl->passed_length))); 6182 /* The symbol needs to be referenced for gfc_get_symbol_decl. */ 6183 fsym->attr.referenced = 1; 6184 not_absent = gfc_conv_expr_present (fsym); 6185 6186 absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR, 6187 logical_type_node, not_0length, 6188 not_absent); 6189 6190 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6191 logical_type_node, cond, absent_failed); 6192 } 6193 6194 /* Build the runtime check. */ 6195 argname = gfc_build_cstring_const (fsym->name); 6196 argname = gfc_build_addr_expr (pchar_type_node, argname); 6197 gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at, 6198 message, argname, 6199 fold_convert (long_integer_type_node, 6200 cl->passed_length), 6201 fold_convert (long_integer_type_node, 6202 cl->backend_decl)); 6203 } 6204 } 6205 6206 6207 static void 6208 create_main_function (tree fndecl) 6209 { 6210 tree old_context; 6211 tree ftn_main; 6212 tree tmp, decl, result_decl, argc, argv, typelist, arglist; 6213 stmtblock_t body; 6214 6215 old_context = current_function_decl; 6216 6217 if (old_context) 6218 { 6219 push_function_context (); 6220 saved_parent_function_decls = saved_function_decls; 6221 saved_function_decls = NULL_TREE; 6222 } 6223 6224 /* main() function must be declared with global scope. */ 6225 gcc_assert (current_function_decl == NULL_TREE); 6226 6227 /* Declare the function. */ 6228 tmp = build_function_type_list (integer_type_node, integer_type_node, 6229 build_pointer_type (pchar_type_node), 6230 NULL_TREE); 6231 main_identifier_node = get_identifier ("main"); 6232 ftn_main = build_decl (input_location, FUNCTION_DECL, 6233 main_identifier_node, tmp); 6234 DECL_EXTERNAL (ftn_main) = 0; 6235 TREE_PUBLIC (ftn_main) = 1; 6236 TREE_STATIC (ftn_main) = 1; 6237 DECL_ATTRIBUTES (ftn_main) 6238 = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE); 6239 6240 /* Setup the result declaration (for "return 0"). */ 6241 result_decl = build_decl (input_location, 6242 RESULT_DECL, NULL_TREE, integer_type_node); 6243 DECL_ARTIFICIAL (result_decl) = 1; 6244 DECL_IGNORED_P (result_decl) = 1; 6245 DECL_CONTEXT (result_decl) = ftn_main; 6246 DECL_RESULT (ftn_main) = result_decl; 6247 6248 pushdecl (ftn_main); 6249 6250 /* Get the arguments. */ 6251 6252 arglist = NULL_TREE; 6253 typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main)); 6254 6255 tmp = TREE_VALUE (typelist); 6256 argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp); 6257 DECL_CONTEXT (argc) = ftn_main; 6258 DECL_ARG_TYPE (argc) = TREE_VALUE (typelist); 6259 TREE_READONLY (argc) = 1; 6260 gfc_finish_decl (argc); 6261 arglist = chainon (arglist, argc); 6262 6263 typelist = TREE_CHAIN (typelist); 6264 tmp = TREE_VALUE (typelist); 6265 argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp); 6266 DECL_CONTEXT (argv) = ftn_main; 6267 DECL_ARG_TYPE (argv) = TREE_VALUE (typelist); 6268 TREE_READONLY (argv) = 1; 6269 DECL_BY_REFERENCE (argv) = 1; 6270 gfc_finish_decl (argv); 6271 arglist = chainon (arglist, argv); 6272 6273 DECL_ARGUMENTS (ftn_main) = arglist; 6274 current_function_decl = ftn_main; 6275 announce_function (ftn_main); 6276 6277 rest_of_decl_compilation (ftn_main, 1, 0); 6278 make_decl_rtl (ftn_main); 6279 allocate_struct_function (ftn_main, false); 6280 pushlevel (); 6281 6282 gfc_init_block (&body); 6283 6284 /* Call some libgfortran initialization routines, call then MAIN__(). */ 6285 6286 /* Call _gfortran_caf_init (*argc, ***argv). */ 6287 if (flag_coarray == GFC_FCOARRAY_LIB) 6288 { 6289 tree pint_type, pppchar_type; 6290 pint_type = build_pointer_type (integer_type_node); 6291 pppchar_type 6292 = build_pointer_type (build_pointer_type (pchar_type_node)); 6293 6294 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_init, 2, 6295 gfc_build_addr_expr (pint_type, argc), 6296 gfc_build_addr_expr (pppchar_type, argv)); 6297 gfc_add_expr_to_block (&body, tmp); 6298 } 6299 6300 /* Call _gfortran_set_args (argc, argv). */ 6301 TREE_USED (argc) = 1; 6302 TREE_USED (argv) = 1; 6303 tmp = build_call_expr_loc (input_location, 6304 gfor_fndecl_set_args, 2, argc, argv); 6305 gfc_add_expr_to_block (&body, tmp); 6306 6307 /* Add a call to set_options to set up the runtime library Fortran 6308 language standard parameters. */ 6309 { 6310 tree array_type, array, var; 6311 vec<constructor_elt, va_gc> *v = NULL; 6312 static const int noptions = 7; 6313 6314 /* Passing a new option to the library requires three modifications: 6315 + add it to the tree_cons list below 6316 + change the noptions variable above 6317 + modify the library (runtime/compile_options.c)! */ 6318 6319 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6320 build_int_cst (integer_type_node, 6321 gfc_option.warn_std)); 6322 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6323 build_int_cst (integer_type_node, 6324 gfc_option.allow_std)); 6325 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6326 build_int_cst (integer_type_node, pedantic)); 6327 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6328 build_int_cst (integer_type_node, flag_backtrace)); 6329 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6330 build_int_cst (integer_type_node, flag_sign_zero)); 6331 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6332 build_int_cst (integer_type_node, 6333 (gfc_option.rtcheck 6334 & GFC_RTCHECK_BOUNDS))); 6335 CONSTRUCTOR_APPEND_ELT (v, NULL_TREE, 6336 build_int_cst (integer_type_node, 6337 gfc_option.fpe_summary)); 6338 6339 array_type = build_array_type_nelts (integer_type_node, noptions); 6340 array = build_constructor (array_type, v); 6341 TREE_CONSTANT (array) = 1; 6342 TREE_STATIC (array) = 1; 6343 6344 /* Create a static variable to hold the jump table. */ 6345 var = build_decl (input_location, VAR_DECL, 6346 create_tmp_var_name ("options"), array_type); 6347 DECL_ARTIFICIAL (var) = 1; 6348 DECL_IGNORED_P (var) = 1; 6349 TREE_CONSTANT (var) = 1; 6350 TREE_STATIC (var) = 1; 6351 TREE_READONLY (var) = 1; 6352 DECL_INITIAL (var) = array; 6353 pushdecl (var); 6354 var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var); 6355 6356 tmp = build_call_expr_loc (input_location, 6357 gfor_fndecl_set_options, 2, 6358 build_int_cst (integer_type_node, noptions), var); 6359 gfc_add_expr_to_block (&body, tmp); 6360 } 6361 6362 /* If -ffpe-trap option was provided, add a call to set_fpe so that 6363 the library will raise a FPE when needed. */ 6364 if (gfc_option.fpe != 0) 6365 { 6366 tmp = build_call_expr_loc (input_location, 6367 gfor_fndecl_set_fpe, 1, 6368 build_int_cst (integer_type_node, 6369 gfc_option.fpe)); 6370 gfc_add_expr_to_block (&body, tmp); 6371 } 6372 6373 /* If this is the main program and an -fconvert option was provided, 6374 add a call to set_convert. */ 6375 6376 if (flag_convert != GFC_FLAG_CONVERT_NATIVE) 6377 { 6378 tmp = build_call_expr_loc (input_location, 6379 gfor_fndecl_set_convert, 1, 6380 build_int_cst (integer_type_node, flag_convert)); 6381 gfc_add_expr_to_block (&body, tmp); 6382 } 6383 6384 /* If this is the main program and an -frecord-marker option was provided, 6385 add a call to set_record_marker. */ 6386 6387 if (flag_record_marker != 0) 6388 { 6389 tmp = build_call_expr_loc (input_location, 6390 gfor_fndecl_set_record_marker, 1, 6391 build_int_cst (integer_type_node, 6392 flag_record_marker)); 6393 gfc_add_expr_to_block (&body, tmp); 6394 } 6395 6396 if (flag_max_subrecord_length != 0) 6397 { 6398 tmp = build_call_expr_loc (input_location, 6399 gfor_fndecl_set_max_subrecord_length, 1, 6400 build_int_cst (integer_type_node, 6401 flag_max_subrecord_length)); 6402 gfc_add_expr_to_block (&body, tmp); 6403 } 6404 6405 /* Call MAIN__(). */ 6406 tmp = build_call_expr_loc (input_location, 6407 fndecl, 0); 6408 gfc_add_expr_to_block (&body, tmp); 6409 6410 /* Mark MAIN__ as used. */ 6411 TREE_USED (fndecl) = 1; 6412 6413 /* Coarray: Call _gfortran_caf_finalize(void). */ 6414 if (flag_coarray == GFC_FCOARRAY_LIB) 6415 { 6416 tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_finalize, 0); 6417 gfc_add_expr_to_block (&body, tmp); 6418 } 6419 6420 /* "return 0". */ 6421 tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node, 6422 DECL_RESULT (ftn_main), 6423 build_int_cst (integer_type_node, 0)); 6424 tmp = build1_v (RETURN_EXPR, tmp); 6425 gfc_add_expr_to_block (&body, tmp); 6426 6427 6428 DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body); 6429 decl = getdecls (); 6430 6431 /* Finish off this function and send it for code generation. */ 6432 poplevel (1, 1); 6433 BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main; 6434 6435 DECL_SAVED_TREE (ftn_main) 6436 = fold_build3_loc (DECL_SOURCE_LOCATION (ftn_main), BIND_EXPR, 6437 void_type_node, decl, DECL_SAVED_TREE (ftn_main), 6438 DECL_INITIAL (ftn_main)); 6439 6440 /* Output the GENERIC tree. */ 6441 dump_function (TDI_original, ftn_main); 6442 6443 cgraph_node::finalize_function (ftn_main, true); 6444 6445 if (old_context) 6446 { 6447 pop_function_context (); 6448 saved_function_decls = saved_parent_function_decls; 6449 } 6450 current_function_decl = old_context; 6451 } 6452 6453 6454 /* Generate an appropriate return-statement for a procedure. */ 6455 6456 tree 6457 gfc_generate_return (void) 6458 { 6459 gfc_symbol* sym; 6460 tree result; 6461 tree fndecl; 6462 6463 sym = current_procedure_symbol; 6464 fndecl = sym->backend_decl; 6465 6466 if (TREE_TYPE (DECL_RESULT (fndecl)) == void_type_node) 6467 result = NULL_TREE; 6468 else 6469 { 6470 result = get_proc_result (sym); 6471 6472 /* Set the return value to the dummy result variable. The 6473 types may be different for scalar default REAL functions 6474 with -ff2c, therefore we have to convert. */ 6475 if (result != NULL_TREE) 6476 { 6477 result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result); 6478 result = fold_build2_loc (input_location, MODIFY_EXPR, 6479 TREE_TYPE (result), DECL_RESULT (fndecl), 6480 result); 6481 } 6482 else 6483 { 6484 /* If the function does not have a result variable, result is 6485 NULL_TREE, and a 'return' is generated without a variable. 6486 The following generates a 'return __result_XXX' where XXX is 6487 the function name. */ 6488 if (sym == sym->result && sym->attr.function && !flag_f2c) 6489 { 6490 result = gfc_get_fake_result_decl (sym, 0); 6491 result = fold_build2_loc (input_location, MODIFY_EXPR, 6492 TREE_TYPE (result), 6493 DECL_RESULT (fndecl), result); 6494 } 6495 } 6496 } 6497 6498 return build1_v (RETURN_EXPR, result); 6499 } 6500 6501 6502 static void 6503 is_from_ieee_module (gfc_symbol *sym) 6504 { 6505 if (sym->from_intmod == INTMOD_IEEE_FEATURES 6506 || sym->from_intmod == INTMOD_IEEE_EXCEPTIONS 6507 || sym->from_intmod == INTMOD_IEEE_ARITHMETIC) 6508 seen_ieee_symbol = 1; 6509 } 6510 6511 6512 static int 6513 is_ieee_module_used (gfc_namespace *ns) 6514 { 6515 seen_ieee_symbol = 0; 6516 gfc_traverse_ns (ns, is_from_ieee_module); 6517 return seen_ieee_symbol; 6518 } 6519 6520 6521 static gfc_omp_clauses *module_oacc_clauses; 6522 6523 6524 static void 6525 add_clause (gfc_symbol *sym, gfc_omp_map_op map_op) 6526 { 6527 gfc_omp_namelist *n; 6528 6529 n = gfc_get_omp_namelist (); 6530 n->sym = sym; 6531 n->u.map_op = map_op; 6532 6533 if (!module_oacc_clauses) 6534 module_oacc_clauses = gfc_get_omp_clauses (); 6535 6536 if (module_oacc_clauses->lists[OMP_LIST_MAP]) 6537 n->next = module_oacc_clauses->lists[OMP_LIST_MAP]; 6538 6539 module_oacc_clauses->lists[OMP_LIST_MAP] = n; 6540 } 6541 6542 6543 static void 6544 find_module_oacc_declare_clauses (gfc_symbol *sym) 6545 { 6546 if (sym->attr.use_assoc) 6547 { 6548 gfc_omp_map_op map_op; 6549 6550 if (sym->attr.oacc_declare_create) 6551 map_op = OMP_MAP_FORCE_ALLOC; 6552 6553 if (sym->attr.oacc_declare_copyin) 6554 map_op = OMP_MAP_FORCE_TO; 6555 6556 if (sym->attr.oacc_declare_deviceptr) 6557 map_op = OMP_MAP_FORCE_DEVICEPTR; 6558 6559 if (sym->attr.oacc_declare_device_resident) 6560 map_op = OMP_MAP_DEVICE_RESIDENT; 6561 6562 if (sym->attr.oacc_declare_create 6563 || sym->attr.oacc_declare_copyin 6564 || sym->attr.oacc_declare_deviceptr 6565 || sym->attr.oacc_declare_device_resident) 6566 { 6567 sym->attr.referenced = 1; 6568 add_clause (sym, map_op); 6569 } 6570 } 6571 } 6572 6573 6574 void 6575 finish_oacc_declare (gfc_namespace *ns, gfc_symbol *sym, bool block) 6576 { 6577 gfc_code *code; 6578 gfc_oacc_declare *oc; 6579 locus where = gfc_current_locus; 6580 gfc_omp_clauses *omp_clauses = NULL; 6581 gfc_omp_namelist *n, *p; 6582 6583 module_oacc_clauses = NULL; 6584 gfc_traverse_ns (ns, find_module_oacc_declare_clauses); 6585 6586 if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM) 6587 { 6588 gfc_oacc_declare *new_oc; 6589 6590 new_oc = gfc_get_oacc_declare (); 6591 new_oc->next = ns->oacc_declare; 6592 new_oc->clauses = module_oacc_clauses; 6593 6594 ns->oacc_declare = new_oc; 6595 } 6596 6597 if (!ns->oacc_declare) 6598 return; 6599 6600 for (oc = ns->oacc_declare; oc; oc = oc->next) 6601 { 6602 if (oc->module_var) 6603 continue; 6604 6605 if (block) 6606 gfc_error ("Sorry, !$ACC DECLARE at %L is not allowed " 6607 "in BLOCK construct", &oc->loc); 6608 6609 6610 if (oc->clauses && oc->clauses->lists[OMP_LIST_MAP]) 6611 { 6612 if (omp_clauses == NULL) 6613 { 6614 omp_clauses = oc->clauses; 6615 continue; 6616 } 6617 6618 for (n = oc->clauses->lists[OMP_LIST_MAP]; n; p = n, n = n->next) 6619 ; 6620 6621 gcc_assert (p->next == NULL); 6622 6623 p->next = omp_clauses->lists[OMP_LIST_MAP]; 6624 omp_clauses = oc->clauses; 6625 } 6626 } 6627 6628 if (!omp_clauses) 6629 return; 6630 6631 for (n = omp_clauses->lists[OMP_LIST_MAP]; n; n = n->next) 6632 { 6633 switch (n->u.map_op) 6634 { 6635 case OMP_MAP_DEVICE_RESIDENT: 6636 n->u.map_op = OMP_MAP_FORCE_ALLOC; 6637 break; 6638 6639 default: 6640 break; 6641 } 6642 } 6643 6644 code = XCNEW (gfc_code); 6645 code->op = EXEC_OACC_DECLARE; 6646 code->loc = where; 6647 6648 code->ext.oacc_declare = gfc_get_oacc_declare (); 6649 code->ext.oacc_declare->clauses = omp_clauses; 6650 6651 code->block = XCNEW (gfc_code); 6652 code->block->op = EXEC_OACC_DECLARE; 6653 code->block->loc = where; 6654 6655 if (ns->code) 6656 code->block->next = ns->code; 6657 6658 ns->code = code; 6659 6660 return; 6661 } 6662 6663 static void 6664 gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t *finally, 6665 tree cfi_desc, tree gfc_desc, gfc_symbol *sym) 6666 { 6667 stmtblock_t block; 6668 gfc_init_block (&block); 6669 tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc); 6670 tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE; 6671 bool do_copy_inout = false; 6672 6673 /* When allocatable + intent out, free the cfi descriptor. */ 6674 if (sym->attr.allocatable && sym->attr.intent == INTENT_OUT) 6675 { 6676 tmp = gfc_get_cfi_desc_base_addr (cfi); 6677 tree call = builtin_decl_explicit (BUILT_IN_FREE); 6678 call = build_call_expr_loc (input_location, call, 1, tmp); 6679 gfc_add_expr_to_block (&block, fold_convert (void_type_node, call)); 6680 gfc_add_modify (&block, tmp, 6681 fold_convert (TREE_TYPE (tmp), null_pointer_node)); 6682 } 6683 6684 /* -fcheck=bound: Do version, rank, attribute, type and is-NULL checks. */ 6685 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) 6686 { 6687 char *msg; 6688 tree tmp3; 6689 msg = xasprintf ("Unexpected version %%d (expected %d) in CFI descriptor " 6690 "passed to dummy argument %s", CFI_VERSION, sym->name); 6691 tmp2 = gfc_get_cfi_desc_version (cfi); 6692 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2, 6693 build_int_cst (TREE_TYPE (tmp2), CFI_VERSION)); 6694 gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, 6695 msg, tmp2); 6696 free (msg); 6697 6698 /* Rank check; however, for character(len=*), assumed/explicit-size arrays 6699 are permitted to differ in rank according to the Fortran rules. */ 6700 if (sym->as && sym->as->type != AS_ASSUMED_SIZE 6701 && sym->as->type != AS_EXPLICIT) 6702 { 6703 if (sym->as->rank != -1) 6704 msg = xasprintf ("Invalid rank %%d (expected %d) in CFI descriptor " 6705 "passed to dummy argument %s", sym->as->rank, 6706 sym->name); 6707 else 6708 msg = xasprintf ("Invalid rank %%d (expected 0..%d) in CFI " 6709 "descriptor passed to dummy argument %s", 6710 CFI_MAX_RANK, sym->name); 6711 6712 tmp3 = tmp2 = tmp = gfc_get_cfi_desc_rank (cfi); 6713 if (sym->as->rank != -1) 6714 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6715 tmp, build_int_cst (signed_char_type_node, 6716 sym->as->rank)); 6717 else 6718 { 6719 tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, 6720 tmp, build_zero_cst (TREE_TYPE (tmp))); 6721 tmp2 = fold_build2_loc (input_location, GT_EXPR, 6722 boolean_type_node, tmp2, 6723 build_int_cst (TREE_TYPE (tmp2), 6724 CFI_MAX_RANK)); 6725 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6726 boolean_type_node, tmp, tmp2); 6727 } 6728 gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, 6729 msg, tmp3); 6730 free (msg); 6731 } 6732 6733 tmp3 = tmp = gfc_get_cfi_desc_attribute (cfi); 6734 if (sym->attr.allocatable || sym->attr.pointer) 6735 { 6736 int attr = (sym->attr.pointer ? CFI_attribute_pointer 6737 : CFI_attribute_allocatable); 6738 msg = xasprintf ("Invalid attribute %%d (expected %d) in CFI " 6739 "descriptor passed to dummy argument %s with %s " 6740 "attribute", attr, sym->name, 6741 sym->attr.pointer ? "pointer" : "allocatable"); 6742 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6743 tmp, build_int_cst (TREE_TYPE (tmp), attr)); 6744 } 6745 else 6746 { 6747 int amin = MIN (CFI_attribute_pointer, 6748 MIN (CFI_attribute_allocatable, CFI_attribute_other)); 6749 int amax = MAX (CFI_attribute_pointer, 6750 MAX (CFI_attribute_allocatable, CFI_attribute_other)); 6751 msg = xasprintf ("Invalid attribute %%d (expected %d..%d) in CFI " 6752 "descriptor passed to nonallocatable, nonpointer " 6753 "dummy argument %s", amin, amax, sym->name); 6754 tmp2 = tmp; 6755 tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, tmp, 6756 build_int_cst (TREE_TYPE (tmp), amin)); 6757 tmp2 = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp2, 6758 build_int_cst (TREE_TYPE (tmp2), amax)); 6759 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, 6760 boolean_type_node, tmp, tmp2); 6761 gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, 6762 msg, tmp3); 6763 free (msg); 6764 msg = xasprintf ("Invalid unallocatated/unassociated CFI " 6765 "descriptor passed to nonallocatable, nonpointer " 6766 "dummy argument %s", sym->name); 6767 tmp3 = tmp = gfc_get_cfi_desc_base_addr (cfi), 6768 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 6769 tmp, null_pointer_node); 6770 } 6771 gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, 6772 msg, tmp3); 6773 free (msg); 6774 6775 if (sym->ts.type != BT_ASSUMED) 6776 { 6777 int type = CFI_type_other; 6778 if (sym->ts.f90_type == BT_VOID) 6779 { 6780 type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR 6781 ? CFI_type_cfunptr : CFI_type_cptr); 6782 } 6783 else 6784 switch (sym->ts.type) 6785 { 6786 case BT_INTEGER: 6787 case BT_LOGICAL: 6788 case BT_REAL: 6789 case BT_COMPLEX: 6790 type = CFI_type_from_type_kind (sym->ts.type, sym->ts.kind); 6791 break; 6792 case BT_CHARACTER: 6793 type = CFI_type_from_type_kind (CFI_type_Character, 6794 sym->ts.kind); 6795 break; 6796 case BT_DERIVED: 6797 type = CFI_type_struct; 6798 break; 6799 case BT_VOID: 6800 type = (sym->ts.u.derived->intmod_sym_id == ISOCBINDING_FUNPTR 6801 ? CFI_type_cfunptr : CFI_type_cptr); 6802 break; 6803 case BT_ASSUMED: 6804 case BT_CLASS: 6805 case BT_PROCEDURE: 6806 case BT_HOLLERITH: 6807 case BT_UNION: 6808 case BT_BOZ: 6809 case BT_UNKNOWN: 6810 gcc_unreachable (); 6811 } 6812 msg = xasprintf ("Unexpected type %%d (expected %d) in CFI descriptor" 6813 " passed to dummy argument %s", type, sym->name); 6814 tmp2 = tmp = gfc_get_cfi_desc_type (cfi); 6815 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6816 tmp, build_int_cst (TREE_TYPE (tmp), type)); 6817 gfc_trans_runtime_check (true, false, tmp, &block, &sym->declared_at, 6818 msg, tmp2); 6819 free (msg); 6820 } 6821 } 6822 6823 if (!sym->attr.referenced) 6824 goto done; 6825 6826 /* Set string length for len=* and len=:, otherwise, it is already set. */ 6827 if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) 6828 { 6829 tmp = fold_convert (gfc_array_index_type, 6830 gfc_get_cfi_desc_elem_len (cfi)); 6831 if (sym->ts.kind != 1) 6832 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 6833 gfc_array_index_type, tmp, 6834 build_int_cst (gfc_charlen_type_node, 6835 sym->ts.kind)); 6836 gfc_add_modify (&block, sym->ts.u.cl->backend_decl, tmp); 6837 } 6838 6839 if (sym->ts.type == BT_CHARACTER 6840 && !INTEGER_CST_P (sym->ts.u.cl->backend_decl)) 6841 { 6842 gfc_conv_string_length (sym->ts.u.cl, NULL, init); 6843 gfc_trans_vla_type_sizes (sym, init); 6844 } 6845 6846 /* gfc->data = cfi->base_addr - or for scalars: gfc = cfi->base_addr. 6847 assumed-size/explicit-size arrays end up here for character(len=*) 6848 only. */ 6849 if (!sym->attr.dimension || !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 6850 { 6851 tmp = gfc_get_cfi_desc_base_addr (cfi); 6852 gfc_add_modify (&block, gfc_desc, 6853 fold_convert (TREE_TYPE (gfc_desc), tmp)); 6854 if (!sym->attr.dimension) 6855 goto done; 6856 } 6857 6858 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 6859 { 6860 /* gfc->dtype = ... (from declaration, not from cfi). */ 6861 etype = gfc_get_element_type (TREE_TYPE (gfc_desc)); 6862 gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc), 6863 gfc_get_dtype_rank_type (sym->as->rank, etype)); 6864 /* gfc->data = cfi->base_addr. */ 6865 gfc_conv_descriptor_data_set (&block, gfc_desc, 6866 gfc_get_cfi_desc_base_addr (cfi)); 6867 } 6868 6869 if (sym->ts.type == BT_ASSUMED) 6870 { 6871 /* For type(*), take elem_len + dtype.type from the actual argument. */ 6872 gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc), 6873 gfc_get_cfi_desc_elem_len (cfi)); 6874 tree cond; 6875 tree ctype = gfc_get_cfi_desc_type (cfi); 6876 ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype), 6877 ctype, build_int_cst (TREE_TYPE (ctype), 6878 CFI_type_mask)); 6879 tree type = gfc_conv_descriptor_type (gfc_desc); 6880 6881 /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */ 6882 /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */ 6883 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6884 build_int_cst (TREE_TYPE (ctype), CFI_type_cptr)); 6885 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, 6886 build_int_cst (TREE_TYPE (type), BT_VOID)); 6887 tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 6888 type, 6889 build_int_cst (TREE_TYPE (type), BT_UNKNOWN)); 6890 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6891 tmp, tmp2); 6892 /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */ 6893 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6894 build_int_cst (TREE_TYPE (ctype), 6895 CFI_type_struct)); 6896 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, 6897 build_int_cst (TREE_TYPE (type), BT_DERIVED)); 6898 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6899 tmp, tmp2); 6900 /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */ 6901 /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if' 6902 before (see below, as generated bottom up). */ 6903 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6904 build_int_cst (TREE_TYPE (ctype), 6905 CFI_type_Character)); 6906 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, 6907 build_int_cst (TREE_TYPE (type), BT_CHARACTER)); 6908 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6909 tmp, tmp2); 6910 /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */ 6911 /* Note: gfc->elem_len = cfi->elem_len/4. */ 6912 /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave 6913 gfc->elem_len == cfi->elem_len, which helps with operations which use 6914 sizeof() in Fortran and cfi->elem_len in C. */ 6915 tmp = gfc_get_cfi_desc_type (cfi); 6916 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp, 6917 build_int_cst (TREE_TYPE (tmp), 6918 CFI_type_ucs4_char)); 6919 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, 6920 build_int_cst (TREE_TYPE (type), BT_CHARACTER)); 6921 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6922 tmp, tmp2); 6923 /* if (CFI_type_Complex) BT_COMPLEX + cfi->elem_len/2 else < tmp2 > */ 6924 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6925 build_int_cst (TREE_TYPE (ctype), 6926 CFI_type_Complex)); 6927 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type, 6928 build_int_cst (TREE_TYPE (type), BT_COMPLEX)); 6929 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6930 tmp, tmp2); 6931 /* if (CFI_type_Integer || CFI_type_Logical || CFI_type_Real) 6932 ctype else <tmp2> */ 6933 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6934 build_int_cst (TREE_TYPE (ctype), 6935 CFI_type_Integer)); 6936 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6937 build_int_cst (TREE_TYPE (ctype), 6938 CFI_type_Logical)); 6939 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 6940 cond, tmp); 6941 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, ctype, 6942 build_int_cst (TREE_TYPE (ctype), 6943 CFI_type_Real)); 6944 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 6945 cond, tmp); 6946 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 6947 type, fold_convert (TREE_TYPE (type), ctype)); 6948 tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, 6949 tmp, tmp2); 6950 gfc_add_expr_to_block (&block, tmp2); 6951 } 6952 6953 if (sym->as->rank < 0) 6954 { 6955 /* Set gfc->dtype.rank, if assumed-rank. */ 6956 rank = gfc_get_cfi_desc_rank (cfi); 6957 gfc_add_modify (&block, gfc_conv_descriptor_rank (gfc_desc), rank); 6958 } 6959 else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 6960 /* In that case, the CFI rank and the declared rank can differ. */ 6961 rank = gfc_get_cfi_desc_rank (cfi); 6962 else 6963 rank = build_int_cst (signed_char_type_node, sym->as->rank); 6964 6965 /* With bind(C), the standard requires that both Fortran callers and callees 6966 handle noncontiguous arrays passed to an dummy with 'contiguous' attribute 6967 and with character(len=*) + assumed-size/explicit-size arrays. 6968 cf. Fortran 2018, 18.3.6, paragraph 5 (and for the caller: para. 6). */ 6969 if ((sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length 6970 && (sym->as->type == AS_ASSUMED_SIZE || sym->as->type == AS_EXPLICIT)) 6971 || sym->attr.contiguous) 6972 { 6973 do_copy_inout = true; 6974 gcc_assert (!sym->attr.pointer); 6975 stmtblock_t block2; 6976 tree data; 6977 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 6978 data = gfc_conv_descriptor_data_get (gfc_desc); 6979 else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) 6980 data = gfc_build_addr_expr (NULL, gfc_desc); 6981 else 6982 data = gfc_desc; 6983 6984 /* Is copy-in/out needed? */ 6985 /* do_copyin = rank != 0 && !assumed-size */ 6986 tree cond_var = gfc_create_var (boolean_type_node, "do_copyin"); 6987 tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6988 rank, build_zero_cst (TREE_TYPE (rank))); 6989 /* dim[rank-1].extent != -1 -> assumed size*/ 6990 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (rank), 6991 rank, build_int_cst (TREE_TYPE (rank), 1)); 6992 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 6993 gfc_get_cfi_dim_extent (cfi, tmp), 6994 build_int_cst (gfc_array_index_type, -1)); 6995 cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, 6996 boolean_type_node, cond, tmp); 6997 gfc_add_modify (&block, cond_var, cond); 6998 /* if (do_copyin) do_copyin = ... || ... || ... */ 6999 gfc_init_block (&block2); 7000 /* dim[0].sm != elem_len */ 7001 tmp = fold_convert (gfc_array_index_type, 7002 gfc_get_cfi_desc_elem_len (cfi)); 7003 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7004 gfc_get_cfi_dim_sm (cfi, gfc_index_zero_node), 7005 tmp); 7006 gfc_add_modify (&block2, cond_var, cond); 7007 7008 /* for (i = 1; i < rank; ++i) 7009 cond &&= dim[i].sm != (dv->dim[i - 1].sm * dv->dim[i - 1].extent) */ 7010 idx = gfc_create_var (TREE_TYPE (rank), "idx"); 7011 stmtblock_t loop_body; 7012 gfc_init_block (&loop_body); 7013 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), 7014 idx, build_int_cst (TREE_TYPE (idx), 1)); 7015 tree tmp2 = gfc_get_cfi_dim_sm (cfi, tmp); 7016 tmp = gfc_get_cfi_dim_extent (cfi, tmp); 7017 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), 7018 tmp2, tmp); 7019 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7020 gfc_get_cfi_dim_sm (cfi, idx), tmp); 7021 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node, 7022 cond_var, cond); 7023 gfc_add_modify (&loop_body, cond_var, cond); 7024 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), 7025 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 7026 gfc_finish_block (&loop_body)); 7027 tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), 7028 build_empty_stmt (input_location)); 7029 gfc_add_expr_to_block (&block, tmp); 7030 7031 /* Copy-in body. */ 7032 gfc_init_block (&block2); 7033 /* size = dim[0].extent; for (i = 1; i < rank; ++i) size *= dim[i].extent */ 7034 size_var = gfc_create_var (size_type_node, "size"); 7035 tmp = fold_convert (size_type_node, 7036 gfc_get_cfi_dim_extent (cfi, gfc_index_zero_node)); 7037 gfc_add_modify (&block2, size_var, tmp); 7038 7039 gfc_init_block (&loop_body); 7040 tmp = fold_convert (size_type_node, 7041 gfc_get_cfi_dim_extent (cfi, idx)); 7042 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 7043 size_var, fold_convert (size_type_node, tmp)); 7044 gfc_add_modify (&loop_body, size_var, tmp); 7045 gfc_simple_for_loop (&block2, idx, build_int_cst (TREE_TYPE (idx), 1), 7046 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 7047 gfc_finish_block (&loop_body)); 7048 /* data = malloc (size * elem_len) */ 7049 tmp = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 7050 size_var, gfc_get_cfi_desc_elem_len (cfi)); 7051 tree call = builtin_decl_explicit (BUILT_IN_MALLOC); 7052 call = build_call_expr_loc (input_location, call, 1, tmp); 7053 gfc_add_modify (&block2, data, fold_convert (TREE_TYPE (data), call)); 7054 7055 /* Copy the data: 7056 for (idx = 0; idx < size; ++idx) 7057 { 7058 shift = 0; 7059 tmpidx = idx 7060 for (dim = 0; dim < rank; ++dim) 7061 { 7062 shift += (tmpidx % extent[d]) * sm[d] 7063 tmpidx = tmpidx / extend[d] 7064 } 7065 memcpy (lhs + idx*elem_len, rhs + shift, elem_len) 7066 } .*/ 7067 idx = gfc_create_var (size_type_node, "arrayidx"); 7068 gfc_init_block (&loop_body); 7069 tree shift = gfc_create_var (size_type_node, "shift"); 7070 tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); 7071 gfc_add_modify (&loop_body, shift, build_zero_cst (TREE_TYPE (shift))); 7072 gfc_add_modify (&loop_body, tmpidx, idx); 7073 stmtblock_t inner_loop; 7074 gfc_init_block (&inner_loop); 7075 tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); 7076 /* shift += (tmpidx % extent[d]) * sm[d] */ 7077 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, 7078 size_type_node, tmpidx, 7079 fold_convert (size_type_node, 7080 gfc_get_cfi_dim_extent (cfi, dim))); 7081 tmp = fold_build2_loc (input_location, MULT_EXPR, 7082 size_type_node, tmp, 7083 fold_convert (size_type_node, 7084 gfc_get_cfi_dim_sm (cfi, dim))); 7085 gfc_add_modify (&inner_loop, shift, 7086 fold_build2_loc (input_location, PLUS_EXPR, 7087 size_type_node, shift, tmp)); 7088 /* tmpidx = tmpidx / extend[d] */ 7089 tmp = fold_convert (size_type_node, gfc_get_cfi_dim_extent (cfi, dim)); 7090 gfc_add_modify (&inner_loop, tmpidx, 7091 fold_build2_loc (input_location, TRUNC_DIV_EXPR, 7092 size_type_node, tmpidx, tmp)); 7093 gfc_simple_for_loop (&loop_body, dim, build_zero_cst (TREE_TYPE (rank)), 7094 rank, LT_EXPR, build_int_cst (TREE_TYPE (dim), 1), 7095 gfc_finish_block (&inner_loop)); 7096 /* Assign. */ 7097 tmp = fold_convert (pchar_type_node, gfc_get_cfi_desc_base_addr (cfi)); 7098 tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); 7099 tree lhs; 7100 /* memcpy (lhs + idx*elem_len, rhs + shift, elem_len) */ 7101 tree elem_len; 7102 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 7103 elem_len = gfc_conv_descriptor_elem_len (gfc_desc); 7104 else 7105 elem_len = gfc_get_cfi_desc_elem_len (cfi); 7106 lhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 7107 elem_len, idx); 7108 lhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, pchar_type_node, 7109 fold_convert (pchar_type_node, data), lhs); 7110 tmp = fold_convert (pvoid_type_node, tmp); 7111 lhs = fold_convert (pvoid_type_node, lhs); 7112 call = builtin_decl_explicit (BUILT_IN_MEMCPY); 7113 call = build_call_expr_loc (input_location, call, 3, lhs, tmp, elem_len); 7114 gfc_add_expr_to_block (&loop_body, fold_convert (void_type_node, call)); 7115 gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), 7116 size_var, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 7117 gfc_finish_block (&loop_body)); 7118 /* if (cond) { block2 } */ 7119 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 7120 data, fold_convert (TREE_TYPE (data), 7121 null_pointer_node)); 7122 tmp = build3_v (COND_EXPR, cond_var, gfc_finish_block (&block2), 7123 build_empty_stmt (input_location)); 7124 gfc_add_expr_to_block (&block, tmp); 7125 } 7126 7127 if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 7128 { 7129 tree offset, type; 7130 type = TREE_TYPE (gfc_desc); 7131 gfc_trans_array_bounds (type, sym, &offset, &block); 7132 if (VAR_P (GFC_TYPE_ARRAY_OFFSET (type))) 7133 gfc_add_modify (&block, GFC_TYPE_ARRAY_OFFSET (type), offset); 7134 goto done; 7135 } 7136 7137 /* If cfi->data != NULL. */ 7138 stmtblock_t block2; 7139 gfc_init_block (&block2); 7140 7141 /* if do_copy_inout: gfc->dspan = gfc->dtype.elem_len 7142 We use gfc instead of cfi on the RHS as this might be a constant. */ 7143 tmp = fold_convert (gfc_array_index_type, 7144 gfc_conv_descriptor_elem_len (gfc_desc)); 7145 if (!do_copy_inout) 7146 { 7147 /* gfc->dspan = ((cfi->dim[0].sm % gfc->elem_len) 7148 ? cfi->dim[0].sm : gfc->elem_len). */ 7149 tree cond; 7150 tree tmp2 = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]); 7151 cond = fold_build2_loc (input_location, TRUNC_MOD_EXPR, 7152 gfc_array_index_type, tmp2, tmp); 7153 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7154 cond, gfc_index_zero_node); 7155 tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, 7156 tmp2, tmp); 7157 } 7158 gfc_conv_descriptor_span_set (&block2, gfc_desc, tmp); 7159 7160 /* Calculate offset + set lbound, ubound and stride. */ 7161 gfc_conv_descriptor_offset_set (&block2, gfc_desc, gfc_index_zero_node); 7162 if (sym->as->rank > 0 && !sym->attr.pointer && !sym->attr.allocatable) 7163 for (int i = 0; i < sym->as->rank; ++i) 7164 { 7165 gfc_se se; 7166 gfc_init_se (&se, NULL ); 7167 if (sym->as->lower[i]) 7168 { 7169 gfc_conv_expr (&se, sym->as->lower[i]); 7170 tmp = se.expr; 7171 } 7172 else 7173 tmp = gfc_index_one_node; 7174 gfc_add_block_to_block (&block2, &se.pre); 7175 gfc_conv_descriptor_lbound_set (&block2, gfc_desc, gfc_rank_cst[i], 7176 tmp); 7177 gfc_add_block_to_block (&block2, &se.post); 7178 } 7179 7180 /* Loop: for (i = 0; i < rank; ++i). */ 7181 idx = gfc_create_var (TREE_TYPE (rank), "idx"); 7182 7183 /* Loop body. */ 7184 stmtblock_t loop_body; 7185 gfc_init_block (&loop_body); 7186 /* gfc->dim[i].lbound = ... */ 7187 if (sym->attr.pointer || sym->attr.allocatable) 7188 { 7189 tmp = gfc_get_cfi_dim_lbound (cfi, idx); 7190 gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, tmp); 7191 } 7192 else if (sym->as->rank < 0) 7193 gfc_conv_descriptor_lbound_set (&loop_body, gfc_desc, idx, 7194 gfc_index_one_node); 7195 7196 /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */ 7197 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 7198 gfc_conv_descriptor_lbound_get (gfc_desc, idx), 7199 gfc_index_one_node); 7200 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, 7201 gfc_get_cfi_dim_extent (cfi, idx), tmp); 7202 gfc_conv_descriptor_ubound_set (&loop_body, gfc_desc, idx, tmp); 7203 7204 if (do_copy_inout) 7205 { 7206 /* gfc->dim[i].stride 7207 = idx == 0 ? 1 : gfc->dim[i-1].stride * cfi->dim[i-1].extent */ 7208 tree cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, 7209 idx, build_zero_cst (TREE_TYPE (idx))); 7210 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (idx), 7211 idx, build_int_cst (TREE_TYPE (idx), 1)); 7212 tree tmp2 = gfc_get_cfi_dim_extent (cfi, tmp); 7213 tmp = gfc_conv_descriptor_stride_get (gfc_desc, tmp); 7214 tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp2), 7215 tmp2, tmp); 7216 tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond, 7217 gfc_index_one_node, tmp); 7218 } 7219 else 7220 { 7221 /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */ 7222 tmp = gfc_get_cfi_dim_sm (cfi, idx); 7223 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, 7224 gfc_array_index_type, tmp, 7225 fold_convert (gfc_array_index_type, 7226 gfc_get_cfi_desc_elem_len (cfi))); 7227 } 7228 gfc_conv_descriptor_stride_set (&loop_body, gfc_desc, idx, tmp); 7229 /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */ 7230 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 7231 gfc_conv_descriptor_stride_get (gfc_desc, idx), 7232 gfc_conv_descriptor_lbound_get (gfc_desc, idx)); 7233 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 7234 gfc_conv_descriptor_offset_get (gfc_desc), tmp); 7235 gfc_conv_descriptor_offset_set (&loop_body, gfc_desc, tmp); 7236 7237 /* Generate loop. */ 7238 gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), 7239 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 7240 gfc_finish_block (&loop_body)); 7241 if (sym->attr.allocatable || sym->attr.pointer) 7242 { 7243 tmp = gfc_get_cfi_desc_base_addr (cfi), 7244 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7245 tmp, null_pointer_node); 7246 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2), 7247 build_empty_stmt (input_location)); 7248 gfc_add_expr_to_block (&block, tmp); 7249 } 7250 else 7251 gfc_add_block_to_block (&block, &block2); 7252 7253 done: 7254 /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ 7255 if (sym->attr.optional) 7256 { 7257 tree present = fold_build2_loc (input_location, NE_EXPR, 7258 boolean_type_node, cfi_desc, 7259 null_pointer_node); 7260 tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, 7261 sym->backend_decl, 7262 fold_convert (TREE_TYPE (sym->backend_decl), 7263 null_pointer_node)); 7264 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), tmp); 7265 gfc_add_expr_to_block (init, tmp); 7266 } 7267 else 7268 gfc_add_block_to_block (init, &block); 7269 7270 if (!sym->attr.referenced) 7271 return; 7272 7273 /* If pointer not changed, nothing to be done (except copy out) */ 7274 if (!do_copy_inout && ((!sym->attr.pointer && !sym->attr.allocatable) 7275 || sym->attr.intent == INTENT_IN)) 7276 return; 7277 7278 gfc_init_block (&block); 7279 7280 /* For bind(C), Fortran does not permit mixing 'pointer' with 'contiguous' (or 7281 len=*). Thus, when copy out is needed, the bounds ofthe descriptor remain 7282 unchanged. */ 7283 if (do_copy_inout) 7284 { 7285 tree data, call; 7286 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 7287 data = gfc_conv_descriptor_data_get (gfc_desc); 7288 else if (!POINTER_TYPE_P (TREE_TYPE (gfc_desc))) 7289 data = gfc_build_addr_expr (NULL, gfc_desc); 7290 else 7291 data = gfc_desc; 7292 gfc_init_block (&block2); 7293 if (sym->attr.intent != INTENT_IN) 7294 { 7295 /* First, create the inner copy-out loop. 7296 for (idx = 0; idx < size; ++idx) 7297 { 7298 shift = 0; 7299 tmpidx = idx 7300 for (dim = 0; dim < rank; ++dim) 7301 { 7302 shift += (tmpidx % extent[d]) * sm[d] 7303 tmpidx = tmpidx / extend[d] 7304 } 7305 memcpy (lhs + shift, rhs + idx*elem_len, elem_len) 7306 } .*/ 7307 stmtblock_t loop_body; 7308 idx = gfc_create_var (size_type_node, "arrayidx"); 7309 gfc_init_block (&loop_body); 7310 tree shift = gfc_create_var (size_type_node, "shift"); 7311 tree tmpidx = gfc_create_var (size_type_node, "tmpidx"); 7312 gfc_add_modify (&loop_body, shift, 7313 build_zero_cst (TREE_TYPE (shift))); 7314 gfc_add_modify (&loop_body, tmpidx, idx); 7315 stmtblock_t inner_loop; 7316 gfc_init_block (&inner_loop); 7317 tree dim = gfc_create_var (TREE_TYPE (rank), "dim"); 7318 /* shift += (tmpidx % extent[d]) * sm[d] */ 7319 tmp = fold_convert (size_type_node, 7320 gfc_get_cfi_dim_extent (cfi, dim)); 7321 tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR, 7322 size_type_node, tmpidx, tmp); 7323 tmp = fold_build2_loc (input_location, MULT_EXPR, 7324 size_type_node, tmp, 7325 fold_convert (size_type_node, 7326 gfc_get_cfi_dim_sm (cfi, dim))); 7327 gfc_add_modify (&inner_loop, shift, 7328 fold_build2_loc (input_location, PLUS_EXPR, 7329 size_type_node, shift, tmp)); 7330 /* tmpidx = tmpidx / extend[d] */ 7331 tmp = fold_convert (size_type_node, 7332 gfc_get_cfi_dim_extent (cfi, dim)); 7333 gfc_add_modify (&inner_loop, tmpidx, 7334 fold_build2_loc (input_location, TRUNC_DIV_EXPR, 7335 size_type_node, tmpidx, tmp)); 7336 gfc_simple_for_loop (&loop_body, dim, 7337 build_zero_cst (TREE_TYPE (rank)), rank, LT_EXPR, 7338 build_int_cst (TREE_TYPE (dim), 1), 7339 gfc_finish_block (&inner_loop)); 7340 /* Assign. */ 7341 tree rhs; 7342 tmp = fold_convert (pchar_type_node, 7343 gfc_get_cfi_desc_base_addr (cfi)); 7344 tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, tmp, shift); 7345 /* memcpy (lhs + shift, rhs + idx*elem_len, elem_len) */ 7346 tree elem_len; 7347 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc))) 7348 elem_len = gfc_conv_descriptor_elem_len (gfc_desc); 7349 else 7350 elem_len = gfc_get_cfi_desc_elem_len (cfi); 7351 rhs = fold_build2_loc (input_location, MULT_EXPR, size_type_node, 7352 elem_len, idx); 7353 rhs = fold_build2_loc (input_location, POINTER_PLUS_EXPR, 7354 pchar_type_node, 7355 fold_convert (pchar_type_node, data), rhs); 7356 tmp = fold_convert (pvoid_type_node, tmp); 7357 rhs = fold_convert (pvoid_type_node, rhs); 7358 call = builtin_decl_explicit (BUILT_IN_MEMCPY); 7359 call = build_call_expr_loc (input_location, call, 3, tmp, rhs, 7360 elem_len); 7361 gfc_add_expr_to_block (&loop_body, 7362 fold_convert (void_type_node, call)); 7363 gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), 7364 size_var, LT_EXPR, 7365 build_int_cst (TREE_TYPE (idx), 1), 7366 gfc_finish_block (&loop_body)); 7367 } 7368 call = builtin_decl_explicit (BUILT_IN_FREE); 7369 call = build_call_expr_loc (input_location, call, 1, data); 7370 gfc_add_expr_to_block (&block2, call); 7371 7372 /* if (cfi->base_addr != gfc->data) { copy out; free(var) }; return */ 7373 tree tmp2 = gfc_get_cfi_desc_base_addr (cfi); 7374 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7375 tmp2, fold_convert (TREE_TYPE (tmp2), data)); 7376 tmp = build3_v (COND_EXPR, tmp2, gfc_finish_block (&block2), 7377 build_empty_stmt (input_location)); 7378 gfc_add_expr_to_block (&block, tmp); 7379 goto done_finally; 7380 } 7381 7382 /* Update pointer + array data data on exit. */ 7383 tmp = gfc_get_cfi_desc_base_addr (cfi); 7384 tmp2 = (!sym->attr.dimension 7385 ? gfc_desc : gfc_conv_descriptor_data_get (gfc_desc)); 7386 gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), tmp2)); 7387 7388 /* Set string length for len=:, only. */ 7389 if (sym->ts.type == BT_CHARACTER && !sym->ts.u.cl->length) 7390 { 7391 tmp = sym->ts.u.cl->backend_decl; 7392 if (sym->ts.kind != 1) 7393 tmp = fold_build2_loc (input_location, MULT_EXPR, 7394 gfc_array_index_type, 7395 sym->ts.u.cl->backend_decl, tmp); 7396 tmp2 = gfc_get_cfi_desc_elem_len (cfi); 7397 gfc_add_modify (&block, tmp2, fold_convert (TREE_TYPE (tmp2), tmp)); 7398 } 7399 7400 if (!sym->attr.dimension) 7401 goto done_finally; 7402 7403 gfc_init_block (&block2); 7404 7405 /* Loop: for (i = 0; i < rank; ++i). */ 7406 idx = gfc_create_var (TREE_TYPE (rank), "idx"); 7407 7408 /* Loop body. */ 7409 gfc_init_block (&loop_body); 7410 /* cfi->dim[i].lower_bound = gfc->dim[i].lbound */ 7411 gfc_add_modify (&loop_body, gfc_get_cfi_dim_lbound (cfi, idx), 7412 gfc_conv_descriptor_lbound_get (gfc_desc, idx)); 7413 /* cfi->dim[i].extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1. */ 7414 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, 7415 gfc_conv_descriptor_ubound_get (gfc_desc, idx), 7416 gfc_conv_descriptor_lbound_get (gfc_desc, idx)); 7417 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, tmp, 7418 gfc_index_one_node); 7419 gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp); 7420 /* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */ 7421 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, 7422 gfc_conv_descriptor_stride_get (gfc_desc, idx), 7423 gfc_conv_descriptor_span_get (gfc_desc)); 7424 gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp); 7425 7426 /* Generate loop. */ 7427 gfc_simple_for_loop (&block2, idx, build_zero_cst (TREE_TYPE (idx)), 7428 rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1), 7429 gfc_finish_block (&loop_body)); 7430 /* if (gfc->data != NULL) { block2 }. */ 7431 tmp = gfc_get_cfi_desc_base_addr (cfi), 7432 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, 7433 tmp, null_pointer_node); 7434 tmp = build3_v (COND_EXPR, tmp, gfc_finish_block (&block2), 7435 build_empty_stmt (input_location)); 7436 gfc_add_expr_to_block (&block, tmp); 7437 7438 done_finally: 7439 /* If optional arg: 'if (arg) { block } else { local_arg = NULL; }'. */ 7440 if (sym->attr.optional) 7441 { 7442 tree present = fold_build2_loc (input_location, NE_EXPR, 7443 boolean_type_node, cfi_desc, 7444 null_pointer_node); 7445 tmp = build3_v (COND_EXPR, present, gfc_finish_block (&block), 7446 build_empty_stmt (input_location)); 7447 gfc_add_expr_to_block (finally, tmp); 7448 } 7449 else 7450 gfc_add_block_to_block (finally, &block); 7451 } 7452 7453 /* Generate code for a function. */ 7454 7455 void 7456 gfc_generate_function_code (gfc_namespace * ns) 7457 { 7458 tree fndecl; 7459 tree old_context; 7460 tree decl; 7461 tree tmp; 7462 tree fpstate = NULL_TREE; 7463 stmtblock_t init, cleanup, outer_block; 7464 stmtblock_t body; 7465 gfc_wrapped_block try_block; 7466 tree recurcheckvar = NULL_TREE; 7467 gfc_symbol *sym; 7468 gfc_symbol *previous_procedure_symbol; 7469 int rank, ieee; 7470 bool is_recursive; 7471 7472 sym = ns->proc_name; 7473 previous_procedure_symbol = current_procedure_symbol; 7474 current_procedure_symbol = sym; 7475 7476 /* Initialize sym->tlink so that gfc_trans_deferred_vars does not get 7477 lost or worse. */ 7478 sym->tlink = sym; 7479 7480 /* Create the declaration for functions with global scope. */ 7481 if (!sym->backend_decl) 7482 gfc_create_function_decl (ns, false); 7483 7484 fndecl = sym->backend_decl; 7485 old_context = current_function_decl; 7486 7487 if (old_context) 7488 { 7489 push_function_context (); 7490 saved_parent_function_decls = saved_function_decls; 7491 saved_function_decls = NULL_TREE; 7492 } 7493 7494 trans_function_start (sym); 7495 7496 gfc_init_block (&init); 7497 gfc_init_block (&cleanup); 7498 gfc_init_block (&outer_block); 7499 7500 if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER) 7501 { 7502 /* Copy length backend_decls to all entry point result 7503 symbols. */ 7504 gfc_entry_list *el; 7505 tree backend_decl; 7506 7507 gfc_conv_const_charlen (ns->proc_name->ts.u.cl); 7508 backend_decl = ns->proc_name->result->ts.u.cl->backend_decl; 7509 for (el = ns->entries; el; el = el->next) 7510 el->sym->result->ts.u.cl->backend_decl = backend_decl; 7511 } 7512 7513 /* Translate COMMON blocks. */ 7514 gfc_trans_common (ns); 7515 7516 /* Null the parent fake result declaration if this namespace is 7517 a module function or an external procedures. */ 7518 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) 7519 || ns->parent == NULL) 7520 parent_fake_result_decl = NULL_TREE; 7521 7522 /* For BIND(C): 7523 - deallocate intent-out allocatable dummy arguments. 7524 - Create GFC variable which will later be populated by convert_CFI_desc */ 7525 if (sym->attr.is_bind_c) 7526 for (gfc_formal_arglist *formal = gfc_sym_get_dummy_args (sym); 7527 formal; formal = formal->next) 7528 { 7529 gfc_symbol *fsym = formal->sym; 7530 if (!is_CFI_desc (fsym, NULL)) 7531 continue; 7532 if (!fsym->attr.referenced) 7533 { 7534 gfc_conv_cfi_to_gfc (&init, &cleanup, fsym->backend_decl, 7535 NULL_TREE, fsym); 7536 continue; 7537 } 7538 /* Let's now create a local GFI descriptor. Afterwards: 7539 desc is the local descriptor, 7540 desc_p is a pointer to it 7541 and stored in sym->backend_decl 7542 GFC_DECL_SAVED_DESCRIPTOR (desc_p) contains the CFI descriptor 7543 -> PARM_DECL and before sym->backend_decl. 7544 For scalars, decl == decl_p is a pointer variable. */ 7545 tree desc_p, desc; 7546 location_t loc = gfc_get_location (&sym->declared_at); 7547 if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length) 7548 fsym->ts.u.cl->backend_decl = gfc_create_var (gfc_array_index_type, 7549 fsym->name); 7550 else if (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->backend_decl) 7551 { 7552 gfc_se se; 7553 gfc_init_se (&se, NULL ); 7554 gfc_conv_expr (&se, fsym->ts.u.cl->length); 7555 gfc_add_block_to_block (&init, &se.pre); 7556 fsym->ts.u.cl->backend_decl = se.expr; 7557 gcc_assert(se.post.head == NULL_TREE); 7558 } 7559 /* Nullify, otherwise gfc_sym_type will return the CFI type. */ 7560 tree tmp = fsym->backend_decl; 7561 fsym->backend_decl = NULL; 7562 tree type = gfc_sym_type (fsym); 7563 gcc_assert (POINTER_TYPE_P (type)); 7564 if (POINTER_TYPE_P (TREE_TYPE (type))) 7565 /* For instance, allocatable scalars. */ 7566 type = TREE_TYPE (type); 7567 if (TREE_CODE (type) == REFERENCE_TYPE) 7568 type = build_pointer_type (TREE_TYPE (type)); 7569 desc_p = build_decl (loc, VAR_DECL, get_identifier (fsym->name), type); 7570 if (!fsym->attr.dimension) 7571 desc = desc_p; 7572 else if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (desc_p)))) 7573 { 7574 /* Character(len=*) explict-size/assumed-size array. */ 7575 desc = desc_p; 7576 gfc_build_qualified_array (desc, fsym); 7577 } 7578 else 7579 { 7580 tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (desc_p))); 7581 tree call = builtin_decl_explicit (BUILT_IN_ALLOCA); 7582 call = build_call_expr_loc (input_location, call, 1, size); 7583 gfc_add_modify (&outer_block, desc_p, 7584 fold_convert (TREE_TYPE(desc_p), call)); 7585 desc = build_fold_indirect_ref_loc (input_location, desc_p); 7586 } 7587 pushdecl (desc_p); 7588 if (fsym->attr.optional) 7589 { 7590 gfc_allocate_lang_decl (desc_p); 7591 GFC_DECL_OPTIONAL_ARGUMENT (desc_p) = 1; 7592 } 7593 fsym->backend_decl = desc_p; 7594 gfc_conv_cfi_to_gfc (&init, &cleanup, tmp, desc, fsym); 7595 } 7596 7597 gfc_generate_contained_functions (ns); 7598 7599 has_coarray_vars = false; 7600 generate_local_vars (ns); 7601 7602 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) 7603 generate_coarray_init (ns); 7604 7605 /* Keep the parent fake result declaration in module functions 7606 or external procedures. */ 7607 if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) 7608 || ns->parent == NULL) 7609 current_fake_result_decl = parent_fake_result_decl; 7610 else 7611 current_fake_result_decl = NULL_TREE; 7612 7613 is_recursive = sym->attr.recursive 7614 || (sym->attr.entry_master 7615 && sym->ns->entries->sym->attr.recursive); 7616 if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) 7617 && !is_recursive && !flag_recursive && !sym->attr.artificial) 7618 { 7619 char * msg; 7620 7621 msg = xasprintf ("Recursive call to nonrecursive procedure '%s'", 7622 sym->name); 7623 recurcheckvar = gfc_create_var (logical_type_node, "is_recursive"); 7624 TREE_STATIC (recurcheckvar) = 1; 7625 DECL_INITIAL (recurcheckvar) = logical_false_node; 7626 gfc_add_expr_to_block (&init, recurcheckvar); 7627 gfc_trans_runtime_check (true, false, recurcheckvar, &init, 7628 &sym->declared_at, msg); 7629 gfc_add_modify (&init, recurcheckvar, logical_true_node); 7630 free (msg); 7631 } 7632 7633 /* Check if an IEEE module is used in the procedure. If so, save 7634 the floating point state. */ 7635 ieee = is_ieee_module_used (ns); 7636 if (ieee) 7637 fpstate = gfc_save_fp_state (&init); 7638 7639 /* Now generate the code for the body of this function. */ 7640 gfc_init_block (&body); 7641 7642 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node 7643 && sym->attr.subroutine) 7644 { 7645 tree alternate_return; 7646 alternate_return = gfc_get_fake_result_decl (sym, 0); 7647 gfc_add_modify (&body, alternate_return, integer_zero_node); 7648 } 7649 7650 if (ns->entries) 7651 { 7652 /* Jump to the correct entry point. */ 7653 tmp = gfc_trans_entry_master_switch (ns->entries); 7654 gfc_add_expr_to_block (&body, tmp); 7655 } 7656 7657 /* If bounds-checking is enabled, generate code to check passed in actual 7658 arguments against the expected dummy argument attributes (e.g. string 7659 lengths). */ 7660 if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c) 7661 add_argument_checking (&body, sym); 7662 7663 finish_oacc_declare (ns, sym, false); 7664 7665 tmp = gfc_trans_code (ns->code); 7666 gfc_add_expr_to_block (&body, tmp); 7667 7668 if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node 7669 || (sym->result && sym->result != sym 7670 && sym->result->ts.type == BT_DERIVED 7671 && sym->result->ts.u.derived->attr.alloc_comp)) 7672 { 7673 bool artificial_result_decl = false; 7674 tree result = get_proc_result (sym); 7675 gfc_symbol *rsym = sym == sym->result ? sym : sym->result; 7676 7677 /* Make sure that a function returning an object with 7678 alloc/pointer_components always has a result, where at least 7679 the allocatable/pointer components are set to zero. */ 7680 if (result == NULL_TREE && sym->attr.function 7681 && ((sym->result->ts.type == BT_DERIVED 7682 && (sym->attr.allocatable 7683 || sym->attr.pointer 7684 || sym->result->ts.u.derived->attr.alloc_comp 7685 || sym->result->ts.u.derived->attr.pointer_comp)) 7686 || (sym->result->ts.type == BT_CLASS 7687 && (CLASS_DATA (sym)->attr.allocatable 7688 || CLASS_DATA (sym)->attr.class_pointer 7689 || CLASS_DATA (sym->result)->attr.alloc_comp 7690 || CLASS_DATA (sym->result)->attr.pointer_comp)))) 7691 { 7692 artificial_result_decl = true; 7693 result = gfc_get_fake_result_decl (sym, 0); 7694 } 7695 7696 if (result != NULL_TREE && sym->attr.function && !sym->attr.pointer) 7697 { 7698 if (sym->attr.allocatable && sym->attr.dimension == 0 7699 && sym->result == sym) 7700 gfc_add_modify (&init, result, fold_convert (TREE_TYPE (result), 7701 null_pointer_node)); 7702 else if (sym->ts.type == BT_CLASS 7703 && CLASS_DATA (sym)->attr.allocatable 7704 && CLASS_DATA (sym)->attr.dimension == 0 7705 && sym->result == sym) 7706 { 7707 tmp = CLASS_DATA (sym)->backend_decl; 7708 tmp = fold_build3_loc (input_location, COMPONENT_REF, 7709 TREE_TYPE (tmp), result, tmp, NULL_TREE); 7710 gfc_add_modify (&init, tmp, fold_convert (TREE_TYPE (tmp), 7711 null_pointer_node)); 7712 } 7713 else if (sym->ts.type == BT_DERIVED 7714 && !sym->attr.allocatable) 7715 { 7716 gfc_expr *init_exp; 7717 /* Arrays are not initialized using the default initializer of 7718 their elements. Therefore only check if a default 7719 initializer is available when the result is scalar. */ 7720 init_exp = rsym->as ? NULL 7721 : gfc_generate_initializer (&rsym->ts, true); 7722 if (init_exp) 7723 { 7724 tmp = gfc_trans_structure_assign (result, init_exp, 0); 7725 gfc_free_expr (init_exp); 7726 gfc_add_expr_to_block (&init, tmp); 7727 } 7728 else if (rsym->ts.u.derived->attr.alloc_comp) 7729 { 7730 rank = rsym->as ? rsym->as->rank : 0; 7731 tmp = gfc_nullify_alloc_comp (rsym->ts.u.derived, result, 7732 rank); 7733 gfc_prepend_expr_to_block (&body, tmp); 7734 } 7735 } 7736 } 7737 7738 if (result == NULL_TREE || artificial_result_decl) 7739 { 7740 /* TODO: move to the appropriate place in resolve.cc. */ 7741 if (warn_return_type > 0 && sym == sym->result) 7742 gfc_warning (OPT_Wreturn_type, 7743 "Return value of function %qs at %L not set", 7744 sym->name, &sym->declared_at); 7745 if (warn_return_type > 0) 7746 suppress_warning (sym->backend_decl); 7747 } 7748 if (result != NULL_TREE) 7749 gfc_add_expr_to_block (&body, gfc_generate_return ()); 7750 } 7751 7752 /* Reset recursion-check variable. */ 7753 if (recurcheckvar != NULL_TREE) 7754 { 7755 gfc_add_modify (&cleanup, recurcheckvar, logical_false_node); 7756 recurcheckvar = NULL; 7757 } 7758 7759 /* If IEEE modules are loaded, restore the floating-point state. */ 7760 if (ieee) 7761 gfc_restore_fp_state (&cleanup, fpstate); 7762 7763 /* Finish the function body and add init and cleanup code. */ 7764 tmp = gfc_finish_block (&body); 7765 /* Add code to create and cleanup arrays. */ 7766 gfc_start_wrapped_block (&try_block, tmp); 7767 gfc_trans_deferred_vars (sym, &try_block); 7768 gfc_add_init_cleanup (&try_block, gfc_finish_block (&init), 7769 gfc_finish_block (&cleanup)); 7770 7771 /* Add all the decls we created during processing. */ 7772 decl = nreverse (saved_function_decls); 7773 while (decl) 7774 { 7775 tree next; 7776 7777 next = DECL_CHAIN (decl); 7778 DECL_CHAIN (decl) = NULL_TREE; 7779 pushdecl (decl); 7780 decl = next; 7781 } 7782 saved_function_decls = NULL_TREE; 7783 7784 gfc_add_expr_to_block (&outer_block, gfc_finish_wrapped_block (&try_block)); 7785 DECL_SAVED_TREE (fndecl) = gfc_finish_block (&outer_block); 7786 decl = getdecls (); 7787 7788 /* Finish off this function and send it for code generation. */ 7789 poplevel (1, 1); 7790 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; 7791 7792 DECL_SAVED_TREE (fndecl) 7793 = fold_build3_loc (DECL_SOURCE_LOCATION (fndecl), BIND_EXPR, void_type_node, 7794 decl, DECL_SAVED_TREE (fndecl), DECL_INITIAL (fndecl)); 7795 7796 /* Output the GENERIC tree. */ 7797 dump_function (TDI_original, fndecl); 7798 7799 /* Store the end of the function, so that we get good line number 7800 info for the epilogue. */ 7801 cfun->function_end_locus = input_location; 7802 7803 /* We're leaving the context of this function, so zap cfun. 7804 It's still in DECL_STRUCT_FUNCTION, and we'll restore it in 7805 tree_rest_of_compilation. */ 7806 set_cfun (NULL); 7807 7808 if (old_context) 7809 { 7810 pop_function_context (); 7811 saved_function_decls = saved_parent_function_decls; 7812 } 7813 current_function_decl = old_context; 7814 7815 if (decl_function_context (fndecl)) 7816 { 7817 /* Register this function with cgraph just far enough to get it 7818 added to our parent's nested function list. 7819 If there are static coarrays in this function, the nested _caf_init 7820 function has already called cgraph_create_node, which also created 7821 the cgraph node for this function. */ 7822 if (!has_coarray_vars || flag_coarray != GFC_FCOARRAY_LIB) 7823 (void) cgraph_node::get_create (fndecl); 7824 } 7825 else 7826 cgraph_node::finalize_function (fndecl, true); 7827 7828 gfc_trans_use_stmts (ns); 7829 gfc_traverse_ns (ns, gfc_emit_parameter_debug_info); 7830 7831 if (sym->attr.is_main_program) 7832 create_main_function (fndecl); 7833 7834 current_procedure_symbol = previous_procedure_symbol; 7835 } 7836 7837 7838 void 7839 gfc_generate_constructors (void) 7840 { 7841 gcc_assert (gfc_static_ctors == NULL_TREE); 7842 #if 0 7843 tree fnname; 7844 tree type; 7845 tree fndecl; 7846 tree decl; 7847 tree tmp; 7848 7849 if (gfc_static_ctors == NULL_TREE) 7850 return; 7851 7852 fnname = get_file_function_name ("I"); 7853 type = build_function_type_list (void_type_node, NULL_TREE); 7854 7855 fndecl = build_decl (input_location, 7856 FUNCTION_DECL, fnname, type); 7857 TREE_PUBLIC (fndecl) = 1; 7858 7859 decl = build_decl (input_location, 7860 RESULT_DECL, NULL_TREE, void_type_node); 7861 DECL_ARTIFICIAL (decl) = 1; 7862 DECL_IGNORED_P (decl) = 1; 7863 DECL_CONTEXT (decl) = fndecl; 7864 DECL_RESULT (fndecl) = decl; 7865 7866 pushdecl (fndecl); 7867 7868 current_function_decl = fndecl; 7869 7870 rest_of_decl_compilation (fndecl, 1, 0); 7871 7872 make_decl_rtl (fndecl); 7873 7874 allocate_struct_function (fndecl, false); 7875 7876 pushlevel (); 7877 7878 for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors)) 7879 { 7880 tmp = build_call_expr_loc (input_location, 7881 TREE_VALUE (gfc_static_ctors), 0); 7882 DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp); 7883 } 7884 7885 decl = getdecls (); 7886 poplevel (1, 1); 7887 7888 BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl; 7889 DECL_SAVED_TREE (fndecl) 7890 = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl), 7891 DECL_INITIAL (fndecl)); 7892 7893 free_after_parsing (cfun); 7894 free_after_compilation (cfun); 7895 7896 tree_rest_of_compilation (fndecl); 7897 7898 current_function_decl = NULL_TREE; 7899 #endif 7900 } 7901 7902 /* Translates a BLOCK DATA program unit. This means emitting the 7903 commons contained therein plus their initializations. We also emit 7904 a globally visible symbol to make sure that each BLOCK DATA program 7905 unit remains unique. */ 7906 7907 void 7908 gfc_generate_block_data (gfc_namespace * ns) 7909 { 7910 tree decl; 7911 tree id; 7912 7913 /* Tell the backend the source location of the block data. */ 7914 if (ns->proc_name) 7915 gfc_set_backend_locus (&ns->proc_name->declared_at); 7916 else 7917 gfc_set_backend_locus (&gfc_current_locus); 7918 7919 /* Process the DATA statements. */ 7920 gfc_trans_common (ns); 7921 7922 /* Create a global symbol with the mane of the block data. This is to 7923 generate linker errors if the same name is used twice. It is never 7924 really used. */ 7925 if (ns->proc_name) 7926 id = gfc_sym_mangled_function_id (ns->proc_name); 7927 else 7928 id = get_identifier ("__BLOCK_DATA__"); 7929 7930 decl = build_decl (input_location, 7931 VAR_DECL, id, gfc_array_index_type); 7932 TREE_PUBLIC (decl) = 1; 7933 TREE_STATIC (decl) = 1; 7934 DECL_IGNORED_P (decl) = 1; 7935 7936 pushdecl (decl); 7937 rest_of_decl_compilation (decl, 1, 0); 7938 } 7939 7940 7941 /* Process the local variables of a BLOCK construct. */ 7942 7943 void 7944 gfc_process_block_locals (gfc_namespace* ns) 7945 { 7946 tree decl; 7947 7948 saved_local_decls = NULL_TREE; 7949 has_coarray_vars = false; 7950 7951 generate_local_vars (ns); 7952 7953 if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars) 7954 generate_coarray_init (ns); 7955 7956 decl = nreverse (saved_local_decls); 7957 while (decl) 7958 { 7959 tree next; 7960 7961 next = DECL_CHAIN (decl); 7962 DECL_CHAIN (decl) = NULL_TREE; 7963 pushdecl (decl); 7964 decl = next; 7965 } 7966 saved_local_decls = NULL_TREE; 7967 } 7968 7969 7970 #include "gt-fortran-trans-decl.h" 7971
Indexes created Wed Mar 25 00:23:37 UTC 2026