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