1/* Maintain binary trees of symbols. 2 Copyright (C) 2000-2022 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 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 22#include "config.h" 23#include "system.h" 24#include "coretypes.h" 25#include "options.h" 26#include "gfortran.h" 27#include "parse.h" 28#include "match.h" 29#include "constructor.h" 30 31 32/* Strings for all symbol attributes. We use these for dumping the 33 parse tree, in error messages, and also when reading and writing 34 modules. */ 35 36const mstring flavors[] = 37{ 38 minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), 39 minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), 40 minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), 41 minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), 42 minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), 43 minit ("UNION", FL_UNION), minit ("STRUCTURE", FL_STRUCT), 44 minit (NULL, -1) 45}; 46 47const mstring procedures[] = 48{ 49 minit ("UNKNOWN-PROC", PROC_UNKNOWN), 50 minit ("MODULE-PROC", PROC_MODULE), 51 minit ("INTERNAL-PROC", PROC_INTERNAL), 52 minit ("DUMMY-PROC", PROC_DUMMY), 53 minit ("INTRINSIC-PROC", PROC_INTRINSIC), 54 minit ("EXTERNAL-PROC", PROC_EXTERNAL), 55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION), 56 minit (NULL, -1) 57}; 58 59const mstring intents[] = 60{ 61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), 62 minit ("IN", INTENT_IN), 63 minit ("OUT", INTENT_OUT), 64 minit ("INOUT", INTENT_INOUT), 65 minit (NULL, -1) 66}; 67 68const mstring access_types[] = 69{ 70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), 71 minit ("PUBLIC", ACCESS_PUBLIC), 72 minit ("PRIVATE", ACCESS_PRIVATE), 73 minit (NULL, -1) 74}; 75 76const mstring ifsrc_types[] = 77{ 78 minit ("UNKNOWN", IFSRC_UNKNOWN), 79 minit ("DECL", IFSRC_DECL), 80 minit ("BODY", IFSRC_IFBODY) 81}; 82 83const mstring save_status[] = 84{ 85 minit ("UNKNOWN", SAVE_NONE), 86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT), 87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), 88}; 89 90/* Set the mstrings for DTIO procedure names. */ 91const mstring dtio_procs[] = 92{ 93 minit ("_dtio_formatted_read", DTIO_RF), 94 minit ("_dtio_formatted_write", DTIO_WF), 95 minit ("_dtio_unformatted_read", DTIO_RUF), 96 minit ("_dtio_unformatted_write", DTIO_WUF), 97}; 98 99/* This is to make sure the backend generates setup code in the correct 100 order. */ 101 102static int next_dummy_order = 1; 103 104 105gfc_namespace *gfc_current_ns; 106gfc_namespace *gfc_global_ns_list; 107 108gfc_gsymbol *gfc_gsym_root = NULL; 109 110gfc_symbol *gfc_derived_types; 111 112static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL }; 113static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var; 114 115 116/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ 117 118/* The following static variable indicates whether a particular element has 119 been explicitly set or not. */ 120 121static int new_flag[GFC_LETTERS]; 122 123 124/* Handle a correctly parsed IMPLICIT NONE. */ 125 126void 127gfc_set_implicit_none (bool type, bool external, locus *loc) 128{ 129 int i; 130 131 if (external) 132 gfc_current_ns->has_implicit_none_export = 1; 133 134 if (type) 135 { 136 gfc_current_ns->seen_implicit_none = 1; 137 for (i = 0; i < GFC_LETTERS; i++) 138 { 139 if (gfc_current_ns->set_flag[i]) 140 { 141 gfc_error_now ("IMPLICIT NONE (type) statement at %L following an " 142 "IMPLICIT statement", loc); 143 return; 144 } 145 gfc_clear_ts (&gfc_current_ns->default_type[i]); 146 gfc_current_ns->set_flag[i] = 1; 147 } 148 } 149} 150 151 152/* Reset the implicit range flags. */ 153 154void 155gfc_clear_new_implicit (void) 156{ 157 int i; 158 159 for (i = 0; i < GFC_LETTERS; i++) 160 new_flag[i] = 0; 161} 162 163 164/* Prepare for a new implicit range. Sets flags in new_flag[]. */ 165 166bool 167gfc_add_new_implicit_range (int c1, int c2) 168{ 169 int i; 170 171 c1 -= 'a'; 172 c2 -= 'a'; 173 174 for (i = c1; i <= c2; i++) 175 { 176 if (new_flag[i]) 177 { 178 gfc_error ("Letter %qc already set in IMPLICIT statement at %C", 179 i + 'A'); 180 return false; 181 } 182 183 new_flag[i] = 1; 184 } 185 186 return true; 187} 188 189 190/* Add a matched implicit range for gfc_set_implicit(). Check if merging 191 the new implicit types back into the existing types will work. */ 192 193bool 194gfc_merge_new_implicit (gfc_typespec *ts) 195{ 196 int i; 197 198 if (gfc_current_ns->seen_implicit_none) 199 { 200 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); 201 return false; 202 } 203 204 for (i = 0; i < GFC_LETTERS; i++) 205 { 206 if (new_flag[i]) 207 { 208 if (gfc_current_ns->set_flag[i]) 209 { 210 gfc_error ("Letter %qc already has an IMPLICIT type at %C", 211 i + 'A'); 212 return false; 213 } 214 215 gfc_current_ns->default_type[i] = *ts; 216 gfc_current_ns->implicit_loc[i] = gfc_current_locus; 217 gfc_current_ns->set_flag[i] = 1; 218 } 219 } 220 return true; 221} 222 223 224/* Given a symbol, return a pointer to the typespec for its default type. */ 225 226gfc_typespec * 227gfc_get_default_type (const char *name, gfc_namespace *ns) 228{ 229 char letter; 230 231 letter = name[0]; 232 233 if (flag_allow_leading_underscore && letter == '_') 234 gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by " 235 "gfortran developers, and should not be used for " 236 "implicitly typed variables"); 237 238 if (letter < 'a' || letter > 'z') 239 gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name); 240 241 if (ns == NULL) 242 ns = gfc_current_ns; 243 244 return &ns->default_type[letter - 'a']; 245} 246 247 248/* Recursively append candidate SYM to CANDIDATES. Store the number of 249 candidates in CANDIDATES_LEN. */ 250 251static void 252lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym, 253 char **&candidates, 254 size_t &candidates_len) 255{ 256 gfc_symtree *p; 257 258 if (sym == NULL) 259 return; 260 261 if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE) 262 vec_push (candidates, candidates_len, sym->name); 263 p = sym->left; 264 if (p) 265 lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); 266 267 p = sym->right; 268 if (p) 269 lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len); 270} 271 272 273/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */ 274 275static const char* 276lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol) 277{ 278 char **candidates = NULL; 279 size_t candidates_len = 0; 280 lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates, 281 candidates_len); 282 return gfc_closest_fuzzy_match (sym_name, candidates); 283} 284 285 286/* Given a pointer to a symbol, set its type according to the first 287 letter of its name. Fails if the letter in question has no default 288 type. */ 289 290bool 291gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) 292{ 293 gfc_typespec *ts; 294 295 if (sym->ts.type != BT_UNKNOWN) 296 gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); 297 298 ts = gfc_get_default_type (sym->name, ns); 299 300 if (ts->type == BT_UNKNOWN) 301 { 302 if (error_flag && !sym->attr.untyped && !gfc_query_suppress_errors ()) 303 { 304 const char *guessed = lookup_symbol_fuzzy (sym->name, sym); 305 if (guessed) 306 gfc_error ("Symbol %qs at %L has no IMPLICIT type" 307 "; did you mean %qs?", 308 sym->name, &sym->declared_at, guessed); 309 else 310 gfc_error ("Symbol %qs at %L has no IMPLICIT type", 311 sym->name, &sym->declared_at); 312 sym->attr.untyped = 1; /* Ensure we only give an error once. */ 313 } 314 315 return false; 316 } 317 318 sym->ts = *ts; 319 sym->attr.implicit_type = 1; 320 321 if (ts->type == BT_CHARACTER && ts->u.cl) 322 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl); 323 else if (ts->type == BT_CLASS 324 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) 325 return false; 326 327 if (sym->attr.is_bind_c == 1 && warn_c_binding_type) 328 { 329 /* BIND(C) variables should not be implicitly declared. */ 330 gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) " 331 "variable %qs at %L may not be C interoperable", 332 sym->name, &sym->declared_at); 333 sym->ts.f90_type = sym->ts.type; 334 } 335 336 if (sym->attr.dummy != 0) 337 { 338 if (sym->ns->proc_name != NULL 339 && (sym->ns->proc_name->attr.subroutine != 0 340 || sym->ns->proc_name->attr.function != 0) 341 && sym->ns->proc_name->attr.is_bind_c != 0 342 && warn_c_binding_type) 343 { 344 /* Dummy args to a BIND(C) routine may not be interoperable if 345 they are implicitly typed. */ 346 gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable " 347 "%qs at %L may not be C interoperable but it is a " 348 "dummy argument to the BIND(C) procedure %qs at %L", 349 sym->name, &(sym->declared_at), 350 sym->ns->proc_name->name, 351 &(sym->ns->proc_name->declared_at)); 352 sym->ts.f90_type = sym->ts.type; 353 } 354 } 355 356 return true; 357} 358 359 360/* This function is called from parse.cc(parse_progunit) to check the 361 type of the function is not implicitly typed in the host namespace 362 and to implicitly type the function result, if necessary. */ 363 364void 365gfc_check_function_type (gfc_namespace *ns) 366{ 367 gfc_symbol *proc = ns->proc_name; 368 369 if (!proc->attr.contained || proc->result->attr.implicit_type) 370 return; 371 372 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL) 373 { 374 if (gfc_set_default_type (proc->result, 0, gfc_current_ns)) 375 { 376 if (proc->result != proc) 377 { 378 proc->ts = proc->result->ts; 379 proc->as = gfc_copy_array_spec (proc->result->as); 380 proc->attr.dimension = proc->result->attr.dimension; 381 proc->attr.pointer = proc->result->attr.pointer; 382 proc->attr.allocatable = proc->result->attr.allocatable; 383 } 384 } 385 else if (!proc->result->attr.proc_pointer) 386 { 387 gfc_error ("Function result %qs at %L has no IMPLICIT type", 388 proc->result->name, &proc->result->declared_at); 389 proc->result->attr.untyped = 1; 390 } 391 } 392} 393 394 395/******************** Symbol attribute stuff *********************/ 396 397/* This is a generic conflict-checker. We do this to avoid having a 398 single conflict in two places. */ 399 400#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } 401#define conf2(a) if (attr->a) { a2 = a; goto conflict; } 402#define conf_std(a, b, std) if (attr->a && attr->b)\ 403 {\ 404 a1 = a;\ 405 a2 = b;\ 406 standard = std;\ 407 goto conflict_std;\ 408 } 409 410bool 411gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) 412{ 413 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", 414 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", 415 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", 416 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", 417 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", 418 *privat = "PRIVATE", *recursive = "RECURSIVE", 419 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", 420 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", 421 *function = "FUNCTION", *subroutine = "SUBROUTINE", 422 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", 423 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", 424 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", 425 *volatile_ = "VOLATILE", *is_protected = "PROTECTED", 426 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", 427 *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT", 428 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION", 429 *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC", 430 *pdt_len = "LEN", *pdt_kind = "KIND"; 431 static const char *threadprivate = "THREADPRIVATE"; 432 static const char *omp_declare_target = "OMP DECLARE TARGET"; 433 static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK"; 434 static const char *oacc_declare_copyin = "OACC DECLARE COPYIN"; 435 static const char *oacc_declare_create = "OACC DECLARE CREATE"; 436 static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR"; 437 static const char *oacc_declare_device_resident = 438 "OACC DECLARE DEVICE_RESIDENT"; 439 440 const char *a1, *a2; 441 int standard; 442 443 if (attr->artificial) 444 return true; 445 446 if (where == NULL) 447 where = &gfc_current_locus; 448 449 if (attr->pointer && attr->intent != INTENT_UNKNOWN) 450 { 451 a1 = pointer; 452 a2 = intent; 453 standard = GFC_STD_F2003; 454 goto conflict_std; 455 } 456 457 if (attr->in_namelist && (attr->allocatable || attr->pointer)) 458 { 459 a1 = in_namelist; 460 a2 = attr->allocatable ? allocatable : pointer; 461 standard = GFC_STD_F2003; 462 goto conflict_std; 463 } 464 465 /* Check for attributes not allowed in a BLOCK DATA. */ 466 if (gfc_current_state () == COMP_BLOCK_DATA) 467 { 468 a1 = NULL; 469 470 if (attr->in_namelist) 471 a1 = in_namelist; 472 if (attr->allocatable) 473 a1 = allocatable; 474 if (attr->external) 475 a1 = external; 476 if (attr->optional) 477 a1 = optional; 478 if (attr->access == ACCESS_PRIVATE) 479 a1 = privat; 480 if (attr->access == ACCESS_PUBLIC) 481 a1 = publik; 482 if (attr->intent != INTENT_UNKNOWN) 483 a1 = intent; 484 485 if (a1 != NULL) 486 { 487 gfc_error 488 ("%s attribute not allowed in BLOCK DATA program unit at %L", 489 a1, where); 490 return false; 491 } 492 } 493 494 if (attr->save == SAVE_EXPLICIT) 495 { 496 conf (dummy, save); 497 conf (in_common, save); 498 conf (result, save); 499 conf (automatic, save); 500 501 switch (attr->flavor) 502 { 503 case FL_PROGRAM: 504 case FL_BLOCK_DATA: 505 case FL_MODULE: 506 case FL_LABEL: 507 case_fl_struct: 508 case FL_PARAMETER: 509 a1 = gfc_code2string (flavors, attr->flavor); 510 a2 = save; 511 goto conflict; 512 case FL_NAMELIST: 513 gfc_error ("Namelist group name at %L cannot have the " 514 "SAVE attribute", where); 515 return false; 516 case FL_PROCEDURE: 517 /* Conflicts between SAVE and PROCEDURE will be checked at 518 resolution stage, see "resolve_fl_procedure". */ 519 case FL_VARIABLE: 520 default: 521 break; 522 } 523 } 524 525 /* The copying of procedure dummy arguments for module procedures in 526 a submodule occur whilst the current state is COMP_CONTAINS. It 527 is necessary, therefore, to let this through. */ 528 if (name && attr->dummy 529 && (attr->function || attr->subroutine) 530 && gfc_current_state () == COMP_CONTAINS 531 && !(gfc_new_block && gfc_new_block->abr_modproc_decl)) 532 gfc_error_now ("internal procedure %qs at %L conflicts with " 533 "DUMMY argument", name, where); 534 535 conf (dummy, entry); 536 conf (dummy, intrinsic); 537 conf (dummy, threadprivate); 538 conf (dummy, omp_declare_target); 539 conf (dummy, omp_declare_target_link); 540 conf (pointer, target); 541 conf (pointer, intrinsic); 542 conf (pointer, elemental); 543 conf (pointer, codimension); 544 conf (allocatable, elemental); 545 546 conf (in_common, automatic); 547 conf (result, automatic); 548 conf (use_assoc, automatic); 549 conf (dummy, automatic); 550 551 conf (target, external); 552 conf (target, intrinsic); 553 554 if (!attr->if_source) 555 conf (external, dimension); /* See Fortran 95's R504. */ 556 557 conf (external, intrinsic); 558 conf (entry, intrinsic); 559 conf (abstract, intrinsic); 560 561 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) 562 conf (external, subroutine); 563 564 if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003, 565 "Procedure pointer at %C")) 566 return false; 567 568 conf (allocatable, pointer); 569 conf_std (allocatable, dummy, GFC_STD_F2003); 570 conf_std (allocatable, function, GFC_STD_F2003); 571 conf_std (allocatable, result, GFC_STD_F2003); 572 conf_std (elemental, recursive, GFC_STD_F2018); 573 574 conf (in_common, dummy); 575 conf (in_common, allocatable); 576 conf (in_common, codimension); 577 conf (in_common, result); 578 579 conf (in_equivalence, use_assoc); 580 conf (in_equivalence, codimension); 581 conf (in_equivalence, dummy); 582 conf (in_equivalence, target); 583 conf (in_equivalence, pointer); 584 conf (in_equivalence, function); 585 conf (in_equivalence, result); 586 conf (in_equivalence, entry); 587 conf (in_equivalence, allocatable); 588 conf (in_equivalence, threadprivate); 589 conf (in_equivalence, omp_declare_target); 590 conf (in_equivalence, omp_declare_target_link); 591 conf (in_equivalence, oacc_declare_create); 592 conf (in_equivalence, oacc_declare_copyin); 593 conf (in_equivalence, oacc_declare_deviceptr); 594 conf (in_equivalence, oacc_declare_device_resident); 595 conf (in_equivalence, is_bind_c); 596 597 conf (dummy, result); 598 conf (entry, result); 599 conf (generic, result); 600 conf (generic, omp_declare_target); 601 conf (generic, omp_declare_target_link); 602 603 conf (function, subroutine); 604 605 if (!function && !subroutine) 606 conf (is_bind_c, dummy); 607 608 conf (is_bind_c, cray_pointer); 609 conf (is_bind_c, cray_pointee); 610 conf (is_bind_c, codimension); 611 conf (is_bind_c, allocatable); 612 conf (is_bind_c, elemental); 613 614 /* Need to also get volatile attr, according to 5.1 of F2003 draft. 615 Parameter conflict caught below. Also, value cannot be specified 616 for a dummy procedure. */ 617 618 /* Cray pointer/pointee conflicts. */ 619 conf (cray_pointer, cray_pointee); 620 conf (cray_pointer, dimension); 621 conf (cray_pointer, codimension); 622 conf (cray_pointer, contiguous); 623 conf (cray_pointer, pointer); 624 conf (cray_pointer, target); 625 conf (cray_pointer, allocatable); 626 conf (cray_pointer, external); 627 conf (cray_pointer, intrinsic); 628 conf (cray_pointer, in_namelist); 629 conf (cray_pointer, function); 630 conf (cray_pointer, subroutine); 631 conf (cray_pointer, entry); 632 633 conf (cray_pointee, allocatable); 634 conf (cray_pointee, contiguous); 635 conf (cray_pointee, codimension); 636 conf (cray_pointee, intent); 637 conf (cray_pointee, optional); 638 conf (cray_pointee, dummy); 639 conf (cray_pointee, target); 640 conf (cray_pointee, intrinsic); 641 conf (cray_pointee, pointer); 642 conf (cray_pointee, entry); 643 conf (cray_pointee, in_common); 644 conf (cray_pointee, in_equivalence); 645 conf (cray_pointee, threadprivate); 646 conf (cray_pointee, omp_declare_target); 647 conf (cray_pointee, omp_declare_target_link); 648 conf (cray_pointee, oacc_declare_create); 649 conf (cray_pointee, oacc_declare_copyin); 650 conf (cray_pointee, oacc_declare_deviceptr); 651 conf (cray_pointee, oacc_declare_device_resident); 652 653 conf (data, dummy); 654 conf (data, function); 655 conf (data, result); 656 conf (data, allocatable); 657 658 conf (value, pointer) 659 conf (value, allocatable) 660 conf (value, subroutine) 661 conf (value, function) 662 conf (value, volatile_) 663 conf (value, dimension) 664 conf (value, codimension) 665 conf (value, external) 666 667 conf (codimension, result) 668 669 if (attr->value 670 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) 671 { 672 a1 = value; 673 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; 674 goto conflict; 675 } 676 677 conf (is_protected, intrinsic) 678 conf (is_protected, in_common) 679 680 conf (asynchronous, intrinsic) 681 conf (asynchronous, external) 682 683 conf (volatile_, intrinsic) 684 conf (volatile_, external) 685 686 if (attr->volatile_ && attr->intent == INTENT_IN) 687 { 688 a1 = volatile_; 689 a2 = intent_in; 690 goto conflict; 691 } 692 693 conf (procedure, allocatable) 694 conf (procedure, dimension) 695 conf (procedure, codimension) 696 conf (procedure, intrinsic) 697 conf (procedure, target) 698 conf (procedure, value) 699 conf (procedure, volatile_) 700 conf (procedure, asynchronous) 701 conf (procedure, entry) 702 703 conf (proc_pointer, abstract) 704 conf (proc_pointer, omp_declare_target) 705 conf (proc_pointer, omp_declare_target_link) 706 707 conf (entry, omp_declare_target) 708 conf (entry, omp_declare_target_link) 709 conf (entry, oacc_declare_create) 710 conf (entry, oacc_declare_copyin) 711 conf (entry, oacc_declare_deviceptr) 712 conf (entry, oacc_declare_device_resident) 713 714 conf (pdt_kind, allocatable) 715 conf (pdt_kind, pointer) 716 conf (pdt_kind, dimension) 717 conf (pdt_kind, codimension) 718 719 conf (pdt_len, allocatable) 720 conf (pdt_len, pointer) 721 conf (pdt_len, dimension) 722 conf (pdt_len, codimension) 723 conf (pdt_len, pdt_kind) 724 725 if (attr->access == ACCESS_PRIVATE) 726 { 727 a1 = privat; 728 conf2 (pdt_kind); 729 conf2 (pdt_len); 730 } 731 732 a1 = gfc_code2string (flavors, attr->flavor); 733 734 if (attr->in_namelist 735 && attr->flavor != FL_VARIABLE 736 && attr->flavor != FL_PROCEDURE 737 && attr->flavor != FL_UNKNOWN) 738 { 739 a2 = in_namelist; 740 goto conflict; 741 } 742 743 switch (attr->flavor) 744 { 745 case FL_PROGRAM: 746 case FL_BLOCK_DATA: 747 case FL_MODULE: 748 case FL_LABEL: 749 conf2 (codimension); 750 conf2 (dimension); 751 conf2 (dummy); 752 conf2 (volatile_); 753 conf2 (asynchronous); 754 conf2 (contiguous); 755 conf2 (pointer); 756 conf2 (is_protected); 757 conf2 (target); 758 conf2 (external); 759 conf2 (intrinsic); 760 conf2 (allocatable); 761 conf2 (result); 762 conf2 (in_namelist); 763 conf2 (optional); 764 conf2 (function); 765 conf2 (subroutine); 766 conf2 (threadprivate); 767 conf2 (omp_declare_target); 768 conf2 (omp_declare_target_link); 769 conf2 (oacc_declare_create); 770 conf2 (oacc_declare_copyin); 771 conf2 (oacc_declare_deviceptr); 772 conf2 (oacc_declare_device_resident); 773 774 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) 775 { 776 a2 = attr->access == ACCESS_PUBLIC ? publik : privat; 777 gfc_error ("%s attribute applied to %s %s at %L", a2, a1, 778 name, where); 779 return false; 780 } 781 782 if (attr->is_bind_c) 783 { 784 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); 785 return false; 786 } 787 788 break; 789 790 case FL_VARIABLE: 791 break; 792 793 case FL_NAMELIST: 794 conf2 (result); 795 break; 796 797 case FL_PROCEDURE: 798 /* Conflicts with INTENT, SAVE and RESULT will be checked 799 at resolution stage, see "resolve_fl_procedure". */ 800 801 if (attr->subroutine) 802 { 803 a1 = subroutine; 804 conf2 (target); 805 conf2 (allocatable); 806 conf2 (volatile_); 807 conf2 (asynchronous); 808 conf2 (in_namelist); 809 conf2 (codimension); 810 conf2 (dimension); 811 conf2 (function); 812 if (!attr->proc_pointer) 813 conf2 (threadprivate); 814 } 815 816 /* Procedure pointers in COMMON blocks are allowed in F03, 817 * but forbidden per F08:C5100. */ 818 if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008)) 819 conf2 (in_common); 820 821 conf2 (omp_declare_target_link); 822 823 switch (attr->proc) 824 { 825 case PROC_ST_FUNCTION: 826 conf2 (dummy); 827 conf2 (target); 828 break; 829 830 case PROC_MODULE: 831 conf2 (dummy); 832 break; 833 834 case PROC_DUMMY: 835 conf2 (result); 836 conf2 (threadprivate); 837 break; 838 839 default: 840 break; 841 } 842 843 break; 844 845 case_fl_struct: 846 conf2 (dummy); 847 conf2 (pointer); 848 conf2 (target); 849 conf2 (external); 850 conf2 (intrinsic); 851 conf2 (allocatable); 852 conf2 (optional); 853 conf2 (entry); 854 conf2 (function); 855 conf2 (subroutine); 856 conf2 (threadprivate); 857 conf2 (result); 858 conf2 (omp_declare_target); 859 conf2 (omp_declare_target_link); 860 conf2 (oacc_declare_create); 861 conf2 (oacc_declare_copyin); 862 conf2 (oacc_declare_deviceptr); 863 conf2 (oacc_declare_device_resident); 864 865 if (attr->intent != INTENT_UNKNOWN) 866 { 867 a2 = intent; 868 goto conflict; 869 } 870 break; 871 872 case FL_PARAMETER: 873 conf2 (external); 874 conf2 (intrinsic); 875 conf2 (optional); 876 conf2 (allocatable); 877 conf2 (function); 878 conf2 (subroutine); 879 conf2 (entry); 880 conf2 (contiguous); 881 conf2 (pointer); 882 conf2 (is_protected); 883 conf2 (target); 884 conf2 (dummy); 885 conf2 (in_common); 886 conf2 (value); 887 conf2 (volatile_); 888 conf2 (asynchronous); 889 conf2 (threadprivate); 890 conf2 (value); 891 conf2 (codimension); 892 conf2 (result); 893 if (!attr->is_iso_c) 894 conf2 (is_bind_c); 895 break; 896 897 default: 898 break; 899 } 900 901 return true; 902 903conflict: 904 if (name == NULL) 905 gfc_error ("%s attribute conflicts with %s attribute at %L", 906 a1, a2, where); 907 else 908 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L", 909 a1, a2, name, where); 910 911 return false; 912 913conflict_std: 914 if (name == NULL) 915 { 916 return gfc_notify_std (standard, "%s attribute conflicts " 917 "with %s attribute at %L", a1, a2, 918 where); 919 } 920 else 921 { 922 return gfc_notify_std (standard, "%s attribute conflicts " 923 "with %s attribute in %qs at %L", 924 a1, a2, name, where); 925 } 926} 927 928#undef conf 929#undef conf2 930#undef conf_std 931 932 933/* Mark a symbol as referenced. */ 934 935void 936gfc_set_sym_referenced (gfc_symbol *sym) 937{ 938 939 if (sym->attr.referenced) 940 return; 941 942 sym->attr.referenced = 1; 943 944 /* Remember which order dummy variables are accessed in. */ 945 if (sym->attr.dummy) 946 sym->dummy_order = next_dummy_order++; 947} 948 949 950/* Common subroutine called by attribute changing subroutines in order 951 to prevent them from changing a symbol that has been 952 use-associated. Returns zero if it is OK to change the symbol, 953 nonzero if not. */ 954 955static int 956check_used (symbol_attribute *attr, const char *name, locus *where) 957{ 958 959 if (attr->use_assoc == 0) 960 return 0; 961 962 if (where == NULL) 963 where = &gfc_current_locus; 964 965 if (name == NULL) 966 gfc_error ("Cannot change attributes of USE-associated symbol at %L", 967 where); 968 else 969 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", 970 name, where); 971 972 return 1; 973} 974 975 976/* Generate an error because of a duplicate attribute. */ 977 978static void 979duplicate_attr (const char *attr, locus *where) 980{ 981 982 if (where == NULL) 983 where = &gfc_current_locus; 984 985 gfc_error ("Duplicate %s attribute specified at %L", attr, where); 986} 987 988 989bool 990gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr, 991 locus *where ATTRIBUTE_UNUSED) 992{ 993 attr->ext_attr |= 1 << ext_attr; 994 return true; 995} 996 997 998/* Called from decl.cc (attr_decl1) to check attributes, when declared 999 separately. */ 1000 1001bool 1002gfc_add_attribute (symbol_attribute *attr, locus *where) 1003{ 1004 if (check_used (attr, NULL, where)) 1005 return false; 1006 1007 return gfc_check_conflict (attr, NULL, where); 1008} 1009 1010 1011bool 1012gfc_add_allocatable (symbol_attribute *attr, locus *where) 1013{ 1014 1015 if (check_used (attr, NULL, where)) 1016 return false; 1017 1018 if (attr->allocatable && ! gfc_submodule_procedure(attr)) 1019 { 1020 duplicate_attr ("ALLOCATABLE", where); 1021 return false; 1022 } 1023 1024 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY 1025 && !gfc_find_state (COMP_INTERFACE)) 1026 { 1027 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", 1028 where); 1029 return false; 1030 } 1031 1032 attr->allocatable = 1; 1033 return gfc_check_conflict (attr, NULL, where); 1034} 1035 1036 1037bool 1038gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where) 1039{ 1040 if (check_used (attr, name, where)) 1041 return false; 1042 1043 if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY, 1044 "Duplicate AUTOMATIC attribute specified at %L", where)) 1045 return false; 1046 1047 attr->automatic = 1; 1048 return gfc_check_conflict (attr, name, where); 1049} 1050 1051 1052bool 1053gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) 1054{ 1055 1056 if (check_used (attr, name, where)) 1057 return false; 1058 1059 if (attr->codimension) 1060 { 1061 duplicate_attr ("CODIMENSION", where); 1062 return false; 1063 } 1064 1065 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY 1066 && !gfc_find_state (COMP_INTERFACE)) 1067 { 1068 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body " 1069 "at %L", name, where); 1070 return false; 1071 } 1072 1073 attr->codimension = 1; 1074 return gfc_check_conflict (attr, name, where); 1075} 1076 1077 1078bool 1079gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) 1080{ 1081 1082 if (check_used (attr, name, where)) 1083 return false; 1084 1085 if (attr->dimension && ! gfc_submodule_procedure(attr)) 1086 { 1087 duplicate_attr ("DIMENSION", where); 1088 return false; 1089 } 1090 1091 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY 1092 && !gfc_find_state (COMP_INTERFACE)) 1093 { 1094 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body " 1095 "at %L", name, where); 1096 return false; 1097 } 1098 1099 attr->dimension = 1; 1100 return gfc_check_conflict (attr, name, where); 1101} 1102 1103 1104bool 1105gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where) 1106{ 1107 1108 if (check_used (attr, name, where)) 1109 return false; 1110 1111 if (attr->contiguous) 1112 { 1113 duplicate_attr ("CONTIGUOUS", where); 1114 return false; 1115 } 1116 1117 attr->contiguous = 1; 1118 return gfc_check_conflict (attr, name, where); 1119} 1120 1121 1122bool 1123gfc_add_external (symbol_attribute *attr, locus *where) 1124{ 1125 1126 if (check_used (attr, NULL, where)) 1127 return false; 1128 1129 if (attr->external) 1130 { 1131 duplicate_attr ("EXTERNAL", where); 1132 return false; 1133 } 1134 1135 if (attr->pointer && attr->if_source != IFSRC_IFBODY) 1136 { 1137 attr->pointer = 0; 1138 attr->proc_pointer = 1; 1139 } 1140 1141 attr->external = 1; 1142 1143 return gfc_check_conflict (attr, NULL, where); 1144} 1145 1146 1147bool 1148gfc_add_intrinsic (symbol_attribute *attr, locus *where) 1149{ 1150 1151 if (check_used (attr, NULL, where)) 1152 return false; 1153 1154 if (attr->intrinsic) 1155 { 1156 duplicate_attr ("INTRINSIC", where); 1157 return false; 1158 } 1159 1160 attr->intrinsic = 1; 1161 1162 return gfc_check_conflict (attr, NULL, where); 1163} 1164 1165 1166bool 1167gfc_add_optional (symbol_attribute *attr, locus *where) 1168{ 1169 1170 if (check_used (attr, NULL, where)) 1171 return false; 1172 1173 if (attr->optional) 1174 { 1175 duplicate_attr ("OPTIONAL", where); 1176 return false; 1177 } 1178 1179 attr->optional = 1; 1180 return gfc_check_conflict (attr, NULL, where); 1181} 1182 1183bool 1184gfc_add_kind (symbol_attribute *attr, locus *where) 1185{ 1186 if (attr->pdt_kind) 1187 { 1188 duplicate_attr ("KIND", where); 1189 return false; 1190 } 1191 1192 attr->pdt_kind = 1; 1193 return gfc_check_conflict (attr, NULL, where); 1194} 1195 1196bool 1197gfc_add_len (symbol_attribute *attr, locus *where) 1198{ 1199 if (attr->pdt_len) 1200 { 1201 duplicate_attr ("LEN", where); 1202 return false; 1203 } 1204 1205 attr->pdt_len = 1; 1206 return gfc_check_conflict (attr, NULL, where); 1207} 1208 1209 1210bool 1211gfc_add_pointer (symbol_attribute *attr, locus *where) 1212{ 1213 1214 if (check_used (attr, NULL, where)) 1215 return false; 1216 1217 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY 1218 && !gfc_find_state (COMP_INTERFACE)) 1219 && ! gfc_submodule_procedure(attr)) 1220 { 1221 duplicate_attr ("POINTER", where); 1222 return false; 1223 } 1224 1225 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) 1226 || (attr->if_source == IFSRC_IFBODY 1227 && !gfc_find_state (COMP_INTERFACE))) 1228 attr->proc_pointer = 1; 1229 else 1230 attr->pointer = 1; 1231 1232 return gfc_check_conflict (attr, NULL, where); 1233} 1234 1235 1236bool 1237gfc_add_cray_pointer (symbol_attribute *attr, locus *where) 1238{ 1239 1240 if (check_used (attr, NULL, where)) 1241 return false; 1242 1243 attr->cray_pointer = 1; 1244 return gfc_check_conflict (attr, NULL, where); 1245} 1246 1247 1248bool 1249gfc_add_cray_pointee (symbol_attribute *attr, locus *where) 1250{ 1251 1252 if (check_used (attr, NULL, where)) 1253 return false; 1254 1255 if (attr->cray_pointee) 1256 { 1257 gfc_error ("Cray Pointee at %L appears in multiple pointer()" 1258 " statements", where); 1259 return false; 1260 } 1261 1262 attr->cray_pointee = 1; 1263 return gfc_check_conflict (attr, NULL, where); 1264} 1265 1266 1267bool 1268gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) 1269{ 1270 if (check_used (attr, name, where)) 1271 return false; 1272 1273 if (attr->is_protected) 1274 { 1275 if (!gfc_notify_std (GFC_STD_LEGACY, 1276 "Duplicate PROTECTED attribute specified at %L", 1277 where)) 1278 return false; 1279 } 1280 1281 attr->is_protected = 1; 1282 return gfc_check_conflict (attr, name, where); 1283} 1284 1285 1286bool 1287gfc_add_result (symbol_attribute *attr, const char *name, locus *where) 1288{ 1289 1290 if (check_used (attr, name, where)) 1291 return false; 1292 1293 attr->result = 1; 1294 return gfc_check_conflict (attr, name, where); 1295} 1296 1297 1298bool 1299gfc_add_save (symbol_attribute *attr, save_state s, const char *name, 1300 locus *where) 1301{ 1302 1303 if (check_used (attr, name, where)) 1304 return false; 1305 1306 if (s == SAVE_EXPLICIT && gfc_pure (NULL)) 1307 { 1308 gfc_error 1309 ("SAVE attribute at %L cannot be specified in a PURE procedure", 1310 where); 1311 return false; 1312 } 1313 1314 if (s == SAVE_EXPLICIT) 1315 gfc_unset_implicit_pure (NULL); 1316 1317 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT 1318 && (flag_automatic || pedantic)) 1319 { 1320 if (!gfc_notify_std (GFC_STD_LEGACY, 1321 "Duplicate SAVE attribute specified at %L", 1322 where)) 1323 return false; 1324 } 1325 1326 attr->save = s; 1327 return gfc_check_conflict (attr, name, where); 1328} 1329 1330 1331bool 1332gfc_add_value (symbol_attribute *attr, const char *name, locus *where) 1333{ 1334 1335 if (check_used (attr, name, where)) 1336 return false; 1337 1338 if (attr->value) 1339 { 1340 if (!gfc_notify_std (GFC_STD_LEGACY, 1341 "Duplicate VALUE attribute specified at %L", 1342 where)) 1343 return false; 1344 } 1345 1346 attr->value = 1; 1347 return gfc_check_conflict (attr, name, where); 1348} 1349 1350 1351bool 1352gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) 1353{ 1354 /* No check_used needed as 11.2.1 of the F2003 standard allows 1355 that the local identifier made accessible by a use statement can be 1356 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ 1357 1358 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) 1359 if (!gfc_notify_std (GFC_STD_LEGACY, 1360 "Duplicate VOLATILE attribute specified at %L", 1361 where)) 1362 return false; 1363 1364 /* F2008: C1282 A designator of a variable with the VOLATILE attribute 1365 shall not appear in a pure subprogram. 1366 1367 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK 1368 construct within a pure subprogram, shall not have the SAVE or 1369 VOLATILE attribute. */ 1370 if (gfc_pure (NULL)) 1371 { 1372 gfc_error ("VOLATILE attribute at %L cannot be specified in a " 1373 "PURE procedure", where); 1374 return false; 1375 } 1376 1377 1378 attr->volatile_ = 1; 1379 attr->volatile_ns = gfc_current_ns; 1380 return gfc_check_conflict (attr, name, where); 1381} 1382 1383 1384bool 1385gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where) 1386{ 1387 /* No check_used needed as 11.2.1 of the F2003 standard allows 1388 that the local identifier made accessible by a use statement can be 1389 given a ASYNCHRONOUS attribute. */ 1390 1391 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns) 1392 if (!gfc_notify_std (GFC_STD_LEGACY, 1393 "Duplicate ASYNCHRONOUS attribute specified at %L", 1394 where)) 1395 return false; 1396 1397 attr->asynchronous = 1; 1398 attr->asynchronous_ns = gfc_current_ns; 1399 return gfc_check_conflict (attr, name, where); 1400} 1401 1402 1403bool 1404gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) 1405{ 1406 1407 if (check_used (attr, name, where)) 1408 return false; 1409 1410 if (attr->threadprivate) 1411 { 1412 duplicate_attr ("THREADPRIVATE", where); 1413 return false; 1414 } 1415 1416 attr->threadprivate = 1; 1417 return gfc_check_conflict (attr, name, where); 1418} 1419 1420 1421bool 1422gfc_add_omp_declare_target (symbol_attribute *attr, const char *name, 1423 locus *where) 1424{ 1425 1426 if (check_used (attr, name, where)) 1427 return false; 1428 1429 if (attr->omp_declare_target) 1430 return true; 1431 1432 attr->omp_declare_target = 1; 1433 return gfc_check_conflict (attr, name, where); 1434} 1435 1436 1437bool 1438gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name, 1439 locus *where) 1440{ 1441 1442 if (check_used (attr, name, where)) 1443 return false; 1444 1445 if (attr->omp_declare_target_link) 1446 return true; 1447 1448 attr->omp_declare_target_link = 1; 1449 return gfc_check_conflict (attr, name, where); 1450} 1451 1452 1453bool 1454gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name, 1455 locus *where) 1456{ 1457 if (check_used (attr, name, where)) 1458 return false; 1459 1460 if (attr->oacc_declare_create) 1461 return true; 1462 1463 attr->oacc_declare_create = 1; 1464 return gfc_check_conflict (attr, name, where); 1465} 1466 1467 1468bool 1469gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name, 1470 locus *where) 1471{ 1472 if (check_used (attr, name, where)) 1473 return false; 1474 1475 if (attr->oacc_declare_copyin) 1476 return true; 1477 1478 attr->oacc_declare_copyin = 1; 1479 return gfc_check_conflict (attr, name, where); 1480} 1481 1482 1483bool 1484gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name, 1485 locus *where) 1486{ 1487 if (check_used (attr, name, where)) 1488 return false; 1489 1490 if (attr->oacc_declare_deviceptr) 1491 return true; 1492 1493 attr->oacc_declare_deviceptr = 1; 1494 return gfc_check_conflict (attr, name, where); 1495} 1496 1497 1498bool 1499gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name, 1500 locus *where) 1501{ 1502 if (check_used (attr, name, where)) 1503 return false; 1504 1505 if (attr->oacc_declare_device_resident) 1506 return true; 1507 1508 attr->oacc_declare_device_resident = 1; 1509 return gfc_check_conflict (attr, name, where); 1510} 1511 1512 1513bool 1514gfc_add_target (symbol_attribute *attr, locus *where) 1515{ 1516 1517 if (check_used (attr, NULL, where)) 1518 return false; 1519 1520 if (attr->target) 1521 { 1522 duplicate_attr ("TARGET", where); 1523 return false; 1524 } 1525 1526 attr->target = 1; 1527 return gfc_check_conflict (attr, NULL, where); 1528} 1529 1530 1531bool 1532gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) 1533{ 1534 1535 if (check_used (attr, name, where)) 1536 return false; 1537 1538 /* Duplicate dummy arguments are allowed due to ENTRY statements. */ 1539 attr->dummy = 1; 1540 return gfc_check_conflict (attr, name, where); 1541} 1542 1543 1544bool 1545gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) 1546{ 1547 1548 if (check_used (attr, name, where)) 1549 return false; 1550 1551 /* Duplicate attribute already checked for. */ 1552 attr->in_common = 1; 1553 return gfc_check_conflict (attr, name, where); 1554} 1555 1556 1557bool 1558gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) 1559{ 1560 1561 /* Duplicate attribute already checked for. */ 1562 attr->in_equivalence = 1; 1563 if (!gfc_check_conflict (attr, name, where)) 1564 return false; 1565 1566 if (attr->flavor == FL_VARIABLE) 1567 return true; 1568 1569 return gfc_add_flavor (attr, FL_VARIABLE, name, where); 1570} 1571 1572 1573bool 1574gfc_add_data (symbol_attribute *attr, const char *name, locus *where) 1575{ 1576 1577 if (check_used (attr, name, where)) 1578 return false; 1579 1580 attr->data = 1; 1581 return gfc_check_conflict (attr, name, where); 1582} 1583 1584 1585bool 1586gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) 1587{ 1588 1589 attr->in_namelist = 1; 1590 return gfc_check_conflict (attr, name, where); 1591} 1592 1593 1594bool 1595gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) 1596{ 1597 1598 if (check_used (attr, name, where)) 1599 return false; 1600 1601 attr->sequence = 1; 1602 return gfc_check_conflict (attr, name, where); 1603} 1604 1605 1606bool 1607gfc_add_elemental (symbol_attribute *attr, locus *where) 1608{ 1609 1610 if (check_used (attr, NULL, where)) 1611 return false; 1612 1613 if (attr->elemental) 1614 { 1615 duplicate_attr ("ELEMENTAL", where); 1616 return false; 1617 } 1618 1619 attr->elemental = 1; 1620 return gfc_check_conflict (attr, NULL, where); 1621} 1622 1623 1624bool 1625gfc_add_pure (symbol_attribute *attr, locus *where) 1626{ 1627 1628 if (check_used (attr, NULL, where)) 1629 return false; 1630 1631 if (attr->pure) 1632 { 1633 duplicate_attr ("PURE", where); 1634 return false; 1635 } 1636 1637 attr->pure = 1; 1638 return gfc_check_conflict (attr, NULL, where); 1639} 1640 1641 1642bool 1643gfc_add_recursive (symbol_attribute *attr, locus *where) 1644{ 1645 1646 if (check_used (attr, NULL, where)) 1647 return false; 1648 1649 if (attr->recursive) 1650 { 1651 duplicate_attr ("RECURSIVE", where); 1652 return false; 1653 } 1654 1655 attr->recursive = 1; 1656 return gfc_check_conflict (attr, NULL, where); 1657} 1658 1659 1660bool 1661gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) 1662{ 1663 1664 if (check_used (attr, name, where)) 1665 return false; 1666 1667 if (attr->entry) 1668 { 1669 duplicate_attr ("ENTRY", where); 1670 return false; 1671 } 1672 1673 attr->entry = 1; 1674 return gfc_check_conflict (attr, name, where); 1675} 1676 1677 1678bool 1679gfc_add_function (symbol_attribute *attr, const char *name, locus *where) 1680{ 1681 1682 if (attr->flavor != FL_PROCEDURE 1683 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) 1684 return false; 1685 1686 attr->function = 1; 1687 return gfc_check_conflict (attr, name, where); 1688} 1689 1690 1691bool 1692gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) 1693{ 1694 1695 if (attr->flavor != FL_PROCEDURE 1696 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) 1697 return false; 1698 1699 attr->subroutine = 1; 1700 1701 /* If we are looking at a BLOCK DATA statement and we encounter a 1702 name with a leading underscore (which must be 1703 compiler-generated), do not check. See PR 84394. */ 1704 1705 if (name && *name != '_' && gfc_current_state () != COMP_BLOCK_DATA) 1706 return gfc_check_conflict (attr, name, where); 1707 else 1708 return true; 1709} 1710 1711 1712bool 1713gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) 1714{ 1715 1716 if (attr->flavor != FL_PROCEDURE 1717 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) 1718 return false; 1719 1720 attr->generic = 1; 1721 return gfc_check_conflict (attr, name, where); 1722} 1723 1724 1725bool 1726gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) 1727{ 1728 1729 if (check_used (attr, NULL, where)) 1730 return false; 1731 1732 if (attr->flavor != FL_PROCEDURE 1733 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) 1734 return false; 1735 1736 if (attr->procedure) 1737 { 1738 duplicate_attr ("PROCEDURE", where); 1739 return false; 1740 } 1741 1742 attr->procedure = 1; 1743 1744 return gfc_check_conflict (attr, NULL, where); 1745} 1746 1747 1748bool 1749gfc_add_abstract (symbol_attribute* attr, locus* where) 1750{ 1751 if (attr->abstract) 1752 { 1753 duplicate_attr ("ABSTRACT", where); 1754 return false; 1755 } 1756 1757 attr->abstract = 1; 1758 1759 return gfc_check_conflict (attr, NULL, where); 1760} 1761 1762 1763/* Flavors are special because some flavors are not what Fortran 1764 considers attributes and can be reaffirmed multiple times. */ 1765 1766bool 1767gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, 1768 locus *where) 1769{ 1770 1771 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE 1772 || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f) 1773 || f == FL_NAMELIST) && check_used (attr, name, where)) 1774 return false; 1775 1776 if (attr->flavor == f && f == FL_VARIABLE) 1777 return true; 1778 1779 /* Copying a procedure dummy argument for a module procedure in a 1780 submodule results in the flavor being copied and would result in 1781 an error without this. */ 1782 if (attr->flavor == f && f == FL_PROCEDURE 1783 && gfc_new_block && gfc_new_block->abr_modproc_decl) 1784 return true; 1785 1786 if (attr->flavor != FL_UNKNOWN) 1787 { 1788 if (where == NULL) 1789 where = &gfc_current_locus; 1790 1791 if (name) 1792 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L", 1793 gfc_code2string (flavors, attr->flavor), name, 1794 gfc_code2string (flavors, f), where); 1795 else 1796 gfc_error ("%s attribute conflicts with %s attribute at %L", 1797 gfc_code2string (flavors, attr->flavor), 1798 gfc_code2string (flavors, f), where); 1799 1800 return false; 1801 } 1802 1803 attr->flavor = f; 1804 1805 return gfc_check_conflict (attr, name, where); 1806} 1807 1808 1809bool 1810gfc_add_procedure (symbol_attribute *attr, procedure_type t, 1811 const char *name, locus *where) 1812{ 1813 1814 if (check_used (attr, name, where)) 1815 return false; 1816 1817 if (attr->flavor != FL_PROCEDURE 1818 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where)) 1819 return false; 1820 1821 if (where == NULL) 1822 where = &gfc_current_locus; 1823 1824 if (attr->proc != PROC_UNKNOWN && !attr->module_procedure 1825 && attr->access == ACCESS_UNKNOWN) 1826 { 1827 if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL 1828 && !gfc_notification_std (GFC_STD_F2008)) 1829 gfc_error ("%s procedure at %L is already declared as %s " 1830 "procedure. \nF2008: A pointer function assignment " 1831 "is ambiguous if it is the first executable statement " 1832 "after the specification block. Please add any other " 1833 "kind of executable statement before it. FIXME", 1834 gfc_code2string (procedures, t), where, 1835 gfc_code2string (procedures, attr->proc)); 1836 else 1837 gfc_error ("%s procedure at %L is already declared as %s " 1838 "procedure", gfc_code2string (procedures, t), where, 1839 gfc_code2string (procedures, attr->proc)); 1840 1841 return false; 1842 } 1843 1844 attr->proc = t; 1845 1846 /* Statement functions are always scalar and functions. */ 1847 if (t == PROC_ST_FUNCTION 1848 && ((!attr->function && !gfc_add_function (attr, name, where)) 1849 || attr->dimension)) 1850 return false; 1851 1852 return gfc_check_conflict (attr, name, where); 1853} 1854 1855 1856bool 1857gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) 1858{ 1859 1860 if (check_used (attr, NULL, where)) 1861 return false; 1862 1863 if (attr->intent == INTENT_UNKNOWN) 1864 { 1865 attr->intent = intent; 1866 return gfc_check_conflict (attr, NULL, where); 1867 } 1868 1869 if (where == NULL) 1870 where = &gfc_current_locus; 1871 1872 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", 1873 gfc_intent_string (attr->intent), 1874 gfc_intent_string (intent), where); 1875 1876 return false; 1877} 1878 1879 1880/* No checks for use-association in public and private statements. */ 1881 1882bool 1883gfc_add_access (symbol_attribute *attr, gfc_access access, 1884 const char *name, locus *where) 1885{ 1886 1887 if (attr->access == ACCESS_UNKNOWN 1888 || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) 1889 { 1890 attr->access = access; 1891 return gfc_check_conflict (attr, name, where); 1892 } 1893 1894 if (where == NULL) 1895 where = &gfc_current_locus; 1896 gfc_error ("ACCESS specification at %L was already specified", where); 1897 1898 return false; 1899} 1900 1901 1902/* Set the is_bind_c field for the given symbol_attribute. */ 1903 1904bool 1905gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, 1906 int is_proc_lang_bind_spec) 1907{ 1908 1909 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) 1910 gfc_error_now ("BIND(C) attribute at %L can only be used for " 1911 "variables or common blocks", where); 1912 else if (attr->is_bind_c) 1913 gfc_error_now ("Duplicate BIND attribute specified at %L", where); 1914 else 1915 attr->is_bind_c = 1; 1916 1917 if (where == NULL) 1918 where = &gfc_current_locus; 1919 1920 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) at %L", where)) 1921 return false; 1922 1923 return gfc_check_conflict (attr, name, where); 1924} 1925 1926 1927/* Set the extension field for the given symbol_attribute. */ 1928 1929bool 1930gfc_add_extension (symbol_attribute *attr, locus *where) 1931{ 1932 if (where == NULL) 1933 where = &gfc_current_locus; 1934 1935 if (attr->extension) 1936 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where); 1937 else 1938 attr->extension = 1; 1939 1940 if (!gfc_notify_std (GFC_STD_F2003, "EXTENDS at %L", where)) 1941 return false; 1942 1943 return true; 1944} 1945 1946 1947bool 1948gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, 1949 gfc_formal_arglist * formal, locus *where) 1950{ 1951 if (check_used (&sym->attr, sym->name, where)) 1952 return false; 1953 1954 /* Skip the following checks in the case of a module_procedures in a 1955 submodule since they will manifestly fail. */ 1956 if (sym->attr.module_procedure == 1 1957 && source == IFSRC_DECL) 1958 goto finish; 1959 1960 if (where == NULL) 1961 where = &gfc_current_locus; 1962 1963 if (sym->attr.if_source != IFSRC_UNKNOWN 1964 && sym->attr.if_source != IFSRC_DECL) 1965 { 1966 gfc_error ("Symbol %qs at %L already has an explicit interface", 1967 sym->name, where); 1968 return false; 1969 } 1970 1971 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) 1972 { 1973 gfc_error ("%qs at %L has attributes specified outside its INTERFACE " 1974 "body", sym->name, where); 1975 return false; 1976 } 1977 1978finish: 1979 sym->formal = formal; 1980 sym->attr.if_source = source; 1981 1982 return true; 1983} 1984 1985 1986/* Add a type to a symbol. */ 1987 1988bool 1989gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) 1990{ 1991 sym_flavor flavor; 1992 bt type; 1993 1994 if (where == NULL) 1995 where = &gfc_current_locus; 1996 1997 if (sym->result) 1998 type = sym->result->ts.type; 1999 else 2000 type = sym->ts.type; 2001 2002 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name) 2003 type = sym->ns->proc_name->ts.type; 2004 2005 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type) 2006 && !(gfc_state_stack->previous && gfc_state_stack->previous->previous 2007 && gfc_state_stack->previous->previous->state == COMP_SUBMODULE) 2008 && !sym->attr.module_procedure) 2009 { 2010 if (sym->attr.use_assoc) 2011 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, " 2012 "use-associated at %L", sym->name, where, sym->module, 2013 &sym->declared_at); 2014 else if (sym->attr.function && sym->attr.result) 2015 gfc_error ("Symbol %qs at %L already has basic type of %s", 2016 sym->ns->proc_name->name, where, gfc_basic_typename (type)); 2017 else 2018 gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name, 2019 where, gfc_basic_typename (type)); 2020 return false; 2021 } 2022 2023 if (sym->attr.procedure && sym->ts.interface) 2024 { 2025 gfc_error ("Procedure %qs at %L may not have basic type of %s", 2026 sym->name, where, gfc_basic_typename (ts->type)); 2027 return false; 2028 } 2029 2030 flavor = sym->attr.flavor; 2031 2032 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE 2033 || flavor == FL_LABEL 2034 || (flavor == FL_PROCEDURE && sym->attr.subroutine) 2035 || flavor == FL_DERIVED || flavor == FL_NAMELIST) 2036 { 2037 gfc_error ("Symbol %qs at %L cannot have a type", 2038 sym->ns->proc_name ? sym->ns->proc_name->name : sym->name, 2039 where); 2040 return false; 2041 } 2042 2043 sym->ts = *ts; 2044 return true; 2045} 2046 2047 2048/* Clears all attributes. */ 2049 2050void 2051gfc_clear_attr (symbol_attribute *attr) 2052{ 2053 memset (attr, 0, sizeof (symbol_attribute)); 2054} 2055 2056 2057/* Check for missing attributes in the new symbol. Currently does 2058 nothing, but it's not clear that it is unnecessary yet. */ 2059 2060bool 2061gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, 2062 locus *where ATTRIBUTE_UNUSED) 2063{ 2064 2065 return true; 2066} 2067 2068 2069/* Copy an attribute to a symbol attribute, bit by bit. Some 2070 attributes have a lot of side-effects but cannot be present given 2071 where we are called from, so we ignore some bits. */ 2072 2073bool 2074gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) 2075{ 2076 int is_proc_lang_bind_spec; 2077 2078 /* In line with the other attributes, we only add bits but do not remove 2079 them; cf. also PR 41034. */ 2080 dest->ext_attr |= src->ext_attr; 2081 2082 if (src->allocatable && !gfc_add_allocatable (dest, where)) 2083 goto fail; 2084 2085 if (src->automatic && !gfc_add_automatic (dest, NULL, where)) 2086 goto fail; 2087 if (src->dimension && !gfc_add_dimension (dest, NULL, where)) 2088 goto fail; 2089 if (src->codimension && !gfc_add_codimension (dest, NULL, where)) 2090 goto fail; 2091 if (src->contiguous && !gfc_add_contiguous (dest, NULL, where)) 2092 goto fail; 2093 if (src->optional && !gfc_add_optional (dest, where)) 2094 goto fail; 2095 if (src->pointer && !gfc_add_pointer (dest, where)) 2096 goto fail; 2097 if (src->is_protected && !gfc_add_protected (dest, NULL, where)) 2098 goto fail; 2099 if (src->save && !gfc_add_save (dest, src->save, NULL, where)) 2100 goto fail; 2101 if (src->value && !gfc_add_value (dest, NULL, where)) 2102 goto fail; 2103 if (src->volatile_ && !gfc_add_volatile (dest, NULL, where)) 2104 goto fail; 2105 if (src->asynchronous && !gfc_add_asynchronous (dest, NULL, where)) 2106 goto fail; 2107 if (src->threadprivate 2108 && !gfc_add_threadprivate (dest, NULL, where)) 2109 goto fail; 2110 if (src->omp_declare_target 2111 && !gfc_add_omp_declare_target (dest, NULL, where)) 2112 goto fail; 2113 if (src->omp_declare_target_link 2114 && !gfc_add_omp_declare_target_link (dest, NULL, where)) 2115 goto fail; 2116 if (src->oacc_declare_create 2117 && !gfc_add_oacc_declare_create (dest, NULL, where)) 2118 goto fail; 2119 if (src->oacc_declare_copyin 2120 && !gfc_add_oacc_declare_copyin (dest, NULL, where)) 2121 goto fail; 2122 if (src->oacc_declare_deviceptr 2123 && !gfc_add_oacc_declare_deviceptr (dest, NULL, where)) 2124 goto fail; 2125 if (src->oacc_declare_device_resident 2126 && !gfc_add_oacc_declare_device_resident (dest, NULL, where)) 2127 goto fail; 2128 if (src->target && !gfc_add_target (dest, where)) 2129 goto fail; 2130 if (src->dummy && !gfc_add_dummy (dest, NULL, where)) 2131 goto fail; 2132 if (src->result && !gfc_add_result (dest, NULL, where)) 2133 goto fail; 2134 if (src->entry) 2135 dest->entry = 1; 2136 2137 if (src->in_namelist && !gfc_add_in_namelist (dest, NULL, where)) 2138 goto fail; 2139 2140 if (src->in_common && !gfc_add_in_common (dest, NULL, where)) 2141 goto fail; 2142 2143 if (src->generic && !gfc_add_generic (dest, NULL, where)) 2144 goto fail; 2145 if (src->function && !gfc_add_function (dest, NULL, where)) 2146 goto fail; 2147 if (src->subroutine && !gfc_add_subroutine (dest, NULL, where)) 2148 goto fail; 2149 2150 if (src->sequence && !gfc_add_sequence (dest, NULL, where)) 2151 goto fail; 2152 if (src->elemental && !gfc_add_elemental (dest, where)) 2153 goto fail; 2154 if (src->pure && !gfc_add_pure (dest, where)) 2155 goto fail; 2156 if (src->recursive && !gfc_add_recursive (dest, where)) 2157 goto fail; 2158 2159 if (src->flavor != FL_UNKNOWN 2160 && !gfc_add_flavor (dest, src->flavor, NULL, where)) 2161 goto fail; 2162 2163 if (src->intent != INTENT_UNKNOWN 2164 && !gfc_add_intent (dest, src->intent, where)) 2165 goto fail; 2166 2167 if (src->access != ACCESS_UNKNOWN 2168 && !gfc_add_access (dest, src->access, NULL, where)) 2169 goto fail; 2170 2171 if (!gfc_missing_attr (dest, where)) 2172 goto fail; 2173 2174 if (src->cray_pointer && !gfc_add_cray_pointer (dest, where)) 2175 goto fail; 2176 if (src->cray_pointee && !gfc_add_cray_pointee (dest, where)) 2177 goto fail; 2178 2179 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); 2180 if (src->is_bind_c 2181 && !gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)) 2182 return false; 2183 2184 if (src->is_c_interop) 2185 dest->is_c_interop = 1; 2186 if (src->is_iso_c) 2187 dest->is_iso_c = 1; 2188 2189 if (src->external && !gfc_add_external (dest, where)) 2190 goto fail; 2191 if (src->intrinsic && !gfc_add_intrinsic (dest, where)) 2192 goto fail; 2193 if (src->proc_pointer) 2194 dest->proc_pointer = 1; 2195 2196 return true; 2197 2198fail: 2199 return false; 2200} 2201 2202 2203/* A function to generate a dummy argument symbol using that from the 2204 interface declaration. Can be used for the result symbol as well if 2205 the flag is set. */ 2206 2207int 2208gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result) 2209{ 2210 int rc; 2211 2212 rc = gfc_get_symbol (sym->name, NULL, dsym); 2213 if (rc) 2214 return rc; 2215 2216 if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus)) 2217 return 1; 2218 2219 if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr), 2220 &gfc_current_locus)) 2221 return 1; 2222 2223 if ((*dsym)->attr.dimension) 2224 (*dsym)->as = gfc_copy_array_spec (sym->as); 2225 2226 (*dsym)->attr.class_ok = sym->attr.class_ok; 2227 2228 if ((*dsym) != NULL && !result 2229 && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL) 2230 || !gfc_missing_attr (&(*dsym)->attr, NULL))) 2231 return 1; 2232 else if ((*dsym) != NULL && result 2233 && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL) 2234 || !gfc_missing_attr (&(*dsym)->attr, NULL))) 2235 return 1; 2236 2237 return 0; 2238} 2239 2240 2241/************** Component name management ************/ 2242 2243/* Component names of a derived type form their own little namespaces 2244 that are separate from all other spaces. The space is composed of 2245 a singly linked list of gfc_component structures whose head is 2246 located in the parent symbol. */ 2247 2248 2249/* Add a component name to a symbol. The call fails if the name is 2250 already present. On success, the component pointer is modified to 2251 point to the additional component structure. */ 2252 2253bool 2254gfc_add_component (gfc_symbol *sym, const char *name, 2255 gfc_component **component) 2256{ 2257 gfc_component *p, *tail; 2258 2259 /* Check for existing components with the same name, but not for union 2260 components or containers. Unions and maps are anonymous so they have 2261 unique internal names which will never conflict. 2262 Don't use gfc_find_component here because it calls gfc_use_derived, 2263 but the derived type may not be fully defined yet. */ 2264 tail = NULL; 2265 2266 for (p = sym->components; p; p = p->next) 2267 { 2268 if (strcmp (p->name, name) == 0) 2269 { 2270 gfc_error ("Component %qs at %C already declared at %L", 2271 name, &p->loc); 2272 return false; 2273 } 2274 2275 tail = p; 2276 } 2277 2278 if (sym->attr.extension 2279 && gfc_find_component (sym->components->ts.u.derived, 2280 name, true, true, NULL)) 2281 { 2282 gfc_error ("Component %qs at %C already in the parent type " 2283 "at %L", name, &sym->components->ts.u.derived->declared_at); 2284 return false; 2285 } 2286 2287 /* Allocate a new component. */ 2288 p = gfc_get_component (); 2289 2290 if (tail == NULL) 2291 sym->components = p; 2292 else 2293 tail->next = p; 2294 2295 p->name = gfc_get_string ("%s", name); 2296 p->loc = gfc_current_locus; 2297 p->ts.type = BT_UNKNOWN; 2298 2299 *component = p; 2300 return true; 2301} 2302 2303 2304/* Recursive function to switch derived types of all symbol in a 2305 namespace. */ 2306 2307static void 2308switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) 2309{ 2310 gfc_symbol *sym; 2311 2312 if (st == NULL) 2313 return; 2314 2315 sym = st->n.sym; 2316 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from) 2317 sym->ts.u.derived = to; 2318 2319 switch_types (st->left, from, to); 2320 switch_types (st->right, from, to); 2321} 2322 2323 2324/* This subroutine is called when a derived type is used in order to 2325 make the final determination about which version to use. The 2326 standard requires that a type be defined before it is 'used', but 2327 such types can appear in IMPLICIT statements before the actual 2328 definition. 'Using' in this context means declaring a variable to 2329 be that type or using the type constructor. 2330 2331 If a type is used and the components haven't been defined, then we 2332 have to have a derived type in a parent unit. We find the node in 2333 the other namespace and point the symtree node in this namespace to 2334 that node. Further reference to this name point to the correct 2335 node. If we can't find the node in a parent namespace, then we have 2336 an error. 2337 2338 This subroutine takes a pointer to a symbol node and returns a 2339 pointer to the translated node or NULL for an error. Usually there 2340 is no translation and we return the node we were passed. */ 2341 2342gfc_symbol * 2343gfc_use_derived (gfc_symbol *sym) 2344{ 2345 gfc_symbol *s; 2346 gfc_typespec *t; 2347 gfc_symtree *st; 2348 int i; 2349 2350 if (!sym) 2351 return NULL; 2352 2353 if (sym->attr.unlimited_polymorphic) 2354 return sym; 2355 2356 if (sym->attr.generic) 2357 sym = gfc_find_dt_in_generic (sym); 2358 2359 if (sym->components != NULL || sym->attr.zero_comp) 2360 return sym; /* Already defined. */ 2361 2362 if (sym->ns->parent == NULL) 2363 goto bad; 2364 2365 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) 2366 { 2367 gfc_error ("Symbol %qs at %C is ambiguous", sym->name); 2368 return NULL; 2369 } 2370 2371 if (s == NULL || !gfc_fl_struct (s->attr.flavor)) 2372 goto bad; 2373 2374 /* Get rid of symbol sym, translating all references to s. */ 2375 for (i = 0; i < GFC_LETTERS; i++) 2376 { 2377 t = &sym->ns->default_type[i]; 2378 if (t->u.derived == sym) 2379 t->u.derived = s; 2380 } 2381 2382 st = gfc_find_symtree (sym->ns->sym_root, sym->name); 2383 st->n.sym = s; 2384 2385 s->refs++; 2386 2387 /* Unlink from list of modified symbols. */ 2388 gfc_commit_symbol (sym); 2389 2390 switch_types (sym->ns->sym_root, sym, s); 2391 2392 /* TODO: Also have to replace sym -> s in other lists like 2393 namelists, common lists and interface lists. */ 2394 gfc_free_symbol (sym); 2395 2396 return s; 2397 2398bad: 2399 gfc_error ("Derived type %qs at %C is being used before it is defined", 2400 sym->name); 2401 return NULL; 2402} 2403 2404 2405/* Find the component with the given name in the union type symbol. 2406 If ref is not NULL it will be set to the chain of components through which 2407 the component can actually be accessed. This is necessary for unions because 2408 intermediate structures may be maps, nested structures, or other unions, 2409 all of which may (or must) be 'anonymous' to user code. */ 2410 2411static gfc_component * 2412find_union_component (gfc_symbol *un, const char *name, 2413 bool noaccess, gfc_ref **ref) 2414{ 2415 gfc_component *m, *check; 2416 gfc_ref *sref, *tmp; 2417 2418 for (m = un->components; m; m = m->next) 2419 { 2420 check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp); 2421 if (check == NULL) 2422 continue; 2423 2424 /* Found component somewhere in m; chain the refs together. */ 2425 if (ref) 2426 { 2427 /* Map ref. */ 2428 sref = gfc_get_ref (); 2429 sref->type = REF_COMPONENT; 2430 sref->u.c.component = m; 2431 sref->u.c.sym = m->ts.u.derived; 2432 sref->next = tmp; 2433 2434 *ref = sref; 2435 } 2436 /* Other checks (such as access) were done in the recursive calls. */ 2437 return check; 2438 } 2439 return NULL; 2440} 2441 2442 2443/* Recursively append candidate COMPONENT structures to CANDIDATES. Store 2444 the number of total candidates in CANDIDATES_LEN. */ 2445 2446static void 2447lookup_component_fuzzy_find_candidates (gfc_component *component, 2448 char **&candidates, 2449 size_t &candidates_len) 2450{ 2451 for (gfc_component *p = component; p; p = p->next) 2452 vec_push (candidates, candidates_len, p->name); 2453} 2454 2455 2456/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */ 2457 2458static const char* 2459lookup_component_fuzzy (const char *member, gfc_component *component) 2460{ 2461 char **candidates = NULL; 2462 size_t candidates_len = 0; 2463 lookup_component_fuzzy_find_candidates (component, candidates, 2464 candidates_len); 2465 return gfc_closest_fuzzy_match (member, candidates); 2466} 2467 2468 2469/* Given a derived type node and a component name, try to locate the 2470 component structure. Returns the NULL pointer if the component is 2471 not found or the components are private. If noaccess is set, no access 2472 checks are done. If silent is set, an error will not be generated if 2473 the component cannot be found or accessed. 2474 2475 If ref is not NULL, *ref is set to represent the chain of components 2476 required to get to the ultimate component. 2477 2478 If the component is simply a direct subcomponent, or is inherited from a 2479 parent derived type in the given derived type, this is a single ref with its 2480 component set to the returned component. 2481 2482 Otherwise, *ref is constructed as a chain of subcomponents. This occurs 2483 when the component is found through an implicit chain of nested union and 2484 map components. Unions and maps are "anonymous" substructures in FORTRAN 2485 which cannot be explicitly referenced, but the reference chain must be 2486 considered as in C for backend translation to correctly compute layouts. 2487 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */ 2488 2489gfc_component * 2490gfc_find_component (gfc_symbol *sym, const char *name, 2491 bool noaccess, bool silent, gfc_ref **ref) 2492{ 2493 gfc_component *p, *check; 2494 gfc_ref *sref = NULL, *tmp = NULL; 2495 2496 if (name == NULL || sym == NULL) 2497 return NULL; 2498 2499 if (sym->attr.flavor == FL_DERIVED) 2500 sym = gfc_use_derived (sym); 2501 else 2502 gcc_assert (gfc_fl_struct (sym->attr.flavor)); 2503 2504 if (sym == NULL) 2505 return NULL; 2506 2507 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */ 2508 if (sym->attr.flavor == FL_UNION) 2509 return find_union_component (sym, name, noaccess, ref); 2510 2511 if (ref) *ref = NULL; 2512 for (p = sym->components; p; p = p->next) 2513 { 2514 /* Nest search into union's maps. */ 2515 if (p->ts.type == BT_UNION) 2516 { 2517 check = find_union_component (p->ts.u.derived, name, noaccess, &tmp); 2518 if (check != NULL) 2519 { 2520 /* Union ref. */ 2521 if (ref) 2522 { 2523 sref = gfc_get_ref (); 2524 sref->type = REF_COMPONENT; 2525 sref->u.c.component = p; 2526 sref->u.c.sym = p->ts.u.derived; 2527 sref->next = tmp; 2528 *ref = sref; 2529 } 2530 return check; 2531 } 2532 } 2533 else if (strcmp (p->name, name) == 0) 2534 break; 2535 2536 continue; 2537 } 2538 2539 if (p && sym->attr.use_assoc && !noaccess) 2540 { 2541 bool is_parent_comp = sym->attr.extension && (p == sym->components); 2542 if (p->attr.access == ACCESS_PRIVATE || 2543 (p->attr.access != ACCESS_PUBLIC 2544 && sym->component_access == ACCESS_PRIVATE 2545 && !is_parent_comp)) 2546 { 2547 if (!silent) 2548 gfc_error ("Component %qs at %C is a PRIVATE component of %qs", 2549 name, sym->name); 2550 return NULL; 2551 } 2552 } 2553 2554 if (p == NULL 2555 && sym->attr.extension 2556 && sym->components->ts.type == BT_DERIVED) 2557 { 2558 p = gfc_find_component (sym->components->ts.u.derived, name, 2559 noaccess, silent, ref); 2560 /* Do not overwrite the error. */ 2561 if (p == NULL) 2562 return p; 2563 } 2564 2565 if (p == NULL && !silent) 2566 { 2567 const char *guessed = lookup_component_fuzzy (name, sym->components); 2568 if (guessed) 2569 gfc_error ("%qs at %C is not a member of the %qs structure" 2570 "; did you mean %qs?", 2571 name, sym->name, guessed); 2572 else 2573 gfc_error ("%qs at %C is not a member of the %qs structure", 2574 name, sym->name); 2575 } 2576 2577 /* Component was found; build the ultimate component reference. */ 2578 if (p != NULL && ref) 2579 { 2580 tmp = gfc_get_ref (); 2581 tmp->type = REF_COMPONENT; 2582 tmp->u.c.component = p; 2583 tmp->u.c.sym = sym; 2584 /* Link the final component ref to the end of the chain of subrefs. */ 2585 if (sref) 2586 { 2587 *ref = sref; 2588 for (; sref->next; sref = sref->next) 2589 ; 2590 sref->next = tmp; 2591 } 2592 else 2593 *ref = tmp; 2594 } 2595 2596 return p; 2597} 2598 2599 2600/* Given a symbol, free all of the component structures and everything 2601 they point to. */ 2602 2603static void 2604free_components (gfc_component *p) 2605{ 2606 gfc_component *q; 2607 2608 for (; p; p = q) 2609 { 2610 q = p->next; 2611 2612 gfc_free_array_spec (p->as); 2613 gfc_free_expr (p->initializer); 2614 if (p->kind_expr) 2615 gfc_free_expr (p->kind_expr); 2616 if (p->param_list) 2617 gfc_free_actual_arglist (p->param_list); 2618 free (p->tb); 2619 p->tb = NULL; 2620 free (p); 2621 } 2622} 2623 2624 2625/******************** Statement label management ********************/ 2626 2627/* Comparison function for statement labels, used for managing the 2628 binary tree. */ 2629 2630static int 2631compare_st_labels (void *a1, void *b1) 2632{ 2633 int a = ((gfc_st_label *) a1)->value; 2634 int b = ((gfc_st_label *) b1)->value; 2635 2636 return (b - a); 2637} 2638 2639 2640/* Free a single gfc_st_label structure, making sure the tree is not 2641 messed up. This function is called only when some parse error 2642 occurs. */ 2643 2644void 2645gfc_free_st_label (gfc_st_label *label) 2646{ 2647 2648 if (label == NULL) 2649 return; 2650 2651 gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels); 2652 2653 if (label->format != NULL) 2654 gfc_free_expr (label->format); 2655 2656 free (label); 2657} 2658 2659 2660/* Free a whole tree of gfc_st_label structures. */ 2661 2662static void 2663free_st_labels (gfc_st_label *label) 2664{ 2665 2666 if (label == NULL) 2667 return; 2668 2669 free_st_labels (label->left); 2670 free_st_labels (label->right); 2671 2672 if (label->format != NULL) 2673 gfc_free_expr (label->format); 2674 free (label); 2675} 2676 2677 2678/* Given a label number, search for and return a pointer to the label 2679 structure, creating it if it does not exist. */ 2680 2681gfc_st_label * 2682gfc_get_st_label (int labelno) 2683{ 2684 gfc_st_label *lp; 2685 gfc_namespace *ns; 2686 2687 if (gfc_current_state () == COMP_DERIVED) 2688 ns = gfc_current_block ()->f2k_derived; 2689 else 2690 { 2691 /* Find the namespace of the scoping unit: 2692 If we're in a BLOCK construct, jump to the parent namespace. */ 2693 ns = gfc_current_ns; 2694 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL) 2695 ns = ns->parent; 2696 } 2697 2698 /* First see if the label is already in this namespace. */ 2699 lp = ns->st_labels; 2700 while (lp) 2701 { 2702 if (lp->value == labelno) 2703 return lp; 2704 2705 if (lp->value < labelno) 2706 lp = lp->left; 2707 else 2708 lp = lp->right; 2709 } 2710 2711 lp = XCNEW (gfc_st_label); 2712 2713 lp->value = labelno; 2714 lp->defined = ST_LABEL_UNKNOWN; 2715 lp->referenced = ST_LABEL_UNKNOWN; 2716 lp->ns = ns; 2717 2718 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels); 2719 2720 return lp; 2721} 2722 2723 2724/* Called when a statement with a statement label is about to be 2725 accepted. We add the label to the list of the current namespace, 2726 making sure it hasn't been defined previously and referenced 2727 correctly. */ 2728 2729void 2730gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) 2731{ 2732 int labelno; 2733 2734 labelno = lp->value; 2735 2736 if (lp->defined != ST_LABEL_UNKNOWN) 2737 gfc_error ("Duplicate statement label %d at %L and %L", labelno, 2738 &lp->where, label_locus); 2739 else 2740 { 2741 lp->where = *label_locus; 2742 2743 switch (type) 2744 { 2745 case ST_LABEL_FORMAT: 2746 if (lp->referenced == ST_LABEL_TARGET 2747 || lp->referenced == ST_LABEL_DO_TARGET) 2748 gfc_error ("Label %d at %C already referenced as branch target", 2749 labelno); 2750 else 2751 lp->defined = ST_LABEL_FORMAT; 2752 2753 break; 2754 2755 case ST_LABEL_TARGET: 2756 case ST_LABEL_DO_TARGET: 2757 if (lp->referenced == ST_LABEL_FORMAT) 2758 gfc_error ("Label %d at %C already referenced as a format label", 2759 labelno); 2760 else 2761 lp->defined = type; 2762 2763 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET 2764 && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, 2765 "DO termination statement which is not END DO" 2766 " or CONTINUE with label %d at %C", labelno)) 2767 return; 2768 break; 2769 2770 default: 2771 lp->defined = ST_LABEL_BAD_TARGET; 2772 lp->referenced = ST_LABEL_BAD_TARGET; 2773 } 2774 } 2775} 2776 2777 2778/* Reference a label. Given a label and its type, see if that 2779 reference is consistent with what is known about that label, 2780 updating the unknown state. Returns false if something goes 2781 wrong. */ 2782 2783bool 2784gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) 2785{ 2786 gfc_sl_type label_type; 2787 int labelno; 2788 bool rc; 2789 2790 if (lp == NULL) 2791 return true; 2792 2793 labelno = lp->value; 2794 2795 if (lp->defined != ST_LABEL_UNKNOWN) 2796 label_type = lp->defined; 2797 else 2798 { 2799 label_type = lp->referenced; 2800 lp->where = gfc_current_locus; 2801 } 2802 2803 if (label_type == ST_LABEL_FORMAT 2804 && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET)) 2805 { 2806 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); 2807 rc = false; 2808 goto done; 2809 } 2810 2811 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET 2812 || label_type == ST_LABEL_BAD_TARGET) 2813 && type == ST_LABEL_FORMAT) 2814 { 2815 gfc_error ("Label %d at %C previously used as branch target", labelno); 2816 rc = false; 2817 goto done; 2818 } 2819 2820 if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET 2821 && !gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL, 2822 "Shared DO termination label %d at %C", labelno)) 2823 return false; 2824 2825 if (type == ST_LABEL_DO_TARGET 2826 && !gfc_notify_std (GFC_STD_F2018_OBS, "Labeled DO statement " 2827 "at %L", &gfc_current_locus)) 2828 return false; 2829 2830 if (lp->referenced != ST_LABEL_DO_TARGET) 2831 lp->referenced = type; 2832 rc = true; 2833 2834done: 2835 return rc; 2836} 2837 2838 2839/************** Symbol table management subroutines ****************/ 2840 2841/* Basic details: Fortran 95 requires a potentially unlimited number 2842 of distinct namespaces when compiling a program unit. This case 2843 occurs during a compilation of internal subprograms because all of 2844 the internal subprograms must be read before we can start 2845 generating code for the host. 2846 2847 Given the tricky nature of the Fortran grammar, we must be able to 2848 undo changes made to a symbol table if the current interpretation 2849 of a statement is found to be incorrect. Whenever a symbol is 2850 looked up, we make a copy of it and link to it. All of these 2851 symbols are kept in a vector so that we can commit or 2852 undo the changes at a later time. 2853 2854 A symtree may point to a symbol node outside of its namespace. In 2855 this case, that symbol has been used as a host associated variable 2856 at some previous time. */ 2857 2858/* Allocate a new namespace structure. Copies the implicit types from 2859 PARENT if PARENT_TYPES is set. */ 2860 2861gfc_namespace * 2862gfc_get_namespace (gfc_namespace *parent, int parent_types) 2863{ 2864 gfc_namespace *ns; 2865 gfc_typespec *ts; 2866 int in; 2867 int i; 2868 2869 ns = XCNEW (gfc_namespace); 2870 ns->sym_root = NULL; 2871 ns->uop_root = NULL; 2872 ns->tb_sym_root = NULL; 2873 ns->finalizers = NULL; 2874 ns->default_access = ACCESS_UNKNOWN; 2875 ns->parent = parent; 2876 2877 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) 2878 { 2879 ns->operator_access[in] = ACCESS_UNKNOWN; 2880 ns->tb_op[in] = NULL; 2881 } 2882 2883 /* Initialize default implicit types. */ 2884 for (i = 'a'; i <= 'z'; i++) 2885 { 2886 ns->set_flag[i - 'a'] = 0; 2887 ts = &ns->default_type[i - 'a']; 2888 2889 if (parent_types && ns->parent != NULL) 2890 { 2891 /* Copy parent settings. */ 2892 *ts = ns->parent->default_type[i - 'a']; 2893 continue; 2894 } 2895 2896 if (flag_implicit_none != 0) 2897 { 2898 gfc_clear_ts (ts); 2899 continue; 2900 } 2901 2902 if ('i' <= i && i <= 'n') 2903 { 2904 ts->type = BT_INTEGER; 2905 ts->kind = gfc_default_integer_kind; 2906 } 2907 else 2908 { 2909 ts->type = BT_REAL; 2910 ts->kind = gfc_default_real_kind; 2911 } 2912 } 2913 2914 ns->refs = 1; 2915 2916 return ns; 2917} 2918 2919 2920/* Comparison function for symtree nodes. */ 2921 2922static int 2923compare_symtree (void *_st1, void *_st2) 2924{ 2925 gfc_symtree *st1, *st2; 2926 2927 st1 = (gfc_symtree *) _st1; 2928 st2 = (gfc_symtree *) _st2; 2929 2930 return strcmp (st1->name, st2->name); 2931} 2932 2933 2934/* Allocate a new symtree node and associate it with the new symbol. */ 2935 2936gfc_symtree * 2937gfc_new_symtree (gfc_symtree **root, const char *name) 2938{ 2939 gfc_symtree *st; 2940 2941 st = XCNEW (gfc_symtree); 2942 st->name = gfc_get_string ("%s", name); 2943 2944 gfc_insert_bbt (root, st, compare_symtree); 2945 return st; 2946} 2947 2948 2949/* Delete a symbol from the tree. Does not free the symbol itself! */ 2950 2951void 2952gfc_delete_symtree (gfc_symtree **root, const char *name) 2953{ 2954 gfc_symtree st, *st0; 2955 const char *p; 2956 2957 /* Submodules are marked as mod.submod. When freeing a submodule 2958 symbol, the symtree only has "submod", so adjust that here. */ 2959 2960 p = strrchr(name, '.'); 2961 if (p) 2962 p++; 2963 else 2964 p = name; 2965 2966 st0 = gfc_find_symtree (*root, p); 2967 2968 st.name = gfc_get_string ("%s", p); 2969 gfc_delete_bbt (root, &st, compare_symtree); 2970 2971 free (st0); 2972} 2973 2974 2975/* Given a root symtree node and a name, try to find the symbol within 2976 the namespace. Returns NULL if the symbol is not found. */ 2977 2978gfc_symtree * 2979gfc_find_symtree (gfc_symtree *st, const char *name) 2980{ 2981 int c; 2982 2983 while (st != NULL) 2984 { 2985 c = strcmp (name, st->name); 2986 if (c == 0) 2987 return st; 2988 2989 st = (c < 0) ? st->left : st->right; 2990 } 2991 2992 return NULL; 2993} 2994 2995 2996/* Return a symtree node with a name that is guaranteed to be unique 2997 within the namespace and corresponds to an illegal fortran name. */ 2998 2999gfc_symtree * 3000gfc_get_unique_symtree (gfc_namespace *ns) 3001{ 3002 char name[GFC_MAX_SYMBOL_LEN + 1]; 3003 static int serial = 0; 3004 3005 sprintf (name, "@%d", serial++); 3006 return gfc_new_symtree (&ns->sym_root, name); 3007} 3008 3009 3010/* Given a name find a user operator node, creating it if it doesn't 3011 exist. These are much simpler than symbols because they can't be 3012 ambiguous with one another. */ 3013 3014gfc_user_op * 3015gfc_get_uop (const char *name) 3016{ 3017 gfc_user_op *uop; 3018 gfc_symtree *st; 3019 gfc_namespace *ns = gfc_current_ns; 3020 3021 if (ns->omp_udr_ns) 3022 ns = ns->parent; 3023 st = gfc_find_symtree (ns->uop_root, name); 3024 if (st != NULL) 3025 return st->n.uop; 3026 3027 st = gfc_new_symtree (&ns->uop_root, name); 3028 3029 uop = st->n.uop = XCNEW (gfc_user_op); 3030 uop->name = gfc_get_string ("%s", name); 3031 uop->access = ACCESS_UNKNOWN; 3032 uop->ns = ns; 3033 3034 return uop; 3035} 3036 3037 3038/* Given a name find the user operator node. Returns NULL if it does 3039 not exist. */ 3040 3041gfc_user_op * 3042gfc_find_uop (const char *name, gfc_namespace *ns) 3043{ 3044 gfc_symtree *st; 3045 3046 if (ns == NULL) 3047 ns = gfc_current_ns; 3048 3049 st = gfc_find_symtree (ns->uop_root, name); 3050 return (st == NULL) ? NULL : st->n.uop; 3051} 3052 3053 3054/* Update a symbol's common_block field, and take care of the associated 3055 memory management. */ 3056 3057static void 3058set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block) 3059{ 3060 if (sym->common_block == common_block) 3061 return; 3062 3063 if (sym->common_block && sym->common_block->name[0] != '\0') 3064 { 3065 sym->common_block->refs--; 3066 if (sym->common_block->refs == 0) 3067 free (sym->common_block); 3068 } 3069 sym->common_block = common_block; 3070} 3071 3072 3073/* Remove a gfc_symbol structure and everything it points to. */ 3074 3075void 3076gfc_free_symbol (gfc_symbol *&sym) 3077{ 3078 3079 if (sym == NULL) 3080 return; 3081 3082 gfc_free_array_spec (sym->as); 3083 3084 free_components (sym->components); 3085 3086 gfc_free_expr (sym->value); 3087 3088 gfc_free_namelist (sym->namelist); 3089 3090 if (sym->ns != sym->formal_ns) 3091 gfc_free_namespace (sym->formal_ns); 3092 3093 if (!sym->attr.generic_copy) 3094 gfc_free_interface (sym->generic); 3095 3096 gfc_free_formal_arglist (sym->formal); 3097 3098 gfc_free_namespace (sym->f2k_derived); 3099 3100 set_symbol_common_block (sym, NULL); 3101 3102 if (sym->param_list) 3103 gfc_free_actual_arglist (sym->param_list); 3104 3105 free (sym); 3106 sym = NULL; 3107} 3108 3109 3110/* Decrease the reference counter and free memory when we reach zero. */ 3111 3112void 3113gfc_release_symbol (gfc_symbol *&sym) 3114{ 3115 if (sym == NULL) 3116 return; 3117 3118 if (sym->formal_ns != NULL && sym->refs == 2 && sym->formal_ns != sym->ns 3119 && (!sym->attr.entry || !sym->module)) 3120 { 3121 /* As formal_ns contains a reference to sym, delete formal_ns just 3122 before the deletion of sym. */ 3123 gfc_namespace *ns = sym->formal_ns; 3124 sym->formal_ns = NULL; 3125 gfc_free_namespace (ns); 3126 } 3127 3128 sym->refs--; 3129 if (sym->refs > 0) 3130 return; 3131 3132 gcc_assert (sym->refs == 0); 3133 gfc_free_symbol (sym); 3134} 3135 3136 3137/* Allocate and initialize a new symbol node. */ 3138 3139gfc_symbol * 3140gfc_new_symbol (const char *name, gfc_namespace *ns) 3141{ 3142 gfc_symbol *p; 3143 3144 p = XCNEW (gfc_symbol); 3145 3146 gfc_clear_ts (&p->ts); 3147 gfc_clear_attr (&p->attr); 3148 p->ns = ns; 3149 p->declared_at = gfc_current_locus; 3150 p->name = gfc_get_string ("%s", name); 3151 3152 return p; 3153} 3154 3155 3156/* Generate an error if a symbol is ambiguous, and set the error flag 3157 on it. */ 3158 3159static void 3160ambiguous_symbol (const char *name, gfc_symtree *st) 3161{ 3162 3163 if (st->n.sym->error) 3164 return; 3165 3166 if (st->n.sym->module) 3167 gfc_error ("Name %qs at %C is an ambiguous reference to %qs " 3168 "from module %qs", name, st->n.sym->name, st->n.sym->module); 3169 else 3170 gfc_error ("Name %qs at %C is an ambiguous reference to %qs " 3171 "from current program unit", name, st->n.sym->name); 3172 3173 st->n.sym->error = 1; 3174} 3175 3176 3177/* If we're in a SELECT TYPE block, check if the variable 'st' matches any 3178 selector on the stack. If yes, replace it by the corresponding temporary. */ 3179 3180static void 3181select_type_insert_tmp (gfc_symtree **st) 3182{ 3183 gfc_select_type_stack *stack = select_type_stack; 3184 for (; stack; stack = stack->prev) 3185 if ((*st)->n.sym == stack->selector && stack->tmp) 3186 { 3187 *st = stack->tmp; 3188 select_type_insert_tmp (st); 3189 return; 3190 } 3191} 3192 3193 3194/* Look for a symtree in the current procedure -- that is, go up to 3195 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */ 3196 3197gfc_symtree* 3198gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns) 3199{ 3200 while (ns) 3201 { 3202 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name); 3203 if (st) 3204 return st; 3205 3206 if (!ns->construct_entities) 3207 break; 3208 ns = ns->parent; 3209 } 3210 3211 return NULL; 3212} 3213 3214 3215/* Search for a symtree starting in the current namespace, resorting to 3216 any parent namespaces if requested by a nonzero parent_flag. 3217 Returns nonzero if the name is ambiguous. */ 3218 3219int 3220gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, 3221 gfc_symtree **result) 3222{ 3223 gfc_symtree *st; 3224 3225 if (ns == NULL) 3226 ns = gfc_current_ns; 3227 3228 do 3229 { 3230 st = gfc_find_symtree (ns->sym_root, name); 3231 if (st != NULL) 3232 { 3233 select_type_insert_tmp (&st); 3234 3235 *result = st; 3236 /* Ambiguous generic interfaces are permitted, as long 3237 as the specific interfaces are different. */ 3238 if (st->ambiguous && !st->n.sym->attr.generic) 3239 { 3240 ambiguous_symbol (name, st); 3241 return 1; 3242 } 3243 3244 return 0; 3245 } 3246 3247 if (!parent_flag) 3248 break; 3249 3250 /* Don't escape an interface block. */ 3251 if (ns && !ns->has_import_set 3252 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY) 3253 break; 3254 3255 ns = ns->parent; 3256 } 3257 while (ns != NULL); 3258 3259 if (gfc_current_state() == COMP_DERIVED 3260 && gfc_current_block ()->attr.pdt_template) 3261 { 3262 gfc_symbol *der = gfc_current_block (); 3263 for (; der; der = gfc_get_derived_super_type (der)) 3264 { 3265 if (der->f2k_derived && der->f2k_derived->sym_root) 3266 { 3267 st = gfc_find_symtree (der->f2k_derived->sym_root, name); 3268 if (st) 3269 break; 3270 } 3271 } 3272 *result = st; 3273 return 0; 3274 } 3275 3276 *result = NULL; 3277 3278 return 0; 3279} 3280 3281 3282/* Same, but returns the symbol instead. */ 3283 3284int 3285gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag, 3286 gfc_symbol **result) 3287{ 3288 gfc_symtree *st; 3289 int i; 3290 3291 i = gfc_find_sym_tree (name, ns, parent_flag, &st); 3292 3293 if (st == NULL) 3294 *result = NULL; 3295 else 3296 *result = st->n.sym; 3297 3298 return i; 3299} 3300 3301 3302/* Tells whether there is only one set of changes in the stack. */ 3303 3304static bool 3305single_undo_checkpoint_p (void) 3306{ 3307 if (latest_undo_chgset == &default_undo_chgset_var) 3308 { 3309 gcc_assert (latest_undo_chgset->previous == NULL); 3310 return true; 3311 } 3312 else 3313 { 3314 gcc_assert (latest_undo_chgset->previous != NULL); 3315 return false; 3316 } 3317} 3318 3319/* Save symbol with the information necessary to back it out. */ 3320 3321void 3322gfc_save_symbol_data (gfc_symbol *sym) 3323{ 3324 gfc_symbol *s; 3325 unsigned i; 3326 3327 if (!single_undo_checkpoint_p ()) 3328 { 3329 /* If there is more than one change set, look for the symbol in the 3330 current one. If it is found there, we can reuse it. */ 3331 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) 3332 if (s == sym) 3333 { 3334 gcc_assert (sym->gfc_new || sym->old_symbol != NULL); 3335 return; 3336 } 3337 } 3338 else if (sym->gfc_new || sym->old_symbol != NULL) 3339 return; 3340 3341 s = XCNEW (gfc_symbol); 3342 *s = *sym; 3343 sym->old_symbol = s; 3344 sym->gfc_new = 0; 3345 3346 latest_undo_chgset->syms.safe_push (sym); 3347} 3348 3349 3350/* Given a name, find a symbol, or create it if it does not exist yet 3351 in the current namespace. If the symbol is found we make sure that 3352 it's OK. 3353 3354 The integer return code indicates 3355 0 All OK 3356 1 The symbol name was ambiguous 3357 2 The name meant to be established was already host associated. 3358 3359 So if the return value is nonzero, then an error was issued. */ 3360 3361int 3362gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, 3363 bool allow_subroutine) 3364{ 3365 gfc_symtree *st; 3366 gfc_symbol *p; 3367 3368 /* This doesn't usually happen during resolution. */ 3369 if (ns == NULL) 3370 ns = gfc_current_ns; 3371 3372 /* Try to find the symbol in ns. */ 3373 st = gfc_find_symtree (ns->sym_root, name); 3374 3375 if (st == NULL && ns->omp_udr_ns) 3376 { 3377 ns = ns->parent; 3378 st = gfc_find_symtree (ns->sym_root, name); 3379 } 3380 3381 if (st == NULL) 3382 { 3383 /* If not there, create a new symbol. */ 3384 p = gfc_new_symbol (name, ns); 3385 3386 /* Add to the list of tentative symbols. */ 3387 p->old_symbol = NULL; 3388 p->mark = 1; 3389 p->gfc_new = 1; 3390 latest_undo_chgset->syms.safe_push (p); 3391 3392 st = gfc_new_symtree (&ns->sym_root, name); 3393 st->n.sym = p; 3394 p->refs++; 3395 3396 } 3397 else 3398 { 3399 /* Make sure the existing symbol is OK. Ambiguous 3400 generic interfaces are permitted, as long as the 3401 specific interfaces are different. */ 3402 if (st->ambiguous && !st->n.sym->attr.generic) 3403 { 3404 ambiguous_symbol (name, st); 3405 return 1; 3406 } 3407 3408 p = st->n.sym; 3409 if (p->ns != ns && (!p->attr.function || ns->proc_name != p) 3410 && !(allow_subroutine && p->attr.subroutine) 3411 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY 3412 && (ns->has_import_set || p->attr.imported))) 3413 { 3414 /* Symbol is from another namespace. */ 3415 gfc_error ("Symbol %qs at %C has already been host associated", 3416 name); 3417 return 2; 3418 } 3419 3420 p->mark = 1; 3421 3422 /* Copy in case this symbol is changed. */ 3423 gfc_save_symbol_data (p); 3424 } 3425 3426 *result = st; 3427 return 0; 3428} 3429 3430 3431int 3432gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) 3433{ 3434 gfc_symtree *st; 3435 int i; 3436 3437 i = gfc_get_sym_tree (name, ns, &st, false); 3438 if (i != 0) 3439 return i; 3440 3441 if (st) 3442 *result = st->n.sym; 3443 else 3444 *result = NULL; 3445 return i; 3446} 3447 3448 3449/* Subroutine that searches for a symbol, creating it if it doesn't 3450 exist, but tries to host-associate the symbol if possible. */ 3451 3452int 3453gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) 3454{ 3455 gfc_symtree *st; 3456 int i; 3457 3458 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); 3459 3460 if (st != NULL) 3461 { 3462 gfc_save_symbol_data (st->n.sym); 3463 *result = st; 3464 return i; 3465 } 3466 3467 i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st); 3468 if (i) 3469 return i; 3470 3471 if (st != NULL) 3472 { 3473 *result = st; 3474 return 0; 3475 } 3476 3477 return gfc_get_sym_tree (name, gfc_current_ns, result, false); 3478} 3479 3480 3481int 3482gfc_get_ha_symbol (const char *name, gfc_symbol **result) 3483{ 3484 int i; 3485 gfc_symtree *st; 3486 3487 i = gfc_get_ha_sym_tree (name, &st); 3488 3489 if (st) 3490 *result = st->n.sym; 3491 else 3492 *result = NULL; 3493 3494 return i; 3495} 3496 3497 3498/* Search for the symtree belonging to a gfc_common_head; we cannot use 3499 head->name as the common_root symtree's name might be mangled. */ 3500 3501static gfc_symtree * 3502find_common_symtree (gfc_symtree *st, gfc_common_head *head) 3503{ 3504 3505 gfc_symtree *result; 3506 3507 if (st == NULL) 3508 return NULL; 3509 3510 if (st->n.common == head) 3511 return st; 3512 3513 result = find_common_symtree (st->left, head); 3514 if (!result) 3515 result = find_common_symtree (st->right, head); 3516 3517 return result; 3518} 3519 3520 3521/* Restore previous state of symbol. Just copy simple stuff. */ 3522 3523static void 3524restore_old_symbol (gfc_symbol *p) 3525{ 3526 gfc_symbol *old; 3527 3528 p->mark = 0; 3529 old = p->old_symbol; 3530 3531 p->ts.type = old->ts.type; 3532 p->ts.kind = old->ts.kind; 3533 3534 p->attr = old->attr; 3535 3536 if (p->value != old->value) 3537 { 3538 gcc_checking_assert (old->value == NULL); 3539 gfc_free_expr (p->value); 3540 p->value = NULL; 3541 } 3542 3543 if (p->as != old->as) 3544 { 3545 if (p->as) 3546 gfc_free_array_spec (p->as); 3547 p->as = old->as; 3548 } 3549 3550 p->generic = old->generic; 3551 p->component_access = old->component_access; 3552 3553 if (p->namelist != NULL && old->namelist == NULL) 3554 { 3555 gfc_free_namelist (p->namelist); 3556 p->namelist = NULL; 3557 } 3558 else 3559 { 3560 if (p->namelist_tail != old->namelist_tail) 3561 { 3562 gfc_free_namelist (old->namelist_tail->next); 3563 old->namelist_tail->next = NULL; 3564 } 3565 } 3566 3567 p->namelist_tail = old->namelist_tail; 3568 3569 if (p->formal != old->formal) 3570 { 3571 gfc_free_formal_arglist (p->formal); 3572 p->formal = old->formal; 3573 } 3574 3575 set_symbol_common_block (p, old->common_block); 3576 p->common_head = old->common_head; 3577 3578 p->old_symbol = old->old_symbol; 3579 free (old); 3580} 3581 3582 3583/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free 3584 the structure itself. */ 3585 3586static void 3587free_undo_change_set_data (gfc_undo_change_set &cs) 3588{ 3589 cs.syms.release (); 3590 cs.tbps.release (); 3591} 3592 3593 3594/* Given a change set pointer, free its target's contents and update it with 3595 the address of the previous change set. Note that only the contents are 3596 freed, not the target itself (the contents' container). It is not a problem 3597 as the latter will be a local variable usually. */ 3598 3599static void 3600pop_undo_change_set (gfc_undo_change_set *&cs) 3601{ 3602 free_undo_change_set_data (*cs); 3603 cs = cs->previous; 3604} 3605 3606 3607static void free_old_symbol (gfc_symbol *sym); 3608 3609 3610/* Merges the current change set into the previous one. The changes themselves 3611 are left untouched; only one checkpoint is forgotten. */ 3612 3613void 3614gfc_drop_last_undo_checkpoint (void) 3615{ 3616 gfc_symbol *s, *t; 3617 unsigned i, j; 3618 3619 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s) 3620 { 3621 /* No need to loop in this case. */ 3622 if (s->old_symbol == NULL) 3623 continue; 3624 3625 /* Remove the duplicate symbols. */ 3626 FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t) 3627 if (t == s) 3628 { 3629 latest_undo_chgset->previous->syms.unordered_remove (j); 3630 3631 /* S->OLD_SYMBOL is the backup symbol for S as it was at the 3632 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL 3633 shall contain from now on the backup symbol for S as it was 3634 at the checkpoint before. */ 3635 if (s->old_symbol->gfc_new) 3636 { 3637 gcc_assert (s->old_symbol->old_symbol == NULL); 3638 s->gfc_new = s->old_symbol->gfc_new; 3639 free_old_symbol (s); 3640 } 3641 else 3642 restore_old_symbol (s->old_symbol); 3643 break; 3644 } 3645 } 3646 3647 latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms); 3648 latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps); 3649 3650 pop_undo_change_set (latest_undo_chgset); 3651} 3652 3653 3654/* Undoes all the changes made to symbols since the previous checkpoint. 3655 This subroutine is made simpler due to the fact that attributes are 3656 never removed once added. */ 3657 3658void 3659gfc_restore_last_undo_checkpoint (void) 3660{ 3661 gfc_symbol *p; 3662 unsigned i; 3663 3664 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) 3665 { 3666 /* Symbol in a common block was new. Or was old and just put in common */ 3667 if (p->common_block 3668 && (p->gfc_new || !p->old_symbol->common_block)) 3669 { 3670 /* If the symbol was added to any common block, it 3671 needs to be removed to stop the resolver looking 3672 for a (possibly) dead symbol. */ 3673 if (p->common_block->head == p && !p->common_next) 3674 { 3675 gfc_symtree st, *st0; 3676 st0 = find_common_symtree (p->ns->common_root, 3677 p->common_block); 3678 if (st0) 3679 { 3680 st.name = st0->name; 3681 gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree); 3682 free (st0); 3683 } 3684 } 3685 3686 if (p->common_block->head == p) 3687 p->common_block->head = p->common_next; 3688 else 3689 { 3690 gfc_symbol *cparent, *csym; 3691 3692 cparent = p->common_block->head; 3693 csym = cparent->common_next; 3694 3695 while (csym != p) 3696 { 3697 cparent = csym; 3698 csym = csym->common_next; 3699 } 3700 3701 gcc_assert(cparent->common_next == p); 3702 cparent->common_next = csym->common_next; 3703 } 3704 p->common_next = NULL; 3705 } 3706 if (p->gfc_new) 3707 { 3708 /* The derived type is saved in the symtree with the first 3709 letter capitalized; the all lower-case version to the 3710 derived type contains its associated generic function. */ 3711 if (gfc_fl_struct (p->attr.flavor)) 3712 gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name)); 3713 else 3714 gfc_delete_symtree (&p->ns->sym_root, p->name); 3715 3716 gfc_release_symbol (p); 3717 } 3718 else 3719 restore_old_symbol (p); 3720 } 3721 3722 latest_undo_chgset->syms.truncate (0); 3723 latest_undo_chgset->tbps.truncate (0); 3724 3725 if (!single_undo_checkpoint_p ()) 3726 pop_undo_change_set (latest_undo_chgset); 3727} 3728 3729 3730/* Makes sure that there is only one set of changes; in other words we haven't 3731 forgotten to pair a call to gfc_new_checkpoint with a call to either 3732 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */ 3733 3734static void 3735enforce_single_undo_checkpoint (void) 3736{ 3737 gcc_checking_assert (single_undo_checkpoint_p ()); 3738} 3739 3740 3741/* Undoes all the changes made to symbols in the current statement. */ 3742 3743void 3744gfc_undo_symbols (void) 3745{ 3746 enforce_single_undo_checkpoint (); 3747 gfc_restore_last_undo_checkpoint (); 3748} 3749 3750 3751/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the 3752 components of old_symbol that might need deallocation are the "allocatables" 3753 that are restored in gfc_undo_symbols(), with two exceptions: namelist and 3754 namelist_tail. In case these differ between old_symbol and sym, it's just 3755 because sym->namelist has gotten a few more items. */ 3756 3757static void 3758free_old_symbol (gfc_symbol *sym) 3759{ 3760 3761 if (sym->old_symbol == NULL) 3762 return; 3763 3764 if (sym->old_symbol->as != NULL 3765 && sym->old_symbol->as != sym->as 3766 && !(sym->ts.type == BT_CLASS 3767 && sym->ts.u.derived->attr.is_class 3768 && sym->old_symbol->as == CLASS_DATA (sym)->as)) 3769 gfc_free_array_spec (sym->old_symbol->as); 3770 3771 if (sym->old_symbol->value != sym->value) 3772 gfc_free_expr (sym->old_symbol->value); 3773 3774 if (sym->old_symbol->formal != sym->formal) 3775 gfc_free_formal_arglist (sym->old_symbol->formal); 3776 3777 free (sym->old_symbol); 3778 sym->old_symbol = NULL; 3779} 3780 3781 3782/* Makes the changes made in the current statement permanent-- gets 3783 rid of undo information. */ 3784 3785void 3786gfc_commit_symbols (void) 3787{ 3788 gfc_symbol *p; 3789 gfc_typebound_proc *tbp; 3790 unsigned i; 3791 3792 enforce_single_undo_checkpoint (); 3793 3794 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) 3795 { 3796 p->mark = 0; 3797 p->gfc_new = 0; 3798 free_old_symbol (p); 3799 } 3800 latest_undo_chgset->syms.truncate (0); 3801 3802 FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp) 3803 tbp->error = 0; 3804 latest_undo_chgset->tbps.truncate (0); 3805} 3806 3807 3808/* Makes the changes made in one symbol permanent -- gets rid of undo 3809 information. */ 3810 3811void 3812gfc_commit_symbol (gfc_symbol *sym) 3813{ 3814 gfc_symbol *p; 3815 unsigned i; 3816 3817 enforce_single_undo_checkpoint (); 3818 3819 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p) 3820 if (p == sym) 3821 { 3822 latest_undo_chgset->syms.unordered_remove (i); 3823 break; 3824 } 3825 3826 sym->mark = 0; 3827 sym->gfc_new = 0; 3828 3829 free_old_symbol (sym); 3830} 3831 3832 3833/* Recursively free trees containing type-bound procedures. */ 3834 3835static void 3836free_tb_tree (gfc_symtree *t) 3837{ 3838 if (t == NULL) 3839 return; 3840 3841 free_tb_tree (t->left); 3842 free_tb_tree (t->right); 3843 3844 /* TODO: Free type-bound procedure u.generic */ 3845 free (t->n.tb); 3846 t->n.tb = NULL; 3847 free (t); 3848} 3849 3850 3851/* Recursive function that deletes an entire tree and all the common 3852 head structures it points to. */ 3853 3854static void 3855free_common_tree (gfc_symtree * common_tree) 3856{ 3857 if (common_tree == NULL) 3858 return; 3859 3860 free_common_tree (common_tree->left); 3861 free_common_tree (common_tree->right); 3862 3863 free (common_tree); 3864} 3865 3866 3867/* Recursive function that deletes an entire tree and all the common 3868 head structures it points to. */ 3869 3870static void 3871free_omp_udr_tree (gfc_symtree * omp_udr_tree) 3872{ 3873 if (omp_udr_tree == NULL) 3874 return; 3875 3876 free_omp_udr_tree (omp_udr_tree->left); 3877 free_omp_udr_tree (omp_udr_tree->right); 3878 3879 gfc_free_omp_udr (omp_udr_tree->n.omp_udr); 3880 free (omp_udr_tree); 3881} 3882 3883 3884/* Recursive function that deletes an entire tree and all the user 3885 operator nodes that it contains. */ 3886 3887static void 3888free_uop_tree (gfc_symtree *uop_tree) 3889{ 3890 if (uop_tree == NULL) 3891 return; 3892 3893 free_uop_tree (uop_tree->left); 3894 free_uop_tree (uop_tree->right); 3895 3896 gfc_free_interface (uop_tree->n.uop->op); 3897 free (uop_tree->n.uop); 3898 free (uop_tree); 3899} 3900 3901 3902/* Recursive function that deletes an entire tree and all the symbols 3903 that it contains. */ 3904 3905static void 3906free_sym_tree (gfc_symtree *sym_tree) 3907{ 3908 if (sym_tree == NULL) 3909 return; 3910 3911 free_sym_tree (sym_tree->left); 3912 free_sym_tree (sym_tree->right); 3913 3914 gfc_release_symbol (sym_tree->n.sym); 3915 free (sym_tree); 3916} 3917 3918 3919/* Free the gfc_equiv_info's. */ 3920 3921static void 3922gfc_free_equiv_infos (gfc_equiv_info *s) 3923{ 3924 if (s == NULL) 3925 return; 3926 gfc_free_equiv_infos (s->next); 3927 free (s); 3928} 3929 3930 3931/* Free the gfc_equiv_lists. */ 3932 3933static void 3934gfc_free_equiv_lists (gfc_equiv_list *l) 3935{ 3936 if (l == NULL) 3937 return; 3938 gfc_free_equiv_lists (l->next); 3939 gfc_free_equiv_infos (l->equiv); 3940 free (l); 3941} 3942 3943 3944/* Free a finalizer procedure list. */ 3945 3946void 3947gfc_free_finalizer (gfc_finalizer* el) 3948{ 3949 if (el) 3950 { 3951 gfc_release_symbol (el->proc_sym); 3952 free (el); 3953 } 3954} 3955 3956static void 3957gfc_free_finalizer_list (gfc_finalizer* list) 3958{ 3959 while (list) 3960 { 3961 gfc_finalizer* current = list; 3962 list = list->next; 3963 gfc_free_finalizer (current); 3964 } 3965} 3966 3967 3968/* Create a new gfc_charlen structure and add it to a namespace. 3969 If 'old_cl' is given, the newly created charlen will be a copy of it. */ 3970 3971gfc_charlen* 3972gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl) 3973{ 3974 gfc_charlen *cl; 3975 3976 cl = gfc_get_charlen (); 3977 3978 /* Copy old_cl. */ 3979 if (old_cl) 3980 { 3981 cl->length = gfc_copy_expr (old_cl->length); 3982 cl->length_from_typespec = old_cl->length_from_typespec; 3983 cl->backend_decl = old_cl->backend_decl; 3984 cl->passed_length = old_cl->passed_length; 3985 cl->resolved = old_cl->resolved; 3986 } 3987 3988 /* Put into namespace. */ 3989 cl->next = ns->cl_list; 3990 ns->cl_list = cl; 3991 3992 return cl; 3993} 3994 3995 3996/* Free the charlen list from cl to end (end is not freed). 3997 Free the whole list if end is NULL. */ 3998 3999static void 4000gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end) 4001{ 4002 gfc_charlen *cl2; 4003 4004 for (; cl != end; cl = cl2) 4005 { 4006 gcc_assert (cl); 4007 4008 cl2 = cl->next; 4009 gfc_free_expr (cl->length); 4010 free (cl); 4011 } 4012} 4013 4014 4015/* Free entry list structs. */ 4016 4017static void 4018free_entry_list (gfc_entry_list *el) 4019{ 4020 gfc_entry_list *next; 4021 4022 if (el == NULL) 4023 return; 4024 4025 next = el->next; 4026 free (el); 4027 free_entry_list (next); 4028} 4029 4030 4031/* Free a namespace structure and everything below it. Interface 4032 lists associated with intrinsic operators are not freed. These are 4033 taken care of when a specific name is freed. */ 4034 4035void 4036gfc_free_namespace (gfc_namespace *&ns) 4037{ 4038 gfc_namespace *p, *q; 4039 int i; 4040 gfc_was_finalized *f; 4041 4042 if (ns == NULL) 4043 return; 4044 4045 ns->refs--; 4046 if (ns->refs > 0) 4047 return; 4048 4049 gcc_assert (ns->refs == 0); 4050 4051 gfc_free_statements (ns->code); 4052 4053 free_sym_tree (ns->sym_root); 4054 free_uop_tree (ns->uop_root); 4055 free_common_tree (ns->common_root); 4056 free_omp_udr_tree (ns->omp_udr_root); 4057 free_tb_tree (ns->tb_sym_root); 4058 free_tb_tree (ns->tb_uop_root); 4059 gfc_free_finalizer_list (ns->finalizers); 4060 gfc_free_omp_declare_simd_list (ns->omp_declare_simd); 4061 gfc_free_omp_declare_variant_list (ns->omp_declare_variant); 4062 gfc_free_charlen (ns->cl_list, NULL); 4063 free_st_labels (ns->st_labels); 4064 4065 free_entry_list (ns->entries); 4066 gfc_free_equiv (ns->equiv); 4067 gfc_free_equiv_lists (ns->equiv_lists); 4068 gfc_free_use_stmts (ns->use_stmts); 4069 4070 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) 4071 gfc_free_interface (ns->op[i]); 4072 4073 gfc_free_data (ns->data); 4074 4075 /* Free all the expr + component combinations that have been 4076 finalized. */ 4077 f = ns->was_finalized; 4078 while (f) 4079 { 4080 gfc_was_finalized* current = f; 4081 f = f->next; 4082 free (current); 4083 } 4084 4085 p = ns->contained; 4086 free (ns); 4087 ns = NULL; 4088 4089 /* Recursively free any contained namespaces. */ 4090 while (p != NULL) 4091 { 4092 q = p; 4093 p = p->sibling; 4094 gfc_free_namespace (q); 4095 } 4096} 4097 4098 4099void 4100gfc_symbol_init_2 (void) 4101{ 4102 4103 gfc_current_ns = gfc_get_namespace (NULL, 0); 4104} 4105 4106 4107void 4108gfc_symbol_done_2 (void) 4109{ 4110 if (gfc_current_ns != NULL) 4111 { 4112 /* free everything from the root. */ 4113 while (gfc_current_ns->parent != NULL) 4114 gfc_current_ns = gfc_current_ns->parent; 4115 gfc_free_namespace (gfc_current_ns); 4116 gfc_current_ns = NULL; 4117 } 4118 gfc_derived_types = NULL; 4119 4120 enforce_single_undo_checkpoint (); 4121 free_undo_change_set_data (*latest_undo_chgset); 4122} 4123 4124 4125/* Count how many nodes a symtree has. */ 4126 4127static unsigned 4128count_st_nodes (const gfc_symtree *st) 4129{ 4130 unsigned nodes; 4131 if (!st) 4132 return 0; 4133 4134 nodes = count_st_nodes (st->left); 4135 nodes++; 4136 nodes += count_st_nodes (st->right); 4137 4138 return nodes; 4139} 4140 4141 4142/* Convert symtree tree into symtree vector. */ 4143 4144static unsigned 4145fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr) 4146{ 4147 if (!st) 4148 return node_cntr; 4149 4150 node_cntr = fill_st_vector (st->left, st_vec, node_cntr); 4151 st_vec[node_cntr++] = st; 4152 node_cntr = fill_st_vector (st->right, st_vec, node_cntr); 4153 4154 return node_cntr; 4155} 4156 4157 4158/* Traverse namespace. As the functions might modify the symtree, we store the 4159 symtree as a vector and operate on this vector. Note: We assume that 4160 sym_func or st_func never deletes nodes from the symtree - only adding is 4161 allowed. Additionally, newly added nodes are not traversed. */ 4162 4163static void 4164do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *), 4165 void (*sym_func) (gfc_symbol *)) 4166{ 4167 gfc_symtree **st_vec; 4168 unsigned nodes, i, node_cntr; 4169 4170 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func)); 4171 nodes = count_st_nodes (st); 4172 st_vec = XALLOCAVEC (gfc_symtree *, nodes); 4173 node_cntr = 0; 4174 fill_st_vector (st, st_vec, node_cntr); 4175 4176 if (sym_func) 4177 { 4178 /* Clear marks. */ 4179 for (i = 0; i < nodes; i++) 4180 st_vec[i]->n.sym->mark = 0; 4181 for (i = 0; i < nodes; i++) 4182 if (!st_vec[i]->n.sym->mark) 4183 { 4184 (*sym_func) (st_vec[i]->n.sym); 4185 st_vec[i]->n.sym->mark = 1; 4186 } 4187 } 4188 else 4189 for (i = 0; i < nodes; i++) 4190 (*st_func) (st_vec[i]); 4191} 4192 4193 4194/* Recursively traverse the symtree nodes. */ 4195 4196void 4197gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *)) 4198{ 4199 do_traverse_symtree (st, st_func, NULL); 4200} 4201 4202 4203/* Call a given function for all symbols in the namespace. We take 4204 care that each gfc_symbol node is called exactly once. */ 4205 4206void 4207gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *)) 4208{ 4209 do_traverse_symtree (ns->sym_root, NULL, sym_func); 4210} 4211 4212 4213/* Return TRUE when name is the name of an intrinsic type. */ 4214 4215bool 4216gfc_is_intrinsic_typename (const char *name) 4217{ 4218 if (strcmp (name, "integer") == 0 4219 || strcmp (name, "real") == 0 4220 || strcmp (name, "character") == 0 4221 || strcmp (name, "logical") == 0 4222 || strcmp (name, "complex") == 0 4223 || strcmp (name, "doubleprecision") == 0 4224 || strcmp (name, "doublecomplex") == 0) 4225 return true; 4226 else 4227 return false; 4228} 4229 4230 4231/* Return TRUE if the symbol is an automatic variable. */ 4232 4233static bool 4234gfc_is_var_automatic (gfc_symbol *sym) 4235{ 4236 /* Pointer and allocatable variables are never automatic. */ 4237 if (sym->attr.pointer || sym->attr.allocatable) 4238 return false; 4239 /* Check for arrays with non-constant size. */ 4240 if (sym->attr.dimension && sym->as 4241 && !gfc_is_compile_time_shape (sym->as)) 4242 return true; 4243 /* Check for non-constant length character variables. */ 4244 if (sym->ts.type == BT_CHARACTER 4245 && sym->ts.u.cl 4246 && !gfc_is_constant_expr (sym->ts.u.cl->length)) 4247 return true; 4248 /* Variables with explicit AUTOMATIC attribute. */ 4249 if (sym->attr.automatic) 4250 return true; 4251 4252 return false; 4253} 4254 4255/* Given a symbol, mark it as SAVEd if it is allowed. */ 4256 4257static void 4258save_symbol (gfc_symbol *sym) 4259{ 4260 4261 if (sym->attr.use_assoc) 4262 return; 4263 4264 if (sym->attr.in_common 4265 || sym->attr.in_equivalence 4266 || sym->attr.dummy 4267 || sym->attr.result 4268 || sym->attr.flavor != FL_VARIABLE) 4269 return; 4270 /* Automatic objects are not saved. */ 4271 if (gfc_is_var_automatic (sym)) 4272 return; 4273 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at); 4274} 4275 4276 4277/* Mark those symbols which can be SAVEd as such. */ 4278 4279void 4280gfc_save_all (gfc_namespace *ns) 4281{ 4282 gfc_traverse_ns (ns, save_symbol); 4283} 4284 4285 4286/* Make sure that no changes to symbols are pending. */ 4287 4288void 4289gfc_enforce_clean_symbol_state(void) 4290{ 4291 enforce_single_undo_checkpoint (); 4292 gcc_assert (latest_undo_chgset->syms.is_empty ()); 4293} 4294 4295 4296/************** Global symbol handling ************/ 4297 4298 4299/* Search a tree for the global symbol. */ 4300 4301gfc_gsymbol * 4302gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) 4303{ 4304 int c; 4305 4306 if (symbol == NULL) 4307 return NULL; 4308 4309 while (symbol) 4310 { 4311 c = strcmp (name, symbol->name); 4312 if (!c) 4313 return symbol; 4314 4315 symbol = (c < 0) ? symbol->left : symbol->right; 4316 } 4317 4318 return NULL; 4319} 4320 4321 4322/* Case insensitive search a tree for the global symbol. */ 4323 4324gfc_gsymbol * 4325gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name) 4326{ 4327 int c; 4328 4329 if (symbol == NULL) 4330 return NULL; 4331 4332 while (symbol) 4333 { 4334 c = strcasecmp (name, symbol->name); 4335 if (!c) 4336 return symbol; 4337 4338 symbol = (c < 0) ? symbol->left : symbol->right; 4339 } 4340 4341 return NULL; 4342} 4343 4344 4345/* Compare two global symbols. Used for managing the BB tree. */ 4346 4347static int 4348gsym_compare (void *_s1, void *_s2) 4349{ 4350 gfc_gsymbol *s1, *s2; 4351 4352 s1 = (gfc_gsymbol *) _s1; 4353 s2 = (gfc_gsymbol *) _s2; 4354 return strcmp (s1->name, s2->name); 4355} 4356 4357 4358/* Get a global symbol, creating it if it doesn't exist. */ 4359 4360gfc_gsymbol * 4361gfc_get_gsymbol (const char *name, bool bind_c) 4362{ 4363 gfc_gsymbol *s; 4364 4365 s = gfc_find_gsymbol (gfc_gsym_root, name); 4366 if (s != NULL) 4367 return s; 4368 4369 s = XCNEW (gfc_gsymbol); 4370 s->type = GSYM_UNKNOWN; 4371 s->name = gfc_get_string ("%s", name); 4372 s->bind_c = bind_c; 4373 4374 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); 4375 4376 return s; 4377} 4378 4379void 4380gfc_traverse_gsymbol (gfc_gsymbol *gsym, 4381 void (*do_something) (gfc_gsymbol *, void *), 4382 void *data) 4383{ 4384 if (gsym->left) 4385 gfc_traverse_gsymbol (gsym->left, do_something, data); 4386 4387 (*do_something) (gsym, data); 4388 4389 if (gsym->right) 4390 gfc_traverse_gsymbol (gsym->right, do_something, data); 4391} 4392 4393static gfc_symbol * 4394get_iso_c_binding_dt (int sym_id) 4395{ 4396 gfc_symbol *dt_list = gfc_derived_types; 4397 4398 /* Loop through the derived types in the name list, searching for 4399 the desired symbol from iso_c_binding. Search the parent namespaces 4400 if necessary and requested to (parent_flag). */ 4401 if (dt_list) 4402 { 4403 while (dt_list->dt_next != gfc_derived_types) 4404 { 4405 if (dt_list->from_intmod != INTMOD_NONE 4406 && dt_list->intmod_sym_id == sym_id) 4407 return dt_list; 4408 4409 dt_list = dt_list->dt_next; 4410 } 4411 } 4412 4413 return NULL; 4414} 4415 4416 4417/* Verifies that the given derived type symbol, derived_sym, is interoperable 4418 with C. This is necessary for any derived type that is BIND(C) and for 4419 derived types that are parameters to functions that are BIND(C). All 4420 fields of the derived type are required to be interoperable, and are tested 4421 for such. If an error occurs, the errors are reported here, allowing for 4422 multiple errors to be handled for a single derived type. */ 4423 4424bool 4425verify_bind_c_derived_type (gfc_symbol *derived_sym) 4426{ 4427 gfc_component *curr_comp = NULL; 4428 bool is_c_interop = false; 4429 bool retval = true; 4430 4431 if (derived_sym == NULL) 4432 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " 4433 "unexpectedly NULL"); 4434 4435 /* If we've already looked at this derived symbol, do not look at it again 4436 so we don't repeat warnings/errors. */ 4437 if (derived_sym->ts.is_c_interop) 4438 return true; 4439 4440 /* The derived type must have the BIND attribute to be interoperable 4441 J3/04-007, Section 15.2.3. */ 4442 if (derived_sym->attr.is_bind_c != 1) 4443 { 4444 derived_sym->ts.is_c_interop = 0; 4445 gfc_error_now ("Derived type %qs declared at %L must have the BIND " 4446 "attribute to be C interoperable", derived_sym->name, 4447 &(derived_sym->declared_at)); 4448 retval = false; 4449 } 4450 4451 curr_comp = derived_sym->components; 4452 4453 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an 4454 empty struct. Section 15.2 in Fortran 2003 states: "The following 4455 subclauses define the conditions under which a Fortran entity is 4456 interoperable. If a Fortran entity is interoperable, an equivalent 4457 entity may be defined by means of C and the Fortran entity is said 4458 to be interoperable with the C entity. There does not have to be such 4459 an interoperating C entity." 4460 */ 4461 if (curr_comp == NULL) 4462 { 4463 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, " 4464 "and may be inaccessible by the C companion processor", 4465 derived_sym->name, &(derived_sym->declared_at)); 4466 derived_sym->ts.is_c_interop = 1; 4467 derived_sym->attr.is_bind_c = 1; 4468 return true; 4469 } 4470 4471 4472 /* Initialize the derived type as being C interoperable. 4473 If we find an error in the components, this will be set false. */ 4474 derived_sym->ts.is_c_interop = 1; 4475 4476 /* Loop through the list of components to verify that the kind of 4477 each is a C interoperable type. */ 4478 do 4479 { 4480 /* The components cannot be pointers (fortran sense). 4481 J3/04-007, Section 15.2.3, C1505. */ 4482 if (curr_comp->attr.pointer != 0) 4483 { 4484 gfc_error ("Component %qs at %L cannot have the " 4485 "POINTER attribute because it is a member " 4486 "of the BIND(C) derived type %qs at %L", 4487 curr_comp->name, &(curr_comp->loc), 4488 derived_sym->name, &(derived_sym->declared_at)); 4489 retval = false; 4490 } 4491 4492 if (curr_comp->attr.proc_pointer != 0) 4493 { 4494 gfc_error ("Procedure pointer component %qs at %L cannot be a member" 4495 " of the BIND(C) derived type %qs at %L", curr_comp->name, 4496 &curr_comp->loc, derived_sym->name, 4497 &derived_sym->declared_at); 4498 retval = false; 4499 } 4500 4501 /* The components cannot be allocatable. 4502 J3/04-007, Section 15.2.3, C1505. */ 4503 if (curr_comp->attr.allocatable != 0) 4504 { 4505 gfc_error ("Component %qs at %L cannot have the " 4506 "ALLOCATABLE attribute because it is a member " 4507 "of the BIND(C) derived type %qs at %L", 4508 curr_comp->name, &(curr_comp->loc), 4509 derived_sym->name, &(derived_sym->declared_at)); 4510 retval = false; 4511 } 4512 4513 /* BIND(C) derived types must have interoperable components. */ 4514 if (curr_comp->ts.type == BT_DERIVED 4515 && curr_comp->ts.u.derived->ts.is_iso_c != 1 4516 && curr_comp->ts.u.derived != derived_sym) 4517 { 4518 /* This should be allowed; the draft says a derived-type cannot 4519 have type parameters if it is has the BIND attribute. Type 4520 parameters seem to be for making parameterized derived types. 4521 There's no need to verify the type if it is c_ptr/c_funptr. */ 4522 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived); 4523 } 4524 else 4525 { 4526 /* Grab the typespec for the given component and test the kind. */ 4527 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts)); 4528 4529 if (!is_c_interop) 4530 { 4531 /* Report warning and continue since not fatal. The 4532 draft does specify a constraint that requires all fields 4533 to interoperate, but if the user says real(4), etc., it 4534 may interoperate with *something* in C, but the compiler 4535 most likely won't know exactly what. Further, it may not 4536 interoperate with the same data type(s) in C if the user 4537 recompiles with different flags (e.g., -m32 and -m64 on 4538 x86_64 and using integer(4) to claim interop with a 4539 C_LONG). */ 4540 if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_type) 4541 /* If the derived type is bind(c), all fields must be 4542 interop. */ 4543 gfc_warning (OPT_Wc_binding_type, 4544 "Component %qs in derived type %qs at %L " 4545 "may not be C interoperable, even though " 4546 "derived type %qs is BIND(C)", 4547 curr_comp->name, derived_sym->name, 4548 &(curr_comp->loc), derived_sym->name); 4549 else if (warn_c_binding_type) 4550 /* If derived type is param to bind(c) routine, or to one 4551 of the iso_c_binding procs, it must be interoperable, so 4552 all fields must interop too. */ 4553 gfc_warning (OPT_Wc_binding_type, 4554 "Component %qs in derived type %qs at %L " 4555 "may not be C interoperable", 4556 curr_comp->name, derived_sym->name, 4557 &(curr_comp->loc)); 4558 } 4559 } 4560 4561 curr_comp = curr_comp->next; 4562 } while (curr_comp != NULL); 4563 4564 if (derived_sym->attr.sequence != 0) 4565 { 4566 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE " 4567 "attribute because it is BIND(C)", derived_sym->name, 4568 &(derived_sym->declared_at)); 4569 retval = false; 4570 } 4571 4572 /* Mark the derived type as not being C interoperable if we found an 4573 error. If there were only warnings, proceed with the assumption 4574 it's interoperable. */ 4575 if (!retval) 4576 derived_sym->ts.is_c_interop = 0; 4577 4578 return retval; 4579} 4580 4581 4582/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ 4583 4584static bool 4585gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree) 4586{ 4587 gfc_constructor *c; 4588 4589 gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym); 4590 dt_symtree->n.sym->attr.referenced = 1; 4591 4592 tmp_sym->attr.is_c_interop = 1; 4593 tmp_sym->attr.is_bind_c = 1; 4594 tmp_sym->ts.is_c_interop = 1; 4595 tmp_sym->ts.is_iso_c = 1; 4596 tmp_sym->ts.type = BT_DERIVED; 4597 tmp_sym->ts.f90_type = BT_VOID; 4598 tmp_sym->attr.flavor = FL_PARAMETER; 4599 tmp_sym->ts.u.derived = dt_symtree->n.sym; 4600 4601 /* Set the c_address field of c_null_ptr and c_null_funptr to 4602 the value of NULL. */ 4603 tmp_sym->value = gfc_get_expr (); 4604 tmp_sym->value->expr_type = EXPR_STRUCTURE; 4605 tmp_sym->value->ts.type = BT_DERIVED; 4606 tmp_sym->value->ts.f90_type = BT_VOID; 4607 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived; 4608 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL); 4609 c = gfc_constructor_first (tmp_sym->value->value.constructor); 4610 c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); 4611 c->expr->ts.is_iso_c = 1; 4612 4613 return true; 4614} 4615 4616 4617/* Add a formal argument, gfc_formal_arglist, to the 4618 end of the given list of arguments. Set the reference to the 4619 provided symbol, param_sym, in the argument. */ 4620 4621static void 4622add_formal_arg (gfc_formal_arglist **head, 4623 gfc_formal_arglist **tail, 4624 gfc_formal_arglist *formal_arg, 4625 gfc_symbol *param_sym) 4626{ 4627 /* Put in list, either as first arg or at the tail (curr arg). */ 4628 if (*head == NULL) 4629 *head = *tail = formal_arg; 4630 else 4631 { 4632 (*tail)->next = formal_arg; 4633 (*tail) = formal_arg; 4634 } 4635 4636 (*tail)->sym = param_sym; 4637 (*tail)->next = NULL; 4638 4639 return; 4640} 4641 4642 4643/* Add a procedure interface to the given symbol (i.e., store a 4644 reference to the list of formal arguments). */ 4645 4646static void 4647add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal) 4648{ 4649 4650 sym->formal = formal; 4651 sym->attr.if_source = source; 4652} 4653 4654 4655/* Copy the formal args from an existing symbol, src, into a new 4656 symbol, dest. New formal args are created, and the description of 4657 each arg is set according to the existing ones. This function is 4658 used when creating procedure declaration variables from a procedure 4659 declaration statement (see match_proc_decl()) to create the formal 4660 args based on the args of a given named interface. 4661 4662 When an actual argument list is provided, skip the absent arguments 4663 unless copy_type is true. 4664 To be used together with gfc_se->ignore_optional. */ 4665 4666void 4667gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src, 4668 gfc_actual_arglist *actual, bool copy_type) 4669{ 4670 gfc_formal_arglist *head = NULL; 4671 gfc_formal_arglist *tail = NULL; 4672 gfc_formal_arglist *formal_arg = NULL; 4673 gfc_intrinsic_arg *curr_arg = NULL; 4674 gfc_formal_arglist *formal_prev = NULL; 4675 gfc_actual_arglist *act_arg = actual; 4676 /* Save current namespace so we can change it for formal args. */ 4677 gfc_namespace *parent_ns = gfc_current_ns; 4678 4679 /* Create a new namespace, which will be the formal ns (namespace 4680 of the formal args). */ 4681 gfc_current_ns = gfc_get_namespace (parent_ns, 0); 4682 gfc_current_ns->proc_name = dest; 4683 4684 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) 4685 { 4686 /* Skip absent arguments. */ 4687 if (actual) 4688 { 4689 gcc_assert (act_arg != NULL); 4690 if (act_arg->expr == NULL) 4691 { 4692 act_arg = act_arg->next; 4693 continue; 4694 } 4695 } 4696 formal_arg = gfc_get_formal_arglist (); 4697 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); 4698 4699 /* May need to copy more info for the symbol. */ 4700 if (copy_type && act_arg->expr != NULL) 4701 { 4702 formal_arg->sym->ts = act_arg->expr->ts; 4703 if (act_arg->expr->rank > 0) 4704 { 4705 formal_arg->sym->attr.dimension = 1; 4706 formal_arg->sym->as = gfc_get_array_spec(); 4707 formal_arg->sym->as->rank = -1; 4708 formal_arg->sym->as->type = AS_ASSUMED_RANK; 4709 } 4710 if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0) 4711 formal_arg->sym->pass_as_value = 1; 4712 } 4713 else 4714 formal_arg->sym->ts = curr_arg->ts; 4715 4716 formal_arg->sym->attr.optional = curr_arg->optional; 4717 formal_arg->sym->attr.value = curr_arg->value; 4718 formal_arg->sym->attr.intent = curr_arg->intent; 4719 formal_arg->sym->attr.flavor = FL_VARIABLE; 4720 formal_arg->sym->attr.dummy = 1; 4721 4722 if (formal_arg->sym->ts.type == BT_CHARACTER) 4723 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 4724 4725 /* If this isn't the first arg, set up the next ptr. For the 4726 last arg built, the formal_arg->next will never get set to 4727 anything other than NULL. */ 4728 if (formal_prev != NULL) 4729 formal_prev->next = formal_arg; 4730 else 4731 formal_arg->next = NULL; 4732 4733 formal_prev = formal_arg; 4734 4735 /* Add arg to list of formal args. */ 4736 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); 4737 4738 /* Validate changes. */ 4739 gfc_commit_symbol (formal_arg->sym); 4740 if (actual) 4741 act_arg = act_arg->next; 4742 } 4743 4744 /* Add the interface to the symbol. */ 4745 add_proc_interface (dest, IFSRC_DECL, head); 4746 4747 /* Store the formal namespace information. */ 4748 if (dest->formal != NULL) 4749 /* The current ns should be that for the dest proc. */ 4750 dest->formal_ns = gfc_current_ns; 4751 /* Restore the current namespace to what it was on entry. */ 4752 gfc_current_ns = parent_ns; 4753} 4754 4755 4756static int 4757std_for_isocbinding_symbol (int id) 4758{ 4759 switch (id) 4760 { 4761#define NAMED_INTCST(a,b,c,d) \ 4762 case a:\ 4763 return d; 4764#include "iso-c-binding.def" 4765#undef NAMED_INTCST 4766 4767#define NAMED_FUNCTION(a,b,c,d) \ 4768 case a:\ 4769 return d; 4770#define NAMED_SUBROUTINE(a,b,c,d) \ 4771 case a:\ 4772 return d; 4773#include "iso-c-binding.def" 4774#undef NAMED_FUNCTION 4775#undef NAMED_SUBROUTINE 4776 4777 default: 4778 return GFC_STD_F2003; 4779 } 4780} 4781 4782/* Generate the given set of C interoperable kind objects, or all 4783 interoperable kinds. This function will only be given kind objects 4784 for valid iso_c_binding defined types because this is verified when 4785 the 'use' statement is parsed. If the user gives an 'only' clause, 4786 the specific kinds are looked up; if they don't exist, an error is 4787 reported. If the user does not give an 'only' clause, all 4788 iso_c_binding symbols are generated. If a list of specific kinds 4789 is given, it must have a NULL in the first empty spot to mark the 4790 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and 4791 point to the symtree for c_(fun)ptr. */ 4792 4793gfc_symtree * 4794generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, 4795 const char *local_name, gfc_symtree *dt_symtree, 4796 bool hidden) 4797{ 4798 const char *const name = (local_name && local_name[0]) 4799 ? local_name : c_interop_kinds_table[s].name; 4800 gfc_symtree *tmp_symtree; 4801 gfc_symbol *tmp_sym = NULL; 4802 int index; 4803 4804 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) 4805 return NULL; 4806 4807 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); 4808 if (hidden 4809 && (!tmp_symtree || !tmp_symtree->n.sym 4810 || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING 4811 || tmp_symtree->n.sym->intmod_sym_id != s)) 4812 tmp_symtree = NULL; 4813 4814 /* Already exists in this scope so don't re-add it. */ 4815 if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL 4816 && (!tmp_sym->attr.generic 4817 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL) 4818 && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING) 4819 { 4820 if (tmp_sym->attr.flavor == FL_DERIVED 4821 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id)) 4822 { 4823 if (gfc_derived_types) 4824 { 4825 tmp_sym->dt_next = gfc_derived_types->dt_next; 4826 gfc_derived_types->dt_next = tmp_sym; 4827 } 4828 else 4829 { 4830 tmp_sym->dt_next = tmp_sym; 4831 } 4832 gfc_derived_types = tmp_sym; 4833 } 4834 4835 return tmp_symtree; 4836 } 4837 4838 /* Create the sym tree in the current ns. */ 4839 if (hidden) 4840 { 4841 tmp_symtree = gfc_get_unique_symtree (gfc_current_ns); 4842 tmp_sym = gfc_new_symbol (name, gfc_current_ns); 4843 4844 /* Add to the list of tentative symbols. */ 4845 latest_undo_chgset->syms.safe_push (tmp_sym); 4846 tmp_sym->old_symbol = NULL; 4847 tmp_sym->mark = 1; 4848 tmp_sym->gfc_new = 1; 4849 4850 tmp_symtree->n.sym = tmp_sym; 4851 tmp_sym->refs++; 4852 } 4853 else 4854 { 4855 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); 4856 gcc_assert (tmp_symtree); 4857 tmp_sym = tmp_symtree->n.sym; 4858 } 4859 4860 /* Say what module this symbol belongs to. */ 4861 tmp_sym->module = gfc_get_string ("%s", mod_name); 4862 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING; 4863 tmp_sym->intmod_sym_id = s; 4864 tmp_sym->attr.is_iso_c = 1; 4865 tmp_sym->attr.use_assoc = 1; 4866 4867 gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR 4868 || s == ISOCBINDING_NULL_PTR); 4869 4870 switch (s) 4871 { 4872 4873#define NAMED_INTCST(a,b,c,d) case a : 4874#define NAMED_REALCST(a,b,c,d) case a : 4875#define NAMED_CMPXCST(a,b,c,d) case a : 4876#define NAMED_LOGCST(a,b,c) case a : 4877#define NAMED_CHARKNDCST(a,b,c) case a : 4878#include "iso-c-binding.def" 4879 4880 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, 4881 c_interop_kinds_table[s].value); 4882 4883 /* Initialize an integer constant expression node. */ 4884 tmp_sym->attr.flavor = FL_PARAMETER; 4885 tmp_sym->ts.type = BT_INTEGER; 4886 tmp_sym->ts.kind = gfc_default_integer_kind; 4887 4888 /* Mark this type as a C interoperable one. */ 4889 tmp_sym->ts.is_c_interop = 1; 4890 tmp_sym->ts.is_iso_c = 1; 4891 tmp_sym->value->ts.is_c_interop = 1; 4892 tmp_sym->value->ts.is_iso_c = 1; 4893 tmp_sym->attr.is_c_interop = 1; 4894 4895 /* Tell what f90 type this c interop kind is valid. */ 4896 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type; 4897 4898 break; 4899 4900 4901#define NAMED_CHARCST(a,b,c) case a : 4902#include "iso-c-binding.def" 4903 4904 /* Initialize an integer constant expression node for the 4905 length of the character. */ 4906 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind, 4907 &gfc_current_locus, NULL, 1); 4908 tmp_sym->value->ts.is_c_interop = 1; 4909 tmp_sym->value->ts.is_iso_c = 1; 4910 tmp_sym->value->value.character.length = 1; 4911 tmp_sym->value->value.character.string[0] 4912 = (gfc_char_t) c_interop_kinds_table[s].value; 4913 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 4914 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, 4915 NULL, 1); 4916 4917 /* May not need this in both attr and ts, but do need in 4918 attr for writing module file. */ 4919 tmp_sym->attr.is_c_interop = 1; 4920 4921 tmp_sym->attr.flavor = FL_PARAMETER; 4922 tmp_sym->ts.type = BT_CHARACTER; 4923 4924 /* Need to set it to the C_CHAR kind. */ 4925 tmp_sym->ts.kind = gfc_default_character_kind; 4926 4927 /* Mark this type as a C interoperable one. */ 4928 tmp_sym->ts.is_c_interop = 1; 4929 tmp_sym->ts.is_iso_c = 1; 4930 4931 /* Tell what f90 type this c interop kind is valid. */ 4932 tmp_sym->ts.f90_type = BT_CHARACTER; 4933 4934 break; 4935 4936 case ISOCBINDING_PTR: 4937 case ISOCBINDING_FUNPTR: 4938 { 4939 gfc_symbol *dt_sym; 4940 gfc_component *tmp_comp = NULL; 4941 4942 /* Generate real derived type. */ 4943 if (hidden) 4944 dt_sym = tmp_sym; 4945 else 4946 { 4947 const char *hidden_name; 4948 gfc_interface *intr, *head; 4949 4950 hidden_name = gfc_dt_upper_string (tmp_sym->name); 4951 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, 4952 hidden_name); 4953 gcc_assert (tmp_symtree == NULL); 4954 gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false); 4955 dt_sym = tmp_symtree->n.sym; 4956 dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR 4957 ? "c_ptr" : "c_funptr"); 4958 4959 /* Generate an artificial generic function. */ 4960 head = tmp_sym->generic; 4961 intr = gfc_get_interface (); 4962 intr->sym = dt_sym; 4963 intr->where = gfc_current_locus; 4964 intr->next = head; 4965 tmp_sym->generic = intr; 4966 4967 if (!tmp_sym->attr.generic 4968 && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)) 4969 return NULL; 4970 4971 if (!tmp_sym->attr.function 4972 && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)) 4973 return NULL; 4974 } 4975 4976 /* Say what module this symbol belongs to. */ 4977 dt_sym->module = gfc_get_string ("%s", mod_name); 4978 dt_sym->from_intmod = INTMOD_ISO_C_BINDING; 4979 dt_sym->intmod_sym_id = s; 4980 dt_sym->attr.use_assoc = 1; 4981 4982 /* Initialize an integer constant expression node. */ 4983 dt_sym->attr.flavor = FL_DERIVED; 4984 dt_sym->ts.is_c_interop = 1; 4985 dt_sym->attr.is_c_interop = 1; 4986 dt_sym->attr.private_comp = 1; 4987 dt_sym->component_access = ACCESS_PRIVATE; 4988 dt_sym->ts.is_iso_c = 1; 4989 dt_sym->ts.type = BT_DERIVED; 4990 dt_sym->ts.f90_type = BT_VOID; 4991 4992 /* A derived type must have the bind attribute to be 4993 interoperable (J3/04-007, Section 15.2.3), even though 4994 the binding label is not used. */ 4995 dt_sym->attr.is_bind_c = 1; 4996 4997 dt_sym->attr.referenced = 1; 4998 dt_sym->ts.u.derived = dt_sym; 4999 5000 /* Add the symbol created for the derived type to the current ns. */ 5001 if (gfc_derived_types) 5002 { 5003 dt_sym->dt_next = gfc_derived_types->dt_next; 5004 gfc_derived_types->dt_next = dt_sym; 5005 } 5006 else 5007 { 5008 dt_sym->dt_next = dt_sym; 5009 } 5010 gfc_derived_types = dt_sym; 5011 5012 gfc_add_component (dt_sym, "c_address", &tmp_comp); 5013 if (tmp_comp == NULL) 5014 gcc_unreachable (); 5015 5016 tmp_comp->ts.type = BT_INTEGER; 5017 5018 /* Set this because the module will need to read/write this field. */ 5019 tmp_comp->ts.f90_type = BT_INTEGER; 5020 5021 /* The kinds for c_ptr and c_funptr are the same. */ 5022 index = get_c_kind ("c_ptr", c_interop_kinds_table); 5023 tmp_comp->ts.kind = c_interop_kinds_table[index].value; 5024 tmp_comp->attr.access = ACCESS_PRIVATE; 5025 5026 /* Mark the component as C interoperable. */ 5027 tmp_comp->ts.is_c_interop = 1; 5028 } 5029 5030 break; 5031 5032 case ISOCBINDING_NULL_PTR: 5033 case ISOCBINDING_NULL_FUNPTR: 5034 gen_special_c_interop_ptr (tmp_sym, dt_symtree); 5035 break; 5036 5037 default: 5038 gcc_unreachable (); 5039 } 5040 gfc_commit_symbol (tmp_sym); 5041 return tmp_symtree; 5042} 5043 5044 5045/* Check that a symbol is already typed. If strict is not set, an untyped 5046 symbol is acceptable for non-standard-conforming mode. */ 5047 5048bool 5049gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, 5050 bool strict, locus where) 5051{ 5052 gcc_assert (sym); 5053 5054 if (gfc_matching_prefix) 5055 return true; 5056 5057 /* Check for the type and try to give it an implicit one. */ 5058 if (sym->ts.type == BT_UNKNOWN 5059 && !gfc_set_default_type (sym, 0, ns)) 5060 { 5061 if (strict) 5062 { 5063 gfc_error ("Symbol %qs is used before it is typed at %L", 5064 sym->name, &where); 5065 return false; 5066 } 5067 5068 if (!gfc_notify_std (GFC_STD_GNU, "Symbol %qs is used before" 5069 " it is typed at %L", sym->name, &where)) 5070 return false; 5071 } 5072 5073 /* Everything is ok. */ 5074 return true; 5075} 5076 5077 5078/* Construct a typebound-procedure structure. Those are stored in a tentative 5079 list and marked `error' until symbols are committed. */ 5080 5081gfc_typebound_proc* 5082gfc_get_typebound_proc (gfc_typebound_proc *tb0) 5083{ 5084 gfc_typebound_proc *result; 5085 5086 result = XCNEW (gfc_typebound_proc); 5087 if (tb0) 5088 *result = *tb0; 5089 result->error = 1; 5090 5091 latest_undo_chgset->tbps.safe_push (result); 5092 5093 return result; 5094} 5095 5096 5097/* Get the super-type of a given derived type. */ 5098 5099gfc_symbol* 5100gfc_get_derived_super_type (gfc_symbol* derived) 5101{ 5102 gcc_assert (derived); 5103 5104 if (derived->attr.generic) 5105 derived = gfc_find_dt_in_generic (derived); 5106 5107 if (!derived->attr.extension) 5108 return NULL; 5109 5110 gcc_assert (derived->components); 5111 gcc_assert (derived->components->ts.type == BT_DERIVED); 5112 gcc_assert (derived->components->ts.u.derived); 5113 5114 if (derived->components->ts.u.derived->attr.generic) 5115 return gfc_find_dt_in_generic (derived->components->ts.u.derived); 5116 5117 return derived->components->ts.u.derived; 5118} 5119 5120 5121/* Check if a derived type t2 is an extension of (or equal to) a type t1. */ 5122 5123bool 5124gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) 5125{ 5126 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension) 5127 t2 = gfc_get_derived_super_type (t2); 5128 return gfc_compare_derived_types (t1, t2); 5129} 5130 5131 5132/* Check if two typespecs are type compatible (F03:5.1.1.2): 5133 If ts1 is nonpolymorphic, ts2 must be the same type. 5134 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */ 5135 5136bool 5137gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2) 5138{ 5139 bool is_class1 = (ts1->type == BT_CLASS); 5140 bool is_class2 = (ts2->type == BT_CLASS); 5141 bool is_derived1 = (ts1->type == BT_DERIVED); 5142 bool is_derived2 = (ts2->type == BT_DERIVED); 5143 bool is_union1 = (ts1->type == BT_UNION); 5144 bool is_union2 = (ts2->type == BT_UNION); 5145 5146 /* A boz-literal-constant has no type. */ 5147 if (ts1->type == BT_BOZ || ts2->type == BT_BOZ) 5148 return false; 5149 5150 if (is_class1 5151 && ts1->u.derived->components 5152 && ((ts1->u.derived->attr.is_class 5153 && ts1->u.derived->components->ts.u.derived->attr 5154 .unlimited_polymorphic) 5155 || ts1->u.derived->attr.unlimited_polymorphic)) 5156 return 1; 5157 5158 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2 5159 && !is_union1 && !is_union2) 5160 return (ts1->type == ts2->type); 5161 5162 if ((is_derived1 && is_derived2) || (is_union1 && is_union2)) 5163 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived); 5164 5165 if (is_derived1 && is_class2) 5166 return gfc_compare_derived_types (ts1->u.derived, 5167 ts2->u.derived->attr.is_class ? 5168 ts2->u.derived->components->ts.u.derived 5169 : ts2->u.derived); 5170 if (is_class1 && is_derived2) 5171 return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? 5172 ts1->u.derived->components->ts.u.derived 5173 : ts1->u.derived, 5174 ts2->u.derived); 5175 else if (is_class1 && is_class2) 5176 return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ? 5177 ts1->u.derived->components->ts.u.derived 5178 : ts1->u.derived, 5179 ts2->u.derived->attr.is_class ? 5180 ts2->u.derived->components->ts.u.derived 5181 : ts2->u.derived); 5182 else 5183 return 0; 5184} 5185 5186 5187/* Find the parent-namespace of the current function. If we're inside 5188 BLOCK constructs, it may not be the current one. */ 5189 5190gfc_namespace* 5191gfc_find_proc_namespace (gfc_namespace* ns) 5192{ 5193 while (ns->construct_entities) 5194 { 5195 ns = ns->parent; 5196 gcc_assert (ns); 5197 } 5198 5199 return ns; 5200} 5201 5202 5203/* Check if an associate-variable should be translated as an `implicit' pointer 5204 internally (if it is associated to a variable and not an array with 5205 descriptor). */ 5206 5207bool 5208gfc_is_associate_pointer (gfc_symbol* sym) 5209{ 5210 if (!sym->assoc) 5211 return false; 5212 5213 if (sym->ts.type == BT_CLASS) 5214 return true; 5215 5216 if (sym->ts.type == BT_CHARACTER 5217 && sym->ts.deferred 5218 && sym->assoc->target 5219 && sym->assoc->target->expr_type == EXPR_FUNCTION) 5220 return true; 5221 5222 if (!sym->assoc->variable) 5223 return false; 5224 5225 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT) 5226 return false; 5227 5228 return true; 5229} 5230 5231 5232gfc_symbol * 5233gfc_find_dt_in_generic (gfc_symbol *sym) 5234{ 5235 gfc_interface *intr = NULL; 5236 5237 if (!sym || gfc_fl_struct (sym->attr.flavor)) 5238 return sym; 5239 5240 if (sym->attr.generic) 5241 for (intr = sym->generic; intr; intr = intr->next) 5242 if (gfc_fl_struct (intr->sym->attr.flavor)) 5243 break; 5244 return intr ? intr->sym : NULL; 5245} 5246 5247 5248/* Get the dummy arguments from a procedure symbol. If it has been declared 5249 via a PROCEDURE statement with a named interface, ts.interface will be set 5250 and the arguments need to be taken from there. */ 5251 5252gfc_formal_arglist * 5253gfc_sym_get_dummy_args (gfc_symbol *sym) 5254{ 5255 gfc_formal_arglist *dummies; 5256 5257 if (sym == NULL) 5258 return NULL; 5259 5260 dummies = sym->formal; 5261 if (dummies == NULL && sym->ts.interface != NULL) 5262 dummies = sym->ts.interface->formal; 5263 5264 return dummies; 5265} 5266