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