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