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