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