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