1/* Perform type resolution on the various structures. 2 Copyright (C) 2001-2020 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#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "options.h" 25#include "bitmap.h" 26#include "gfortran.h" 27#include "arith.h" /* For gfc_compare_expr(). */ 28#include "dependency.h" 29#include "data.h" 30#include "target-memory.h" /* for gfc_simplify_transfer */ 31#include "constructor.h" 32 33/* Types used in equivalence statements. */ 34 35enum seq_type 36{ 37 SEQ_NONDEFAULT, SEQ_NUMERIC, SEQ_CHARACTER, SEQ_MIXED 38}; 39 40/* Stack to keep track of the nesting of blocks as we move through the 41 code. See resolve_branch() and gfc_resolve_code(). */ 42 43typedef struct code_stack 44{ 45 struct gfc_code *head, *current; 46 struct code_stack *prev; 47 48 /* This bitmap keeps track of the targets valid for a branch from 49 inside this block except for END {IF|SELECT}s of enclosing 50 blocks. */ 51 bitmap reachable_labels; 52} 53code_stack; 54 55static code_stack *cs_base = NULL; 56 57 58/* Nonzero if we're inside a FORALL or DO CONCURRENT block. */ 59 60static int forall_flag; 61int gfc_do_concurrent_flag; 62 63/* True when we are resolving an expression that is an actual argument to 64 a procedure. */ 65static bool actual_arg = false; 66/* True when we are resolving an expression that is the first actual argument 67 to a procedure. */ 68static bool first_actual_arg = false; 69 70 71/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */ 72 73static int omp_workshare_flag; 74 75/* True if we are processing a formal arglist. The corresponding function 76 resets the flag each time that it is read. */ 77static bool formal_arg_flag = false; 78 79/* True if we are resolving a specification expression. */ 80static bool specification_expr = false; 81 82/* The id of the last entry seen. */ 83static int current_entry_id; 84 85/* We use bitmaps to determine if a branch target is valid. */ 86static bitmap_obstack labels_obstack; 87 88/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */ 89static bool inquiry_argument = false; 90 91 92bool 93gfc_is_formal_arg (void) 94{ 95 return formal_arg_flag; 96} 97 98/* Is the symbol host associated? */ 99static bool 100is_sym_host_assoc (gfc_symbol *sym, gfc_namespace *ns) 101{ 102 for (ns = ns->parent; ns; ns = ns->parent) 103 { 104 if (sym->ns == ns) 105 return true; 106 } 107 108 return false; 109} 110 111/* Ensure a typespec used is valid; for instance, TYPE(t) is invalid if t is 112 an ABSTRACT derived-type. If where is not NULL, an error message with that 113 locus is printed, optionally using name. */ 114 115static bool 116resolve_typespec_used (gfc_typespec* ts, locus* where, const char* name) 117{ 118 if (ts->type == BT_DERIVED && ts->u.derived->attr.abstract) 119 { 120 if (where) 121 { 122 if (name) 123 gfc_error ("%qs at %L is of the ABSTRACT type %qs", 124 name, where, ts->u.derived->name); 125 else 126 gfc_error ("ABSTRACT type %qs used at %L", 127 ts->u.derived->name, where); 128 } 129 130 return false; 131 } 132 133 return true; 134} 135 136 137static bool 138check_proc_interface (gfc_symbol *ifc, locus *where) 139{ 140 /* Several checks for F08:C1216. */ 141 if (ifc->attr.procedure) 142 { 143 gfc_error ("Interface %qs at %L is declared " 144 "in a later PROCEDURE statement", ifc->name, where); 145 return false; 146 } 147 if (ifc->generic) 148 { 149 /* For generic interfaces, check if there is 150 a specific procedure with the same name. */ 151 gfc_interface *gen = ifc->generic; 152 while (gen && strcmp (gen->sym->name, ifc->name) != 0) 153 gen = gen->next; 154 if (!gen) 155 { 156 gfc_error ("Interface %qs at %L may not be generic", 157 ifc->name, where); 158 return false; 159 } 160 } 161 if (ifc->attr.proc == PROC_ST_FUNCTION) 162 { 163 gfc_error ("Interface %qs at %L may not be a statement function", 164 ifc->name, where); 165 return false; 166 } 167 if (gfc_is_intrinsic (ifc, 0, ifc->declared_at) 168 || gfc_is_intrinsic (ifc, 1, ifc->declared_at)) 169 ifc->attr.intrinsic = 1; 170 if (ifc->attr.intrinsic && !gfc_intrinsic_actual_ok (ifc->name, 0)) 171 { 172 gfc_error ("Intrinsic procedure %qs not allowed in " 173 "PROCEDURE statement at %L", ifc->name, where); 174 return false; 175 } 176 if (!ifc->attr.if_source && !ifc->attr.intrinsic && ifc->name[0] != '\0') 177 { 178 gfc_error ("Interface %qs at %L must be explicit", ifc->name, where); 179 return false; 180 } 181 return true; 182} 183 184 185static void resolve_symbol (gfc_symbol *sym); 186 187 188/* Resolve the interface for a PROCEDURE declaration or procedure pointer. */ 189 190static bool 191resolve_procedure_interface (gfc_symbol *sym) 192{ 193 gfc_symbol *ifc = sym->ts.interface; 194 195 if (!ifc) 196 return true; 197 198 if (ifc == sym) 199 { 200 gfc_error ("PROCEDURE %qs at %L may not be used as its own interface", 201 sym->name, &sym->declared_at); 202 return false; 203 } 204 if (!check_proc_interface (ifc, &sym->declared_at)) 205 return false; 206 207 if (ifc->attr.if_source || ifc->attr.intrinsic) 208 { 209 /* Resolve interface and copy attributes. */ 210 resolve_symbol (ifc); 211 if (ifc->attr.intrinsic) 212 gfc_resolve_intrinsic (ifc, &ifc->declared_at); 213 214 if (ifc->result) 215 { 216 sym->ts = ifc->result->ts; 217 sym->attr.allocatable = ifc->result->attr.allocatable; 218 sym->attr.pointer = ifc->result->attr.pointer; 219 sym->attr.dimension = ifc->result->attr.dimension; 220 sym->attr.class_ok = ifc->result->attr.class_ok; 221 sym->as = gfc_copy_array_spec (ifc->result->as); 222 sym->result = sym; 223 } 224 else 225 { 226 sym->ts = ifc->ts; 227 sym->attr.allocatable = ifc->attr.allocatable; 228 sym->attr.pointer = ifc->attr.pointer; 229 sym->attr.dimension = ifc->attr.dimension; 230 sym->attr.class_ok = ifc->attr.class_ok; 231 sym->as = gfc_copy_array_spec (ifc->as); 232 } 233 sym->ts.interface = ifc; 234 sym->attr.function = ifc->attr.function; 235 sym->attr.subroutine = ifc->attr.subroutine; 236 237 sym->attr.pure = ifc->attr.pure; 238 sym->attr.elemental = ifc->attr.elemental; 239 sym->attr.contiguous = ifc->attr.contiguous; 240 sym->attr.recursive = ifc->attr.recursive; 241 sym->attr.always_explicit = ifc->attr.always_explicit; 242 sym->attr.ext_attr |= ifc->attr.ext_attr; 243 sym->attr.is_bind_c = ifc->attr.is_bind_c; 244 /* Copy char length. */ 245 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) 246 { 247 sym->ts.u.cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); 248 if (sym->ts.u.cl->length && !sym->ts.u.cl->resolved 249 && !gfc_resolve_expr (sym->ts.u.cl->length)) 250 return false; 251 } 252 } 253 254 return true; 255} 256 257 258/* Resolve types of formal argument lists. These have to be done early so that 259 the formal argument lists of module procedures can be copied to the 260 containing module before the individual procedures are resolved 261 individually. We also resolve argument lists of procedures in interface 262 blocks because they are self-contained scoping units. 263 264 Since a dummy argument cannot be a non-dummy procedure, the only 265 resort left for untyped names are the IMPLICIT types. */ 266 267void 268gfc_resolve_formal_arglist (gfc_symbol *proc) 269{ 270 gfc_formal_arglist *f; 271 gfc_symbol *sym; 272 bool saved_specification_expr; 273 int i; 274 275 if (proc->result != NULL) 276 sym = proc->result; 277 else 278 sym = proc; 279 280 if (gfc_elemental (proc) 281 || sym->attr.pointer || sym->attr.allocatable 282 || (sym->as && sym->as->rank != 0)) 283 { 284 proc->attr.always_explicit = 1; 285 sym->attr.always_explicit = 1; 286 } 287 288 formal_arg_flag = true; 289 290 for (f = proc->formal; f; f = f->next) 291 { 292 gfc_array_spec *as; 293 294 sym = f->sym; 295 296 if (sym == NULL) 297 { 298 /* Alternate return placeholder. */ 299 if (gfc_elemental (proc)) 300 gfc_error ("Alternate return specifier in elemental subroutine " 301 "%qs at %L is not allowed", proc->name, 302 &proc->declared_at); 303 if (proc->attr.function) 304 gfc_error ("Alternate return specifier in function " 305 "%qs at %L is not allowed", proc->name, 306 &proc->declared_at); 307 continue; 308 } 309 else if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL 310 && !resolve_procedure_interface (sym)) 311 return; 312 313 if (strcmp (proc->name, sym->name) == 0) 314 { 315 gfc_error ("Self-referential argument " 316 "%qs at %L is not allowed", sym->name, 317 &proc->declared_at); 318 return; 319 } 320 321 if (sym->attr.if_source != IFSRC_UNKNOWN) 322 gfc_resolve_formal_arglist (sym); 323 324 if (sym->attr.subroutine || sym->attr.external) 325 { 326 if (sym->attr.flavor == FL_UNKNOWN) 327 gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, &sym->declared_at); 328 } 329 else 330 { 331 if (sym->ts.type == BT_UNKNOWN && !proc->attr.intrinsic 332 && (!sym->attr.function || sym->result == sym)) 333 gfc_set_default_type (sym, 1, sym->ns); 334 } 335 336 as = sym->ts.type == BT_CLASS && sym->attr.class_ok 337 ? CLASS_DATA (sym)->as : sym->as; 338 339 saved_specification_expr = specification_expr; 340 specification_expr = true; 341 gfc_resolve_array_spec (as, 0); 342 specification_expr = saved_specification_expr; 343 344 /* We can't tell if an array with dimension (:) is assumed or deferred 345 shape until we know if it has the pointer or allocatable attributes. 346 */ 347 if (as && as->rank > 0 && as->type == AS_DEFERRED 348 && ((sym->ts.type != BT_CLASS 349 && !(sym->attr.pointer || sym->attr.allocatable)) 350 || (sym->ts.type == BT_CLASS 351 && !(CLASS_DATA (sym)->attr.class_pointer 352 || CLASS_DATA (sym)->attr.allocatable))) 353 && sym->attr.flavor != FL_PROCEDURE) 354 { 355 as->type = AS_ASSUMED_SHAPE; 356 for (i = 0; i < as->rank; i++) 357 as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 358 } 359 360 if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE) 361 || (as && as->type == AS_ASSUMED_RANK) 362 || sym->attr.pointer || sym->attr.allocatable || sym->attr.target 363 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 364 && (CLASS_DATA (sym)->attr.class_pointer 365 || CLASS_DATA (sym)->attr.allocatable 366 || CLASS_DATA (sym)->attr.target)) 367 || sym->attr.optional) 368 { 369 proc->attr.always_explicit = 1; 370 if (proc->result) 371 proc->result->attr.always_explicit = 1; 372 } 373 374 /* If the flavor is unknown at this point, it has to be a variable. 375 A procedure specification would have already set the type. */ 376 377 if (sym->attr.flavor == FL_UNKNOWN) 378 gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name, &sym->declared_at); 379 380 if (gfc_pure (proc)) 381 { 382 if (sym->attr.flavor == FL_PROCEDURE) 383 { 384 /* F08:C1279. */ 385 if (!gfc_pure (sym)) 386 { 387 gfc_error ("Dummy procedure %qs of PURE procedure at %L must " 388 "also be PURE", sym->name, &sym->declared_at); 389 continue; 390 } 391 } 392 else if (!sym->attr.pointer) 393 { 394 if (proc->attr.function && sym->attr.intent != INTENT_IN) 395 { 396 if (sym->attr.value) 397 gfc_notify_std (GFC_STD_F2008, "Argument %qs" 398 " of pure function %qs at %L with VALUE " 399 "attribute but without INTENT(IN)", 400 sym->name, proc->name, &sym->declared_at); 401 else 402 gfc_error ("Argument %qs of pure function %qs at %L must " 403 "be INTENT(IN) or VALUE", sym->name, proc->name, 404 &sym->declared_at); 405 } 406 407 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN) 408 { 409 if (sym->attr.value) 410 gfc_notify_std (GFC_STD_F2008, "Argument %qs" 411 " of pure subroutine %qs at %L with VALUE " 412 "attribute but without INTENT", sym->name, 413 proc->name, &sym->declared_at); 414 else 415 gfc_error ("Argument %qs of pure subroutine %qs at %L " 416 "must have its INTENT specified or have the " 417 "VALUE attribute", sym->name, proc->name, 418 &sym->declared_at); 419 } 420 } 421 422 /* F08:C1278a. */ 423 if (sym->ts.type == BT_CLASS && sym->attr.intent == INTENT_OUT) 424 { 425 gfc_error ("INTENT(OUT) argument %qs of pure procedure %qs at %L" 426 " may not be polymorphic", sym->name, proc->name, 427 &sym->declared_at); 428 continue; 429 } 430 } 431 432 if (proc->attr.implicit_pure) 433 { 434 if (sym->attr.flavor == FL_PROCEDURE) 435 { 436 if (!gfc_pure (sym)) 437 proc->attr.implicit_pure = 0; 438 } 439 else if (!sym->attr.pointer) 440 { 441 if (proc->attr.function && sym->attr.intent != INTENT_IN 442 && !sym->value) 443 proc->attr.implicit_pure = 0; 444 445 if (proc->attr.subroutine && sym->attr.intent == INTENT_UNKNOWN 446 && !sym->value) 447 proc->attr.implicit_pure = 0; 448 } 449 } 450 451 if (gfc_elemental (proc)) 452 { 453 /* F08:C1289. */ 454 if (sym->attr.codimension 455 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 456 && CLASS_DATA (sym)->attr.codimension)) 457 { 458 gfc_error ("Coarray dummy argument %qs at %L to elemental " 459 "procedure", sym->name, &sym->declared_at); 460 continue; 461 } 462 463 if (sym->as || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 464 && CLASS_DATA (sym)->as)) 465 { 466 gfc_error ("Argument %qs of elemental procedure at %L must " 467 "be scalar", sym->name, &sym->declared_at); 468 continue; 469 } 470 471 if (sym->attr.allocatable 472 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 473 && CLASS_DATA (sym)->attr.allocatable)) 474 { 475 gfc_error ("Argument %qs of elemental procedure at %L cannot " 476 "have the ALLOCATABLE attribute", sym->name, 477 &sym->declared_at); 478 continue; 479 } 480 481 if (sym->attr.pointer 482 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 483 && CLASS_DATA (sym)->attr.class_pointer)) 484 { 485 gfc_error ("Argument %qs of elemental procedure at %L cannot " 486 "have the POINTER attribute", sym->name, 487 &sym->declared_at); 488 continue; 489 } 490 491 if (sym->attr.flavor == FL_PROCEDURE) 492 { 493 gfc_error ("Dummy procedure %qs not allowed in elemental " 494 "procedure %qs at %L", sym->name, proc->name, 495 &sym->declared_at); 496 continue; 497 } 498 499 /* Fortran 2008 Corrigendum 1, C1290a. */ 500 if (sym->attr.intent == INTENT_UNKNOWN && !sym->attr.value) 501 { 502 gfc_error ("Argument %qs of elemental procedure %qs at %L must " 503 "have its INTENT specified or have the VALUE " 504 "attribute", sym->name, proc->name, 505 &sym->declared_at); 506 continue; 507 } 508 } 509 510 /* Each dummy shall be specified to be scalar. */ 511 if (proc->attr.proc == PROC_ST_FUNCTION) 512 { 513 if (sym->as != NULL) 514 { 515 /* F03:C1263 (R1238) The function-name and each dummy-arg-name 516 shall be specified, explicitly or implicitly, to be scalar. */ 517 gfc_error ("Argument '%s' of statement function '%s' at %L " 518 "must be scalar", sym->name, proc->name, 519 &proc->declared_at); 520 continue; 521 } 522 523 if (sym->ts.type == BT_CHARACTER) 524 { 525 gfc_charlen *cl = sym->ts.u.cl; 526 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) 527 { 528 gfc_error ("Character-valued argument %qs of statement " 529 "function at %L must have constant length", 530 sym->name, &sym->declared_at); 531 continue; 532 } 533 } 534 } 535 } 536 formal_arg_flag = false; 537} 538 539 540/* Work function called when searching for symbols that have argument lists 541 associated with them. */ 542 543static void 544find_arglists (gfc_symbol *sym) 545{ 546 if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns 547 || gfc_fl_struct (sym->attr.flavor) || sym->attr.intrinsic) 548 return; 549 550 gfc_resolve_formal_arglist (sym); 551} 552 553 554/* Given a namespace, resolve all formal argument lists within the namespace. 555 */ 556 557static void 558resolve_formal_arglists (gfc_namespace *ns) 559{ 560 if (ns == NULL) 561 return; 562 563 gfc_traverse_ns (ns, find_arglists); 564} 565 566 567static void 568resolve_contained_fntype (gfc_symbol *sym, gfc_namespace *ns) 569{ 570 bool t; 571 572 if (sym && sym->attr.flavor == FL_PROCEDURE 573 && sym->ns->parent 574 && sym->ns->parent->proc_name 575 && sym->ns->parent->proc_name->attr.flavor == FL_PROCEDURE 576 && !strcmp (sym->name, sym->ns->parent->proc_name->name)) 577 gfc_error ("Contained procedure %qs at %L has the same name as its " 578 "encompassing procedure", sym->name, &sym->declared_at); 579 580 /* If this namespace is not a function or an entry master function, 581 ignore it. */ 582 if (! sym || !(sym->attr.function || sym->attr.flavor == FL_VARIABLE) 583 || sym->attr.entry_master) 584 return; 585 586 if (!sym->result) 587 return; 588 589 /* Try to find out of what the return type is. */ 590 if (sym->result->ts.type == BT_UNKNOWN && sym->result->ts.interface == NULL) 591 { 592 t = gfc_set_default_type (sym->result, 0, ns); 593 594 if (!t && !sym->result->attr.untyped) 595 { 596 if (sym->result == sym) 597 gfc_error ("Contained function %qs at %L has no IMPLICIT type", 598 sym->name, &sym->declared_at); 599 else if (!sym->result->attr.proc_pointer) 600 gfc_error ("Result %qs of contained function %qs at %L has " 601 "no IMPLICIT type", sym->result->name, sym->name, 602 &sym->result->declared_at); 603 sym->result->attr.untyped = 1; 604 } 605 } 606 607 /* Fortran 2008 Draft Standard, page 535, C418, on type-param-value 608 type, lists the only ways a character length value of * can be used: 609 dummy arguments of procedures, named constants, function results and 610 in allocate statements if the allocate_object is an assumed length dummy 611 in external functions. Internal function results and results of module 612 procedures are not on this list, ergo, not permitted. */ 613 614 if (sym->result->ts.type == BT_CHARACTER) 615 { 616 gfc_charlen *cl = sym->result->ts.u.cl; 617 if ((!cl || !cl->length) && !sym->result->ts.deferred) 618 { 619 /* See if this is a module-procedure and adapt error message 620 accordingly. */ 621 bool module_proc; 622 gcc_assert (ns->parent && ns->parent->proc_name); 623 module_proc = (ns->parent->proc_name->attr.flavor == FL_MODULE); 624 625 gfc_error (module_proc 626 ? G_("Character-valued module procedure %qs at %L" 627 " must not be assumed length") 628 : G_("Character-valued internal function %qs at %L" 629 " must not be assumed length"), 630 sym->name, &sym->declared_at); 631 } 632 } 633} 634 635 636/* Add NEW_ARGS to the formal argument list of PROC, taking care not to 637 introduce duplicates. */ 638 639static void 640merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) 641{ 642 gfc_formal_arglist *f, *new_arglist; 643 gfc_symbol *new_sym; 644 645 for (; new_args != NULL; new_args = new_args->next) 646 { 647 new_sym = new_args->sym; 648 /* See if this arg is already in the formal argument list. */ 649 for (f = proc->formal; f; f = f->next) 650 { 651 if (new_sym == f->sym) 652 break; 653 } 654 655 if (f) 656 continue; 657 658 /* Add a new argument. Argument order is not important. */ 659 new_arglist = gfc_get_formal_arglist (); 660 new_arglist->sym = new_sym; 661 new_arglist->next = proc->formal; 662 proc->formal = new_arglist; 663 } 664} 665 666 667/* Flag the arguments that are not present in all entries. */ 668 669static void 670check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args) 671{ 672 gfc_formal_arglist *f, *head; 673 head = new_args; 674 675 for (f = proc->formal; f; f = f->next) 676 { 677 if (f->sym == NULL) 678 continue; 679 680 for (new_args = head; new_args; new_args = new_args->next) 681 { 682 if (new_args->sym == f->sym) 683 break; 684 } 685 686 if (new_args) 687 continue; 688 689 f->sym->attr.not_always_present = 1; 690 } 691} 692 693 694/* Resolve alternate entry points. If a symbol has multiple entry points we 695 create a new master symbol for the main routine, and turn the existing 696 symbol into an entry point. */ 697 698static void 699resolve_entries (gfc_namespace *ns) 700{ 701 gfc_namespace *old_ns; 702 gfc_code *c; 703 gfc_symbol *proc; 704 gfc_entry_list *el; 705 char name[GFC_MAX_SYMBOL_LEN + 1]; 706 static int master_count = 0; 707 708 if (ns->proc_name == NULL) 709 return; 710 711 /* No need to do anything if this procedure doesn't have alternate entry 712 points. */ 713 if (!ns->entries) 714 return; 715 716 /* We may already have resolved alternate entry points. */ 717 if (ns->proc_name->attr.entry_master) 718 return; 719 720 /* If this isn't a procedure something has gone horribly wrong. */ 721 gcc_assert (ns->proc_name->attr.flavor == FL_PROCEDURE); 722 723 /* Remember the current namespace. */ 724 old_ns = gfc_current_ns; 725 726 gfc_current_ns = ns; 727 728 /* Add the main entry point to the list of entry points. */ 729 el = gfc_get_entry_list (); 730 el->sym = ns->proc_name; 731 el->id = 0; 732 el->next = ns->entries; 733 ns->entries = el; 734 ns->proc_name->attr.entry = 1; 735 736 /* If it is a module function, it needs to be in the right namespace 737 so that gfc_get_fake_result_decl can gather up the results. The 738 need for this arose in get_proc_name, where these beasts were 739 left in their own namespace, to keep prior references linked to 740 the entry declaration.*/ 741 if (ns->proc_name->attr.function 742 && ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE) 743 el->sym->ns = ns; 744 745 /* Do the same for entries where the master is not a module 746 procedure. These are retained in the module namespace because 747 of the module procedure declaration. */ 748 for (el = el->next; el; el = el->next) 749 if (el->sym->ns->proc_name->attr.flavor == FL_MODULE 750 && el->sym->attr.mod_proc) 751 el->sym->ns = ns; 752 el = ns->entries; 753 754 /* Add an entry statement for it. */ 755 c = gfc_get_code (EXEC_ENTRY); 756 c->ext.entry = el; 757 c->next = ns->code; 758 ns->code = c; 759 760 /* Create a new symbol for the master function. */ 761 /* Give the internal function a unique name (within this file). 762 Also include the function name so the user has some hope of figuring 763 out what is going on. */ 764 snprintf (name, GFC_MAX_SYMBOL_LEN, "master.%d.%s", 765 master_count++, ns->proc_name->name); 766 gfc_get_ha_symbol (name, &proc); 767 gcc_assert (proc != NULL); 768 769 gfc_add_procedure (&proc->attr, PROC_INTERNAL, proc->name, NULL); 770 if (ns->proc_name->attr.subroutine) 771 gfc_add_subroutine (&proc->attr, proc->name, NULL); 772 else 773 { 774 gfc_symbol *sym; 775 gfc_typespec *ts, *fts; 776 gfc_array_spec *as, *fas; 777 gfc_add_function (&proc->attr, proc->name, NULL); 778 proc->result = proc; 779 fas = ns->entries->sym->as; 780 fas = fas ? fas : ns->entries->sym->result->as; 781 fts = &ns->entries->sym->result->ts; 782 if (fts->type == BT_UNKNOWN) 783 fts = gfc_get_default_type (ns->entries->sym->result->name, NULL); 784 for (el = ns->entries->next; el; el = el->next) 785 { 786 ts = &el->sym->result->ts; 787 as = el->sym->as; 788 as = as ? as : el->sym->result->as; 789 if (ts->type == BT_UNKNOWN) 790 ts = gfc_get_default_type (el->sym->result->name, NULL); 791 792 if (! gfc_compare_types (ts, fts) 793 || (el->sym->result->attr.dimension 794 != ns->entries->sym->result->attr.dimension) 795 || (el->sym->result->attr.pointer 796 != ns->entries->sym->result->attr.pointer)) 797 break; 798 else if (as && fas && ns->entries->sym->result != el->sym->result 799 && gfc_compare_array_spec (as, fas) == 0) 800 gfc_error ("Function %s at %L has entries with mismatched " 801 "array specifications", ns->entries->sym->name, 802 &ns->entries->sym->declared_at); 803 /* The characteristics need to match and thus both need to have 804 the same string length, i.e. both len=*, or both len=4. 805 Having both len=<variable> is also possible, but difficult to 806 check at compile time. */ 807 else if (ts->type == BT_CHARACTER && ts->u.cl && fts->u.cl 808 && (((ts->u.cl->length && !fts->u.cl->length) 809 ||(!ts->u.cl->length && fts->u.cl->length)) 810 || (ts->u.cl->length 811 && ts->u.cl->length->expr_type 812 != fts->u.cl->length->expr_type) 813 || (ts->u.cl->length 814 && ts->u.cl->length->expr_type == EXPR_CONSTANT 815 && mpz_cmp (ts->u.cl->length->value.integer, 816 fts->u.cl->length->value.integer) != 0))) 817 gfc_notify_std (GFC_STD_GNU, "Function %s at %L with " 818 "entries returning variables of different " 819 "string lengths", ns->entries->sym->name, 820 &ns->entries->sym->declared_at); 821 } 822 823 if (el == NULL) 824 { 825 sym = ns->entries->sym->result; 826 /* All result types the same. */ 827 proc->ts = *fts; 828 if (sym->attr.dimension) 829 gfc_set_array_spec (proc, gfc_copy_array_spec (sym->as), NULL); 830 if (sym->attr.pointer) 831 gfc_add_pointer (&proc->attr, NULL); 832 } 833 else 834 { 835 /* Otherwise the result will be passed through a union by 836 reference. */ 837 proc->attr.mixed_entry_master = 1; 838 for (el = ns->entries; el; el = el->next) 839 { 840 sym = el->sym->result; 841 if (sym->attr.dimension) 842 { 843 if (el == ns->entries) 844 gfc_error ("FUNCTION result %s cannot be an array in " 845 "FUNCTION %s at %L", sym->name, 846 ns->entries->sym->name, &sym->declared_at); 847 else 848 gfc_error ("ENTRY result %s cannot be an array in " 849 "FUNCTION %s at %L", sym->name, 850 ns->entries->sym->name, &sym->declared_at); 851 } 852 else if (sym->attr.pointer) 853 { 854 if (el == ns->entries) 855 gfc_error ("FUNCTION result %s cannot be a POINTER in " 856 "FUNCTION %s at %L", sym->name, 857 ns->entries->sym->name, &sym->declared_at); 858 else 859 gfc_error ("ENTRY result %s cannot be a POINTER in " 860 "FUNCTION %s at %L", sym->name, 861 ns->entries->sym->name, &sym->declared_at); 862 } 863 else 864 { 865 ts = &sym->ts; 866 if (ts->type == BT_UNKNOWN) 867 ts = gfc_get_default_type (sym->name, NULL); 868 switch (ts->type) 869 { 870 case BT_INTEGER: 871 if (ts->kind == gfc_default_integer_kind) 872 sym = NULL; 873 break; 874 case BT_REAL: 875 if (ts->kind == gfc_default_real_kind 876 || ts->kind == gfc_default_double_kind) 877 sym = NULL; 878 break; 879 case BT_COMPLEX: 880 if (ts->kind == gfc_default_complex_kind) 881 sym = NULL; 882 break; 883 case BT_LOGICAL: 884 if (ts->kind == gfc_default_logical_kind) 885 sym = NULL; 886 break; 887 case BT_UNKNOWN: 888 /* We will issue error elsewhere. */ 889 sym = NULL; 890 break; 891 default: 892 break; 893 } 894 if (sym) 895 { 896 if (el == ns->entries) 897 gfc_error ("FUNCTION result %s cannot be of type %s " 898 "in FUNCTION %s at %L", sym->name, 899 gfc_typename (ts), ns->entries->sym->name, 900 &sym->declared_at); 901 else 902 gfc_error ("ENTRY result %s cannot be of type %s " 903 "in FUNCTION %s at %L", sym->name, 904 gfc_typename (ts), ns->entries->sym->name, 905 &sym->declared_at); 906 } 907 } 908 } 909 } 910 } 911 proc->attr.access = ACCESS_PRIVATE; 912 proc->attr.entry_master = 1; 913 914 /* Merge all the entry point arguments. */ 915 for (el = ns->entries; el; el = el->next) 916 merge_argument_lists (proc, el->sym->formal); 917 918 /* Check the master formal arguments for any that are not 919 present in all entry points. */ 920 for (el = ns->entries; el; el = el->next) 921 check_argument_lists (proc, el->sym->formal); 922 923 /* Use the master function for the function body. */ 924 ns->proc_name = proc; 925 926 /* Finalize the new symbols. */ 927 gfc_commit_symbols (); 928 929 /* Restore the original namespace. */ 930 gfc_current_ns = old_ns; 931} 932 933 934/* Resolve common variables. */ 935static void 936resolve_common_vars (gfc_common_head *common_block, bool named_common) 937{ 938 gfc_symbol *csym = common_block->head; 939 940 for (; csym; csym = csym->common_next) 941 { 942 /* gfc_add_in_common may have been called before, but the reported errors 943 have been ignored to continue parsing. 944 We do the checks again here. */ 945 if (!csym->attr.use_assoc) 946 { 947 gfc_add_in_common (&csym->attr, csym->name, &common_block->where); 948 gfc_notify_std (GFC_STD_F2018_OBS, "COMMON block at %L", 949 &common_block->where); 950 } 951 952 if (csym->value || csym->attr.data) 953 { 954 if (!csym->ns->is_block_data) 955 gfc_notify_std (GFC_STD_GNU, "Variable %qs at %L is in COMMON " 956 "but only in BLOCK DATA initialization is " 957 "allowed", csym->name, &csym->declared_at); 958 else if (!named_common) 959 gfc_notify_std (GFC_STD_GNU, "Initialized variable %qs at %L is " 960 "in a blank COMMON but initialization is only " 961 "allowed in named common blocks", csym->name, 962 &csym->declared_at); 963 } 964 965 if (UNLIMITED_POLY (csym)) 966 gfc_error_now ("%qs in cannot appear in COMMON at %L " 967 "[F2008:C5100]", csym->name, &csym->declared_at); 968 969 if (csym->ts.type != BT_DERIVED) 970 continue; 971 972 if (!(csym->ts.u.derived->attr.sequence 973 || csym->ts.u.derived->attr.is_bind_c)) 974 gfc_error_now ("Derived type variable %qs in COMMON at %L " 975 "has neither the SEQUENCE nor the BIND(C) " 976 "attribute", csym->name, &csym->declared_at); 977 if (csym->ts.u.derived->attr.alloc_comp) 978 gfc_error_now ("Derived type variable %qs in COMMON at %L " 979 "has an ultimate component that is " 980 "allocatable", csym->name, &csym->declared_at); 981 if (gfc_has_default_initializer (csym->ts.u.derived)) 982 gfc_error_now ("Derived type variable %qs in COMMON at %L " 983 "may not have default initializer", csym->name, 984 &csym->declared_at); 985 986 if (csym->attr.flavor == FL_UNKNOWN && !csym->attr.proc_pointer) 987 gfc_add_flavor (&csym->attr, FL_VARIABLE, csym->name, &csym->declared_at); 988 } 989} 990 991/* Resolve common blocks. */ 992static void 993resolve_common_blocks (gfc_symtree *common_root) 994{ 995 gfc_symbol *sym; 996 gfc_gsymbol * gsym; 997 998 if (common_root == NULL) 999 return; 1000 1001 if (common_root->left) 1002 resolve_common_blocks (common_root->left); 1003 if (common_root->right) 1004 resolve_common_blocks (common_root->right); 1005 1006 resolve_common_vars (common_root->n.common, true); 1007 1008 /* The common name is a global name - in Fortran 2003 also if it has a 1009 C binding name, since Fortran 2008 only the C binding name is a global 1010 identifier. */ 1011 if (!common_root->n.common->binding_label 1012 || gfc_notification_std (GFC_STD_F2008)) 1013 { 1014 gsym = gfc_find_gsymbol (gfc_gsym_root, 1015 common_root->n.common->name); 1016 1017 if (gsym && gfc_notification_std (GFC_STD_F2008) 1018 && gsym->type == GSYM_COMMON 1019 && ((common_root->n.common->binding_label 1020 && (!gsym->binding_label 1021 || strcmp (common_root->n.common->binding_label, 1022 gsym->binding_label) != 0)) 1023 || (!common_root->n.common->binding_label 1024 && gsym->binding_label))) 1025 { 1026 gfc_error ("In Fortran 2003 COMMON %qs block at %L is a global " 1027 "identifier and must thus have the same binding name " 1028 "as the same-named COMMON block at %L: %s vs %s", 1029 common_root->n.common->name, &common_root->n.common->where, 1030 &gsym->where, 1031 common_root->n.common->binding_label 1032 ? common_root->n.common->binding_label : "(blank)", 1033 gsym->binding_label ? gsym->binding_label : "(blank)"); 1034 return; 1035 } 1036 1037 if (gsym && gsym->type != GSYM_COMMON 1038 && !common_root->n.common->binding_label) 1039 { 1040 gfc_error ("COMMON block %qs at %L uses the same global identifier " 1041 "as entity at %L", 1042 common_root->n.common->name, &common_root->n.common->where, 1043 &gsym->where); 1044 return; 1045 } 1046 if (gsym && gsym->type != GSYM_COMMON) 1047 { 1048 gfc_error ("Fortran 2008: COMMON block %qs with binding label at " 1049 "%L sharing the identifier with global non-COMMON-block " 1050 "entity at %L", common_root->n.common->name, 1051 &common_root->n.common->where, &gsym->where); 1052 return; 1053 } 1054 if (!gsym) 1055 { 1056 gsym = gfc_get_gsymbol (common_root->n.common->name, false); 1057 gsym->type = GSYM_COMMON; 1058 gsym->where = common_root->n.common->where; 1059 gsym->defined = 1; 1060 } 1061 gsym->used = 1; 1062 } 1063 1064 if (common_root->n.common->binding_label) 1065 { 1066 gsym = gfc_find_gsymbol (gfc_gsym_root, 1067 common_root->n.common->binding_label); 1068 if (gsym && gsym->type != GSYM_COMMON) 1069 { 1070 gfc_error ("COMMON block at %L with binding label %qs uses the same " 1071 "global identifier as entity at %L", 1072 &common_root->n.common->where, 1073 common_root->n.common->binding_label, &gsym->where); 1074 return; 1075 } 1076 if (!gsym) 1077 { 1078 gsym = gfc_get_gsymbol (common_root->n.common->binding_label, true); 1079 gsym->type = GSYM_COMMON; 1080 gsym->where = common_root->n.common->where; 1081 gsym->defined = 1; 1082 } 1083 gsym->used = 1; 1084 } 1085 1086 gfc_find_symbol (common_root->name, gfc_current_ns, 0, &sym); 1087 if (sym == NULL) 1088 return; 1089 1090 if (sym->attr.flavor == FL_PARAMETER) 1091 gfc_error ("COMMON block %qs at %L is used as PARAMETER at %L", 1092 sym->name, &common_root->n.common->where, &sym->declared_at); 1093 1094 if (sym->attr.external) 1095 gfc_error ("COMMON block %qs at %L cannot have the EXTERNAL attribute", 1096 sym->name, &common_root->n.common->where); 1097 1098 if (sym->attr.intrinsic) 1099 gfc_error ("COMMON block %qs at %L is also an intrinsic procedure", 1100 sym->name, &common_root->n.common->where); 1101 else if (sym->attr.result 1102 || gfc_is_function_return_value (sym, gfc_current_ns)) 1103 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " 1104 "that is also a function result", sym->name, 1105 &common_root->n.common->where); 1106 else if (sym->attr.flavor == FL_PROCEDURE && sym->attr.proc != PROC_INTERNAL 1107 && sym->attr.proc != PROC_ST_FUNCTION) 1108 gfc_notify_std (GFC_STD_F2003, "COMMON block %qs at %L " 1109 "that is also a global procedure", sym->name, 1110 &common_root->n.common->where); 1111} 1112 1113 1114/* Resolve contained function types. Because contained functions can call one 1115 another, they have to be worked out before any of the contained procedures 1116 can be resolved. 1117 1118 The good news is that if a function doesn't already have a type, the only 1119 way it can get one is through an IMPLICIT type or a RESULT variable, because 1120 by definition contained functions are contained namespace they're contained 1121 in, not in a sibling or parent namespace. */ 1122 1123static void 1124resolve_contained_functions (gfc_namespace *ns) 1125{ 1126 gfc_namespace *child; 1127 gfc_entry_list *el; 1128 1129 resolve_formal_arglists (ns); 1130 1131 for (child = ns->contained; child; child = child->sibling) 1132 { 1133 /* Resolve alternate entry points first. */ 1134 resolve_entries (child); 1135 1136 /* Then check function return types. */ 1137 resolve_contained_fntype (child->proc_name, child); 1138 for (el = child->entries; el; el = el->next) 1139 resolve_contained_fntype (el->sym, child); 1140 } 1141} 1142 1143 1144 1145/* A Parameterized Derived Type constructor must contain values for 1146 the PDT KIND parameters or they must have a default initializer. 1147 Go through the constructor picking out the KIND expressions, 1148 storing them in 'param_list' and then call gfc_get_pdt_instance 1149 to obtain the PDT instance. */ 1150 1151static gfc_actual_arglist *param_list, *param_tail, *param; 1152 1153static bool 1154get_pdt_spec_expr (gfc_component *c, gfc_expr *expr) 1155{ 1156 param = gfc_get_actual_arglist (); 1157 if (!param_list) 1158 param_list = param_tail = param; 1159 else 1160 { 1161 param_tail->next = param; 1162 param_tail = param_tail->next; 1163 } 1164 1165 param_tail->name = c->name; 1166 if (expr) 1167 param_tail->expr = gfc_copy_expr (expr); 1168 else if (c->initializer) 1169 param_tail->expr = gfc_copy_expr (c->initializer); 1170 else 1171 { 1172 param_tail->spec_type = SPEC_ASSUMED; 1173 if (c->attr.pdt_kind) 1174 { 1175 gfc_error ("The KIND parameter %qs in the PDT constructor " 1176 "at %C has no value", param->name); 1177 return false; 1178 } 1179 } 1180 1181 return true; 1182} 1183 1184static bool 1185get_pdt_constructor (gfc_expr *expr, gfc_constructor **constr, 1186 gfc_symbol *derived) 1187{ 1188 gfc_constructor *cons = NULL; 1189 gfc_component *comp; 1190 bool t = true; 1191 1192 if (expr && expr->expr_type == EXPR_STRUCTURE) 1193 cons = gfc_constructor_first (expr->value.constructor); 1194 else if (constr) 1195 cons = *constr; 1196 gcc_assert (cons); 1197 1198 comp = derived->components; 1199 1200 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) 1201 { 1202 if (cons->expr 1203 && cons->expr->expr_type == EXPR_STRUCTURE 1204 && comp->ts.type == BT_DERIVED) 1205 { 1206 t = get_pdt_constructor (cons->expr, NULL, comp->ts.u.derived); 1207 if (!t) 1208 return t; 1209 } 1210 else if (comp->ts.type == BT_DERIVED) 1211 { 1212 t = get_pdt_constructor (NULL, &cons, comp->ts.u.derived); 1213 if (!t) 1214 return t; 1215 } 1216 else if ((comp->attr.pdt_kind || comp->attr.pdt_len) 1217 && derived->attr.pdt_template) 1218 { 1219 t = get_pdt_spec_expr (comp, cons->expr); 1220 if (!t) 1221 return t; 1222 } 1223 } 1224 return t; 1225} 1226 1227 1228static bool resolve_fl_derived0 (gfc_symbol *sym); 1229static bool resolve_fl_struct (gfc_symbol *sym); 1230 1231 1232/* Resolve all of the elements of a structure constructor and make sure that 1233 the types are correct. The 'init' flag indicates that the given 1234 constructor is an initializer. */ 1235 1236static bool 1237resolve_structure_cons (gfc_expr *expr, int init) 1238{ 1239 gfc_constructor *cons; 1240 gfc_component *comp; 1241 bool t; 1242 symbol_attribute a; 1243 1244 t = true; 1245 1246 if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION) 1247 { 1248 if (expr->ts.u.derived->attr.flavor == FL_DERIVED) 1249 resolve_fl_derived0 (expr->ts.u.derived); 1250 else 1251 resolve_fl_struct (expr->ts.u.derived); 1252 1253 /* If this is a Parameterized Derived Type template, find the 1254 instance corresponding to the PDT kind parameters. */ 1255 if (expr->ts.u.derived->attr.pdt_template) 1256 { 1257 param_list = NULL; 1258 t = get_pdt_constructor (expr, NULL, expr->ts.u.derived); 1259 if (!t) 1260 return t; 1261 gfc_get_pdt_instance (param_list, &expr->ts.u.derived, NULL); 1262 1263 expr->param_list = gfc_copy_actual_arglist (param_list); 1264 1265 if (param_list) 1266 gfc_free_actual_arglist (param_list); 1267 1268 if (!expr->ts.u.derived->attr.pdt_type) 1269 return false; 1270 } 1271 } 1272 1273 cons = gfc_constructor_first (expr->value.constructor); 1274 1275 /* A constructor may have references if it is the result of substituting a 1276 parameter variable. In this case we just pull out the component we 1277 want. */ 1278 if (expr->ref) 1279 comp = expr->ref->u.c.sym->components; 1280 else 1281 comp = expr->ts.u.derived->components; 1282 1283 for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons)) 1284 { 1285 int rank; 1286 1287 if (!cons->expr) 1288 continue; 1289 1290 /* Unions use an EXPR_NULL contrived expression to tell the translation 1291 phase to generate an initializer of the appropriate length. 1292 Ignore it here. */ 1293 if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL) 1294 continue; 1295 1296 if (!gfc_resolve_expr (cons->expr)) 1297 { 1298 t = false; 1299 continue; 1300 } 1301 1302 rank = comp->as ? comp->as->rank : 0; 1303 if (comp->ts.type == BT_CLASS 1304 && !comp->ts.u.derived->attr.unlimited_polymorphic 1305 && CLASS_DATA (comp)->as) 1306 rank = CLASS_DATA (comp)->as->rank; 1307 1308 if (cons->expr->expr_type != EXPR_NULL && rank != cons->expr->rank 1309 && (comp->attr.allocatable || cons->expr->rank)) 1310 { 1311 gfc_error ("The rank of the element in the structure " 1312 "constructor at %L does not match that of the " 1313 "component (%d/%d)", &cons->expr->where, 1314 cons->expr->rank, rank); 1315 t = false; 1316 } 1317 1318 /* If we don't have the right type, try to convert it. */ 1319 1320 if (!comp->attr.proc_pointer && 1321 !gfc_compare_types (&cons->expr->ts, &comp->ts)) 1322 { 1323 if (strcmp (comp->name, "_extends") == 0) 1324 { 1325 /* Can afford to be brutal with the _extends initializer. 1326 The derived type can get lost because it is PRIVATE 1327 but it is not usage constrained by the standard. */ 1328 cons->expr->ts = comp->ts; 1329 } 1330 else if (comp->attr.pointer && cons->expr->ts.type != BT_UNKNOWN) 1331 { 1332 gfc_error ("The element in the structure constructor at %L, " 1333 "for pointer component %qs, is %s but should be %s", 1334 &cons->expr->where, comp->name, 1335 gfc_basic_typename (cons->expr->ts.type), 1336 gfc_basic_typename (comp->ts.type)); 1337 t = false; 1338 } 1339 else 1340 { 1341 bool t2 = gfc_convert_type (cons->expr, &comp->ts, 1); 1342 if (t) 1343 t = t2; 1344 } 1345 } 1346 1347 /* For strings, the length of the constructor should be the same as 1348 the one of the structure, ensure this if the lengths are known at 1349 compile time and when we are dealing with PARAMETER or structure 1350 constructors. */ 1351 if (cons->expr->ts.type == BT_CHARACTER && comp->ts.u.cl 1352 && comp->ts.u.cl->length 1353 && comp->ts.u.cl->length->expr_type == EXPR_CONSTANT 1354 && cons->expr->ts.u.cl && cons->expr->ts.u.cl->length 1355 && cons->expr->ts.u.cl->length->expr_type == EXPR_CONSTANT 1356 && cons->expr->rank != 0 1357 && mpz_cmp (cons->expr->ts.u.cl->length->value.integer, 1358 comp->ts.u.cl->length->value.integer) != 0) 1359 { 1360 if (cons->expr->expr_type == EXPR_VARIABLE 1361 && cons->expr->symtree->n.sym->attr.flavor == FL_PARAMETER) 1362 { 1363 /* Wrap the parameter in an array constructor (EXPR_ARRAY) 1364 to make use of the gfc_resolve_character_array_constructor 1365 machinery. The expression is later simplified away to 1366 an array of string literals. */ 1367 gfc_expr *para = cons->expr; 1368 cons->expr = gfc_get_expr (); 1369 cons->expr->ts = para->ts; 1370 cons->expr->where = para->where; 1371 cons->expr->expr_type = EXPR_ARRAY; 1372 cons->expr->rank = para->rank; 1373 cons->expr->shape = gfc_copy_shape (para->shape, para->rank); 1374 gfc_constructor_append_expr (&cons->expr->value.constructor, 1375 para, &cons->expr->where); 1376 } 1377 1378 if (cons->expr->expr_type == EXPR_ARRAY) 1379 { 1380 /* Rely on the cleanup of the namespace to deal correctly with 1381 the old charlen. (There was a block here that attempted to 1382 remove the charlen but broke the chain in so doing.) */ 1383 cons->expr->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 1384 cons->expr->ts.u.cl->length_from_typespec = true; 1385 cons->expr->ts.u.cl->length = gfc_copy_expr (comp->ts.u.cl->length); 1386 gfc_resolve_character_array_constructor (cons->expr); 1387 } 1388 } 1389 1390 if (cons->expr->expr_type == EXPR_NULL 1391 && !(comp->attr.pointer || comp->attr.allocatable 1392 || comp->attr.proc_pointer || comp->ts.f90_type == BT_VOID 1393 || (comp->ts.type == BT_CLASS 1394 && (CLASS_DATA (comp)->attr.class_pointer 1395 || CLASS_DATA (comp)->attr.allocatable)))) 1396 { 1397 t = false; 1398 gfc_error ("The NULL in the structure constructor at %L is " 1399 "being applied to component %qs, which is neither " 1400 "a POINTER nor ALLOCATABLE", &cons->expr->where, 1401 comp->name); 1402 } 1403 1404 if (comp->attr.proc_pointer && comp->ts.interface) 1405 { 1406 /* Check procedure pointer interface. */ 1407 gfc_symbol *s2 = NULL; 1408 gfc_component *c2; 1409 const char *name; 1410 char err[200]; 1411 1412 c2 = gfc_get_proc_ptr_comp (cons->expr); 1413 if (c2) 1414 { 1415 s2 = c2->ts.interface; 1416 name = c2->name; 1417 } 1418 else if (cons->expr->expr_type == EXPR_FUNCTION) 1419 { 1420 s2 = cons->expr->symtree->n.sym->result; 1421 name = cons->expr->symtree->n.sym->result->name; 1422 } 1423 else if (cons->expr->expr_type != EXPR_NULL) 1424 { 1425 s2 = cons->expr->symtree->n.sym; 1426 name = cons->expr->symtree->n.sym->name; 1427 } 1428 1429 if (s2 && !gfc_compare_interfaces (comp->ts.interface, s2, name, 0, 1, 1430 err, sizeof (err), NULL, NULL)) 1431 { 1432 gfc_error_opt (0, "Interface mismatch for procedure-pointer " 1433 "component %qs in structure constructor at %L:" 1434 " %s", comp->name, &cons->expr->where, err); 1435 return false; 1436 } 1437 } 1438 1439 /* Validate shape, except for dynamic or PDT arrays. */ 1440 if (cons->expr->expr_type == EXPR_ARRAY && rank == cons->expr->rank 1441 && comp->as && !comp->attr.allocatable && !comp->attr.pointer 1442 && !comp->attr.pdt_array) 1443 { 1444 mpz_t len; 1445 mpz_init (len); 1446 for (int n = 0; n < rank; n++) 1447 { 1448 if (comp->as->upper[n]->expr_type != EXPR_CONSTANT 1449 || comp->as->lower[n]->expr_type != EXPR_CONSTANT) 1450 { 1451 gfc_error ("Bad array spec of component %qs referenced in " 1452 "structure constructor at %L", 1453 comp->name, &cons->expr->where); 1454 t = false; 1455 break; 1456 }; 1457 if (cons->expr->shape == NULL) 1458 continue; 1459 mpz_set_ui (len, 1); 1460 mpz_add (len, len, comp->as->upper[n]->value.integer); 1461 mpz_sub (len, len, comp->as->lower[n]->value.integer); 1462 if (mpz_cmp (cons->expr->shape[n], len) != 0) 1463 { 1464 gfc_error ("The shape of component %qs in the structure " 1465 "constructor at %L differs from the shape of the " 1466 "declared component for dimension %d (%ld/%ld)", 1467 comp->name, &cons->expr->where, n+1, 1468 mpz_get_si (cons->expr->shape[n]), 1469 mpz_get_si (len)); 1470 t = false; 1471 } 1472 } 1473 mpz_clear (len); 1474 } 1475 1476 if (!comp->attr.pointer || comp->attr.proc_pointer 1477 || cons->expr->expr_type == EXPR_NULL) 1478 continue; 1479 1480 a = gfc_expr_attr (cons->expr); 1481 1482 if (!a.pointer && !a.target) 1483 { 1484 t = false; 1485 gfc_error ("The element in the structure constructor at %L, " 1486 "for pointer component %qs should be a POINTER or " 1487 "a TARGET", &cons->expr->where, comp->name); 1488 } 1489 1490 if (init) 1491 { 1492 /* F08:C461. Additional checks for pointer initialization. */ 1493 if (a.allocatable) 1494 { 1495 t = false; 1496 gfc_error ("Pointer initialization target at %L " 1497 "must not be ALLOCATABLE", &cons->expr->where); 1498 } 1499 if (!a.save) 1500 { 1501 t = false; 1502 gfc_error ("Pointer initialization target at %L " 1503 "must have the SAVE attribute", &cons->expr->where); 1504 } 1505 } 1506 1507 /* F2003, C1272 (3). */ 1508 bool impure = cons->expr->expr_type == EXPR_VARIABLE 1509 && (gfc_impure_variable (cons->expr->symtree->n.sym) 1510 || gfc_is_coindexed (cons->expr)); 1511 if (impure && gfc_pure (NULL)) 1512 { 1513 t = false; 1514 gfc_error ("Invalid expression in the structure constructor for " 1515 "pointer component %qs at %L in PURE procedure", 1516 comp->name, &cons->expr->where); 1517 } 1518 1519 if (impure) 1520 gfc_unset_implicit_pure (NULL); 1521 } 1522 1523 return t; 1524} 1525 1526 1527/****************** Expression name resolution ******************/ 1528 1529/* Returns 0 if a symbol was not declared with a type or 1530 attribute declaration statement, nonzero otherwise. */ 1531 1532static int 1533was_declared (gfc_symbol *sym) 1534{ 1535 symbol_attribute a; 1536 1537 a = sym->attr; 1538 1539 if (!a.implicit_type && sym->ts.type != BT_UNKNOWN) 1540 return 1; 1541 1542 if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic 1543 || a.optional || a.pointer || a.save || a.target || a.volatile_ 1544 || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN 1545 || a.asynchronous || a.codimension) 1546 return 1; 1547 1548 return 0; 1549} 1550 1551 1552/* Determine if a symbol is generic or not. */ 1553 1554static int 1555generic_sym (gfc_symbol *sym) 1556{ 1557 gfc_symbol *s; 1558 1559 if (sym->attr.generic || 1560 (sym->attr.intrinsic && gfc_generic_intrinsic (sym->name))) 1561 return 1; 1562 1563 if (was_declared (sym) || sym->ns->parent == NULL) 1564 return 0; 1565 1566 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); 1567 1568 if (s != NULL) 1569 { 1570 if (s == sym) 1571 return 0; 1572 else 1573 return generic_sym (s); 1574 } 1575 1576 return 0; 1577} 1578 1579 1580/* Determine if a symbol is specific or not. */ 1581 1582static int 1583specific_sym (gfc_symbol *sym) 1584{ 1585 gfc_symbol *s; 1586 1587 if (sym->attr.if_source == IFSRC_IFBODY 1588 || sym->attr.proc == PROC_MODULE 1589 || sym->attr.proc == PROC_INTERNAL 1590 || sym->attr.proc == PROC_ST_FUNCTION 1591 || (sym->attr.intrinsic && gfc_specific_intrinsic (sym->name)) 1592 || sym->attr.external) 1593 return 1; 1594 1595 if (was_declared (sym) || sym->ns->parent == NULL) 1596 return 0; 1597 1598 gfc_find_symbol (sym->name, sym->ns->parent, 1, &s); 1599 1600 return (s == NULL) ? 0 : specific_sym (s); 1601} 1602 1603 1604/* Figure out if the procedure is specific, generic or unknown. */ 1605 1606enum proc_type 1607{ PTYPE_GENERIC = 1, PTYPE_SPECIFIC, PTYPE_UNKNOWN }; 1608 1609static proc_type 1610procedure_kind (gfc_symbol *sym) 1611{ 1612 if (generic_sym (sym)) 1613 return PTYPE_GENERIC; 1614 1615 if (specific_sym (sym)) 1616 return PTYPE_SPECIFIC; 1617 1618 return PTYPE_UNKNOWN; 1619} 1620 1621/* Check references to assumed size arrays. The flag need_full_assumed_size 1622 is nonzero when matching actual arguments. */ 1623 1624static int need_full_assumed_size = 0; 1625 1626static bool 1627check_assumed_size_reference (gfc_symbol *sym, gfc_expr *e) 1628{ 1629 if (need_full_assumed_size || !(sym->as && sym->as->type == AS_ASSUMED_SIZE)) 1630 return false; 1631 1632 /* FIXME: The comparison "e->ref->u.ar.type == AR_FULL" is wrong. 1633 What should it be? */ 1634 if (e->ref && (e->ref->u.ar.end[e->ref->u.ar.as->rank - 1] == NULL) 1635 && (e->ref->u.ar.as->type == AS_ASSUMED_SIZE) 1636 && (e->ref->u.ar.type == AR_FULL)) 1637 { 1638 gfc_error ("The upper bound in the last dimension must " 1639 "appear in the reference to the assumed size " 1640 "array %qs at %L", sym->name, &e->where); 1641 return true; 1642 } 1643 return false; 1644} 1645 1646 1647/* Look for bad assumed size array references in argument expressions 1648 of elemental and array valued intrinsic procedures. Since this is 1649 called from procedure resolution functions, it only recurses at 1650 operators. */ 1651 1652static bool 1653resolve_assumed_size_actual (gfc_expr *e) 1654{ 1655 if (e == NULL) 1656 return false; 1657 1658 switch (e->expr_type) 1659 { 1660 case EXPR_VARIABLE: 1661 if (e->symtree && check_assumed_size_reference (e->symtree->n.sym, e)) 1662 return true; 1663 break; 1664 1665 case EXPR_OP: 1666 if (resolve_assumed_size_actual (e->value.op.op1) 1667 || resolve_assumed_size_actual (e->value.op.op2)) 1668 return true; 1669 break; 1670 1671 default: 1672 break; 1673 } 1674 return false; 1675} 1676 1677 1678/* Check a generic procedure, passed as an actual argument, to see if 1679 there is a matching specific name. If none, it is an error, and if 1680 more than one, the reference is ambiguous. */ 1681static int 1682count_specific_procs (gfc_expr *e) 1683{ 1684 int n; 1685 gfc_interface *p; 1686 gfc_symbol *sym; 1687 1688 n = 0; 1689 sym = e->symtree->n.sym; 1690 1691 for (p = sym->generic; p; p = p->next) 1692 if (strcmp (sym->name, p->sym->name) == 0) 1693 { 1694 e->symtree = gfc_find_symtree (p->sym->ns->sym_root, 1695 sym->name); 1696 n++; 1697 } 1698 1699 if (n > 1) 1700 gfc_error ("%qs at %L is ambiguous", e->symtree->n.sym->name, 1701 &e->where); 1702 1703 if (n == 0) 1704 gfc_error ("GENERIC procedure %qs is not allowed as an actual " 1705 "argument at %L", sym->name, &e->where); 1706 1707 return n; 1708} 1709 1710 1711/* See if a call to sym could possibly be a not allowed RECURSION because of 1712 a missing RECURSIVE declaration. This means that either sym is the current 1713 context itself, or sym is the parent of a contained procedure calling its 1714 non-RECURSIVE containing procedure. 1715 This also works if sym is an ENTRY. */ 1716 1717static bool 1718is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) 1719{ 1720 gfc_symbol* proc_sym; 1721 gfc_symbol* context_proc; 1722 gfc_namespace* real_context; 1723 1724 if (sym->attr.flavor == FL_PROGRAM 1725 || gfc_fl_struct (sym->attr.flavor)) 1726 return false; 1727 1728 /* If we've got an ENTRY, find real procedure. */ 1729 if (sym->attr.entry && sym->ns->entries) 1730 proc_sym = sym->ns->entries->sym; 1731 else 1732 proc_sym = sym; 1733 1734 /* If sym is RECURSIVE, all is well of course. */ 1735 if (proc_sym->attr.recursive || flag_recursive) 1736 return false; 1737 1738 /* Find the context procedure's "real" symbol if it has entries. 1739 We look for a procedure symbol, so recurse on the parents if we don't 1740 find one (like in case of a BLOCK construct). */ 1741 for (real_context = context; ; real_context = real_context->parent) 1742 { 1743 /* We should find something, eventually! */ 1744 gcc_assert (real_context); 1745 1746 context_proc = (real_context->entries ? real_context->entries->sym 1747 : real_context->proc_name); 1748 1749 /* In some special cases, there may not be a proc_name, like for this 1750 invalid code: 1751 real(bad_kind()) function foo () ... 1752 when checking the call to bad_kind (). 1753 In these cases, we simply return here and assume that the 1754 call is ok. */ 1755 if (!context_proc) 1756 return false; 1757 1758 if (context_proc->attr.flavor != FL_LABEL) 1759 break; 1760 } 1761 1762 /* A call from sym's body to itself is recursion, of course. */ 1763 if (context_proc == proc_sym) 1764 return true; 1765 1766 /* The same is true if context is a contained procedure and sym the 1767 containing one. */ 1768 if (context_proc->attr.contained) 1769 { 1770 gfc_symbol* parent_proc; 1771 1772 gcc_assert (context->parent); 1773 parent_proc = (context->parent->entries ? context->parent->entries->sym 1774 : context->parent->proc_name); 1775 1776 if (parent_proc == proc_sym) 1777 return true; 1778 } 1779 1780 return false; 1781} 1782 1783 1784/* Resolve an intrinsic procedure: Set its function/subroutine attribute, 1785 its typespec and formal argument list. */ 1786 1787bool 1788gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc) 1789{ 1790 gfc_intrinsic_sym* isym = NULL; 1791 const char* symstd; 1792 1793 if (sym->resolve_symbol_called >= 2) 1794 return true; 1795 1796 sym->resolve_symbol_called = 2; 1797 1798 /* Already resolved. */ 1799 if (sym->from_intmod && sym->ts.type != BT_UNKNOWN) 1800 return true; 1801 1802 /* We already know this one is an intrinsic, so we don't call 1803 gfc_is_intrinsic for full checking but rather use gfc_find_function and 1804 gfc_find_subroutine directly to check whether it is a function or 1805 subroutine. */ 1806 1807 if (sym->intmod_sym_id && sym->attr.subroutine) 1808 { 1809 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); 1810 isym = gfc_intrinsic_subroutine_by_id (id); 1811 } 1812 else if (sym->intmod_sym_id) 1813 { 1814 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); 1815 isym = gfc_intrinsic_function_by_id (id); 1816 } 1817 else if (!sym->attr.subroutine) 1818 isym = gfc_find_function (sym->name); 1819 1820 if (isym && !sym->attr.subroutine) 1821 { 1822 if (sym->ts.type != BT_UNKNOWN && warn_surprising 1823 && !sym->attr.implicit_type) 1824 gfc_warning (OPT_Wsurprising, 1825 "Type specified for intrinsic function %qs at %L is" 1826 " ignored", sym->name, &sym->declared_at); 1827 1828 if (!sym->attr.function && 1829 !gfc_add_function(&sym->attr, sym->name, loc)) 1830 return false; 1831 1832 sym->ts = isym->ts; 1833 } 1834 else if (isym || (isym = gfc_find_subroutine (sym->name))) 1835 { 1836 if (sym->ts.type != BT_UNKNOWN && !sym->attr.implicit_type) 1837 { 1838 gfc_error ("Intrinsic subroutine %qs at %L shall not have a type" 1839 " specifier", sym->name, &sym->declared_at); 1840 return false; 1841 } 1842 1843 if (!sym->attr.subroutine && 1844 !gfc_add_subroutine(&sym->attr, sym->name, loc)) 1845 return false; 1846 } 1847 else 1848 { 1849 gfc_error ("%qs declared INTRINSIC at %L does not exist", sym->name, 1850 &sym->declared_at); 1851 return false; 1852 } 1853 1854 gfc_copy_formal_args_intr (sym, isym, NULL); 1855 1856 sym->attr.pure = isym->pure; 1857 sym->attr.elemental = isym->elemental; 1858 1859 /* Check it is actually available in the standard settings. */ 1860 if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at)) 1861 { 1862 gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not " 1863 "available in the current standard settings but %s. Use " 1864 "an appropriate %<-std=*%> option or enable " 1865 "%<-fall-intrinsics%> in order to use it.", 1866 sym->name, &sym->declared_at, symstd); 1867 return false; 1868 } 1869 1870 return true; 1871} 1872 1873 1874/* Resolve a procedure expression, like passing it to a called procedure or as 1875 RHS for a procedure pointer assignment. */ 1876 1877static bool 1878resolve_procedure_expression (gfc_expr* expr) 1879{ 1880 gfc_symbol* sym; 1881 1882 if (expr->expr_type != EXPR_VARIABLE) 1883 return true; 1884 gcc_assert (expr->symtree); 1885 1886 sym = expr->symtree->n.sym; 1887 1888 if (sym->attr.intrinsic) 1889 gfc_resolve_intrinsic (sym, &expr->where); 1890 1891 if (sym->attr.flavor != FL_PROCEDURE 1892 || (sym->attr.function && sym->result == sym)) 1893 return true; 1894 1895 /* A non-RECURSIVE procedure that is used as procedure expression within its 1896 own body is in danger of being called recursively. */ 1897 if (is_illegal_recursion (sym, gfc_current_ns)) 1898 gfc_warning (0, "Non-RECURSIVE procedure %qs at %L is possibly calling" 1899 " itself recursively. Declare it RECURSIVE or use" 1900 " %<-frecursive%>", sym->name, &expr->where); 1901 1902 return true; 1903} 1904 1905 1906/* Check that name is not a derived type. */ 1907 1908static bool 1909is_dt_name (const char *name) 1910{ 1911 gfc_symbol *dt_list, *dt_first; 1912 1913 dt_list = dt_first = gfc_derived_types; 1914 for (; dt_list; dt_list = dt_list->dt_next) 1915 { 1916 if (strcmp(dt_list->name, name) == 0) 1917 return true; 1918 if (dt_first == dt_list->dt_next) 1919 break; 1920 } 1921 return false; 1922} 1923 1924 1925/* Resolve an actual argument list. Most of the time, this is just 1926 resolving the expressions in the list. 1927 The exception is that we sometimes have to decide whether arguments 1928 that look like procedure arguments are really simple variable 1929 references. */ 1930 1931static bool 1932resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, 1933 bool no_formal_args) 1934{ 1935 gfc_symbol *sym; 1936 gfc_symtree *parent_st; 1937 gfc_expr *e; 1938 gfc_component *comp; 1939 int save_need_full_assumed_size; 1940 bool return_value = false; 1941 bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg; 1942 1943 actual_arg = true; 1944 first_actual_arg = true; 1945 1946 for (; arg; arg = arg->next) 1947 { 1948 e = arg->expr; 1949 if (e == NULL) 1950 { 1951 /* Check the label is a valid branching target. */ 1952 if (arg->label) 1953 { 1954 if (arg->label->defined == ST_LABEL_UNKNOWN) 1955 { 1956 gfc_error ("Label %d referenced at %L is never defined", 1957 arg->label->value, &arg->label->where); 1958 goto cleanup; 1959 } 1960 } 1961 first_actual_arg = false; 1962 continue; 1963 } 1964 1965 if (e->expr_type == EXPR_VARIABLE 1966 && e->symtree->n.sym->attr.generic 1967 && no_formal_args 1968 && count_specific_procs (e) != 1) 1969 goto cleanup; 1970 1971 if (e->ts.type != BT_PROCEDURE) 1972 { 1973 save_need_full_assumed_size = need_full_assumed_size; 1974 if (e->expr_type != EXPR_VARIABLE) 1975 need_full_assumed_size = 0; 1976 if (!gfc_resolve_expr (e)) 1977 goto cleanup; 1978 need_full_assumed_size = save_need_full_assumed_size; 1979 goto argument_list; 1980 } 1981 1982 /* See if the expression node should really be a variable reference. */ 1983 1984 sym = e->symtree->n.sym; 1985 1986 if (sym->attr.flavor == FL_PROCEDURE && is_dt_name (sym->name)) 1987 { 1988 gfc_error ("Derived type %qs is used as an actual " 1989 "argument at %L", sym->name, &e->where); 1990 goto cleanup; 1991 } 1992 1993 if (sym->attr.flavor == FL_PROCEDURE 1994 || sym->attr.intrinsic 1995 || sym->attr.external) 1996 { 1997 int actual_ok; 1998 1999 /* If a procedure is not already determined to be something else 2000 check if it is intrinsic. */ 2001 if (gfc_is_intrinsic (sym, sym->attr.subroutine, e->where)) 2002 sym->attr.intrinsic = 1; 2003 2004 if (sym->attr.proc == PROC_ST_FUNCTION) 2005 { 2006 gfc_error ("Statement function %qs at %L is not allowed as an " 2007 "actual argument", sym->name, &e->where); 2008 } 2009 2010 actual_ok = gfc_intrinsic_actual_ok (sym->name, 2011 sym->attr.subroutine); 2012 if (sym->attr.intrinsic && actual_ok == 0) 2013 { 2014 gfc_error ("Intrinsic %qs at %L is not allowed as an " 2015 "actual argument", sym->name, &e->where); 2016 } 2017 2018 if (sym->attr.contained && !sym->attr.use_assoc 2019 && sym->ns->proc_name->attr.flavor != FL_MODULE) 2020 { 2021 if (!gfc_notify_std (GFC_STD_F2008, "Internal procedure %qs is" 2022 " used as actual argument at %L", 2023 sym->name, &e->where)) 2024 goto cleanup; 2025 } 2026 2027 if (sym->attr.elemental && !sym->attr.intrinsic) 2028 { 2029 gfc_error ("ELEMENTAL non-INTRINSIC procedure %qs is not " 2030 "allowed as an actual argument at %L", sym->name, 2031 &e->where); 2032 } 2033 2034 /* Check if a generic interface has a specific procedure 2035 with the same name before emitting an error. */ 2036 if (sym->attr.generic && count_specific_procs (e) != 1) 2037 goto cleanup; 2038 2039 /* Just in case a specific was found for the expression. */ 2040 sym = e->symtree->n.sym; 2041 2042 /* If the symbol is the function that names the current (or 2043 parent) scope, then we really have a variable reference. */ 2044 2045 if (gfc_is_function_return_value (sym, sym->ns)) 2046 goto got_variable; 2047 2048 /* If all else fails, see if we have a specific intrinsic. */ 2049 if (sym->ts.type == BT_UNKNOWN && sym->attr.intrinsic) 2050 { 2051 gfc_intrinsic_sym *isym; 2052 2053 isym = gfc_find_function (sym->name); 2054 if (isym == NULL || !isym->specific) 2055 { 2056 gfc_error ("Unable to find a specific INTRINSIC procedure " 2057 "for the reference %qs at %L", sym->name, 2058 &e->where); 2059 goto cleanup; 2060 } 2061 sym->ts = isym->ts; 2062 sym->attr.intrinsic = 1; 2063 sym->attr.function = 1; 2064 } 2065 2066 if (!gfc_resolve_expr (e)) 2067 goto cleanup; 2068 goto argument_list; 2069 } 2070 2071 /* See if the name is a module procedure in a parent unit. */ 2072 2073 if (was_declared (sym) || sym->ns->parent == NULL) 2074 goto got_variable; 2075 2076 if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st)) 2077 { 2078 gfc_error ("Symbol %qs at %L is ambiguous", sym->name, &e->where); 2079 goto cleanup; 2080 } 2081 2082 if (parent_st == NULL) 2083 goto got_variable; 2084 2085 sym = parent_st->n.sym; 2086 e->symtree = parent_st; /* Point to the right thing. */ 2087 2088 if (sym->attr.flavor == FL_PROCEDURE 2089 || sym->attr.intrinsic 2090 || sym->attr.external) 2091 { 2092 if (!gfc_resolve_expr (e)) 2093 goto cleanup; 2094 goto argument_list; 2095 } 2096 2097 got_variable: 2098 e->expr_type = EXPR_VARIABLE; 2099 e->ts = sym->ts; 2100 if ((sym->as != NULL && sym->ts.type != BT_CLASS) 2101 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 2102 && CLASS_DATA (sym)->as)) 2103 { 2104 e->rank = sym->ts.type == BT_CLASS 2105 ? CLASS_DATA (sym)->as->rank : sym->as->rank; 2106 e->ref = gfc_get_ref (); 2107 e->ref->type = REF_ARRAY; 2108 e->ref->u.ar.type = AR_FULL; 2109 e->ref->u.ar.as = sym->ts.type == BT_CLASS 2110 ? CLASS_DATA (sym)->as : sym->as; 2111 } 2112 2113 /* Expressions are assigned a default ts.type of BT_PROCEDURE in 2114 primary.c (match_actual_arg). If above code determines that it 2115 is a variable instead, it needs to be resolved as it was not 2116 done at the beginning of this function. */ 2117 save_need_full_assumed_size = need_full_assumed_size; 2118 if (e->expr_type != EXPR_VARIABLE) 2119 need_full_assumed_size = 0; 2120 if (!gfc_resolve_expr (e)) 2121 goto cleanup; 2122 need_full_assumed_size = save_need_full_assumed_size; 2123 2124 argument_list: 2125 /* Check argument list functions %VAL, %LOC and %REF. There is 2126 nothing to do for %REF. */ 2127 if (arg->name && arg->name[0] == '%') 2128 { 2129 if (strcmp ("%VAL", arg->name) == 0) 2130 { 2131 if (e->ts.type == BT_CHARACTER || e->ts.type == BT_DERIVED) 2132 { 2133 gfc_error ("By-value argument at %L is not of numeric " 2134 "type", &e->where); 2135 goto cleanup; 2136 } 2137 2138 if (e->rank) 2139 { 2140 gfc_error ("By-value argument at %L cannot be an array or " 2141 "an array section", &e->where); 2142 goto cleanup; 2143 } 2144 2145 /* Intrinsics are still PROC_UNKNOWN here. However, 2146 since same file external procedures are not resolvable 2147 in gfortran, it is a good deal easier to leave them to 2148 intrinsic.c. */ 2149 if (ptype != PROC_UNKNOWN 2150 && ptype != PROC_DUMMY 2151 && ptype != PROC_EXTERNAL 2152 && ptype != PROC_MODULE) 2153 { 2154 gfc_error ("By-value argument at %L is not allowed " 2155 "in this context", &e->where); 2156 goto cleanup; 2157 } 2158 } 2159 2160 /* Statement functions have already been excluded above. */ 2161 else if (strcmp ("%LOC", arg->name) == 0 2162 && e->ts.type == BT_PROCEDURE) 2163 { 2164 if (e->symtree->n.sym->attr.proc == PROC_INTERNAL) 2165 { 2166 gfc_error ("Passing internal procedure at %L by location " 2167 "not allowed", &e->where); 2168 goto cleanup; 2169 } 2170 } 2171 } 2172 2173 comp = gfc_get_proc_ptr_comp(e); 2174 if (e->expr_type == EXPR_VARIABLE 2175 && comp && comp->attr.elemental) 2176 { 2177 gfc_error ("ELEMENTAL procedure pointer component %qs is not " 2178 "allowed as an actual argument at %L", comp->name, 2179 &e->where); 2180 } 2181 2182 /* Fortran 2008, C1237. */ 2183 if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) 2184 && gfc_has_ultimate_pointer (e)) 2185 { 2186 gfc_error ("Coindexed actual argument at %L with ultimate pointer " 2187 "component", &e->where); 2188 goto cleanup; 2189 } 2190 2191 first_actual_arg = false; 2192 } 2193 2194 return_value = true; 2195 2196cleanup: 2197 actual_arg = actual_arg_sav; 2198 first_actual_arg = first_actual_arg_sav; 2199 2200 return return_value; 2201} 2202 2203 2204/* Do the checks of the actual argument list that are specific to elemental 2205 procedures. If called with c == NULL, we have a function, otherwise if 2206 expr == NULL, we have a subroutine. */ 2207 2208static bool 2209resolve_elemental_actual (gfc_expr *expr, gfc_code *c) 2210{ 2211 gfc_actual_arglist *arg0; 2212 gfc_actual_arglist *arg; 2213 gfc_symbol *esym = NULL; 2214 gfc_intrinsic_sym *isym = NULL; 2215 gfc_expr *e = NULL; 2216 gfc_intrinsic_arg *iformal = NULL; 2217 gfc_formal_arglist *eformal = NULL; 2218 bool formal_optional = false; 2219 bool set_by_optional = false; 2220 int i; 2221 int rank = 0; 2222 2223 /* Is this an elemental procedure? */ 2224 if (expr && expr->value.function.actual != NULL) 2225 { 2226 if (expr->value.function.esym != NULL 2227 && expr->value.function.esym->attr.elemental) 2228 { 2229 arg0 = expr->value.function.actual; 2230 esym = expr->value.function.esym; 2231 } 2232 else if (expr->value.function.isym != NULL 2233 && expr->value.function.isym->elemental) 2234 { 2235 arg0 = expr->value.function.actual; 2236 isym = expr->value.function.isym; 2237 } 2238 else 2239 return true; 2240 } 2241 else if (c && c->ext.actual != NULL) 2242 { 2243 arg0 = c->ext.actual; 2244 2245 if (c->resolved_sym) 2246 esym = c->resolved_sym; 2247 else 2248 esym = c->symtree->n.sym; 2249 gcc_assert (esym); 2250 2251 if (!esym->attr.elemental) 2252 return true; 2253 } 2254 else 2255 return true; 2256 2257 /* The rank of an elemental is the rank of its array argument(s). */ 2258 for (arg = arg0; arg; arg = arg->next) 2259 { 2260 if (arg->expr != NULL && arg->expr->rank != 0) 2261 { 2262 rank = arg->expr->rank; 2263 if (arg->expr->expr_type == EXPR_VARIABLE 2264 && arg->expr->symtree->n.sym->attr.optional) 2265 set_by_optional = true; 2266 2267 /* Function specific; set the result rank and shape. */ 2268 if (expr) 2269 { 2270 expr->rank = rank; 2271 if (!expr->shape && arg->expr->shape) 2272 { 2273 expr->shape = gfc_get_shape (rank); 2274 for (i = 0; i < rank; i++) 2275 mpz_init_set (expr->shape[i], arg->expr->shape[i]); 2276 } 2277 } 2278 break; 2279 } 2280 } 2281 2282 /* If it is an array, it shall not be supplied as an actual argument 2283 to an elemental procedure unless an array of the same rank is supplied 2284 as an actual argument corresponding to a nonoptional dummy argument of 2285 that elemental procedure(12.4.1.5). */ 2286 formal_optional = false; 2287 if (isym) 2288 iformal = isym->formal; 2289 else 2290 eformal = esym->formal; 2291 2292 for (arg = arg0; arg; arg = arg->next) 2293 { 2294 if (eformal) 2295 { 2296 if (eformal->sym && eformal->sym->attr.optional) 2297 formal_optional = true; 2298 eformal = eformal->next; 2299 } 2300 else if (isym && iformal) 2301 { 2302 if (iformal->optional) 2303 formal_optional = true; 2304 iformal = iformal->next; 2305 } 2306 else if (isym) 2307 formal_optional = true; 2308 2309 if (pedantic && arg->expr != NULL 2310 && arg->expr->expr_type == EXPR_VARIABLE 2311 && arg->expr->symtree->n.sym->attr.optional 2312 && formal_optional 2313 && arg->expr->rank 2314 && (set_by_optional || arg->expr->rank != rank) 2315 && !(isym && isym->id == GFC_ISYM_CONVERSION)) 2316 { 2317 gfc_warning (OPT_Wpedantic, 2318 "%qs at %L is an array and OPTIONAL; IF IT IS " 2319 "MISSING, it cannot be the actual argument of an " 2320 "ELEMENTAL procedure unless there is a non-optional " 2321 "argument with the same rank (12.4.1.5)", 2322 arg->expr->symtree->n.sym->name, &arg->expr->where); 2323 } 2324 } 2325 2326 for (arg = arg0; arg; arg = arg->next) 2327 { 2328 if (arg->expr == NULL || arg->expr->rank == 0) 2329 continue; 2330 2331 /* Being elemental, the last upper bound of an assumed size array 2332 argument must be present. */ 2333 if (resolve_assumed_size_actual (arg->expr)) 2334 return false; 2335 2336 /* Elemental procedure's array actual arguments must conform. */ 2337 if (e != NULL) 2338 { 2339 if (!gfc_check_conformance (arg->expr, e, "elemental procedure")) 2340 return false; 2341 } 2342 else 2343 e = arg->expr; 2344 } 2345 2346 /* INTENT(OUT) is only allowed for subroutines; if any actual argument 2347 is an array, the intent inout/out variable needs to be also an array. */ 2348 if (rank > 0 && esym && expr == NULL) 2349 for (eformal = esym->formal, arg = arg0; arg && eformal; 2350 arg = arg->next, eformal = eformal->next) 2351 if ((eformal->sym->attr.intent == INTENT_OUT 2352 || eformal->sym->attr.intent == INTENT_INOUT) 2353 && arg->expr && arg->expr->rank == 0) 2354 { 2355 gfc_error ("Actual argument at %L for INTENT(%s) dummy %qs of " 2356 "ELEMENTAL subroutine %qs is a scalar, but another " 2357 "actual argument is an array", &arg->expr->where, 2358 (eformal->sym->attr.intent == INTENT_OUT) ? "OUT" 2359 : "INOUT", eformal->sym->name, esym->name); 2360 return false; 2361 } 2362 return true; 2363} 2364 2365 2366/* This function does the checking of references to global procedures 2367 as defined in sections 18.1 and 14.1, respectively, of the Fortran 2368 77 and 95 standards. It checks for a gsymbol for the name, making 2369 one if it does not already exist. If it already exists, then the 2370 reference being resolved must correspond to the type of gsymbol. 2371 Otherwise, the new symbol is equipped with the attributes of the 2372 reference. The corresponding code that is called in creating 2373 global entities is parse.c. 2374 2375 In addition, for all but -std=legacy, the gsymbols are used to 2376 check the interfaces of external procedures from the same file. 2377 The namespace of the gsymbol is resolved and then, once this is 2378 done the interface is checked. */ 2379 2380 2381static bool 2382not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) 2383{ 2384 if (!gsym_ns->proc_name->attr.recursive) 2385 return true; 2386 2387 if (sym->ns == gsym_ns) 2388 return false; 2389 2390 if (sym->ns->parent && sym->ns->parent == gsym_ns) 2391 return false; 2392 2393 return true; 2394} 2395 2396static bool 2397not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) 2398{ 2399 if (gsym_ns->entries) 2400 { 2401 gfc_entry_list *entry = gsym_ns->entries; 2402 2403 for (; entry; entry = entry->next) 2404 { 2405 if (strcmp (sym->name, entry->sym->name) == 0) 2406 { 2407 if (strcmp (gsym_ns->proc_name->name, 2408 sym->ns->proc_name->name) == 0) 2409 return false; 2410 2411 if (sym->ns->parent 2412 && strcmp (gsym_ns->proc_name->name, 2413 sym->ns->parent->proc_name->name) == 0) 2414 return false; 2415 } 2416 } 2417 } 2418 return true; 2419} 2420 2421 2422/* Check for the requirement of an explicit interface. F08:12.4.2.2. */ 2423 2424bool 2425gfc_explicit_interface_required (gfc_symbol *sym, char *errmsg, int err_len) 2426{ 2427 gfc_formal_arglist *arg = gfc_sym_get_dummy_args (sym); 2428 2429 for ( ; arg; arg = arg->next) 2430 { 2431 if (!arg->sym) 2432 continue; 2433 2434 if (arg->sym->attr.allocatable) /* (2a) */ 2435 { 2436 strncpy (errmsg, _("allocatable argument"), err_len); 2437 return true; 2438 } 2439 else if (arg->sym->attr.asynchronous) 2440 { 2441 strncpy (errmsg, _("asynchronous argument"), err_len); 2442 return true; 2443 } 2444 else if (arg->sym->attr.optional) 2445 { 2446 strncpy (errmsg, _("optional argument"), err_len); 2447 return true; 2448 } 2449 else if (arg->sym->attr.pointer) 2450 { 2451 strncpy (errmsg, _("pointer argument"), err_len); 2452 return true; 2453 } 2454 else if (arg->sym->attr.target) 2455 { 2456 strncpy (errmsg, _("target argument"), err_len); 2457 return true; 2458 } 2459 else if (arg->sym->attr.value) 2460 { 2461 strncpy (errmsg, _("value argument"), err_len); 2462 return true; 2463 } 2464 else if (arg->sym->attr.volatile_) 2465 { 2466 strncpy (errmsg, _("volatile argument"), err_len); 2467 return true; 2468 } 2469 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_SHAPE) /* (2b) */ 2470 { 2471 strncpy (errmsg, _("assumed-shape argument"), err_len); 2472 return true; 2473 } 2474 else if (arg->sym->as && arg->sym->as->type == AS_ASSUMED_RANK) /* TS 29113, 6.2. */ 2475 { 2476 strncpy (errmsg, _("assumed-rank argument"), err_len); 2477 return true; 2478 } 2479 else if (arg->sym->attr.codimension) /* (2c) */ 2480 { 2481 strncpy (errmsg, _("coarray argument"), err_len); 2482 return true; 2483 } 2484 else if (false) /* (2d) TODO: parametrized derived type */ 2485 { 2486 strncpy (errmsg, _("parametrized derived type argument"), err_len); 2487 return true; 2488 } 2489 else if (arg->sym->ts.type == BT_CLASS) /* (2e) */ 2490 { 2491 strncpy (errmsg, _("polymorphic argument"), err_len); 2492 return true; 2493 } 2494 else if (arg->sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 2495 { 2496 strncpy (errmsg, _("NO_ARG_CHECK attribute"), err_len); 2497 return true; 2498 } 2499 else if (arg->sym->ts.type == BT_ASSUMED) 2500 { 2501 /* As assumed-type is unlimited polymorphic (cf. above). 2502 See also TS 29113, Note 6.1. */ 2503 strncpy (errmsg, _("assumed-type argument"), err_len); 2504 return true; 2505 } 2506 } 2507 2508 if (sym->attr.function) 2509 { 2510 gfc_symbol *res = sym->result ? sym->result : sym; 2511 2512 if (res->attr.dimension) /* (3a) */ 2513 { 2514 strncpy (errmsg, _("array result"), err_len); 2515 return true; 2516 } 2517 else if (res->attr.pointer || res->attr.allocatable) /* (3b) */ 2518 { 2519 strncpy (errmsg, _("pointer or allocatable result"), err_len); 2520 return true; 2521 } 2522 else if (res->ts.type == BT_CHARACTER && res->ts.u.cl 2523 && res->ts.u.cl->length 2524 && res->ts.u.cl->length->expr_type != EXPR_CONSTANT) /* (3c) */ 2525 { 2526 strncpy (errmsg, _("result with non-constant character length"), err_len); 2527 return true; 2528 } 2529 } 2530 2531 if (sym->attr.elemental && !sym->attr.intrinsic) /* (4) */ 2532 { 2533 strncpy (errmsg, _("elemental procedure"), err_len); 2534 return true; 2535 } 2536 else if (sym->attr.is_bind_c) /* (5) */ 2537 { 2538 strncpy (errmsg, _("bind(c) procedure"), err_len); 2539 return true; 2540 } 2541 2542 return false; 2543} 2544 2545 2546static void 2547resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) 2548{ 2549 gfc_gsymbol * gsym; 2550 gfc_namespace *ns; 2551 enum gfc_symbol_type type; 2552 char reason[200]; 2553 2554 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; 2555 2556 gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, 2557 sym->binding_label != NULL); 2558 2559 if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) 2560 gfc_global_used (gsym, where); 2561 2562 if ((sym->attr.if_source == IFSRC_UNKNOWN 2563 || sym->attr.if_source == IFSRC_IFBODY) 2564 && gsym->type != GSYM_UNKNOWN 2565 && !gsym->binding_label 2566 && gsym->ns 2567 && gsym->ns->proc_name 2568 && not_in_recursive (sym, gsym->ns) 2569 && not_entry_self_reference (sym, gsym->ns)) 2570 { 2571 gfc_symbol *def_sym; 2572 def_sym = gsym->ns->proc_name; 2573 2574 if (gsym->ns->resolved != -1) 2575 { 2576 2577 /* Resolve the gsymbol namespace if needed. */ 2578 if (!gsym->ns->resolved) 2579 { 2580 gfc_symbol *old_dt_list; 2581 2582 /* Stash away derived types so that the backend_decls 2583 do not get mixed up. */ 2584 old_dt_list = gfc_derived_types; 2585 gfc_derived_types = NULL; 2586 2587 gfc_resolve (gsym->ns); 2588 2589 /* Store the new derived types with the global namespace. */ 2590 if (gfc_derived_types) 2591 gsym->ns->derived_types = gfc_derived_types; 2592 2593 /* Restore the derived types of this namespace. */ 2594 gfc_derived_types = old_dt_list; 2595 } 2596 2597 /* Make sure that translation for the gsymbol occurs before 2598 the procedure currently being resolved. */ 2599 ns = gfc_global_ns_list; 2600 for (; ns && ns != gsym->ns; ns = ns->sibling) 2601 { 2602 if (ns->sibling == gsym->ns) 2603 { 2604 ns->sibling = gsym->ns->sibling; 2605 gsym->ns->sibling = gfc_global_ns_list; 2606 gfc_global_ns_list = gsym->ns; 2607 break; 2608 } 2609 } 2610 2611 /* This can happen if a binding name has been specified. */ 2612 if (gsym->binding_label && gsym->sym_name != def_sym->name) 2613 gfc_find_symbol (gsym->sym_name, gsym->ns, 0, &def_sym); 2614 2615 if (def_sym->attr.entry_master || def_sym->attr.entry) 2616 { 2617 gfc_entry_list *entry; 2618 for (entry = gsym->ns->entries; entry; entry = entry->next) 2619 if (strcmp (entry->sym->name, sym->name) == 0) 2620 { 2621 def_sym = entry->sym; 2622 break; 2623 } 2624 } 2625 } 2626 2627 if (sym->attr.function && !gfc_compare_types (&sym->ts, &def_sym->ts)) 2628 { 2629 gfc_error ("Return type mismatch of function %qs at %L (%s/%s)", 2630 sym->name, &sym->declared_at, gfc_typename (&sym->ts), 2631 gfc_typename (&def_sym->ts)); 2632 goto done; 2633 } 2634 2635 if (sym->attr.if_source == IFSRC_UNKNOWN 2636 && gfc_explicit_interface_required (def_sym, reason, sizeof(reason))) 2637 { 2638 gfc_error ("Explicit interface required for %qs at %L: %s", 2639 sym->name, &sym->declared_at, reason); 2640 goto done; 2641 } 2642 2643 bool bad_result_characteristics; 2644 if (!gfc_compare_interfaces (sym, def_sym, sym->name, 0, 1, 2645 reason, sizeof(reason), NULL, NULL, 2646 &bad_result_characteristics)) 2647 { 2648 /* Turn erros into warnings with -std=gnu and -std=legacy, 2649 unless a function returns a wrong type, which can lead 2650 to all kinds of ICEs and wrong code. */ 2651 2652 if (!pedantic && (gfc_option.allow_std & GFC_STD_GNU) 2653 && !bad_result_characteristics) 2654 gfc_errors_to_warnings (true); 2655 2656 gfc_error ("Interface mismatch in global procedure %qs at %L: %s", 2657 sym->name, &sym->declared_at, reason); 2658 gfc_errors_to_warnings (false); 2659 goto done; 2660 } 2661 } 2662 2663done: 2664 2665 if (gsym->type == GSYM_UNKNOWN) 2666 { 2667 gsym->type = type; 2668 gsym->where = *where; 2669 } 2670 2671 gsym->used = 1; 2672} 2673 2674 2675/************* Function resolution *************/ 2676 2677/* Resolve a function call known to be generic. 2678 Section 14.1.2.4.1. */ 2679 2680static match 2681resolve_generic_f0 (gfc_expr *expr, gfc_symbol *sym) 2682{ 2683 gfc_symbol *s; 2684 2685 if (sym->attr.generic) 2686 { 2687 s = gfc_search_interface (sym->generic, 0, &expr->value.function.actual); 2688 if (s != NULL) 2689 { 2690 expr->value.function.name = s->name; 2691 expr->value.function.esym = s; 2692 2693 if (s->ts.type != BT_UNKNOWN) 2694 expr->ts = s->ts; 2695 else if (s->result != NULL && s->result->ts.type != BT_UNKNOWN) 2696 expr->ts = s->result->ts; 2697 2698 if (s->as != NULL) 2699 expr->rank = s->as->rank; 2700 else if (s->result != NULL && s->result->as != NULL) 2701 expr->rank = s->result->as->rank; 2702 2703 gfc_set_sym_referenced (expr->value.function.esym); 2704 2705 return MATCH_YES; 2706 } 2707 2708 /* TODO: Need to search for elemental references in generic 2709 interface. */ 2710 } 2711 2712 if (sym->attr.intrinsic) 2713 return gfc_intrinsic_func_interface (expr, 0); 2714 2715 return MATCH_NO; 2716} 2717 2718 2719static bool 2720resolve_generic_f (gfc_expr *expr) 2721{ 2722 gfc_symbol *sym; 2723 match m; 2724 gfc_interface *intr = NULL; 2725 2726 sym = expr->symtree->n.sym; 2727 2728 for (;;) 2729 { 2730 m = resolve_generic_f0 (expr, sym); 2731 if (m == MATCH_YES) 2732 return true; 2733 else if (m == MATCH_ERROR) 2734 return false; 2735 2736generic: 2737 if (!intr) 2738 for (intr = sym->generic; intr; intr = intr->next) 2739 if (gfc_fl_struct (intr->sym->attr.flavor)) 2740 break; 2741 2742 if (sym->ns->parent == NULL) 2743 break; 2744 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); 2745 2746 if (sym == NULL) 2747 break; 2748 if (!generic_sym (sym)) 2749 goto generic; 2750 } 2751 2752 /* Last ditch attempt. See if the reference is to an intrinsic 2753 that possesses a matching interface. 14.1.2.4 */ 2754 if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where)) 2755 { 2756 if (gfc_init_expr_flag) 2757 gfc_error ("Function %qs in initialization expression at %L " 2758 "must be an intrinsic function", 2759 expr->symtree->n.sym->name, &expr->where); 2760 else 2761 gfc_error ("There is no specific function for the generic %qs " 2762 "at %L", expr->symtree->n.sym->name, &expr->where); 2763 return false; 2764 } 2765 2766 if (intr) 2767 { 2768 if (!gfc_convert_to_structure_constructor (expr, intr->sym, NULL, 2769 NULL, false)) 2770 return false; 2771 if (!gfc_use_derived (expr->ts.u.derived)) 2772 return false; 2773 return resolve_structure_cons (expr, 0); 2774 } 2775 2776 m = gfc_intrinsic_func_interface (expr, 0); 2777 if (m == MATCH_YES) 2778 return true; 2779 2780 if (m == MATCH_NO) 2781 gfc_error ("Generic function %qs at %L is not consistent with a " 2782 "specific intrinsic interface", expr->symtree->n.sym->name, 2783 &expr->where); 2784 2785 return false; 2786} 2787 2788 2789/* Resolve a function call known to be specific. */ 2790 2791static match 2792resolve_specific_f0 (gfc_symbol *sym, gfc_expr *expr) 2793{ 2794 match m; 2795 2796 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) 2797 { 2798 if (sym->attr.dummy) 2799 { 2800 sym->attr.proc = PROC_DUMMY; 2801 goto found; 2802 } 2803 2804 sym->attr.proc = PROC_EXTERNAL; 2805 goto found; 2806 } 2807 2808 if (sym->attr.proc == PROC_MODULE 2809 || sym->attr.proc == PROC_ST_FUNCTION 2810 || sym->attr.proc == PROC_INTERNAL) 2811 goto found; 2812 2813 if (sym->attr.intrinsic) 2814 { 2815 m = gfc_intrinsic_func_interface (expr, 1); 2816 if (m == MATCH_YES) 2817 return MATCH_YES; 2818 if (m == MATCH_NO) 2819 gfc_error ("Function %qs at %L is INTRINSIC but is not compatible " 2820 "with an intrinsic", sym->name, &expr->where); 2821 2822 return MATCH_ERROR; 2823 } 2824 2825 return MATCH_NO; 2826 2827found: 2828 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); 2829 2830 if (sym->result) 2831 expr->ts = sym->result->ts; 2832 else 2833 expr->ts = sym->ts; 2834 expr->value.function.name = sym->name; 2835 expr->value.function.esym = sym; 2836 /* Prevent crash when sym->ts.u.derived->components is not set due to previous 2837 error(s). */ 2838 if (sym->ts.type == BT_CLASS && !CLASS_DATA (sym)) 2839 return MATCH_ERROR; 2840 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) 2841 expr->rank = CLASS_DATA (sym)->as->rank; 2842 else if (sym->as != NULL) 2843 expr->rank = sym->as->rank; 2844 2845 return MATCH_YES; 2846} 2847 2848 2849static bool 2850resolve_specific_f (gfc_expr *expr) 2851{ 2852 gfc_symbol *sym; 2853 match m; 2854 2855 sym = expr->symtree->n.sym; 2856 2857 for (;;) 2858 { 2859 m = resolve_specific_f0 (sym, expr); 2860 if (m == MATCH_YES) 2861 return true; 2862 if (m == MATCH_ERROR) 2863 return false; 2864 2865 if (sym->ns->parent == NULL) 2866 break; 2867 2868 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); 2869 2870 if (sym == NULL) 2871 break; 2872 } 2873 2874 gfc_error ("Unable to resolve the specific function %qs at %L", 2875 expr->symtree->n.sym->name, &expr->where); 2876 2877 return true; 2878} 2879 2880/* Recursively append candidate SYM to CANDIDATES. Store the number of 2881 candidates in CANDIDATES_LEN. */ 2882 2883static void 2884lookup_function_fuzzy_find_candidates (gfc_symtree *sym, 2885 char **&candidates, 2886 size_t &candidates_len) 2887{ 2888 gfc_symtree *p; 2889 2890 if (sym == NULL) 2891 return; 2892 if ((sym->n.sym->ts.type != BT_UNKNOWN || sym->n.sym->attr.external) 2893 && sym->n.sym->attr.flavor == FL_PROCEDURE) 2894 vec_push (candidates, candidates_len, sym->name); 2895 2896 p = sym->left; 2897 if (p) 2898 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); 2899 2900 p = sym->right; 2901 if (p) 2902 lookup_function_fuzzy_find_candidates (p, candidates, candidates_len); 2903} 2904 2905 2906/* Lookup function FN fuzzily, taking names in SYMROOT into account. */ 2907 2908const char* 2909gfc_lookup_function_fuzzy (const char *fn, gfc_symtree *symroot) 2910{ 2911 char **candidates = NULL; 2912 size_t candidates_len = 0; 2913 lookup_function_fuzzy_find_candidates (symroot, candidates, candidates_len); 2914 return gfc_closest_fuzzy_match (fn, candidates); 2915} 2916 2917 2918/* Resolve a procedure call not known to be generic nor specific. */ 2919 2920static bool 2921resolve_unknown_f (gfc_expr *expr) 2922{ 2923 gfc_symbol *sym; 2924 gfc_typespec *ts; 2925 2926 sym = expr->symtree->n.sym; 2927 2928 if (sym->attr.dummy) 2929 { 2930 sym->attr.proc = PROC_DUMMY; 2931 expr->value.function.name = sym->name; 2932 goto set_type; 2933 } 2934 2935 /* See if we have an intrinsic function reference. */ 2936 2937 if (gfc_is_intrinsic (sym, 0, expr->where)) 2938 { 2939 if (gfc_intrinsic_func_interface (expr, 1) == MATCH_YES) 2940 return true; 2941 return false; 2942 } 2943 2944 /* The reference is to an external name. */ 2945 2946 sym->attr.proc = PROC_EXTERNAL; 2947 expr->value.function.name = sym->name; 2948 expr->value.function.esym = expr->symtree->n.sym; 2949 2950 if (sym->as != NULL) 2951 expr->rank = sym->as->rank; 2952 2953 /* Type of the expression is either the type of the symbol or the 2954 default type of the symbol. */ 2955 2956set_type: 2957 gfc_procedure_use (sym, &expr->value.function.actual, &expr->where); 2958 2959 if (sym->ts.type != BT_UNKNOWN) 2960 expr->ts = sym->ts; 2961 else 2962 { 2963 ts = gfc_get_default_type (sym->name, sym->ns); 2964 2965 if (ts->type == BT_UNKNOWN) 2966 { 2967 const char *guessed 2968 = gfc_lookup_function_fuzzy (sym->name, sym->ns->sym_root); 2969 if (guessed) 2970 gfc_error ("Function %qs at %L has no IMPLICIT type" 2971 "; did you mean %qs?", 2972 sym->name, &expr->where, guessed); 2973 else 2974 gfc_error ("Function %qs at %L has no IMPLICIT type", 2975 sym->name, &expr->where); 2976 return false; 2977 } 2978 else 2979 expr->ts = *ts; 2980 } 2981 2982 return true; 2983} 2984 2985 2986/* Return true, if the symbol is an external procedure. */ 2987static bool 2988is_external_proc (gfc_symbol *sym) 2989{ 2990 if (!sym->attr.dummy && !sym->attr.contained 2991 && !gfc_is_intrinsic (sym, sym->attr.subroutine, sym->declared_at) 2992 && sym->attr.proc != PROC_ST_FUNCTION 2993 && !sym->attr.proc_pointer 2994 && !sym->attr.use_assoc 2995 && sym->name) 2996 return true; 2997 2998 return false; 2999} 3000 3001 3002/* Figure out if a function reference is pure or not. Also set the name 3003 of the function for a potential error message. Return nonzero if the 3004 function is PURE, zero if not. */ 3005static int 3006pure_stmt_function (gfc_expr *, gfc_symbol *); 3007 3008int 3009gfc_pure_function (gfc_expr *e, const char **name) 3010{ 3011 int pure; 3012 gfc_component *comp; 3013 3014 *name = NULL; 3015 3016 if (e->symtree != NULL 3017 && e->symtree->n.sym != NULL 3018 && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) 3019 return pure_stmt_function (e, e->symtree->n.sym); 3020 3021 comp = gfc_get_proc_ptr_comp (e); 3022 if (comp) 3023 { 3024 pure = gfc_pure (comp->ts.interface); 3025 *name = comp->name; 3026 } 3027 else if (e->value.function.esym) 3028 { 3029 pure = gfc_pure (e->value.function.esym); 3030 *name = e->value.function.esym->name; 3031 } 3032 else if (e->value.function.isym) 3033 { 3034 pure = e->value.function.isym->pure 3035 || e->value.function.isym->elemental; 3036 *name = e->value.function.isym->name; 3037 } 3038 else 3039 { 3040 /* Implicit functions are not pure. */ 3041 pure = 0; 3042 *name = e->value.function.name; 3043 } 3044 3045 return pure; 3046} 3047 3048 3049/* Check if the expression is a reference to an implicitly pure function. */ 3050 3051int 3052gfc_implicit_pure_function (gfc_expr *e) 3053{ 3054 gfc_component *comp = gfc_get_proc_ptr_comp (e); 3055 if (comp) 3056 return gfc_implicit_pure (comp->ts.interface); 3057 else if (e->value.function.esym) 3058 return gfc_implicit_pure (e->value.function.esym); 3059 else 3060 return 0; 3061} 3062 3063 3064static bool 3065impure_stmt_fcn (gfc_expr *e, gfc_symbol *sym, 3066 int *f ATTRIBUTE_UNUSED) 3067{ 3068 const char *name; 3069 3070 /* Don't bother recursing into other statement functions 3071 since they will be checked individually for purity. */ 3072 if (e->expr_type != EXPR_FUNCTION 3073 || !e->symtree 3074 || e->symtree->n.sym == sym 3075 || e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION) 3076 return false; 3077 3078 return gfc_pure_function (e, &name) ? false : true; 3079} 3080 3081 3082static int 3083pure_stmt_function (gfc_expr *e, gfc_symbol *sym) 3084{ 3085 return gfc_traverse_expr (e, sym, impure_stmt_fcn, 0) ? 0 : 1; 3086} 3087 3088 3089/* Check if an impure function is allowed in the current context. */ 3090 3091static bool check_pure_function (gfc_expr *e) 3092{ 3093 const char *name = NULL; 3094 if (!gfc_pure_function (e, &name) && name) 3095 { 3096 if (forall_flag) 3097 { 3098 gfc_error ("Reference to impure function %qs at %L inside a " 3099 "FORALL %s", name, &e->where, 3100 forall_flag == 2 ? "mask" : "block"); 3101 return false; 3102 } 3103 else if (gfc_do_concurrent_flag) 3104 { 3105 gfc_error ("Reference to impure function %qs at %L inside a " 3106 "DO CONCURRENT %s", name, &e->where, 3107 gfc_do_concurrent_flag == 2 ? "mask" : "block"); 3108 return false; 3109 } 3110 else if (gfc_pure (NULL)) 3111 { 3112 gfc_error ("Reference to impure function %qs at %L " 3113 "within a PURE procedure", name, &e->where); 3114 return false; 3115 } 3116 if (!gfc_implicit_pure_function (e)) 3117 gfc_unset_implicit_pure (NULL); 3118 } 3119 return true; 3120} 3121 3122 3123/* Update current procedure's array_outer_dependency flag, considering 3124 a call to procedure SYM. */ 3125 3126static void 3127update_current_proc_array_outer_dependency (gfc_symbol *sym) 3128{ 3129 /* Check to see if this is a sibling function that has not yet 3130 been resolved. */ 3131 gfc_namespace *sibling = gfc_current_ns->sibling; 3132 for (; sibling; sibling = sibling->sibling) 3133 { 3134 if (sibling->proc_name == sym) 3135 { 3136 gfc_resolve (sibling); 3137 break; 3138 } 3139 } 3140 3141 /* If SYM has references to outer arrays, so has the procedure calling 3142 SYM. If SYM is a procedure pointer, we can assume the worst. */ 3143 if ((sym->attr.array_outer_dependency || sym->attr.proc_pointer) 3144 && gfc_current_ns->proc_name) 3145 gfc_current_ns->proc_name->attr.array_outer_dependency = 1; 3146} 3147 3148 3149/* Resolve a function call, which means resolving the arguments, then figuring 3150 out which entity the name refers to. */ 3151 3152static bool 3153resolve_function (gfc_expr *expr) 3154{ 3155 gfc_actual_arglist *arg; 3156 gfc_symbol *sym; 3157 bool t; 3158 int temp; 3159 procedure_type p = PROC_INTRINSIC; 3160 bool no_formal_args; 3161 3162 sym = NULL; 3163 if (expr->symtree) 3164 sym = expr->symtree->n.sym; 3165 3166 /* If this is a procedure pointer component, it has already been resolved. */ 3167 if (gfc_is_proc_ptr_comp (expr)) 3168 return true; 3169 3170 /* Avoid re-resolving the arguments of caf_get, which can lead to inserting 3171 another caf_get. */ 3172 if (sym && sym->attr.intrinsic 3173 && (sym->intmod_sym_id == GFC_ISYM_CAF_GET 3174 || sym->intmod_sym_id == GFC_ISYM_CAF_SEND)) 3175 return true; 3176 3177 if (expr->ref) 3178 { 3179 gfc_error ("Unexpected junk after %qs at %L", expr->symtree->n.sym->name, 3180 &expr->where); 3181 return false; 3182 } 3183 3184 if (sym && sym->attr.intrinsic 3185 && !gfc_resolve_intrinsic (sym, &expr->where)) 3186 return false; 3187 3188 if (sym && (sym->attr.flavor == FL_VARIABLE || sym->attr.subroutine)) 3189 { 3190 gfc_error ("%qs at %L is not a function", sym->name, &expr->where); 3191 return false; 3192 } 3193 3194 /* If this is a deferred TBP with an abstract interface (which may 3195 of course be referenced), expr->value.function.esym will be set. */ 3196 if (sym && sym->attr.abstract && !expr->value.function.esym) 3197 { 3198 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", 3199 sym->name, &expr->where); 3200 return false; 3201 } 3202 3203 /* If this is a deferred TBP with an abstract interface, its result 3204 cannot be an assumed length character (F2003: C418). */ 3205 if (sym && sym->attr.abstract && sym->attr.function 3206 && sym->result->ts.u.cl 3207 && sym->result->ts.u.cl->length == NULL 3208 && !sym->result->ts.deferred) 3209 { 3210 gfc_error ("ABSTRACT INTERFACE %qs at %L must not have an assumed " 3211 "character length result (F2008: C418)", sym->name, 3212 &sym->declared_at); 3213 return false; 3214 } 3215 3216 /* Switch off assumed size checking and do this again for certain kinds 3217 of procedure, once the procedure itself is resolved. */ 3218 need_full_assumed_size++; 3219 3220 if (expr->symtree && expr->symtree->n.sym) 3221 p = expr->symtree->n.sym->attr.proc; 3222 3223 if (expr->value.function.isym && expr->value.function.isym->inquiry) 3224 inquiry_argument = true; 3225 no_formal_args = sym && is_external_proc (sym) 3226 && gfc_sym_get_dummy_args (sym) == NULL; 3227 3228 if (!resolve_actual_arglist (expr->value.function.actual, 3229 p, no_formal_args)) 3230 { 3231 inquiry_argument = false; 3232 return false; 3233 } 3234 3235 inquiry_argument = false; 3236 3237 /* Resume assumed_size checking. */ 3238 need_full_assumed_size--; 3239 3240 /* If the procedure is external, check for usage. */ 3241 if (sym && is_external_proc (sym)) 3242 resolve_global_procedure (sym, &expr->where, 0); 3243 3244 if (sym && sym->ts.type == BT_CHARACTER 3245 && sym->ts.u.cl 3246 && sym->ts.u.cl->length == NULL 3247 && !sym->attr.dummy 3248 && !sym->ts.deferred 3249 && expr->value.function.esym == NULL 3250 && !sym->attr.contained) 3251 { 3252 /* Internal procedures are taken care of in resolve_contained_fntype. */ 3253 gfc_error ("Function %qs is declared CHARACTER(*) and cannot " 3254 "be used at %L since it is not a dummy argument", 3255 sym->name, &expr->where); 3256 return false; 3257 } 3258 3259 /* See if function is already resolved. */ 3260 3261 if (expr->value.function.name != NULL 3262 || expr->value.function.isym != NULL) 3263 { 3264 if (expr->ts.type == BT_UNKNOWN) 3265 expr->ts = sym->ts; 3266 t = true; 3267 } 3268 else 3269 { 3270 /* Apply the rules of section 14.1.2. */ 3271 3272 switch (procedure_kind (sym)) 3273 { 3274 case PTYPE_GENERIC: 3275 t = resolve_generic_f (expr); 3276 break; 3277 3278 case PTYPE_SPECIFIC: 3279 t = resolve_specific_f (expr); 3280 break; 3281 3282 case PTYPE_UNKNOWN: 3283 t = resolve_unknown_f (expr); 3284 break; 3285 3286 default: 3287 gfc_internal_error ("resolve_function(): bad function type"); 3288 } 3289 } 3290 3291 /* If the expression is still a function (it might have simplified), 3292 then we check to see if we are calling an elemental function. */ 3293 3294 if (expr->expr_type != EXPR_FUNCTION) 3295 return t; 3296 3297 /* Walk the argument list looking for invalid BOZ. */ 3298 for (arg = expr->value.function.actual; arg; arg = arg->next) 3299 if (arg->expr && arg->expr->ts.type == BT_BOZ) 3300 { 3301 gfc_error ("A BOZ literal constant at %L cannot appear as an " 3302 "actual argument in a function reference", 3303 &arg->expr->where); 3304 return false; 3305 } 3306 3307 temp = need_full_assumed_size; 3308 need_full_assumed_size = 0; 3309 3310 if (!resolve_elemental_actual (expr, NULL)) 3311 return false; 3312 3313 if (omp_workshare_flag 3314 && expr->value.function.esym 3315 && ! gfc_elemental (expr->value.function.esym)) 3316 { 3317 gfc_error ("User defined non-ELEMENTAL function %qs at %L not allowed " 3318 "in WORKSHARE construct", expr->value.function.esym->name, 3319 &expr->where); 3320 t = false; 3321 } 3322 3323#define GENERIC_ID expr->value.function.isym->id 3324 else if (expr->value.function.actual != NULL 3325 && expr->value.function.isym != NULL 3326 && GENERIC_ID != GFC_ISYM_LBOUND 3327 && GENERIC_ID != GFC_ISYM_LCOBOUND 3328 && GENERIC_ID != GFC_ISYM_UCOBOUND 3329 && GENERIC_ID != GFC_ISYM_LEN 3330 && GENERIC_ID != GFC_ISYM_LOC 3331 && GENERIC_ID != GFC_ISYM_C_LOC 3332 && GENERIC_ID != GFC_ISYM_PRESENT) 3333 { 3334 /* Array intrinsics must also have the last upper bound of an 3335 assumed size array argument. UBOUND and SIZE have to be 3336 excluded from the check if the second argument is anything 3337 than a constant. */ 3338 3339 for (arg = expr->value.function.actual; arg; arg = arg->next) 3340 { 3341 if ((GENERIC_ID == GFC_ISYM_UBOUND || GENERIC_ID == GFC_ISYM_SIZE) 3342 && arg == expr->value.function.actual 3343 && arg->next != NULL && arg->next->expr) 3344 { 3345 if (arg->next->expr->expr_type != EXPR_CONSTANT) 3346 break; 3347 3348 if (arg->next->name && strcmp (arg->next->name, "kind") == 0) 3349 break; 3350 3351 if ((int)mpz_get_si (arg->next->expr->value.integer) 3352 < arg->expr->rank) 3353 break; 3354 } 3355 3356 if (arg->expr != NULL 3357 && arg->expr->rank > 0 3358 && resolve_assumed_size_actual (arg->expr)) 3359 return false; 3360 } 3361 } 3362#undef GENERIC_ID 3363 3364 need_full_assumed_size = temp; 3365 3366 if (!check_pure_function(expr)) 3367 t = false; 3368 3369 /* Functions without the RECURSIVE attribution are not allowed to 3370 * call themselves. */ 3371 if (expr->value.function.esym && !expr->value.function.esym->attr.recursive) 3372 { 3373 gfc_symbol *esym; 3374 esym = expr->value.function.esym; 3375 3376 if (is_illegal_recursion (esym, gfc_current_ns)) 3377 { 3378 if (esym->attr.entry && esym->ns->entries) 3379 gfc_error ("ENTRY %qs at %L cannot be called recursively, as" 3380 " function %qs is not RECURSIVE", 3381 esym->name, &expr->where, esym->ns->entries->sym->name); 3382 else 3383 gfc_error ("Function %qs at %L cannot be called recursively, as it" 3384 " is not RECURSIVE", esym->name, &expr->where); 3385 3386 t = false; 3387 } 3388 } 3389 3390 /* Character lengths of use associated functions may contains references to 3391 symbols not referenced from the current program unit otherwise. Make sure 3392 those symbols are marked as referenced. */ 3393 3394 if (expr->ts.type == BT_CHARACTER && expr->value.function.esym 3395 && expr->value.function.esym->attr.use_assoc) 3396 { 3397 gfc_expr_set_symbols_referenced (expr->ts.u.cl->length); 3398 } 3399 3400 /* Make sure that the expression has a typespec that works. */ 3401 if (expr->ts.type == BT_UNKNOWN) 3402 { 3403 if (expr->symtree->n.sym->result 3404 && expr->symtree->n.sym->result->ts.type != BT_UNKNOWN 3405 && !expr->symtree->n.sym->result->attr.proc_pointer) 3406 expr->ts = expr->symtree->n.sym->result->ts; 3407 } 3408 3409 if (!expr->ref && !expr->value.function.isym) 3410 { 3411 if (expr->value.function.esym) 3412 update_current_proc_array_outer_dependency (expr->value.function.esym); 3413 else 3414 update_current_proc_array_outer_dependency (sym); 3415 } 3416 else if (expr->ref) 3417 /* typebound procedure: Assume the worst. */ 3418 gfc_current_ns->proc_name->attr.array_outer_dependency = 1; 3419 3420 return t; 3421} 3422 3423 3424/************* Subroutine resolution *************/ 3425 3426static bool 3427pure_subroutine (gfc_symbol *sym, const char *name, locus *loc) 3428{ 3429 if (gfc_pure (sym)) 3430 return true; 3431 3432 if (forall_flag) 3433 { 3434 gfc_error ("Subroutine call to %qs in FORALL block at %L is not PURE", 3435 name, loc); 3436 return false; 3437 } 3438 else if (gfc_do_concurrent_flag) 3439 { 3440 gfc_error ("Subroutine call to %qs in DO CONCURRENT block at %L is not " 3441 "PURE", name, loc); 3442 return false; 3443 } 3444 else if (gfc_pure (NULL)) 3445 { 3446 gfc_error ("Subroutine call to %qs at %L is not PURE", name, loc); 3447 return false; 3448 } 3449 3450 gfc_unset_implicit_pure (NULL); 3451 return true; 3452} 3453 3454 3455static match 3456resolve_generic_s0 (gfc_code *c, gfc_symbol *sym) 3457{ 3458 gfc_symbol *s; 3459 3460 if (sym->attr.generic) 3461 { 3462 s = gfc_search_interface (sym->generic, 1, &c->ext.actual); 3463 if (s != NULL) 3464 { 3465 c->resolved_sym = s; 3466 if (!pure_subroutine (s, s->name, &c->loc)) 3467 return MATCH_ERROR; 3468 return MATCH_YES; 3469 } 3470 3471 /* TODO: Need to search for elemental references in generic interface. */ 3472 } 3473 3474 if (sym->attr.intrinsic) 3475 return gfc_intrinsic_sub_interface (c, 0); 3476 3477 return MATCH_NO; 3478} 3479 3480 3481static bool 3482resolve_generic_s (gfc_code *c) 3483{ 3484 gfc_symbol *sym; 3485 match m; 3486 3487 sym = c->symtree->n.sym; 3488 3489 for (;;) 3490 { 3491 m = resolve_generic_s0 (c, sym); 3492 if (m == MATCH_YES) 3493 return true; 3494 else if (m == MATCH_ERROR) 3495 return false; 3496 3497generic: 3498 if (sym->ns->parent == NULL) 3499 break; 3500 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); 3501 3502 if (sym == NULL) 3503 break; 3504 if (!generic_sym (sym)) 3505 goto generic; 3506 } 3507 3508 /* Last ditch attempt. See if the reference is to an intrinsic 3509 that possesses a matching interface. 14.1.2.4 */ 3510 sym = c->symtree->n.sym; 3511 3512 if (!gfc_is_intrinsic (sym, 1, c->loc)) 3513 { 3514 gfc_error ("There is no specific subroutine for the generic %qs at %L", 3515 sym->name, &c->loc); 3516 return false; 3517 } 3518 3519 m = gfc_intrinsic_sub_interface (c, 0); 3520 if (m == MATCH_YES) 3521 return true; 3522 if (m == MATCH_NO) 3523 gfc_error ("Generic subroutine %qs at %L is not consistent with an " 3524 "intrinsic subroutine interface", sym->name, &c->loc); 3525 3526 return false; 3527} 3528 3529 3530/* Resolve a subroutine call known to be specific. */ 3531 3532static match 3533resolve_specific_s0 (gfc_code *c, gfc_symbol *sym) 3534{ 3535 match m; 3536 3537 if (sym->attr.external || sym->attr.if_source == IFSRC_IFBODY) 3538 { 3539 if (sym->attr.dummy) 3540 { 3541 sym->attr.proc = PROC_DUMMY; 3542 goto found; 3543 } 3544 3545 sym->attr.proc = PROC_EXTERNAL; 3546 goto found; 3547 } 3548 3549 if (sym->attr.proc == PROC_MODULE || sym->attr.proc == PROC_INTERNAL) 3550 goto found; 3551 3552 if (sym->attr.intrinsic) 3553 { 3554 m = gfc_intrinsic_sub_interface (c, 1); 3555 if (m == MATCH_YES) 3556 return MATCH_YES; 3557 if (m == MATCH_NO) 3558 gfc_error ("Subroutine %qs at %L is INTRINSIC but is not compatible " 3559 "with an intrinsic", sym->name, &c->loc); 3560 3561 return MATCH_ERROR; 3562 } 3563 3564 return MATCH_NO; 3565 3566found: 3567 gfc_procedure_use (sym, &c->ext.actual, &c->loc); 3568 3569 c->resolved_sym = sym; 3570 if (!pure_subroutine (sym, sym->name, &c->loc)) 3571 return MATCH_ERROR; 3572 3573 return MATCH_YES; 3574} 3575 3576 3577static bool 3578resolve_specific_s (gfc_code *c) 3579{ 3580 gfc_symbol *sym; 3581 match m; 3582 3583 sym = c->symtree->n.sym; 3584 3585 for (;;) 3586 { 3587 m = resolve_specific_s0 (c, sym); 3588 if (m == MATCH_YES) 3589 return true; 3590 if (m == MATCH_ERROR) 3591 return false; 3592 3593 if (sym->ns->parent == NULL) 3594 break; 3595 3596 gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); 3597 3598 if (sym == NULL) 3599 break; 3600 } 3601 3602 sym = c->symtree->n.sym; 3603 gfc_error ("Unable to resolve the specific subroutine %qs at %L", 3604 sym->name, &c->loc); 3605 3606 return false; 3607} 3608 3609 3610/* Resolve a subroutine call not known to be generic nor specific. */ 3611 3612static bool 3613resolve_unknown_s (gfc_code *c) 3614{ 3615 gfc_symbol *sym; 3616 3617 sym = c->symtree->n.sym; 3618 3619 if (sym->attr.dummy) 3620 { 3621 sym->attr.proc = PROC_DUMMY; 3622 goto found; 3623 } 3624 3625 /* See if we have an intrinsic function reference. */ 3626 3627 if (gfc_is_intrinsic (sym, 1, c->loc)) 3628 { 3629 if (gfc_intrinsic_sub_interface (c, 1) == MATCH_YES) 3630 return true; 3631 return false; 3632 } 3633 3634 /* The reference is to an external name. */ 3635 3636found: 3637 gfc_procedure_use (sym, &c->ext.actual, &c->loc); 3638 3639 c->resolved_sym = sym; 3640 3641 return pure_subroutine (sym, sym->name, &c->loc); 3642} 3643 3644 3645/* Resolve a subroutine call. Although it was tempting to use the same code 3646 for functions, subroutines and functions are stored differently and this 3647 makes things awkward. */ 3648 3649static bool 3650resolve_call (gfc_code *c) 3651{ 3652 bool t; 3653 procedure_type ptype = PROC_INTRINSIC; 3654 gfc_symbol *csym, *sym; 3655 bool no_formal_args; 3656 3657 csym = c->symtree ? c->symtree->n.sym : NULL; 3658 3659 if (csym && csym->ts.type != BT_UNKNOWN) 3660 { 3661 gfc_error ("%qs at %L has a type, which is not consistent with " 3662 "the CALL at %L", csym->name, &csym->declared_at, &c->loc); 3663 return false; 3664 } 3665 3666 if (csym && gfc_current_ns->parent && csym->ns != gfc_current_ns) 3667 { 3668 gfc_symtree *st; 3669 gfc_find_sym_tree (c->symtree->name, gfc_current_ns, 1, &st); 3670 sym = st ? st->n.sym : NULL; 3671 if (sym && csym != sym 3672 && sym->ns == gfc_current_ns 3673 && sym->attr.flavor == FL_PROCEDURE 3674 && sym->attr.contained) 3675 { 3676 sym->refs++; 3677 if (csym->attr.generic) 3678 c->symtree->n.sym = sym; 3679 else 3680 c->symtree = st; 3681 csym = c->symtree->n.sym; 3682 } 3683 } 3684 3685 /* If this ia a deferred TBP, c->expr1 will be set. */ 3686 if (!c->expr1 && csym) 3687 { 3688 if (csym->attr.abstract) 3689 { 3690 gfc_error ("ABSTRACT INTERFACE %qs must not be referenced at %L", 3691 csym->name, &c->loc); 3692 return false; 3693 } 3694 3695 /* Subroutines without the RECURSIVE attribution are not allowed to 3696 call themselves. */ 3697 if (is_illegal_recursion (csym, gfc_current_ns)) 3698 { 3699 if (csym->attr.entry && csym->ns->entries) 3700 gfc_error ("ENTRY %qs at %L cannot be called recursively, " 3701 "as subroutine %qs is not RECURSIVE", 3702 csym->name, &c->loc, csym->ns->entries->sym->name); 3703 else 3704 gfc_error ("SUBROUTINE %qs at %L cannot be called recursively, " 3705 "as it is not RECURSIVE", csym->name, &c->loc); 3706 3707 t = false; 3708 } 3709 } 3710 3711 /* Switch off assumed size checking and do this again for certain kinds 3712 of procedure, once the procedure itself is resolved. */ 3713 need_full_assumed_size++; 3714 3715 if (csym) 3716 ptype = csym->attr.proc; 3717 3718 no_formal_args = csym && is_external_proc (csym) 3719 && gfc_sym_get_dummy_args (csym) == NULL; 3720 if (!resolve_actual_arglist (c->ext.actual, ptype, no_formal_args)) 3721 return false; 3722 3723 /* Resume assumed_size checking. */ 3724 need_full_assumed_size--; 3725 3726 /* If external, check for usage. */ 3727 if (csym && is_external_proc (csym)) 3728 resolve_global_procedure (csym, &c->loc, 1); 3729 3730 t = true; 3731 if (c->resolved_sym == NULL) 3732 { 3733 c->resolved_isym = NULL; 3734 switch (procedure_kind (csym)) 3735 { 3736 case PTYPE_GENERIC: 3737 t = resolve_generic_s (c); 3738 break; 3739 3740 case PTYPE_SPECIFIC: 3741 t = resolve_specific_s (c); 3742 break; 3743 3744 case PTYPE_UNKNOWN: 3745 t = resolve_unknown_s (c); 3746 break; 3747 3748 default: 3749 gfc_internal_error ("resolve_subroutine(): bad function type"); 3750 } 3751 } 3752 3753 /* Some checks of elemental subroutine actual arguments. */ 3754 if (!resolve_elemental_actual (NULL, c)) 3755 return false; 3756 3757 if (!c->expr1) 3758 update_current_proc_array_outer_dependency (csym); 3759 else 3760 /* Typebound procedure: Assume the worst. */ 3761 gfc_current_ns->proc_name->attr.array_outer_dependency = 1; 3762 3763 return t; 3764} 3765 3766 3767/* Compare the shapes of two arrays that have non-NULL shapes. If both 3768 op1->shape and op2->shape are non-NULL return true if their shapes 3769 match. If both op1->shape and op2->shape are non-NULL return false 3770 if their shapes do not match. If either op1->shape or op2->shape is 3771 NULL, return true. */ 3772 3773static bool 3774compare_shapes (gfc_expr *op1, gfc_expr *op2) 3775{ 3776 bool t; 3777 int i; 3778 3779 t = true; 3780 3781 if (op1->shape != NULL && op2->shape != NULL) 3782 { 3783 for (i = 0; i < op1->rank; i++) 3784 { 3785 if (mpz_cmp (op1->shape[i], op2->shape[i]) != 0) 3786 { 3787 gfc_error ("Shapes for operands at %L and %L are not conformable", 3788 &op1->where, &op2->where); 3789 t = false; 3790 break; 3791 } 3792 } 3793 } 3794 3795 return t; 3796} 3797 3798/* Convert a logical operator to the corresponding bitwise intrinsic call. 3799 For example A .AND. B becomes IAND(A, B). */ 3800static gfc_expr * 3801logical_to_bitwise (gfc_expr *e) 3802{ 3803 gfc_expr *tmp, *op1, *op2; 3804 gfc_isym_id isym; 3805 gfc_actual_arglist *args = NULL; 3806 3807 gcc_assert (e->expr_type == EXPR_OP); 3808 3809 isym = GFC_ISYM_NONE; 3810 op1 = e->value.op.op1; 3811 op2 = e->value.op.op2; 3812 3813 switch (e->value.op.op) 3814 { 3815 case INTRINSIC_NOT: 3816 isym = GFC_ISYM_NOT; 3817 break; 3818 case INTRINSIC_AND: 3819 isym = GFC_ISYM_IAND; 3820 break; 3821 case INTRINSIC_OR: 3822 isym = GFC_ISYM_IOR; 3823 break; 3824 case INTRINSIC_NEQV: 3825 isym = GFC_ISYM_IEOR; 3826 break; 3827 case INTRINSIC_EQV: 3828 /* "Bitwise eqv" is just the complement of NEQV === IEOR. 3829 Change the old expression to NEQV, which will get replaced by IEOR, 3830 and wrap it in NOT. */ 3831 tmp = gfc_copy_expr (e); 3832 tmp->value.op.op = INTRINSIC_NEQV; 3833 tmp = logical_to_bitwise (tmp); 3834 isym = GFC_ISYM_NOT; 3835 op1 = tmp; 3836 op2 = NULL; 3837 break; 3838 default: 3839 gfc_internal_error ("logical_to_bitwise(): Bad intrinsic"); 3840 } 3841 3842 /* Inherit the original operation's operands as arguments. */ 3843 args = gfc_get_actual_arglist (); 3844 args->expr = op1; 3845 if (op2) 3846 { 3847 args->next = gfc_get_actual_arglist (); 3848 args->next->expr = op2; 3849 } 3850 3851 /* Convert the expression to a function call. */ 3852 e->expr_type = EXPR_FUNCTION; 3853 e->value.function.actual = args; 3854 e->value.function.isym = gfc_intrinsic_function_by_id (isym); 3855 e->value.function.name = e->value.function.isym->name; 3856 e->value.function.esym = NULL; 3857 3858 /* Make up a pre-resolved function call symtree if we need to. */ 3859 if (!e->symtree || !e->symtree->n.sym) 3860 { 3861 gfc_symbol *sym; 3862 gfc_get_ha_sym_tree (e->value.function.isym->name, &e->symtree); 3863 sym = e->symtree->n.sym; 3864 sym->result = sym; 3865 sym->attr.flavor = FL_PROCEDURE; 3866 sym->attr.function = 1; 3867 sym->attr.elemental = 1; 3868 sym->attr.pure = 1; 3869 sym->attr.referenced = 1; 3870 gfc_intrinsic_symbol (sym); 3871 gfc_commit_symbol (sym); 3872 } 3873 3874 args->name = e->value.function.isym->formal->name; 3875 if (e->value.function.isym->formal->next) 3876 args->next->name = e->value.function.isym->formal->next->name; 3877 3878 return e; 3879} 3880 3881/* Recursively append candidate UOP to CANDIDATES. Store the number of 3882 candidates in CANDIDATES_LEN. */ 3883static void 3884lookup_uop_fuzzy_find_candidates (gfc_symtree *uop, 3885 char **&candidates, 3886 size_t &candidates_len) 3887{ 3888 gfc_symtree *p; 3889 3890 if (uop == NULL) 3891 return; 3892 3893 /* Not sure how to properly filter here. Use all for a start. 3894 n.uop.op is NULL for empty interface operators (is that legal?) disregard 3895 these as i suppose they don't make terribly sense. */ 3896 3897 if (uop->n.uop->op != NULL) 3898 vec_push (candidates, candidates_len, uop->name); 3899 3900 p = uop->left; 3901 if (p) 3902 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); 3903 3904 p = uop->right; 3905 if (p) 3906 lookup_uop_fuzzy_find_candidates (p, candidates, candidates_len); 3907} 3908 3909/* Lookup user-operator OP fuzzily, taking names in UOP into account. */ 3910 3911static const char* 3912lookup_uop_fuzzy (const char *op, gfc_symtree *uop) 3913{ 3914 char **candidates = NULL; 3915 size_t candidates_len = 0; 3916 lookup_uop_fuzzy_find_candidates (uop, candidates, candidates_len); 3917 return gfc_closest_fuzzy_match (op, candidates); 3918} 3919 3920 3921/* Callback finding an impure function as an operand to an .and. or 3922 .or. expression. Remember the last function warned about to 3923 avoid double warnings when recursing. */ 3924 3925static int 3926impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED, 3927 void *data) 3928{ 3929 gfc_expr *f = *e; 3930 const char *name; 3931 static gfc_expr *last = NULL; 3932 bool *found = (bool *) data; 3933 3934 if (f->expr_type == EXPR_FUNCTION) 3935 { 3936 *found = 1; 3937 if (f != last && !gfc_pure_function (f, &name) 3938 && !gfc_implicit_pure_function (f)) 3939 { 3940 if (name) 3941 gfc_warning (OPT_Wfunction_elimination, 3942 "Impure function %qs at %L might not be evaluated", 3943 name, &f->where); 3944 else 3945 gfc_warning (OPT_Wfunction_elimination, 3946 "Impure function at %L might not be evaluated", 3947 &f->where); 3948 } 3949 last = f; 3950 } 3951 3952 return 0; 3953} 3954 3955/* Return true if TYPE is character based, false otherwise. */ 3956 3957static int 3958is_character_based (bt type) 3959{ 3960 return type == BT_CHARACTER || type == BT_HOLLERITH; 3961} 3962 3963 3964/* If expression is a hollerith, convert it to character and issue a warning 3965 for the conversion. */ 3966 3967static void 3968convert_hollerith_to_character (gfc_expr *e) 3969{ 3970 if (e->ts.type == BT_HOLLERITH) 3971 { 3972 gfc_typespec t; 3973 gfc_clear_ts (&t); 3974 t.type = BT_CHARACTER; 3975 t.kind = e->ts.kind; 3976 gfc_convert_type_warn (e, &t, 2, 1); 3977 } 3978} 3979 3980/* Convert to numeric and issue a warning for the conversion. */ 3981 3982static void 3983convert_to_numeric (gfc_expr *a, gfc_expr *b) 3984{ 3985 gfc_typespec t; 3986 gfc_clear_ts (&t); 3987 t.type = b->ts.type; 3988 t.kind = b->ts.kind; 3989 gfc_convert_type_warn (a, &t, 2, 1); 3990} 3991 3992/* Resolve an operator expression node. This can involve replacing the 3993 operation with a user defined function call. */ 3994 3995static bool 3996resolve_operator (gfc_expr *e) 3997{ 3998 gfc_expr *op1, *op2; 3999 /* One error uses 3 names; additional space for wording (also via gettext). */ 4000 char msg[3*GFC_MAX_SYMBOL_LEN + 1 + 50]; 4001 bool dual_locus_error; 4002 bool t = true; 4003 4004 /* Resolve all subnodes-- give them types. */ 4005 4006 switch (e->value.op.op) 4007 { 4008 default: 4009 if (!gfc_resolve_expr (e->value.op.op2)) 4010 return false; 4011 4012 /* Fall through. */ 4013 4014 case INTRINSIC_NOT: 4015 case INTRINSIC_UPLUS: 4016 case INTRINSIC_UMINUS: 4017 case INTRINSIC_PARENTHESES: 4018 if (!gfc_resolve_expr (e->value.op.op1)) 4019 return false; 4020 if (e->value.op.op1 4021 && e->value.op.op1->ts.type == BT_BOZ && !e->value.op.op2) 4022 { 4023 gfc_error ("BOZ literal constant at %L cannot be an operand of " 4024 "unary operator %qs", &e->value.op.op1->where, 4025 gfc_op2string (e->value.op.op)); 4026 return false; 4027 } 4028 break; 4029 } 4030 4031 /* Typecheck the new node. */ 4032 4033 op1 = e->value.op.op1; 4034 op2 = e->value.op.op2; 4035 if (op1 == NULL && op2 == NULL) 4036 return false; 4037 4038 dual_locus_error = false; 4039 4040 /* op1 and op2 cannot both be BOZ. */ 4041 if (op1 && op1->ts.type == BT_BOZ 4042 && op2 && op2->ts.type == BT_BOZ) 4043 { 4044 gfc_error ("Operands at %L and %L cannot appear as operands of " 4045 "binary operator %qs", &op1->where, &op2->where, 4046 gfc_op2string (e->value.op.op)); 4047 return false; 4048 } 4049 4050 if ((op1 && op1->expr_type == EXPR_NULL) 4051 || (op2 && op2->expr_type == EXPR_NULL)) 4052 { 4053 snprintf (msg, sizeof (msg), 4054 _("Invalid context for NULL() pointer at %%L")); 4055 goto bad_op; 4056 } 4057 4058 switch (e->value.op.op) 4059 { 4060 case INTRINSIC_UPLUS: 4061 case INTRINSIC_UMINUS: 4062 if (op1->ts.type == BT_INTEGER 4063 || op1->ts.type == BT_REAL 4064 || op1->ts.type == BT_COMPLEX) 4065 { 4066 e->ts = op1->ts; 4067 break; 4068 } 4069 4070 snprintf (msg, sizeof (msg), 4071 _("Operand of unary numeric operator %%<%s%%> at %%L is %s"), 4072 gfc_op2string (e->value.op.op), gfc_typename (e)); 4073 goto bad_op; 4074 4075 case INTRINSIC_PLUS: 4076 case INTRINSIC_MINUS: 4077 case INTRINSIC_TIMES: 4078 case INTRINSIC_DIVIDE: 4079 case INTRINSIC_POWER: 4080 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) 4081 { 4082 gfc_type_convert_binary (e, 1); 4083 break; 4084 } 4085 4086 if (op1->ts.type == BT_DERIVED || op2->ts.type == BT_DERIVED) 4087 snprintf (msg, sizeof (msg), 4088 _("Unexpected derived-type entities in binary intrinsic " 4089 "numeric operator %%<%s%%> at %%L"), 4090 gfc_op2string (e->value.op.op)); 4091 else 4092 snprintf (msg, sizeof(msg), 4093 _("Operands of binary numeric operator %%<%s%%> at %%L are %s/%s"), 4094 gfc_op2string (e->value.op.op), gfc_typename (op1), 4095 gfc_typename (op2)); 4096 goto bad_op; 4097 4098 case INTRINSIC_CONCAT: 4099 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 4100 && op1->ts.kind == op2->ts.kind) 4101 { 4102 e->ts.type = BT_CHARACTER; 4103 e->ts.kind = op1->ts.kind; 4104 break; 4105 } 4106 4107 snprintf (msg, sizeof (msg), 4108 _("Operands of string concatenation operator at %%L are %s/%s"), 4109 gfc_typename (op1), gfc_typename (op2)); 4110 goto bad_op; 4111 4112 case INTRINSIC_AND: 4113 case INTRINSIC_OR: 4114 case INTRINSIC_EQV: 4115 case INTRINSIC_NEQV: 4116 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) 4117 { 4118 e->ts.type = BT_LOGICAL; 4119 e->ts.kind = gfc_kind_max (op1, op2); 4120 if (op1->ts.kind < e->ts.kind) 4121 gfc_convert_type (op1, &e->ts, 2); 4122 else if (op2->ts.kind < e->ts.kind) 4123 gfc_convert_type (op2, &e->ts, 2); 4124 4125 if (flag_frontend_optimize && 4126 (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)) 4127 { 4128 /* Warn about short-circuiting 4129 with impure function as second operand. */ 4130 bool op2_f = false; 4131 gfc_expr_walker (&op2, impure_function_callback, &op2_f); 4132 } 4133 break; 4134 } 4135 4136 /* Logical ops on integers become bitwise ops with -fdec. */ 4137 else if (flag_dec 4138 && (op1->ts.type == BT_INTEGER || op2->ts.type == BT_INTEGER)) 4139 { 4140 e->ts.type = BT_INTEGER; 4141 e->ts.kind = gfc_kind_max (op1, op2); 4142 if (op1->ts.type != e->ts.type || op1->ts.kind != e->ts.kind) 4143 gfc_convert_type (op1, &e->ts, 1); 4144 if (op2->ts.type != e->ts.type || op2->ts.kind != e->ts.kind) 4145 gfc_convert_type (op2, &e->ts, 1); 4146 e = logical_to_bitwise (e); 4147 goto simplify_op; 4148 } 4149 4150 snprintf (msg, sizeof (msg), 4151 _("Operands of logical operator %%<%s%%> at %%L are %s/%s"), 4152 gfc_op2string (e->value.op.op), gfc_typename (op1), 4153 gfc_typename (op2)); 4154 4155 goto bad_op; 4156 4157 case INTRINSIC_NOT: 4158 /* Logical ops on integers become bitwise ops with -fdec. */ 4159 if (flag_dec && op1->ts.type == BT_INTEGER) 4160 { 4161 e->ts.type = BT_INTEGER; 4162 e->ts.kind = op1->ts.kind; 4163 e = logical_to_bitwise (e); 4164 goto simplify_op; 4165 } 4166 4167 if (op1->ts.type == BT_LOGICAL) 4168 { 4169 e->ts.type = BT_LOGICAL; 4170 e->ts.kind = op1->ts.kind; 4171 break; 4172 } 4173 4174 snprintf (msg, sizeof (msg), _("Operand of .not. operator at %%L is %s"), 4175 gfc_typename (op1)); 4176 goto bad_op; 4177 4178 case INTRINSIC_GT: 4179 case INTRINSIC_GT_OS: 4180 case INTRINSIC_GE: 4181 case INTRINSIC_GE_OS: 4182 case INTRINSIC_LT: 4183 case INTRINSIC_LT_OS: 4184 case INTRINSIC_LE: 4185 case INTRINSIC_LE_OS: 4186 if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX) 4187 { 4188 strcpy (msg, _("COMPLEX quantities cannot be compared at %L")); 4189 goto bad_op; 4190 } 4191 4192 /* Fall through. */ 4193 4194 case INTRINSIC_EQ: 4195 case INTRINSIC_EQ_OS: 4196 case INTRINSIC_NE: 4197 case INTRINSIC_NE_OS: 4198 4199 if (flag_dec 4200 && is_character_based (op1->ts.type) 4201 && is_character_based (op2->ts.type)) 4202 { 4203 convert_hollerith_to_character (op1); 4204 convert_hollerith_to_character (op2); 4205 } 4206 4207 if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER 4208 && op1->ts.kind == op2->ts.kind) 4209 { 4210 e->ts.type = BT_LOGICAL; 4211 e->ts.kind = gfc_default_logical_kind; 4212 break; 4213 } 4214 4215 /* If op1 is BOZ, then op2 is not!. Try to convert to type of op2. */ 4216 if (op1->ts.type == BT_BOZ) 4217 { 4218 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " 4219 "an operand of a relational operator", 4220 &op1->where)) 4221 return false; 4222 4223 if (op2->ts.type == BT_INTEGER && !gfc_boz2int (op1, op2->ts.kind)) 4224 return false; 4225 4226 if (op2->ts.type == BT_REAL && !gfc_boz2real (op1, op2->ts.kind)) 4227 return false; 4228 } 4229 4230 /* If op2 is BOZ, then op1 is not!. Try to convert to type of op2. */ 4231 if (op2->ts.type == BT_BOZ) 4232 { 4233 if (gfc_invalid_boz ("BOZ literal constant near %L cannot appear as " 4234 "an operand of a relational operator", 4235 &op2->where)) 4236 return false; 4237 4238 if (op1->ts.type == BT_INTEGER && !gfc_boz2int (op2, op1->ts.kind)) 4239 return false; 4240 4241 if (op1->ts.type == BT_REAL && !gfc_boz2real (op2, op1->ts.kind)) 4242 return false; 4243 } 4244 if (flag_dec 4245 && op1->ts.type == BT_HOLLERITH && gfc_numeric_ts (&op2->ts)) 4246 convert_to_numeric (op1, op2); 4247 4248 if (flag_dec 4249 && gfc_numeric_ts (&op1->ts) && op2->ts.type == BT_HOLLERITH) 4250 convert_to_numeric (op2, op1); 4251 4252 if (gfc_numeric_ts (&op1->ts) && gfc_numeric_ts (&op2->ts)) 4253 { 4254 gfc_type_convert_binary (e, 1); 4255 4256 e->ts.type = BT_LOGICAL; 4257 e->ts.kind = gfc_default_logical_kind; 4258 4259 if (warn_compare_reals) 4260 { 4261 gfc_intrinsic_op op = e->value.op.op; 4262 4263 /* Type conversion has made sure that the types of op1 and op2 4264 agree, so it is only necessary to check the first one. */ 4265 if ((op1->ts.type == BT_REAL || op1->ts.type == BT_COMPLEX) 4266 && (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS 4267 || op == INTRINSIC_NE || op == INTRINSIC_NE_OS)) 4268 { 4269 const char *msg; 4270 4271 if (op == INTRINSIC_EQ || op == INTRINSIC_EQ_OS) 4272 msg = "Equality comparison for %s at %L"; 4273 else 4274 msg = "Inequality comparison for %s at %L"; 4275 4276 gfc_warning (OPT_Wcompare_reals, msg, 4277 gfc_typename (op1), &op1->where); 4278 } 4279 } 4280 4281 break; 4282 } 4283 4284 if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL) 4285 snprintf (msg, sizeof (msg), 4286 _("Logicals at %%L must be compared with %s instead of %s"), 4287 (e->value.op.op == INTRINSIC_EQ 4288 || e->value.op.op == INTRINSIC_EQ_OS) 4289 ? ".eqv." : ".neqv.", gfc_op2string (e->value.op.op)); 4290 else 4291 snprintf (msg, sizeof (msg), 4292 _("Operands of comparison operator %%<%s%%> at %%L are %s/%s"), 4293 gfc_op2string (e->value.op.op), gfc_typename (op1), 4294 gfc_typename (op2)); 4295 4296 goto bad_op; 4297 4298 case INTRINSIC_USER: 4299 if (e->value.op.uop->op == NULL) 4300 { 4301 const char *name = e->value.op.uop->name; 4302 const char *guessed; 4303 guessed = lookup_uop_fuzzy (name, e->value.op.uop->ns->uop_root); 4304 if (guessed) 4305 snprintf (msg, sizeof (msg), 4306 _("Unknown operator %%<%s%%> at %%L; did you mean '%s'?"), 4307 name, guessed); 4308 else 4309 snprintf (msg, sizeof (msg), _("Unknown operator %%<%s%%> at %%L"), 4310 name); 4311 } 4312 else if (op2 == NULL) 4313 snprintf (msg, sizeof (msg), 4314 _("Operand of user operator %%<%s%%> at %%L is %s"), 4315 e->value.op.uop->name, gfc_typename (op1)); 4316 else 4317 { 4318 snprintf (msg, sizeof (msg), 4319 _("Operands of user operator %%<%s%%> at %%L are %s/%s"), 4320 e->value.op.uop->name, gfc_typename (op1), 4321 gfc_typename (op2)); 4322 e->value.op.uop->op->sym->attr.referenced = 1; 4323 } 4324 4325 goto bad_op; 4326 4327 case INTRINSIC_PARENTHESES: 4328 e->ts = op1->ts; 4329 if (e->ts.type == BT_CHARACTER) 4330 e->ts.u.cl = op1->ts.u.cl; 4331 break; 4332 4333 default: 4334 gfc_internal_error ("resolve_operator(): Bad intrinsic"); 4335 } 4336 4337 /* Deal with arrayness of an operand through an operator. */ 4338 4339 switch (e->value.op.op) 4340 { 4341 case INTRINSIC_PLUS: 4342 case INTRINSIC_MINUS: 4343 case INTRINSIC_TIMES: 4344 case INTRINSIC_DIVIDE: 4345 case INTRINSIC_POWER: 4346 case INTRINSIC_CONCAT: 4347 case INTRINSIC_AND: 4348 case INTRINSIC_OR: 4349 case INTRINSIC_EQV: 4350 case INTRINSIC_NEQV: 4351 case INTRINSIC_EQ: 4352 case INTRINSIC_EQ_OS: 4353 case INTRINSIC_NE: 4354 case INTRINSIC_NE_OS: 4355 case INTRINSIC_GT: 4356 case INTRINSIC_GT_OS: 4357 case INTRINSIC_GE: 4358 case INTRINSIC_GE_OS: 4359 case INTRINSIC_LT: 4360 case INTRINSIC_LT_OS: 4361 case INTRINSIC_LE: 4362 case INTRINSIC_LE_OS: 4363 4364 if (op1->rank == 0 && op2->rank == 0) 4365 e->rank = 0; 4366 4367 if (op1->rank == 0 && op2->rank != 0) 4368 { 4369 e->rank = op2->rank; 4370 4371 if (e->shape == NULL) 4372 e->shape = gfc_copy_shape (op2->shape, op2->rank); 4373 } 4374 4375 if (op1->rank != 0 && op2->rank == 0) 4376 { 4377 e->rank = op1->rank; 4378 4379 if (e->shape == NULL) 4380 e->shape = gfc_copy_shape (op1->shape, op1->rank); 4381 } 4382 4383 if (op1->rank != 0 && op2->rank != 0) 4384 { 4385 if (op1->rank == op2->rank) 4386 { 4387 e->rank = op1->rank; 4388 if (e->shape == NULL) 4389 { 4390 t = compare_shapes (op1, op2); 4391 if (!t) 4392 e->shape = NULL; 4393 else 4394 e->shape = gfc_copy_shape (op1->shape, op1->rank); 4395 } 4396 } 4397 else 4398 { 4399 /* Allow higher level expressions to work. */ 4400 e->rank = 0; 4401 4402 /* Try user-defined operators, and otherwise throw an error. */ 4403 dual_locus_error = true; 4404 snprintf (msg, sizeof (msg), 4405 _("Inconsistent ranks for operator at %%L and %%L")); 4406 goto bad_op; 4407 } 4408 } 4409 4410 break; 4411 4412 case INTRINSIC_PARENTHESES: 4413 case INTRINSIC_NOT: 4414 case INTRINSIC_UPLUS: 4415 case INTRINSIC_UMINUS: 4416 /* Simply copy arrayness attribute */ 4417 e->rank = op1->rank; 4418 4419 if (e->shape == NULL) 4420 e->shape = gfc_copy_shape (op1->shape, op1->rank); 4421 4422 break; 4423 4424 default: 4425 break; 4426 } 4427 4428simplify_op: 4429 4430 /* Attempt to simplify the expression. */ 4431 if (t) 4432 { 4433 t = gfc_simplify_expr (e, 0); 4434 /* Some calls do not succeed in simplification and return false 4435 even though there is no error; e.g. variable references to 4436 PARAMETER arrays. */ 4437 if (!gfc_is_constant_expr (e)) 4438 t = true; 4439 } 4440 return t; 4441 4442bad_op: 4443 4444 { 4445 match m = gfc_extend_expr (e); 4446 if (m == MATCH_YES) 4447 return true; 4448 if (m == MATCH_ERROR) 4449 return false; 4450 } 4451 4452 if (dual_locus_error) 4453 gfc_error (msg, &op1->where, &op2->where); 4454 else 4455 gfc_error (msg, &e->where); 4456 4457 return false; 4458} 4459 4460 4461/************** Array resolution subroutines **************/ 4462 4463enum compare_result 4464{ CMP_LT, CMP_EQ, CMP_GT, CMP_UNKNOWN }; 4465 4466/* Compare two integer expressions. */ 4467 4468static compare_result 4469compare_bound (gfc_expr *a, gfc_expr *b) 4470{ 4471 int i; 4472 4473 if (a == NULL || a->expr_type != EXPR_CONSTANT 4474 || b == NULL || b->expr_type != EXPR_CONSTANT) 4475 return CMP_UNKNOWN; 4476 4477 /* If either of the types isn't INTEGER, we must have 4478 raised an error earlier. */ 4479 4480 if (a->ts.type != BT_INTEGER || b->ts.type != BT_INTEGER) 4481 return CMP_UNKNOWN; 4482 4483 i = mpz_cmp (a->value.integer, b->value.integer); 4484 4485 if (i < 0) 4486 return CMP_LT; 4487 if (i > 0) 4488 return CMP_GT; 4489 return CMP_EQ; 4490} 4491 4492 4493/* Compare an integer expression with an integer. */ 4494 4495static compare_result 4496compare_bound_int (gfc_expr *a, int b) 4497{ 4498 int i; 4499 4500 if (a == NULL 4501 || a->expr_type != EXPR_CONSTANT 4502 || a->ts.type != BT_INTEGER) 4503 return CMP_UNKNOWN; 4504 4505 i = mpz_cmp_si (a->value.integer, b); 4506 4507 if (i < 0) 4508 return CMP_LT; 4509 if (i > 0) 4510 return CMP_GT; 4511 return CMP_EQ; 4512} 4513 4514 4515/* Compare an integer expression with a mpz_t. */ 4516 4517static compare_result 4518compare_bound_mpz_t (gfc_expr *a, mpz_t b) 4519{ 4520 int i; 4521 4522 if (a == NULL 4523 || a->expr_type != EXPR_CONSTANT 4524 || a->ts.type != BT_INTEGER) 4525 return CMP_UNKNOWN; 4526 4527 i = mpz_cmp (a->value.integer, b); 4528 4529 if (i < 0) 4530 return CMP_LT; 4531 if (i > 0) 4532 return CMP_GT; 4533 return CMP_EQ; 4534} 4535 4536 4537/* Compute the last value of a sequence given by a triplet. 4538 Return 0 if it wasn't able to compute the last value, or if the 4539 sequence if empty, and 1 otherwise. */ 4540 4541static int 4542compute_last_value_for_triplet (gfc_expr *start, gfc_expr *end, 4543 gfc_expr *stride, mpz_t last) 4544{ 4545 mpz_t rem; 4546 4547 if (start == NULL || start->expr_type != EXPR_CONSTANT 4548 || end == NULL || end->expr_type != EXPR_CONSTANT 4549 || (stride != NULL && stride->expr_type != EXPR_CONSTANT)) 4550 return 0; 4551 4552 if (start->ts.type != BT_INTEGER || end->ts.type != BT_INTEGER 4553 || (stride != NULL && stride->ts.type != BT_INTEGER)) 4554 return 0; 4555 4556 if (stride == NULL || compare_bound_int (stride, 1) == CMP_EQ) 4557 { 4558 if (compare_bound (start, end) == CMP_GT) 4559 return 0; 4560 mpz_set (last, end->value.integer); 4561 return 1; 4562 } 4563 4564 if (compare_bound_int (stride, 0) == CMP_GT) 4565 { 4566 /* Stride is positive */ 4567 if (mpz_cmp (start->value.integer, end->value.integer) > 0) 4568 return 0; 4569 } 4570 else 4571 { 4572 /* Stride is negative */ 4573 if (mpz_cmp (start->value.integer, end->value.integer) < 0) 4574 return 0; 4575 } 4576 4577 mpz_init (rem); 4578 mpz_sub (rem, end->value.integer, start->value.integer); 4579 mpz_tdiv_r (rem, rem, stride->value.integer); 4580 mpz_sub (last, end->value.integer, rem); 4581 mpz_clear (rem); 4582 4583 return 1; 4584} 4585 4586 4587/* Compare a single dimension of an array reference to the array 4588 specification. */ 4589 4590static bool 4591check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) 4592{ 4593 mpz_t last_value; 4594 4595 if (ar->dimen_type[i] == DIMEN_STAR) 4596 { 4597 gcc_assert (ar->stride[i] == NULL); 4598 /* This implies [*] as [*:] and [*:3] are not possible. */ 4599 if (ar->start[i] == NULL) 4600 { 4601 gcc_assert (ar->end[i] == NULL); 4602 return true; 4603 } 4604 } 4605 4606/* Given start, end and stride values, calculate the minimum and 4607 maximum referenced indexes. */ 4608 4609 switch (ar->dimen_type[i]) 4610 { 4611 case DIMEN_VECTOR: 4612 case DIMEN_THIS_IMAGE: 4613 break; 4614 4615 case DIMEN_STAR: 4616 case DIMEN_ELEMENT: 4617 if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) 4618 { 4619 if (i < as->rank) 4620 gfc_warning (0, "Array reference at %L is out of bounds " 4621 "(%ld < %ld) in dimension %d", &ar->c_where[i], 4622 mpz_get_si (ar->start[i]->value.integer), 4623 mpz_get_si (as->lower[i]->value.integer), i+1); 4624 else 4625 gfc_warning (0, "Array reference at %L is out of bounds " 4626 "(%ld < %ld) in codimension %d", &ar->c_where[i], 4627 mpz_get_si (ar->start[i]->value.integer), 4628 mpz_get_si (as->lower[i]->value.integer), 4629 i + 1 - as->rank); 4630 return true; 4631 } 4632 if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) 4633 { 4634 if (i < as->rank) 4635 gfc_warning (0, "Array reference at %L is out of bounds " 4636 "(%ld > %ld) in dimension %d", &ar->c_where[i], 4637 mpz_get_si (ar->start[i]->value.integer), 4638 mpz_get_si (as->upper[i]->value.integer), i+1); 4639 else 4640 gfc_warning (0, "Array reference at %L is out of bounds " 4641 "(%ld > %ld) in codimension %d", &ar->c_where[i], 4642 mpz_get_si (ar->start[i]->value.integer), 4643 mpz_get_si (as->upper[i]->value.integer), 4644 i + 1 - as->rank); 4645 return true; 4646 } 4647 4648 break; 4649 4650 case DIMEN_RANGE: 4651 { 4652#define AR_START (ar->start[i] ? ar->start[i] : as->lower[i]) 4653#define AR_END (ar->end[i] ? ar->end[i] : as->upper[i]) 4654 4655 compare_result comp_start_end = compare_bound (AR_START, AR_END); 4656 compare_result comp_stride_zero = compare_bound_int (ar->stride[i], 0); 4657 4658 /* Check for zero stride, which is not allowed. */ 4659 if (comp_stride_zero == CMP_EQ) 4660 { 4661 gfc_error ("Illegal stride of zero at %L", &ar->c_where[i]); 4662 return false; 4663 } 4664 4665 /* if start == end || (stride > 0 && start < end) 4666 || (stride < 0 && start > end), 4667 then the array section contains at least one element. In this 4668 case, there is an out-of-bounds access if 4669 (start < lower || start > upper). */ 4670 if (comp_start_end == CMP_EQ 4671 || ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL) 4672 && comp_start_end == CMP_LT) 4673 || (comp_stride_zero == CMP_LT 4674 && comp_start_end == CMP_GT)) 4675 { 4676 if (compare_bound (AR_START, as->lower[i]) == CMP_LT) 4677 { 4678 gfc_warning (0, "Lower array reference at %L is out of bounds " 4679 "(%ld < %ld) in dimension %d", &ar->c_where[i], 4680 mpz_get_si (AR_START->value.integer), 4681 mpz_get_si (as->lower[i]->value.integer), i+1); 4682 return true; 4683 } 4684 if (compare_bound (AR_START, as->upper[i]) == CMP_GT) 4685 { 4686 gfc_warning (0, "Lower array reference at %L is out of bounds " 4687 "(%ld > %ld) in dimension %d", &ar->c_where[i], 4688 mpz_get_si (AR_START->value.integer), 4689 mpz_get_si (as->upper[i]->value.integer), i+1); 4690 return true; 4691 } 4692 } 4693 4694 /* If we can compute the highest index of the array section, 4695 then it also has to be between lower and upper. */ 4696 mpz_init (last_value); 4697 if (compute_last_value_for_triplet (AR_START, AR_END, ar->stride[i], 4698 last_value)) 4699 { 4700 if (compare_bound_mpz_t (as->lower[i], last_value) == CMP_GT) 4701 { 4702 gfc_warning (0, "Upper array reference at %L is out of bounds " 4703 "(%ld < %ld) in dimension %d", &ar->c_where[i], 4704 mpz_get_si (last_value), 4705 mpz_get_si (as->lower[i]->value.integer), i+1); 4706 mpz_clear (last_value); 4707 return true; 4708 } 4709 if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT) 4710 { 4711 gfc_warning (0, "Upper array reference at %L is out of bounds " 4712 "(%ld > %ld) in dimension %d", &ar->c_where[i], 4713 mpz_get_si (last_value), 4714 mpz_get_si (as->upper[i]->value.integer), i+1); 4715 mpz_clear (last_value); 4716 return true; 4717 } 4718 } 4719 mpz_clear (last_value); 4720 4721#undef AR_START 4722#undef AR_END 4723 } 4724 break; 4725 4726 default: 4727 gfc_internal_error ("check_dimension(): Bad array reference"); 4728 } 4729 4730 return true; 4731} 4732 4733 4734/* Compare an array reference with an array specification. */ 4735 4736static bool 4737compare_spec_to_ref (gfc_array_ref *ar) 4738{ 4739 gfc_array_spec *as; 4740 int i; 4741 4742 as = ar->as; 4743 i = as->rank - 1; 4744 /* TODO: Full array sections are only allowed as actual parameters. */ 4745 if (as->type == AS_ASSUMED_SIZE 4746 && (/*ar->type == AR_FULL 4747 ||*/ (ar->type == AR_SECTION 4748 && ar->dimen_type[i] == DIMEN_RANGE && ar->end[i] == NULL))) 4749 { 4750 gfc_error ("Rightmost upper bound of assumed size array section " 4751 "not specified at %L", &ar->where); 4752 return false; 4753 } 4754 4755 if (ar->type == AR_FULL) 4756 return true; 4757 4758 if (as->rank != ar->dimen) 4759 { 4760 gfc_error ("Rank mismatch in array reference at %L (%d/%d)", 4761 &ar->where, ar->dimen, as->rank); 4762 return false; 4763 } 4764 4765 /* ar->codimen == 0 is a local array. */ 4766 if (as->corank != ar->codimen && ar->codimen != 0) 4767 { 4768 gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", 4769 &ar->where, ar->codimen, as->corank); 4770 return false; 4771 } 4772 4773 for (i = 0; i < as->rank; i++) 4774 if (!check_dimension (i, ar, as)) 4775 return false; 4776 4777 /* Local access has no coarray spec. */ 4778 if (ar->codimen != 0) 4779 for (i = as->rank; i < as->rank + as->corank; i++) 4780 { 4781 if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate 4782 && ar->dimen_type[i] != DIMEN_THIS_IMAGE) 4783 { 4784 gfc_error ("Coindex of codimension %d must be a scalar at %L", 4785 i + 1 - as->rank, &ar->where); 4786 return false; 4787 } 4788 if (!check_dimension (i, ar, as)) 4789 return false; 4790 } 4791 4792 return true; 4793} 4794 4795 4796/* Resolve one part of an array index. */ 4797 4798static bool 4799gfc_resolve_index_1 (gfc_expr *index, int check_scalar, 4800 int force_index_integer_kind) 4801{ 4802 gfc_typespec ts; 4803 4804 if (index == NULL) 4805 return true; 4806 4807 if (!gfc_resolve_expr (index)) 4808 return false; 4809 4810 if (check_scalar && index->rank != 0) 4811 { 4812 gfc_error ("Array index at %L must be scalar", &index->where); 4813 return false; 4814 } 4815 4816 if (index->ts.type != BT_INTEGER && index->ts.type != BT_REAL) 4817 { 4818 gfc_error ("Array index at %L must be of INTEGER type, found %s", 4819 &index->where, gfc_basic_typename (index->ts.type)); 4820 return false; 4821 } 4822 4823 if (index->ts.type == BT_REAL) 4824 if (!gfc_notify_std (GFC_STD_LEGACY, "REAL array index at %L", 4825 &index->where)) 4826 return false; 4827 4828 if ((index->ts.kind != gfc_index_integer_kind 4829 && force_index_integer_kind) 4830 || index->ts.type != BT_INTEGER) 4831 { 4832 gfc_clear_ts (&ts); 4833 ts.type = BT_INTEGER; 4834 ts.kind = gfc_index_integer_kind; 4835 4836 gfc_convert_type_warn (index, &ts, 2, 0); 4837 } 4838 4839 return true; 4840} 4841 4842/* Resolve one part of an array index. */ 4843 4844bool 4845gfc_resolve_index (gfc_expr *index, int check_scalar) 4846{ 4847 return gfc_resolve_index_1 (index, check_scalar, 1); 4848} 4849 4850/* Resolve a dim argument to an intrinsic function. */ 4851 4852bool 4853gfc_resolve_dim_arg (gfc_expr *dim) 4854{ 4855 if (dim == NULL) 4856 return true; 4857 4858 if (!gfc_resolve_expr (dim)) 4859 return false; 4860 4861 if (dim->rank != 0) 4862 { 4863 gfc_error ("Argument dim at %L must be scalar", &dim->where); 4864 return false; 4865 4866 } 4867 4868 if (dim->ts.type != BT_INTEGER) 4869 { 4870 gfc_error ("Argument dim at %L must be of INTEGER type", &dim->where); 4871 return false; 4872 } 4873 4874 if (dim->ts.kind != gfc_index_integer_kind) 4875 { 4876 gfc_typespec ts; 4877 4878 gfc_clear_ts (&ts); 4879 ts.type = BT_INTEGER; 4880 ts.kind = gfc_index_integer_kind; 4881 4882 gfc_convert_type_warn (dim, &ts, 2, 0); 4883 } 4884 4885 return true; 4886} 4887 4888/* Given an expression that contains array references, update those array 4889 references to point to the right array specifications. While this is 4890 filled in during matching, this information is difficult to save and load 4891 in a module, so we take care of it here. 4892 4893 The idea here is that the original array reference comes from the 4894 base symbol. We traverse the list of reference structures, setting 4895 the stored reference to references. Component references can 4896 provide an additional array specification. */ 4897static void 4898resolve_assoc_var (gfc_symbol* sym, bool resolve_target); 4899 4900static void 4901find_array_spec (gfc_expr *e) 4902{ 4903 gfc_array_spec *as; 4904 gfc_component *c; 4905 gfc_ref *ref; 4906 bool class_as = false; 4907 4908 if (e->symtree->n.sym->assoc) 4909 { 4910 if (e->symtree->n.sym->assoc->target) 4911 gfc_resolve_expr (e->symtree->n.sym->assoc->target); 4912 resolve_assoc_var (e->symtree->n.sym, false); 4913 } 4914 4915 if (e->symtree->n.sym->ts.type == BT_CLASS) 4916 { 4917 as = CLASS_DATA (e->symtree->n.sym)->as; 4918 class_as = true; 4919 } 4920 else 4921 as = e->symtree->n.sym->as; 4922 4923 for (ref = e->ref; ref; ref = ref->next) 4924 switch (ref->type) 4925 { 4926 case REF_ARRAY: 4927 if (as == NULL) 4928 gfc_internal_error ("find_array_spec(): Missing spec"); 4929 4930 ref->u.ar.as = as; 4931 as = NULL; 4932 break; 4933 4934 case REF_COMPONENT: 4935 c = ref->u.c.component; 4936 if (c->attr.dimension) 4937 { 4938 if (as != NULL && !(class_as && as == c->as)) 4939 gfc_internal_error ("find_array_spec(): unused as(1)"); 4940 as = c->as; 4941 } 4942 4943 break; 4944 4945 case REF_SUBSTRING: 4946 case REF_INQUIRY: 4947 break; 4948 } 4949 4950 if (as != NULL) 4951 gfc_internal_error ("find_array_spec(): unused as(2)"); 4952} 4953 4954 4955/* Resolve an array reference. */ 4956 4957static bool 4958resolve_array_ref (gfc_array_ref *ar) 4959{ 4960 int i, check_scalar; 4961 gfc_expr *e; 4962 4963 for (i = 0; i < ar->dimen + ar->codimen; i++) 4964 { 4965 check_scalar = ar->dimen_type[i] == DIMEN_RANGE; 4966 4967 /* Do not force gfc_index_integer_kind for the start. We can 4968 do fine with any integer kind. This avoids temporary arrays 4969 created for indexing with a vector. */ 4970 if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0)) 4971 return false; 4972 if (!gfc_resolve_index (ar->end[i], check_scalar)) 4973 return false; 4974 if (!gfc_resolve_index (ar->stride[i], check_scalar)) 4975 return false; 4976 4977 e = ar->start[i]; 4978 4979 if (ar->dimen_type[i] == DIMEN_UNKNOWN) 4980 switch (e->rank) 4981 { 4982 case 0: 4983 ar->dimen_type[i] = DIMEN_ELEMENT; 4984 break; 4985 4986 case 1: 4987 ar->dimen_type[i] = DIMEN_VECTOR; 4988 if (e->expr_type == EXPR_VARIABLE 4989 && e->symtree->n.sym->ts.type == BT_DERIVED) 4990 ar->start[i] = gfc_get_parentheses (e); 4991 break; 4992 4993 default: 4994 gfc_error ("Array index at %L is an array of rank %d", 4995 &ar->c_where[i], e->rank); 4996 return false; 4997 } 4998 4999 /* Fill in the upper bound, which may be lower than the 5000 specified one for something like a(2:10:5), which is 5001 identical to a(2:7:5). Only relevant for strides not equal 5002 to one. Don't try a division by zero. */ 5003 if (ar->dimen_type[i] == DIMEN_RANGE 5004 && ar->stride[i] != NULL && ar->stride[i]->expr_type == EXPR_CONSTANT 5005 && mpz_cmp_si (ar->stride[i]->value.integer, 1L) != 0 5006 && mpz_cmp_si (ar->stride[i]->value.integer, 0L) != 0) 5007 { 5008 mpz_t size, end; 5009 5010 if (gfc_ref_dimen_size (ar, i, &size, &end)) 5011 { 5012 if (ar->end[i] == NULL) 5013 { 5014 ar->end[i] = 5015 gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind, 5016 &ar->where); 5017 mpz_set (ar->end[i]->value.integer, end); 5018 } 5019 else if (ar->end[i]->ts.type == BT_INTEGER 5020 && ar->end[i]->expr_type == EXPR_CONSTANT) 5021 { 5022 mpz_set (ar->end[i]->value.integer, end); 5023 } 5024 else 5025 gcc_unreachable (); 5026 5027 mpz_clear (size); 5028 mpz_clear (end); 5029 } 5030 } 5031 } 5032 5033 if (ar->type == AR_FULL) 5034 { 5035 if (ar->as->rank == 0) 5036 ar->type = AR_ELEMENT; 5037 5038 /* Make sure array is the same as array(:,:), this way 5039 we don't need to special case all the time. */ 5040 ar->dimen = ar->as->rank; 5041 for (i = 0; i < ar->dimen; i++) 5042 { 5043 ar->dimen_type[i] = DIMEN_RANGE; 5044 5045 gcc_assert (ar->start[i] == NULL); 5046 gcc_assert (ar->end[i] == NULL); 5047 gcc_assert (ar->stride[i] == NULL); 5048 } 5049 } 5050 5051 /* If the reference type is unknown, figure out what kind it is. */ 5052 5053 if (ar->type == AR_UNKNOWN) 5054 { 5055 ar->type = AR_ELEMENT; 5056 for (i = 0; i < ar->dimen; i++) 5057 if (ar->dimen_type[i] == DIMEN_RANGE 5058 || ar->dimen_type[i] == DIMEN_VECTOR) 5059 { 5060 ar->type = AR_SECTION; 5061 break; 5062 } 5063 } 5064 5065 if (!ar->as->cray_pointee && !compare_spec_to_ref (ar)) 5066 return false; 5067 5068 if (ar->as->corank && ar->codimen == 0) 5069 { 5070 int n; 5071 ar->codimen = ar->as->corank; 5072 for (n = ar->dimen; n < ar->dimen + ar->codimen; n++) 5073 ar->dimen_type[n] = DIMEN_THIS_IMAGE; 5074 } 5075 5076 return true; 5077} 5078 5079 5080bool 5081gfc_resolve_substring (gfc_ref *ref, bool *equal_length) 5082{ 5083 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 5084 5085 if (ref->u.ss.start != NULL) 5086 { 5087 if (!gfc_resolve_expr (ref->u.ss.start)) 5088 return false; 5089 5090 if (ref->u.ss.start->ts.type != BT_INTEGER) 5091 { 5092 gfc_error ("Substring start index at %L must be of type INTEGER", 5093 &ref->u.ss.start->where); 5094 return false; 5095 } 5096 5097 if (ref->u.ss.start->rank != 0) 5098 { 5099 gfc_error ("Substring start index at %L must be scalar", 5100 &ref->u.ss.start->where); 5101 return false; 5102 } 5103 5104 if (compare_bound_int (ref->u.ss.start, 1) == CMP_LT 5105 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ 5106 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) 5107 { 5108 gfc_error ("Substring start index at %L is less than one", 5109 &ref->u.ss.start->where); 5110 return false; 5111 } 5112 } 5113 5114 if (ref->u.ss.end != NULL) 5115 { 5116 if (!gfc_resolve_expr (ref->u.ss.end)) 5117 return false; 5118 5119 if (ref->u.ss.end->ts.type != BT_INTEGER) 5120 { 5121 gfc_error ("Substring end index at %L must be of type INTEGER", 5122 &ref->u.ss.end->where); 5123 return false; 5124 } 5125 5126 if (ref->u.ss.end->rank != 0) 5127 { 5128 gfc_error ("Substring end index at %L must be scalar", 5129 &ref->u.ss.end->where); 5130 return false; 5131 } 5132 5133 if (ref->u.ss.length != NULL 5134 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_GT 5135 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ 5136 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) 5137 { 5138 gfc_error ("Substring end index at %L exceeds the string length", 5139 &ref->u.ss.start->where); 5140 return false; 5141 } 5142 5143 if (compare_bound_mpz_t (ref->u.ss.end, 5144 gfc_integer_kinds[k].huge) == CMP_GT 5145 && (compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_EQ 5146 || compare_bound (ref->u.ss.end, ref->u.ss.start) == CMP_GT)) 5147 { 5148 gfc_error ("Substring end index at %L is too large", 5149 &ref->u.ss.end->where); 5150 return false; 5151 } 5152 /* If the substring has the same length as the original 5153 variable, the reference itself can be deleted. */ 5154 5155 if (ref->u.ss.length != NULL 5156 && compare_bound (ref->u.ss.end, ref->u.ss.length->length) == CMP_EQ 5157 && compare_bound_int (ref->u.ss.start, 1) == CMP_EQ) 5158 *equal_length = true; 5159 } 5160 5161 return true; 5162} 5163 5164 5165/* This function supplies missing substring charlens. */ 5166 5167void 5168gfc_resolve_substring_charlen (gfc_expr *e) 5169{ 5170 gfc_ref *char_ref; 5171 gfc_expr *start, *end; 5172 gfc_typespec *ts = NULL; 5173 mpz_t diff; 5174 5175 for (char_ref = e->ref; char_ref; char_ref = char_ref->next) 5176 { 5177 if (char_ref->type == REF_SUBSTRING || char_ref->type == REF_INQUIRY) 5178 break; 5179 if (char_ref->type == REF_COMPONENT) 5180 ts = &char_ref->u.c.component->ts; 5181 } 5182 5183 if (!char_ref || char_ref->type == REF_INQUIRY) 5184 return; 5185 5186 gcc_assert (char_ref->next == NULL); 5187 5188 if (e->ts.u.cl) 5189 { 5190 if (e->ts.u.cl->length) 5191 gfc_free_expr (e->ts.u.cl->length); 5192 else if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.dummy) 5193 return; 5194 } 5195 5196 e->ts.type = BT_CHARACTER; 5197 e->ts.kind = gfc_default_character_kind; 5198 5199 if (!e->ts.u.cl) 5200 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 5201 5202 if (char_ref->u.ss.start) 5203 start = gfc_copy_expr (char_ref->u.ss.start); 5204 else 5205 start = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); 5206 5207 if (char_ref->u.ss.end) 5208 end = gfc_copy_expr (char_ref->u.ss.end); 5209 else if (e->expr_type == EXPR_VARIABLE) 5210 { 5211 if (!ts) 5212 ts = &e->symtree->n.sym->ts; 5213 end = gfc_copy_expr (ts->u.cl->length); 5214 } 5215 else 5216 end = NULL; 5217 5218 if (!start || !end) 5219 { 5220 gfc_free_expr (start); 5221 gfc_free_expr (end); 5222 return; 5223 } 5224 5225 /* Length = (end - start + 1). 5226 Check first whether it has a constant length. */ 5227 if (gfc_dep_difference (end, start, &diff)) 5228 { 5229 gfc_expr *len = gfc_get_constant_expr (BT_INTEGER, gfc_charlen_int_kind, 5230 &e->where); 5231 5232 mpz_add_ui (len->value.integer, diff, 1); 5233 mpz_clear (diff); 5234 e->ts.u.cl->length = len; 5235 /* The check for length < 0 is handled below */ 5236 } 5237 else 5238 { 5239 e->ts.u.cl->length = gfc_subtract (end, start); 5240 e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, 5241 gfc_get_int_expr (gfc_charlen_int_kind, 5242 NULL, 1)); 5243 } 5244 5245 /* F2008, 6.4.1: Both the starting point and the ending point shall 5246 be within the range 1, 2, ..., n unless the starting point exceeds 5247 the ending point, in which case the substring has length zero. */ 5248 5249 if (mpz_cmp_si (e->ts.u.cl->length->value.integer, 0) < 0) 5250 mpz_set_si (e->ts.u.cl->length->value.integer, 0); 5251 5252 e->ts.u.cl->length->ts.type = BT_INTEGER; 5253 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; 5254 5255 /* Make sure that the length is simplified. */ 5256 gfc_simplify_expr (e->ts.u.cl->length, 1); 5257 gfc_resolve_expr (e->ts.u.cl->length); 5258} 5259 5260 5261/* Resolve subtype references. */ 5262 5263bool 5264gfc_resolve_ref (gfc_expr *expr) 5265{ 5266 int current_part_dimension, n_components, seen_part_dimension, dim; 5267 gfc_ref *ref, **prev, *array_ref; 5268 bool equal_length; 5269 5270 for (ref = expr->ref; ref; ref = ref->next) 5271 if (ref->type == REF_ARRAY && ref->u.ar.as == NULL) 5272 { 5273 find_array_spec (expr); 5274 break; 5275 } 5276 5277 for (prev = &expr->ref; *prev != NULL; 5278 prev = *prev == NULL ? prev : &(*prev)->next) 5279 switch ((*prev)->type) 5280 { 5281 case REF_ARRAY: 5282 if (!resolve_array_ref (&(*prev)->u.ar)) 5283 return false; 5284 break; 5285 5286 case REF_COMPONENT: 5287 case REF_INQUIRY: 5288 break; 5289 5290 case REF_SUBSTRING: 5291 equal_length = false; 5292 if (!gfc_resolve_substring (*prev, &equal_length)) 5293 return false; 5294 5295 if (expr->expr_type != EXPR_SUBSTRING && equal_length) 5296 { 5297 /* Remove the reference and move the charlen, if any. */ 5298 ref = *prev; 5299 *prev = ref->next; 5300 ref->next = NULL; 5301 expr->ts.u.cl = ref->u.ss.length; 5302 ref->u.ss.length = NULL; 5303 gfc_free_ref_list (ref); 5304 } 5305 break; 5306 } 5307 5308 /* Check constraints on part references. */ 5309 5310 current_part_dimension = 0; 5311 seen_part_dimension = 0; 5312 n_components = 0; 5313 array_ref = NULL; 5314 5315 for (ref = expr->ref; ref; ref = ref->next) 5316 { 5317 switch (ref->type) 5318 { 5319 case REF_ARRAY: 5320 array_ref = ref; 5321 switch (ref->u.ar.type) 5322 { 5323 case AR_FULL: 5324 /* Coarray scalar. */ 5325 if (ref->u.ar.as->rank == 0) 5326 { 5327 current_part_dimension = 0; 5328 break; 5329 } 5330 /* Fall through. */ 5331 case AR_SECTION: 5332 current_part_dimension = 1; 5333 break; 5334 5335 case AR_ELEMENT: 5336 array_ref = NULL; 5337 current_part_dimension = 0; 5338 break; 5339 5340 case AR_UNKNOWN: 5341 gfc_internal_error ("resolve_ref(): Bad array reference"); 5342 } 5343 5344 break; 5345 5346 case REF_COMPONENT: 5347 if (current_part_dimension || seen_part_dimension) 5348 { 5349 /* F03:C614. */ 5350 if (ref->u.c.component->attr.pointer 5351 || ref->u.c.component->attr.proc_pointer 5352 || (ref->u.c.component->ts.type == BT_CLASS 5353 && CLASS_DATA (ref->u.c.component)->attr.pointer)) 5354 { 5355 gfc_error ("Component to the right of a part reference " 5356 "with nonzero rank must not have the POINTER " 5357 "attribute at %L", &expr->where); 5358 return false; 5359 } 5360 else if (ref->u.c.component->attr.allocatable 5361 || (ref->u.c.component->ts.type == BT_CLASS 5362 && CLASS_DATA (ref->u.c.component)->attr.allocatable)) 5363 5364 { 5365 gfc_error ("Component to the right of a part reference " 5366 "with nonzero rank must not have the ALLOCATABLE " 5367 "attribute at %L", &expr->where); 5368 return false; 5369 } 5370 } 5371 5372 n_components++; 5373 break; 5374 5375 case REF_SUBSTRING: 5376 break; 5377 5378 case REF_INQUIRY: 5379 /* Implement requirement in note 9.7 of F2018 that the result of the 5380 LEN inquiry be a scalar. */ 5381 if (ref->u.i == INQUIRY_LEN && array_ref && expr->ts.deferred) 5382 { 5383 array_ref->u.ar.type = AR_ELEMENT; 5384 expr->rank = 0; 5385 /* INQUIRY_LEN is not evaluated from the rest of the expr 5386 but directly from the string length. This means that setting 5387 the array indices to one does not matter but might trigger 5388 a runtime bounds error. Suppress the check. */ 5389 expr->no_bounds_check = 1; 5390 for (dim = 0; dim < array_ref->u.ar.dimen; dim++) 5391 { 5392 array_ref->u.ar.dimen_type[dim] = DIMEN_ELEMENT; 5393 if (array_ref->u.ar.start[dim]) 5394 gfc_free_expr (array_ref->u.ar.start[dim]); 5395 array_ref->u.ar.start[dim] 5396 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 5397 if (array_ref->u.ar.end[dim]) 5398 gfc_free_expr (array_ref->u.ar.end[dim]); 5399 if (array_ref->u.ar.stride[dim]) 5400 gfc_free_expr (array_ref->u.ar.stride[dim]); 5401 } 5402 } 5403 break; 5404 } 5405 5406 if (((ref->type == REF_COMPONENT && n_components > 1) 5407 || ref->next == NULL) 5408 && current_part_dimension 5409 && seen_part_dimension) 5410 { 5411 gfc_error ("Two or more part references with nonzero rank must " 5412 "not be specified at %L", &expr->where); 5413 return false; 5414 } 5415 5416 if (ref->type == REF_COMPONENT) 5417 { 5418 if (current_part_dimension) 5419 seen_part_dimension = 1; 5420 5421 /* reset to make sure */ 5422 current_part_dimension = 0; 5423 } 5424 } 5425 5426 return true; 5427} 5428 5429 5430/* Given an expression, determine its shape. This is easier than it sounds. 5431 Leaves the shape array NULL if it is not possible to determine the shape. */ 5432 5433static void 5434expression_shape (gfc_expr *e) 5435{ 5436 mpz_t array[GFC_MAX_DIMENSIONS]; 5437 int i; 5438 5439 if (e->rank <= 0 || e->shape != NULL) 5440 return; 5441 5442 for (i = 0; i < e->rank; i++) 5443 if (!gfc_array_dimen_size (e, i, &array[i])) 5444 goto fail; 5445 5446 e->shape = gfc_get_shape (e->rank); 5447 5448 memcpy (e->shape, array, e->rank * sizeof (mpz_t)); 5449 5450 return; 5451 5452fail: 5453 for (i--; i >= 0; i--) 5454 mpz_clear (array[i]); 5455} 5456 5457 5458/* Given a variable expression node, compute the rank of the expression by 5459 examining the base symbol and any reference structures it may have. */ 5460 5461void 5462gfc_expression_rank (gfc_expr *e) 5463{ 5464 gfc_ref *ref; 5465 int i, rank; 5466 5467 /* Just to make sure, because EXPR_COMPCALL's also have an e->ref and that 5468 could lead to serious confusion... */ 5469 gcc_assert (e->expr_type != EXPR_COMPCALL); 5470 5471 if (e->ref == NULL) 5472 { 5473 if (e->expr_type == EXPR_ARRAY) 5474 goto done; 5475 /* Constructors can have a rank different from one via RESHAPE(). */ 5476 5477 e->rank = ((e->symtree == NULL || e->symtree->n.sym->as == NULL) 5478 ? 0 : e->symtree->n.sym->as->rank); 5479 goto done; 5480 } 5481 5482 rank = 0; 5483 5484 for (ref = e->ref; ref; ref = ref->next) 5485 { 5486 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.proc_pointer 5487 && ref->u.c.component->attr.function && !ref->next) 5488 rank = ref->u.c.component->as ? ref->u.c.component->as->rank : 0; 5489 5490 if (ref->type != REF_ARRAY) 5491 continue; 5492 5493 if (ref->u.ar.type == AR_FULL) 5494 { 5495 rank = ref->u.ar.as->rank; 5496 break; 5497 } 5498 5499 if (ref->u.ar.type == AR_SECTION) 5500 { 5501 /* Figure out the rank of the section. */ 5502 if (rank != 0) 5503 gfc_internal_error ("gfc_expression_rank(): Two array specs"); 5504 5505 for (i = 0; i < ref->u.ar.dimen; i++) 5506 if (ref->u.ar.dimen_type[i] == DIMEN_RANGE 5507 || ref->u.ar.dimen_type[i] == DIMEN_VECTOR) 5508 rank++; 5509 5510 break; 5511 } 5512 } 5513 5514 e->rank = rank; 5515 5516done: 5517 expression_shape (e); 5518} 5519 5520 5521static void 5522add_caf_get_intrinsic (gfc_expr *e) 5523{ 5524 gfc_expr *wrapper, *tmp_expr; 5525 gfc_ref *ref; 5526 int n; 5527 5528 for (ref = e->ref; ref; ref = ref->next) 5529 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5530 break; 5531 if (ref == NULL) 5532 return; 5533 5534 for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 5535 if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) 5536 return; 5537 5538 tmp_expr = XCNEW (gfc_expr); 5539 *tmp_expr = *e; 5540 wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET, 5541 "caf_get", tmp_expr->where, 1, tmp_expr); 5542 wrapper->ts = e->ts; 5543 wrapper->rank = e->rank; 5544 if (e->rank) 5545 wrapper->shape = gfc_copy_shape (e->shape, e->rank); 5546 *e = *wrapper; 5547 free (wrapper); 5548} 5549 5550 5551static void 5552remove_caf_get_intrinsic (gfc_expr *e) 5553{ 5554 gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym 5555 && e->value.function.isym->id == GFC_ISYM_CAF_GET); 5556 gfc_expr *e2 = e->value.function.actual->expr; 5557 e->value.function.actual->expr = NULL; 5558 gfc_free_actual_arglist (e->value.function.actual); 5559 gfc_free_shape (&e->shape, e->rank); 5560 *e = *e2; 5561 free (e2); 5562} 5563 5564 5565/* Resolve a variable expression. */ 5566 5567static bool 5568resolve_variable (gfc_expr *e) 5569{ 5570 gfc_symbol *sym; 5571 bool t; 5572 5573 t = true; 5574 5575 if (e->symtree == NULL) 5576 return false; 5577 sym = e->symtree->n.sym; 5578 5579 /* Use same check as for TYPE(*) below; this check has to be before TYPE(*) 5580 as ts.type is set to BT_ASSUMED in resolve_symbol. */ 5581 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 5582 { 5583 if (!actual_arg || inquiry_argument) 5584 { 5585 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may only " 5586 "be used as actual argument", sym->name, &e->where); 5587 return false; 5588 } 5589 } 5590 /* TS 29113, 407b. */ 5591 else if (e->ts.type == BT_ASSUMED) 5592 { 5593 if (!actual_arg) 5594 { 5595 gfc_error ("Assumed-type variable %s at %L may only be used " 5596 "as actual argument", sym->name, &e->where); 5597 return false; 5598 } 5599 else if (inquiry_argument && !first_actual_arg) 5600 { 5601 /* FIXME: It doesn't work reliably as inquiry_argument is not set 5602 for all inquiry functions in resolve_function; the reason is 5603 that the function-name resolution happens too late in that 5604 function. */ 5605 gfc_error ("Assumed-type variable %s at %L as actual argument to " 5606 "an inquiry function shall be the first argument", 5607 sym->name, &e->where); 5608 return false; 5609 } 5610 } 5611 /* TS 29113, C535b. */ 5612 else if (((sym->ts.type == BT_CLASS && sym->attr.class_ok 5613 && sym->ts.u.derived && CLASS_DATA (sym) 5614 && CLASS_DATA (sym)->as 5615 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) 5616 || (sym->ts.type != BT_CLASS && sym->as 5617 && sym->as->type == AS_ASSUMED_RANK)) 5618 && !sym->attr.select_rank_temporary) 5619 { 5620 if (!actual_arg 5621 && !(cs_base && cs_base->current 5622 && cs_base->current->op == EXEC_SELECT_RANK)) 5623 { 5624 gfc_error ("Assumed-rank variable %s at %L may only be used as " 5625 "actual argument", sym->name, &e->where); 5626 return false; 5627 } 5628 else if (inquiry_argument && !first_actual_arg) 5629 { 5630 /* FIXME: It doesn't work reliably as inquiry_argument is not set 5631 for all inquiry functions in resolve_function; the reason is 5632 that the function-name resolution happens too late in that 5633 function. */ 5634 gfc_error ("Assumed-rank variable %s at %L as actual argument " 5635 "to an inquiry function shall be the first argument", 5636 sym->name, &e->where); 5637 return false; 5638 } 5639 } 5640 5641 if ((sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) && e->ref 5642 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL 5643 && e->ref->next == NULL)) 5644 { 5645 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall not have " 5646 "a subobject reference", sym->name, &e->ref->u.ar.where); 5647 return false; 5648 } 5649 /* TS 29113, 407b. */ 5650 else if (e->ts.type == BT_ASSUMED && e->ref 5651 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL 5652 && e->ref->next == NULL)) 5653 { 5654 gfc_error ("Assumed-type variable %s at %L shall not have a subobject " 5655 "reference", sym->name, &e->ref->u.ar.where); 5656 return false; 5657 } 5658 5659 /* TS 29113, C535b. */ 5660 if (((sym->ts.type == BT_CLASS && sym->attr.class_ok 5661 && sym->ts.u.derived && CLASS_DATA (sym) 5662 && CLASS_DATA (sym)->as 5663 && CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK) 5664 || (sym->ts.type != BT_CLASS && sym->as 5665 && sym->as->type == AS_ASSUMED_RANK)) 5666 && e->ref 5667 && !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL 5668 && e->ref->next == NULL)) 5669 { 5670 gfc_error ("Assumed-rank variable %s at %L shall not have a subobject " 5671 "reference", sym->name, &e->ref->u.ar.where); 5672 return false; 5673 } 5674 5675 /* For variables that are used in an associate (target => object) where 5676 the object's basetype is array valued while the target is scalar, 5677 the ts' type of the component refs is still array valued, which 5678 can't be translated that way. */ 5679 if (sym->assoc && e->rank == 0 && e->ref && sym->ts.type == BT_CLASS 5680 && sym->assoc->target && sym->assoc->target->ts.type == BT_CLASS 5681 && sym->assoc->target->ts.u.derived 5682 && CLASS_DATA (sym->assoc->target) 5683 && CLASS_DATA (sym->assoc->target)->as) 5684 { 5685 gfc_ref *ref = e->ref; 5686 while (ref) 5687 { 5688 switch (ref->type) 5689 { 5690 case REF_COMPONENT: 5691 ref->u.c.sym = sym->ts.u.derived; 5692 /* Stop the loop. */ 5693 ref = NULL; 5694 break; 5695 default: 5696 ref = ref->next; 5697 break; 5698 } 5699 } 5700 } 5701 5702 /* If this is an associate-name, it may be parsed with an array reference 5703 in error even though the target is scalar. Fail directly in this case. 5704 TODO Understand why class scalar expressions must be excluded. */ 5705 if (sym->assoc && !(sym->ts.type == BT_CLASS && e->rank == 0)) 5706 { 5707 if (sym->ts.type == BT_CLASS) 5708 gfc_fix_class_refs (e); 5709 if (!sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) 5710 return false; 5711 else if (sym->attr.dimension && (!e->ref || e->ref->type != REF_ARRAY)) 5712 { 5713 /* This can happen because the parser did not detect that the 5714 associate name is an array and the expression had no array 5715 part_ref. */ 5716 gfc_ref *ref = gfc_get_ref (); 5717 ref->type = REF_ARRAY; 5718 ref->u.ar = *gfc_get_array_ref(); 5719 ref->u.ar.type = AR_FULL; 5720 if (sym->as) 5721 { 5722 ref->u.ar.as = sym->as; 5723 ref->u.ar.dimen = sym->as->rank; 5724 } 5725 ref->next = e->ref; 5726 e->ref = ref; 5727 5728 } 5729 } 5730 5731 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic) 5732 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); 5733 5734 /* On the other hand, the parser may not have known this is an array; 5735 in this case, we have to add a FULL reference. */ 5736 if (sym->assoc && sym->attr.dimension && !e->ref) 5737 { 5738 e->ref = gfc_get_ref (); 5739 e->ref->type = REF_ARRAY; 5740 e->ref->u.ar.type = AR_FULL; 5741 e->ref->u.ar.dimen = 0; 5742 } 5743 5744 /* Like above, but for class types, where the checking whether an array 5745 ref is present is more complicated. Furthermore make sure not to add 5746 the full array ref to _vptr or _len refs. */ 5747 if (sym->assoc && sym->ts.type == BT_CLASS && sym->ts.u.derived 5748 && CLASS_DATA (sym) 5749 && CLASS_DATA (sym)->attr.dimension 5750 && (e->ts.type != BT_DERIVED || !e->ts.u.derived->attr.vtype)) 5751 { 5752 gfc_ref *ref, *newref; 5753 5754 newref = gfc_get_ref (); 5755 newref->type = REF_ARRAY; 5756 newref->u.ar.type = AR_FULL; 5757 newref->u.ar.dimen = 0; 5758 /* Because this is an associate var and the first ref either is a ref to 5759 the _data component or not, no traversal of the ref chain is 5760 needed. The array ref needs to be inserted after the _data ref, 5761 or when that is not present, which may happend for polymorphic 5762 types, then at the first position. */ 5763 ref = e->ref; 5764 if (!ref) 5765 e->ref = newref; 5766 else if (ref->type == REF_COMPONENT 5767 && strcmp ("_data", ref->u.c.component->name) == 0) 5768 { 5769 if (!ref->next || ref->next->type != REF_ARRAY) 5770 { 5771 newref->next = ref->next; 5772 ref->next = newref; 5773 } 5774 else 5775 /* Array ref present already. */ 5776 gfc_free_ref_list (newref); 5777 } 5778 else if (ref->type == REF_ARRAY) 5779 /* Array ref present already. */ 5780 gfc_free_ref_list (newref); 5781 else 5782 { 5783 newref->next = ref; 5784 e->ref = newref; 5785 } 5786 } 5787 5788 if (e->ref && !gfc_resolve_ref (e)) 5789 return false; 5790 5791 if (sym->attr.flavor == FL_PROCEDURE 5792 && (!sym->attr.function 5793 || (sym->attr.function && sym->result 5794 && sym->result->attr.proc_pointer 5795 && !sym->result->attr.function))) 5796 { 5797 e->ts.type = BT_PROCEDURE; 5798 goto resolve_procedure; 5799 } 5800 5801 if (sym->ts.type != BT_UNKNOWN) 5802 gfc_variable_attr (e, &e->ts); 5803 else if (sym->attr.flavor == FL_PROCEDURE 5804 && sym->attr.function && sym->result 5805 && sym->result->ts.type != BT_UNKNOWN 5806 && sym->result->attr.proc_pointer) 5807 e->ts = sym->result->ts; 5808 else 5809 { 5810 /* Must be a simple variable reference. */ 5811 if (!gfc_set_default_type (sym, 1, sym->ns)) 5812 return false; 5813 e->ts = sym->ts; 5814 } 5815 5816 if (check_assumed_size_reference (sym, e)) 5817 return false; 5818 5819 /* Deal with forward references to entries during gfc_resolve_code, to 5820 satisfy, at least partially, 12.5.2.5. */ 5821 if (gfc_current_ns->entries 5822 && current_entry_id == sym->entry_id 5823 && cs_base 5824 && cs_base->current 5825 && cs_base->current->op != EXEC_ENTRY) 5826 { 5827 gfc_entry_list *entry; 5828 gfc_formal_arglist *formal; 5829 int n; 5830 bool seen, saved_specification_expr; 5831 5832 /* If the symbol is a dummy... */ 5833 if (sym->attr.dummy && sym->ns == gfc_current_ns) 5834 { 5835 entry = gfc_current_ns->entries; 5836 seen = false; 5837 5838 /* ...test if the symbol is a parameter of previous entries. */ 5839 for (; entry && entry->id <= current_entry_id; entry = entry->next) 5840 for (formal = entry->sym->formal; formal; formal = formal->next) 5841 { 5842 if (formal->sym && sym->name == formal->sym->name) 5843 { 5844 seen = true; 5845 break; 5846 } 5847 } 5848 5849 /* If it has not been seen as a dummy, this is an error. */ 5850 if (!seen) 5851 { 5852 if (specification_expr) 5853 gfc_error ("Variable %qs, used in a specification expression" 5854 ", is referenced at %L before the ENTRY statement " 5855 "in which it is a parameter", 5856 sym->name, &cs_base->current->loc); 5857 else 5858 gfc_error ("Variable %qs is used at %L before the ENTRY " 5859 "statement in which it is a parameter", 5860 sym->name, &cs_base->current->loc); 5861 t = false; 5862 } 5863 } 5864 5865 /* Now do the same check on the specification expressions. */ 5866 saved_specification_expr = specification_expr; 5867 specification_expr = true; 5868 if (sym->ts.type == BT_CHARACTER 5869 && !gfc_resolve_expr (sym->ts.u.cl->length)) 5870 t = false; 5871 5872 if (sym->as) 5873 for (n = 0; n < sym->as->rank; n++) 5874 { 5875 if (!gfc_resolve_expr (sym->as->lower[n])) 5876 t = false; 5877 if (!gfc_resolve_expr (sym->as->upper[n])) 5878 t = false; 5879 } 5880 specification_expr = saved_specification_expr; 5881 5882 if (t) 5883 /* Update the symbol's entry level. */ 5884 sym->entry_id = current_entry_id + 1; 5885 } 5886 5887 /* If a symbol has been host_associated mark it. This is used latter, 5888 to identify if aliasing is possible via host association. */ 5889 if (sym->attr.flavor == FL_VARIABLE 5890 && gfc_current_ns->parent 5891 && (gfc_current_ns->parent == sym->ns 5892 || (gfc_current_ns->parent->parent 5893 && gfc_current_ns->parent->parent == sym->ns))) 5894 sym->attr.host_assoc = 1; 5895 5896 if (gfc_current_ns->proc_name 5897 && sym->attr.dimension 5898 && (sym->ns != gfc_current_ns 5899 || sym->attr.use_assoc 5900 || sym->attr.in_common)) 5901 gfc_current_ns->proc_name->attr.array_outer_dependency = 1; 5902 5903resolve_procedure: 5904 if (t && !resolve_procedure_expression (e)) 5905 t = false; 5906 5907 /* F2008, C617 and C1229. */ 5908 if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) 5909 && gfc_is_coindexed (e)) 5910 { 5911 gfc_ref *ref, *ref2 = NULL; 5912 5913 for (ref = e->ref; ref; ref = ref->next) 5914 { 5915 if (ref->type == REF_COMPONENT) 5916 ref2 = ref; 5917 if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) 5918 break; 5919 } 5920 5921 for ( ; ref; ref = ref->next) 5922 if (ref->type == REF_COMPONENT) 5923 break; 5924 5925 /* Expression itself is not coindexed object. */ 5926 if (ref && e->ts.type == BT_CLASS) 5927 { 5928 gfc_error ("Polymorphic subobject of coindexed object at %L", 5929 &e->where); 5930 t = false; 5931 } 5932 5933 /* Expression itself is coindexed object. */ 5934 if (ref == NULL) 5935 { 5936 gfc_component *c; 5937 c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; 5938 for ( ; c; c = c->next) 5939 if (c->attr.allocatable && c->ts.type == BT_CLASS) 5940 { 5941 gfc_error ("Coindexed object with polymorphic allocatable " 5942 "subcomponent at %L", &e->where); 5943 t = false; 5944 break; 5945 } 5946 } 5947 } 5948 5949 if (t) 5950 gfc_expression_rank (e); 5951 5952 if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e)) 5953 add_caf_get_intrinsic (e); 5954 5955 /* Simplify cases where access to a parameter array results in a 5956 single constant. Suppress errors since those will have been 5957 issued before, as warnings. */ 5958 if (e->rank == 0 && sym->as && sym->attr.flavor == FL_PARAMETER) 5959 { 5960 gfc_push_suppress_errors (); 5961 gfc_simplify_expr (e, 1); 5962 gfc_pop_suppress_errors (); 5963 } 5964 5965 return t; 5966} 5967 5968 5969/* Checks to see that the correct symbol has been host associated. 5970 The only situation where this arises is that in which a twice 5971 contained function is parsed after the host association is made. 5972 Therefore, on detecting this, change the symbol in the expression 5973 and convert the array reference into an actual arglist if the old 5974 symbol is a variable. */ 5975static bool 5976check_host_association (gfc_expr *e) 5977{ 5978 gfc_symbol *sym, *old_sym; 5979 gfc_symtree *st; 5980 int n; 5981 gfc_ref *ref; 5982 gfc_actual_arglist *arg, *tail = NULL; 5983 bool retval = e->expr_type == EXPR_FUNCTION; 5984 5985 /* If the expression is the result of substitution in 5986 interface.c(gfc_extend_expr) because there is no way in 5987 which the host association can be wrong. */ 5988 if (e->symtree == NULL 5989 || e->symtree->n.sym == NULL 5990 || e->user_operator) 5991 return retval; 5992 5993 old_sym = e->symtree->n.sym; 5994 5995 if (gfc_current_ns->parent 5996 && old_sym->ns != gfc_current_ns) 5997 { 5998 /* Use the 'USE' name so that renamed module symbols are 5999 correctly handled. */ 6000 gfc_find_symbol (e->symtree->name, gfc_current_ns, 1, &sym); 6001 6002 if (sym && old_sym != sym 6003 && sym->ts.type == old_sym->ts.type 6004 && sym->attr.flavor == FL_PROCEDURE 6005 && sym->attr.contained) 6006 { 6007 /* Clear the shape, since it might not be valid. */ 6008 gfc_free_shape (&e->shape, e->rank); 6009 6010 /* Give the expression the right symtree! */ 6011 gfc_find_sym_tree (e->symtree->name, NULL, 1, &st); 6012 gcc_assert (st != NULL); 6013 6014 if (old_sym->attr.flavor == FL_PROCEDURE 6015 || e->expr_type == EXPR_FUNCTION) 6016 { 6017 /* Original was function so point to the new symbol, since 6018 the actual argument list is already attached to the 6019 expression. */ 6020 e->value.function.esym = NULL; 6021 e->symtree = st; 6022 } 6023 else 6024 { 6025 /* Original was variable so convert array references into 6026 an actual arglist. This does not need any checking now 6027 since resolve_function will take care of it. */ 6028 e->value.function.actual = NULL; 6029 e->expr_type = EXPR_FUNCTION; 6030 e->symtree = st; 6031 6032 /* Ambiguity will not arise if the array reference is not 6033 the last reference. */ 6034 for (ref = e->ref; ref; ref = ref->next) 6035 if (ref->type == REF_ARRAY && ref->next == NULL) 6036 break; 6037 6038 gcc_assert (ref->type == REF_ARRAY); 6039 6040 /* Grab the start expressions from the array ref and 6041 copy them into actual arguments. */ 6042 for (n = 0; n < ref->u.ar.dimen; n++) 6043 { 6044 arg = gfc_get_actual_arglist (); 6045 arg->expr = gfc_copy_expr (ref->u.ar.start[n]); 6046 if (e->value.function.actual == NULL) 6047 tail = e->value.function.actual = arg; 6048 else 6049 { 6050 tail->next = arg; 6051 tail = arg; 6052 } 6053 } 6054 6055 /* Dump the reference list and set the rank. */ 6056 gfc_free_ref_list (e->ref); 6057 e->ref = NULL; 6058 e->rank = sym->as ? sym->as->rank : 0; 6059 } 6060 6061 gfc_resolve_expr (e); 6062 sym->refs++; 6063 } 6064 } 6065 /* This might have changed! */ 6066 return e->expr_type == EXPR_FUNCTION; 6067} 6068 6069 6070static void 6071gfc_resolve_character_operator (gfc_expr *e) 6072{ 6073 gfc_expr *op1 = e->value.op.op1; 6074 gfc_expr *op2 = e->value.op.op2; 6075 gfc_expr *e1 = NULL; 6076 gfc_expr *e2 = NULL; 6077 6078 gcc_assert (e->value.op.op == INTRINSIC_CONCAT); 6079 6080 if (op1->ts.u.cl && op1->ts.u.cl->length) 6081 e1 = gfc_copy_expr (op1->ts.u.cl->length); 6082 else if (op1->expr_type == EXPR_CONSTANT) 6083 e1 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 6084 op1->value.character.length); 6085 6086 if (op2->ts.u.cl && op2->ts.u.cl->length) 6087 e2 = gfc_copy_expr (op2->ts.u.cl->length); 6088 else if (op2->expr_type == EXPR_CONSTANT) 6089 e2 = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 6090 op2->value.character.length); 6091 6092 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 6093 6094 if (!e1 || !e2) 6095 { 6096 gfc_free_expr (e1); 6097 gfc_free_expr (e2); 6098 6099 return; 6100 } 6101 6102 e->ts.u.cl->length = gfc_add (e1, e2); 6103 e->ts.u.cl->length->ts.type = BT_INTEGER; 6104 e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind; 6105 gfc_simplify_expr (e->ts.u.cl->length, 0); 6106 gfc_resolve_expr (e->ts.u.cl->length); 6107 6108 return; 6109} 6110 6111 6112/* Ensure that an character expression has a charlen and, if possible, a 6113 length expression. */ 6114 6115static void 6116fixup_charlen (gfc_expr *e) 6117{ 6118 /* The cases fall through so that changes in expression type and the need 6119 for multiple fixes are picked up. In all circumstances, a charlen should 6120 be available for the middle end to hang a backend_decl on. */ 6121 switch (e->expr_type) 6122 { 6123 case EXPR_OP: 6124 gfc_resolve_character_operator (e); 6125 /* FALLTHRU */ 6126 6127 case EXPR_ARRAY: 6128 if (e->expr_type == EXPR_ARRAY) 6129 gfc_resolve_character_array_constructor (e); 6130 /* FALLTHRU */ 6131 6132 case EXPR_SUBSTRING: 6133 if (!e->ts.u.cl && e->ref) 6134 gfc_resolve_substring_charlen (e); 6135 /* FALLTHRU */ 6136 6137 default: 6138 if (!e->ts.u.cl) 6139 e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 6140 6141 break; 6142 } 6143} 6144 6145 6146/* Update an actual argument to include the passed-object for type-bound 6147 procedures at the right position. */ 6148 6149static gfc_actual_arglist* 6150update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos, 6151 const char *name) 6152{ 6153 gcc_assert (argpos > 0); 6154 6155 if (argpos == 1) 6156 { 6157 gfc_actual_arglist* result; 6158 6159 result = gfc_get_actual_arglist (); 6160 result->expr = po; 6161 result->next = lst; 6162 if (name) 6163 result->name = name; 6164 6165 return result; 6166 } 6167 6168 if (lst) 6169 lst->next = update_arglist_pass (lst->next, po, argpos - 1, name); 6170 else 6171 lst = update_arglist_pass (NULL, po, argpos - 1, name); 6172 return lst; 6173} 6174 6175 6176/* Extract the passed-object from an EXPR_COMPCALL (a copy of it). */ 6177 6178static gfc_expr* 6179extract_compcall_passed_object (gfc_expr* e) 6180{ 6181 gfc_expr* po; 6182 6183 if (e->expr_type == EXPR_UNKNOWN) 6184 { 6185 gfc_error ("Error in typebound call at %L", 6186 &e->where); 6187 return NULL; 6188 } 6189 6190 gcc_assert (e->expr_type == EXPR_COMPCALL); 6191 6192 if (e->value.compcall.base_object) 6193 po = gfc_copy_expr (e->value.compcall.base_object); 6194 else 6195 { 6196 po = gfc_get_expr (); 6197 po->expr_type = EXPR_VARIABLE; 6198 po->symtree = e->symtree; 6199 po->ref = gfc_copy_ref (e->ref); 6200 po->where = e->where; 6201 } 6202 6203 if (!gfc_resolve_expr (po)) 6204 return NULL; 6205 6206 return po; 6207} 6208 6209 6210/* Update the arglist of an EXPR_COMPCALL expression to include the 6211 passed-object. */ 6212 6213static bool 6214update_compcall_arglist (gfc_expr* e) 6215{ 6216 gfc_expr* po; 6217 gfc_typebound_proc* tbp; 6218 6219 tbp = e->value.compcall.tbp; 6220 6221 if (tbp->error) 6222 return false; 6223 6224 po = extract_compcall_passed_object (e); 6225 if (!po) 6226 return false; 6227 6228 if (tbp->nopass || e->value.compcall.ignore_pass) 6229 { 6230 gfc_free_expr (po); 6231 return true; 6232 } 6233 6234 if (tbp->pass_arg_num <= 0) 6235 return false; 6236 6237 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, 6238 tbp->pass_arg_num, 6239 tbp->pass_arg); 6240 6241 return true; 6242} 6243 6244 6245/* Extract the passed object from a PPC call (a copy of it). */ 6246 6247static gfc_expr* 6248extract_ppc_passed_object (gfc_expr *e) 6249{ 6250 gfc_expr *po; 6251 gfc_ref **ref; 6252 6253 po = gfc_get_expr (); 6254 po->expr_type = EXPR_VARIABLE; 6255 po->symtree = e->symtree; 6256 po->ref = gfc_copy_ref (e->ref); 6257 po->where = e->where; 6258 6259 /* Remove PPC reference. */ 6260 ref = &po->ref; 6261 while ((*ref)->next) 6262 ref = &(*ref)->next; 6263 gfc_free_ref_list (*ref); 6264 *ref = NULL; 6265 6266 if (!gfc_resolve_expr (po)) 6267 return NULL; 6268 6269 return po; 6270} 6271 6272 6273/* Update the actual arglist of a procedure pointer component to include the 6274 passed-object. */ 6275 6276static bool 6277update_ppc_arglist (gfc_expr* e) 6278{ 6279 gfc_expr* po; 6280 gfc_component *ppc; 6281 gfc_typebound_proc* tb; 6282 6283 ppc = gfc_get_proc_ptr_comp (e); 6284 if (!ppc) 6285 return false; 6286 6287 tb = ppc->tb; 6288 6289 if (tb->error) 6290 return false; 6291 else if (tb->nopass) 6292 return true; 6293 6294 po = extract_ppc_passed_object (e); 6295 if (!po) 6296 return false; 6297 6298 /* F08:R739. */ 6299 if (po->rank != 0) 6300 { 6301 gfc_error ("Passed-object at %L must be scalar", &e->where); 6302 return false; 6303 } 6304 6305 /* F08:C611. */ 6306 if (po->ts.type == BT_DERIVED && po->ts.u.derived->attr.abstract) 6307 { 6308 gfc_error ("Base object for procedure-pointer component call at %L is of" 6309 " ABSTRACT type %qs", &e->where, po->ts.u.derived->name); 6310 return false; 6311 } 6312 6313 gcc_assert (tb->pass_arg_num > 0); 6314 e->value.compcall.actual = update_arglist_pass (e->value.compcall.actual, po, 6315 tb->pass_arg_num, 6316 tb->pass_arg); 6317 6318 return true; 6319} 6320 6321 6322/* Check that the object a TBP is called on is valid, i.e. it must not be 6323 of ABSTRACT type (as in subobject%abstract_parent%tbp()). */ 6324 6325static bool 6326check_typebound_baseobject (gfc_expr* e) 6327{ 6328 gfc_expr* base; 6329 bool return_value = false; 6330 6331 base = extract_compcall_passed_object (e); 6332 if (!base) 6333 return false; 6334 6335 if (base->ts.type != BT_DERIVED && base->ts.type != BT_CLASS) 6336 { 6337 gfc_error ("Error in typebound call at %L", &e->where); 6338 goto cleanup; 6339 } 6340 6341 if (base->ts.type == BT_CLASS && !gfc_expr_attr (base).class_ok) 6342 return false; 6343 6344 /* F08:C611. */ 6345 if (base->ts.type == BT_DERIVED && base->ts.u.derived->attr.abstract) 6346 { 6347 gfc_error ("Base object for type-bound procedure call at %L is of" 6348 " ABSTRACT type %qs", &e->where, base->ts.u.derived->name); 6349 goto cleanup; 6350 } 6351 6352 /* F08:C1230. If the procedure called is NOPASS, 6353 the base object must be scalar. */ 6354 if (e->value.compcall.tbp->nopass && base->rank != 0) 6355 { 6356 gfc_error ("Base object for NOPASS type-bound procedure call at %L must" 6357 " be scalar", &e->where); 6358 goto cleanup; 6359 } 6360 6361 return_value = true; 6362 6363cleanup: 6364 gfc_free_expr (base); 6365 return return_value; 6366} 6367 6368 6369/* Resolve a call to a type-bound procedure, either function or subroutine, 6370 statically from the data in an EXPR_COMPCALL expression. The adapted 6371 arglist and the target-procedure symtree are returned. */ 6372 6373static bool 6374resolve_typebound_static (gfc_expr* e, gfc_symtree** target, 6375 gfc_actual_arglist** actual) 6376{ 6377 gcc_assert (e->expr_type == EXPR_COMPCALL); 6378 gcc_assert (!e->value.compcall.tbp->is_generic); 6379 6380 /* Update the actual arglist for PASS. */ 6381 if (!update_compcall_arglist (e)) 6382 return false; 6383 6384 *actual = e->value.compcall.actual; 6385 *target = e->value.compcall.tbp->u.specific; 6386 6387 gfc_free_ref_list (e->ref); 6388 e->ref = NULL; 6389 e->value.compcall.actual = NULL; 6390 6391 /* If we find a deferred typebound procedure, check for derived types 6392 that an overriding typebound procedure has not been missed. */ 6393 if (e->value.compcall.name 6394 && !e->value.compcall.tbp->non_overridable 6395 && e->value.compcall.base_object 6396 && e->value.compcall.base_object->ts.type == BT_DERIVED) 6397 { 6398 gfc_symtree *st; 6399 gfc_symbol *derived; 6400 6401 /* Use the derived type of the base_object. */ 6402 derived = e->value.compcall.base_object->ts.u.derived; 6403 st = NULL; 6404 6405 /* If necessary, go through the inheritance chain. */ 6406 while (!st && derived) 6407 { 6408 /* Look for the typebound procedure 'name'. */ 6409 if (derived->f2k_derived && derived->f2k_derived->tb_sym_root) 6410 st = gfc_find_symtree (derived->f2k_derived->tb_sym_root, 6411 e->value.compcall.name); 6412 if (!st) 6413 derived = gfc_get_derived_super_type (derived); 6414 } 6415 6416 /* Now find the specific name in the derived type namespace. */ 6417 if (st && st->n.tb && st->n.tb->u.specific) 6418 gfc_find_sym_tree (st->n.tb->u.specific->name, 6419 derived->ns, 1, &st); 6420 if (st) 6421 *target = st; 6422 } 6423 return true; 6424} 6425 6426 6427/* Get the ultimate declared type from an expression. In addition, 6428 return the last class/derived type reference and the copy of the 6429 reference list. If check_types is set true, derived types are 6430 identified as well as class references. */ 6431static gfc_symbol* 6432get_declared_from_expr (gfc_ref **class_ref, gfc_ref **new_ref, 6433 gfc_expr *e, bool check_types) 6434{ 6435 gfc_symbol *declared; 6436 gfc_ref *ref; 6437 6438 declared = NULL; 6439 if (class_ref) 6440 *class_ref = NULL; 6441 if (new_ref) 6442 *new_ref = gfc_copy_ref (e->ref); 6443 6444 for (ref = e->ref; ref; ref = ref->next) 6445 { 6446 if (ref->type != REF_COMPONENT) 6447 continue; 6448 6449 if ((ref->u.c.component->ts.type == BT_CLASS 6450 || (check_types && gfc_bt_struct (ref->u.c.component->ts.type))) 6451 && ref->u.c.component->attr.flavor != FL_PROCEDURE) 6452 { 6453 declared = ref->u.c.component->ts.u.derived; 6454 if (class_ref) 6455 *class_ref = ref; 6456 } 6457 } 6458 6459 if (declared == NULL) 6460 declared = e->symtree->n.sym->ts.u.derived; 6461 6462 return declared; 6463} 6464 6465 6466/* Given an EXPR_COMPCALL calling a GENERIC typebound procedure, figure out 6467 which of the specific bindings (if any) matches the arglist and transform 6468 the expression into a call of that binding. */ 6469 6470static bool 6471resolve_typebound_generic_call (gfc_expr* e, const char **name) 6472{ 6473 gfc_typebound_proc* genproc; 6474 const char* genname; 6475 gfc_symtree *st; 6476 gfc_symbol *derived; 6477 6478 gcc_assert (e->expr_type == EXPR_COMPCALL); 6479 genname = e->value.compcall.name; 6480 genproc = e->value.compcall.tbp; 6481 6482 if (!genproc->is_generic) 6483 return true; 6484 6485 /* Try the bindings on this type and in the inheritance hierarchy. */ 6486 for (; genproc; genproc = genproc->overridden) 6487 { 6488 gfc_tbp_generic* g; 6489 6490 gcc_assert (genproc->is_generic); 6491 for (g = genproc->u.generic; g; g = g->next) 6492 { 6493 gfc_symbol* target; 6494 gfc_actual_arglist* args; 6495 bool matches; 6496 6497 gcc_assert (g->specific); 6498 6499 if (g->specific->error) 6500 continue; 6501 6502 target = g->specific->u.specific->n.sym; 6503 6504 /* Get the right arglist by handling PASS/NOPASS. */ 6505 args = gfc_copy_actual_arglist (e->value.compcall.actual); 6506 if (!g->specific->nopass) 6507 { 6508 gfc_expr* po; 6509 po = extract_compcall_passed_object (e); 6510 if (!po) 6511 { 6512 gfc_free_actual_arglist (args); 6513 return false; 6514 } 6515 6516 gcc_assert (g->specific->pass_arg_num > 0); 6517 gcc_assert (!g->specific->error); 6518 args = update_arglist_pass (args, po, g->specific->pass_arg_num, 6519 g->specific->pass_arg); 6520 } 6521 resolve_actual_arglist (args, target->attr.proc, 6522 is_external_proc (target) 6523 && gfc_sym_get_dummy_args (target) == NULL); 6524 6525 /* Check if this arglist matches the formal. */ 6526 matches = gfc_arglist_matches_symbol (&args, target); 6527 6528 /* Clean up and break out of the loop if we've found it. */ 6529 gfc_free_actual_arglist (args); 6530 if (matches) 6531 { 6532 e->value.compcall.tbp = g->specific; 6533 genname = g->specific_st->name; 6534 /* Pass along the name for CLASS methods, where the vtab 6535 procedure pointer component has to be referenced. */ 6536 if (name) 6537 *name = genname; 6538 goto success; 6539 } 6540 } 6541 } 6542 6543 /* Nothing matching found! */ 6544 gfc_error ("Found no matching specific binding for the call to the GENERIC" 6545 " %qs at %L", genname, &e->where); 6546 return false; 6547 6548success: 6549 /* Make sure that we have the right specific instance for the name. */ 6550 derived = get_declared_from_expr (NULL, NULL, e, true); 6551 6552 st = gfc_find_typebound_proc (derived, NULL, genname, true, &e->where); 6553 if (st) 6554 e->value.compcall.tbp = st->n.tb; 6555 6556 return true; 6557} 6558 6559 6560/* Resolve a call to a type-bound subroutine. */ 6561 6562static bool 6563resolve_typebound_call (gfc_code* c, const char **name, bool *overridable) 6564{ 6565 gfc_actual_arglist* newactual; 6566 gfc_symtree* target; 6567 6568 /* Check that's really a SUBROUTINE. */ 6569 if (!c->expr1->value.compcall.tbp->subroutine) 6570 { 6571 if (!c->expr1->value.compcall.tbp->is_generic 6572 && c->expr1->value.compcall.tbp->u.specific 6573 && c->expr1->value.compcall.tbp->u.specific->n.sym 6574 && c->expr1->value.compcall.tbp->u.specific->n.sym->attr.subroutine) 6575 c->expr1->value.compcall.tbp->subroutine = 1; 6576 else 6577 { 6578 gfc_error ("%qs at %L should be a SUBROUTINE", 6579 c->expr1->value.compcall.name, &c->loc); 6580 return false; 6581 } 6582 } 6583 6584 if (!check_typebound_baseobject (c->expr1)) 6585 return false; 6586 6587 /* Pass along the name for CLASS methods, where the vtab 6588 procedure pointer component has to be referenced. */ 6589 if (name) 6590 *name = c->expr1->value.compcall.name; 6591 6592 if (!resolve_typebound_generic_call (c->expr1, name)) 6593 return false; 6594 6595 /* Pass along the NON_OVERRIDABLE attribute of the specific TBP. */ 6596 if (overridable) 6597 *overridable = !c->expr1->value.compcall.tbp->non_overridable; 6598 6599 /* Transform into an ordinary EXEC_CALL for now. */ 6600 6601 if (!resolve_typebound_static (c->expr1, &target, &newactual)) 6602 return false; 6603 6604 c->ext.actual = newactual; 6605 c->symtree = target; 6606 c->op = (c->expr1->value.compcall.assign ? EXEC_ASSIGN_CALL : EXEC_CALL); 6607 6608 gcc_assert (!c->expr1->ref && !c->expr1->value.compcall.actual); 6609 6610 gfc_free_expr (c->expr1); 6611 c->expr1 = gfc_get_expr (); 6612 c->expr1->expr_type = EXPR_FUNCTION; 6613 c->expr1->symtree = target; 6614 c->expr1->where = c->loc; 6615 6616 return resolve_call (c); 6617} 6618 6619 6620/* Resolve a component-call expression. */ 6621static bool 6622resolve_compcall (gfc_expr* e, const char **name) 6623{ 6624 gfc_actual_arglist* newactual; 6625 gfc_symtree* target; 6626 6627 /* Check that's really a FUNCTION. */ 6628 if (!e->value.compcall.tbp->function) 6629 { 6630 gfc_error ("%qs at %L should be a FUNCTION", 6631 e->value.compcall.name, &e->where); 6632 return false; 6633 } 6634 6635 6636 /* These must not be assign-calls! */ 6637 gcc_assert (!e->value.compcall.assign); 6638 6639 if (!check_typebound_baseobject (e)) 6640 return false; 6641 6642 /* Pass along the name for CLASS methods, where the vtab 6643 procedure pointer component has to be referenced. */ 6644 if (name) 6645 *name = e->value.compcall.name; 6646 6647 if (!resolve_typebound_generic_call (e, name)) 6648 return false; 6649 gcc_assert (!e->value.compcall.tbp->is_generic); 6650 6651 /* Take the rank from the function's symbol. */ 6652 if (e->value.compcall.tbp->u.specific->n.sym->as) 6653 e->rank = e->value.compcall.tbp->u.specific->n.sym->as->rank; 6654 6655 /* For now, we simply transform it into an EXPR_FUNCTION call with the same 6656 arglist to the TBP's binding target. */ 6657 6658 if (!resolve_typebound_static (e, &target, &newactual)) 6659 return false; 6660 6661 e->value.function.actual = newactual; 6662 e->value.function.name = NULL; 6663 e->value.function.esym = target->n.sym; 6664 e->value.function.isym = NULL; 6665 e->symtree = target; 6666 e->ts = target->n.sym->ts; 6667 e->expr_type = EXPR_FUNCTION; 6668 6669 /* Resolution is not necessary if this is a class subroutine; this 6670 function only has to identify the specific proc. Resolution of 6671 the call will be done next in resolve_typebound_call. */ 6672 return gfc_resolve_expr (e); 6673} 6674 6675 6676static bool resolve_fl_derived (gfc_symbol *sym); 6677 6678 6679/* Resolve a typebound function, or 'method'. First separate all 6680 the non-CLASS references by calling resolve_compcall directly. */ 6681 6682static bool 6683resolve_typebound_function (gfc_expr* e) 6684{ 6685 gfc_symbol *declared; 6686 gfc_component *c; 6687 gfc_ref *new_ref; 6688 gfc_ref *class_ref; 6689 gfc_symtree *st; 6690 const char *name; 6691 gfc_typespec ts; 6692 gfc_expr *expr; 6693 bool overridable; 6694 6695 st = e->symtree; 6696 6697 /* Deal with typebound operators for CLASS objects. */ 6698 expr = e->value.compcall.base_object; 6699 overridable = !e->value.compcall.tbp->non_overridable; 6700 if (expr && expr->ts.type == BT_CLASS && e->value.compcall.name) 6701 { 6702 /* Since the typebound operators are generic, we have to ensure 6703 that any delays in resolution are corrected and that the vtab 6704 is present. */ 6705 ts = expr->ts; 6706 declared = ts.u.derived; 6707 c = gfc_find_component (declared, "_vptr", true, true, NULL); 6708 if (c->ts.u.derived == NULL) 6709 c->ts.u.derived = gfc_find_derived_vtab (declared); 6710 6711 if (!resolve_compcall (e, &name)) 6712 return false; 6713 6714 /* Use the generic name if it is there. */ 6715 name = name ? name : e->value.function.esym->name; 6716 e->symtree = expr->symtree; 6717 e->ref = gfc_copy_ref (expr->ref); 6718 get_declared_from_expr (&class_ref, NULL, e, false); 6719 6720 /* Trim away the extraneous references that emerge from nested 6721 use of interface.c (extend_expr). */ 6722 if (class_ref && class_ref->next) 6723 { 6724 gfc_free_ref_list (class_ref->next); 6725 class_ref->next = NULL; 6726 } 6727 else if (e->ref && !class_ref && expr->ts.type != BT_CLASS) 6728 { 6729 gfc_free_ref_list (e->ref); 6730 e->ref = NULL; 6731 } 6732 6733 gfc_add_vptr_component (e); 6734 gfc_add_component_ref (e, name); 6735 e->value.function.esym = NULL; 6736 if (expr->expr_type != EXPR_VARIABLE) 6737 e->base_expr = expr; 6738 return true; 6739 } 6740 6741 if (st == NULL) 6742 return resolve_compcall (e, NULL); 6743 6744 if (!gfc_resolve_ref (e)) 6745 return false; 6746 6747 /* Get the CLASS declared type. */ 6748 declared = get_declared_from_expr (&class_ref, &new_ref, e, true); 6749 6750 if (!resolve_fl_derived (declared)) 6751 return false; 6752 6753 /* Weed out cases of the ultimate component being a derived type. */ 6754 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) 6755 || (!class_ref && st->n.sym->ts.type != BT_CLASS)) 6756 { 6757 gfc_free_ref_list (new_ref); 6758 return resolve_compcall (e, NULL); 6759 } 6760 6761 c = gfc_find_component (declared, "_data", true, true, NULL); 6762 6763 /* Treat the call as if it is a typebound procedure, in order to roll 6764 out the correct name for the specific function. */ 6765 if (!resolve_compcall (e, &name)) 6766 { 6767 gfc_free_ref_list (new_ref); 6768 return false; 6769 } 6770 ts = e->ts; 6771 6772 if (overridable) 6773 { 6774 /* Convert the expression to a procedure pointer component call. */ 6775 e->value.function.esym = NULL; 6776 e->symtree = st; 6777 6778 if (new_ref) 6779 e->ref = new_ref; 6780 6781 /* '_vptr' points to the vtab, which contains the procedure pointers. */ 6782 gfc_add_vptr_component (e); 6783 gfc_add_component_ref (e, name); 6784 6785 /* Recover the typespec for the expression. This is really only 6786 necessary for generic procedures, where the additional call 6787 to gfc_add_component_ref seems to throw the collection of the 6788 correct typespec. */ 6789 e->ts = ts; 6790 } 6791 else if (new_ref) 6792 gfc_free_ref_list (new_ref); 6793 6794 return true; 6795} 6796 6797/* Resolve a typebound subroutine, or 'method'. First separate all 6798 the non-CLASS references by calling resolve_typebound_call 6799 directly. */ 6800 6801static bool 6802resolve_typebound_subroutine (gfc_code *code) 6803{ 6804 gfc_symbol *declared; 6805 gfc_component *c; 6806 gfc_ref *new_ref; 6807 gfc_ref *class_ref; 6808 gfc_symtree *st; 6809 const char *name; 6810 gfc_typespec ts; 6811 gfc_expr *expr; 6812 bool overridable; 6813 6814 st = code->expr1->symtree; 6815 6816 /* Deal with typebound operators for CLASS objects. */ 6817 expr = code->expr1->value.compcall.base_object; 6818 overridable = !code->expr1->value.compcall.tbp->non_overridable; 6819 if (expr && expr->ts.type == BT_CLASS && code->expr1->value.compcall.name) 6820 { 6821 /* If the base_object is not a variable, the corresponding actual 6822 argument expression must be stored in e->base_expression so 6823 that the corresponding tree temporary can be used as the base 6824 object in gfc_conv_procedure_call. */ 6825 if (expr->expr_type != EXPR_VARIABLE) 6826 { 6827 gfc_actual_arglist *args; 6828 6829 args= code->expr1->value.function.actual; 6830 for (; args; args = args->next) 6831 if (expr == args->expr) 6832 expr = args->expr; 6833 } 6834 6835 /* Since the typebound operators are generic, we have to ensure 6836 that any delays in resolution are corrected and that the vtab 6837 is present. */ 6838 declared = expr->ts.u.derived; 6839 c = gfc_find_component (declared, "_vptr", true, true, NULL); 6840 if (c->ts.u.derived == NULL) 6841 c->ts.u.derived = gfc_find_derived_vtab (declared); 6842 6843 if (!resolve_typebound_call (code, &name, NULL)) 6844 return false; 6845 6846 /* Use the generic name if it is there. */ 6847 name = name ? name : code->expr1->value.function.esym->name; 6848 code->expr1->symtree = expr->symtree; 6849 code->expr1->ref = gfc_copy_ref (expr->ref); 6850 6851 /* Trim away the extraneous references that emerge from nested 6852 use of interface.c (extend_expr). */ 6853 get_declared_from_expr (&class_ref, NULL, code->expr1, false); 6854 if (class_ref && class_ref->next) 6855 { 6856 gfc_free_ref_list (class_ref->next); 6857 class_ref->next = NULL; 6858 } 6859 else if (code->expr1->ref && !class_ref) 6860 { 6861 gfc_free_ref_list (code->expr1->ref); 6862 code->expr1->ref = NULL; 6863 } 6864 6865 /* Now use the procedure in the vtable. */ 6866 gfc_add_vptr_component (code->expr1); 6867 gfc_add_component_ref (code->expr1, name); 6868 code->expr1->value.function.esym = NULL; 6869 if (expr->expr_type != EXPR_VARIABLE) 6870 code->expr1->base_expr = expr; 6871 return true; 6872 } 6873 6874 if (st == NULL) 6875 return resolve_typebound_call (code, NULL, NULL); 6876 6877 if (!gfc_resolve_ref (code->expr1)) 6878 return false; 6879 6880 /* Get the CLASS declared type. */ 6881 get_declared_from_expr (&class_ref, &new_ref, code->expr1, true); 6882 6883 /* Weed out cases of the ultimate component being a derived type. */ 6884 if ((class_ref && gfc_bt_struct (class_ref->u.c.component->ts.type)) 6885 || (!class_ref && st->n.sym->ts.type != BT_CLASS)) 6886 { 6887 gfc_free_ref_list (new_ref); 6888 return resolve_typebound_call (code, NULL, NULL); 6889 } 6890 6891 if (!resolve_typebound_call (code, &name, &overridable)) 6892 { 6893 gfc_free_ref_list (new_ref); 6894 return false; 6895 } 6896 ts = code->expr1->ts; 6897 6898 if (overridable) 6899 { 6900 /* Convert the expression to a procedure pointer component call. */ 6901 code->expr1->value.function.esym = NULL; 6902 code->expr1->symtree = st; 6903 6904 if (new_ref) 6905 code->expr1->ref = new_ref; 6906 6907 /* '_vptr' points to the vtab, which contains the procedure pointers. */ 6908 gfc_add_vptr_component (code->expr1); 6909 gfc_add_component_ref (code->expr1, name); 6910 6911 /* Recover the typespec for the expression. This is really only 6912 necessary for generic procedures, where the additional call 6913 to gfc_add_component_ref seems to throw the collection of the 6914 correct typespec. */ 6915 code->expr1->ts = ts; 6916 } 6917 else if (new_ref) 6918 gfc_free_ref_list (new_ref); 6919 6920 return true; 6921} 6922 6923 6924/* Resolve a CALL to a Procedure Pointer Component (Subroutine). */ 6925 6926static bool 6927resolve_ppc_call (gfc_code* c) 6928{ 6929 gfc_component *comp; 6930 6931 comp = gfc_get_proc_ptr_comp (c->expr1); 6932 gcc_assert (comp != NULL); 6933 6934 c->resolved_sym = c->expr1->symtree->n.sym; 6935 c->expr1->expr_type = EXPR_VARIABLE; 6936 6937 if (!comp->attr.subroutine) 6938 gfc_add_subroutine (&comp->attr, comp->name, &c->expr1->where); 6939 6940 if (!gfc_resolve_ref (c->expr1)) 6941 return false; 6942 6943 if (!update_ppc_arglist (c->expr1)) 6944 return false; 6945 6946 c->ext.actual = c->expr1->value.compcall.actual; 6947 6948 if (!resolve_actual_arglist (c->ext.actual, comp->attr.proc, 6949 !(comp->ts.interface 6950 && comp->ts.interface->formal))) 6951 return false; 6952 6953 if (!pure_subroutine (comp->ts.interface, comp->name, &c->expr1->where)) 6954 return false; 6955 6956 gfc_ppc_use (comp, &c->expr1->value.compcall.actual, &c->expr1->where); 6957 6958 return true; 6959} 6960 6961 6962/* Resolve a Function Call to a Procedure Pointer Component (Function). */ 6963 6964static bool 6965resolve_expr_ppc (gfc_expr* e) 6966{ 6967 gfc_component *comp; 6968 6969 comp = gfc_get_proc_ptr_comp (e); 6970 gcc_assert (comp != NULL); 6971 6972 /* Convert to EXPR_FUNCTION. */ 6973 e->expr_type = EXPR_FUNCTION; 6974 e->value.function.isym = NULL; 6975 e->value.function.actual = e->value.compcall.actual; 6976 e->ts = comp->ts; 6977 if (comp->as != NULL) 6978 e->rank = comp->as->rank; 6979 6980 if (!comp->attr.function) 6981 gfc_add_function (&comp->attr, comp->name, &e->where); 6982 6983 if (!gfc_resolve_ref (e)) 6984 return false; 6985 6986 if (!resolve_actual_arglist (e->value.function.actual, comp->attr.proc, 6987 !(comp->ts.interface 6988 && comp->ts.interface->formal))) 6989 return false; 6990 6991 if (!update_ppc_arglist (e)) 6992 return false; 6993 6994 if (!check_pure_function(e)) 6995 return false; 6996 6997 gfc_ppc_use (comp, &e->value.compcall.actual, &e->where); 6998 6999 return true; 7000} 7001 7002 7003static bool 7004gfc_is_expandable_expr (gfc_expr *e) 7005{ 7006 gfc_constructor *con; 7007 7008 if (e->expr_type == EXPR_ARRAY) 7009 { 7010 /* Traverse the constructor looking for variables that are flavor 7011 parameter. Parameters must be expanded since they are fully used at 7012 compile time. */ 7013 con = gfc_constructor_first (e->value.constructor); 7014 for (; con; con = gfc_constructor_next (con)) 7015 { 7016 if (con->expr->expr_type == EXPR_VARIABLE 7017 && con->expr->symtree 7018 && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER 7019 || con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE)) 7020 return true; 7021 if (con->expr->expr_type == EXPR_ARRAY 7022 && gfc_is_expandable_expr (con->expr)) 7023 return true; 7024 } 7025 } 7026 7027 return false; 7028} 7029 7030 7031/* Sometimes variables in specification expressions of the result 7032 of module procedures in submodules wind up not being the 'real' 7033 dummy. Find this, if possible, in the namespace of the first 7034 formal argument. */ 7035 7036static void 7037fixup_unique_dummy (gfc_expr *e) 7038{ 7039 gfc_symtree *st = NULL; 7040 gfc_symbol *s = NULL; 7041 7042 if (e->symtree->n.sym->ns->proc_name 7043 && e->symtree->n.sym->ns->proc_name->formal) 7044 s = e->symtree->n.sym->ns->proc_name->formal->sym; 7045 7046 if (s != NULL) 7047 st = gfc_find_symtree (s->ns->sym_root, e->symtree->n.sym->name); 7048 7049 if (st != NULL 7050 && st->n.sym != NULL 7051 && st->n.sym->attr.dummy) 7052 e->symtree = st; 7053} 7054 7055/* Resolve an expression. That is, make sure that types of operands agree 7056 with their operators, intrinsic operators are converted to function calls 7057 for overloaded types and unresolved function references are resolved. */ 7058 7059bool 7060gfc_resolve_expr (gfc_expr *e) 7061{ 7062 bool t; 7063 bool inquiry_save, actual_arg_save, first_actual_arg_save; 7064 7065 if (e == NULL || e->do_not_resolve_again) 7066 return true; 7067 7068 /* inquiry_argument only applies to variables. */ 7069 inquiry_save = inquiry_argument; 7070 actual_arg_save = actual_arg; 7071 first_actual_arg_save = first_actual_arg; 7072 7073 if (e->expr_type != EXPR_VARIABLE) 7074 { 7075 inquiry_argument = false; 7076 actual_arg = false; 7077 first_actual_arg = false; 7078 } 7079 else if (e->symtree != NULL 7080 && *e->symtree->name == '@' 7081 && e->symtree->n.sym->attr.dummy) 7082 { 7083 /* Deal with submodule specification expressions that are not 7084 found to be referenced in module.c(read_cleanup). */ 7085 fixup_unique_dummy (e); 7086 } 7087 7088 switch (e->expr_type) 7089 { 7090 case EXPR_OP: 7091 t = resolve_operator (e); 7092 break; 7093 7094 case EXPR_FUNCTION: 7095 case EXPR_VARIABLE: 7096 7097 if (check_host_association (e)) 7098 t = resolve_function (e); 7099 else 7100 t = resolve_variable (e); 7101 7102 if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref 7103 && e->ref->type != REF_SUBSTRING) 7104 gfc_resolve_substring_charlen (e); 7105 7106 break; 7107 7108 case EXPR_COMPCALL: 7109 t = resolve_typebound_function (e); 7110 break; 7111 7112 case EXPR_SUBSTRING: 7113 t = gfc_resolve_ref (e); 7114 break; 7115 7116 case EXPR_CONSTANT: 7117 case EXPR_NULL: 7118 t = true; 7119 break; 7120 7121 case EXPR_PPC: 7122 t = resolve_expr_ppc (e); 7123 break; 7124 7125 case EXPR_ARRAY: 7126 t = false; 7127 if (!gfc_resolve_ref (e)) 7128 break; 7129 7130 t = gfc_resolve_array_constructor (e); 7131 /* Also try to expand a constructor. */ 7132 if (t) 7133 { 7134 gfc_expression_rank (e); 7135 if (gfc_is_constant_expr (e) || gfc_is_expandable_expr (e)) 7136 gfc_expand_constructor (e, false); 7137 } 7138 7139 /* This provides the opportunity for the length of constructors with 7140 character valued function elements to propagate the string length 7141 to the expression. */ 7142 if (t && e->ts.type == BT_CHARACTER) 7143 { 7144 /* For efficiency, we call gfc_expand_constructor for BT_CHARACTER 7145 here rather then add a duplicate test for it above. */ 7146 gfc_expand_constructor (e, false); 7147 t = gfc_resolve_character_array_constructor (e); 7148 } 7149 7150 break; 7151 7152 case EXPR_STRUCTURE: 7153 t = gfc_resolve_ref (e); 7154 if (!t) 7155 break; 7156 7157 t = resolve_structure_cons (e, 0); 7158 if (!t) 7159 break; 7160 7161 t = gfc_simplify_expr (e, 0); 7162 break; 7163 7164 default: 7165 gfc_internal_error ("gfc_resolve_expr(): Bad expression type"); 7166 } 7167 7168 if (e->ts.type == BT_CHARACTER && t && !e->ts.u.cl) 7169 fixup_charlen (e); 7170 7171 inquiry_argument = inquiry_save; 7172 actual_arg = actual_arg_save; 7173 first_actual_arg = first_actual_arg_save; 7174 7175 /* For some reason, resolving these expressions a second time mangles 7176 the typespec of the expression itself. */ 7177 if (t && e->expr_type == EXPR_VARIABLE 7178 && e->symtree->n.sym->attr.select_rank_temporary 7179 && UNLIMITED_POLY (e->symtree->n.sym)) 7180 e->do_not_resolve_again = 1; 7181 7182 return t; 7183} 7184 7185 7186/* Resolve an expression from an iterator. They must be scalar and have 7187 INTEGER or (optionally) REAL type. */ 7188 7189static bool 7190gfc_resolve_iterator_expr (gfc_expr *expr, bool real_ok, 7191 const char *name_msgid) 7192{ 7193 if (!gfc_resolve_expr (expr)) 7194 return false; 7195 7196 if (expr->rank != 0) 7197 { 7198 gfc_error ("%s at %L must be a scalar", _(name_msgid), &expr->where); 7199 return false; 7200 } 7201 7202 if (expr->ts.type != BT_INTEGER) 7203 { 7204 if (expr->ts.type == BT_REAL) 7205 { 7206 if (real_ok) 7207 return gfc_notify_std (GFC_STD_F95_DEL, 7208 "%s at %L must be integer", 7209 _(name_msgid), &expr->where); 7210 else 7211 { 7212 gfc_error ("%s at %L must be INTEGER", _(name_msgid), 7213 &expr->where); 7214 return false; 7215 } 7216 } 7217 else 7218 { 7219 gfc_error ("%s at %L must be INTEGER", _(name_msgid), &expr->where); 7220 return false; 7221 } 7222 } 7223 return true; 7224} 7225 7226 7227/* Resolve the expressions in an iterator structure. If REAL_OK is 7228 false allow only INTEGER type iterators, otherwise allow REAL types. 7229 Set own_scope to true for ac-implied-do and data-implied-do as those 7230 have a separate scope such that, e.g., a INTENT(IN) doesn't apply. */ 7231 7232bool 7233gfc_resolve_iterator (gfc_iterator *iter, bool real_ok, bool own_scope) 7234{ 7235 if (!gfc_resolve_iterator_expr (iter->var, real_ok, "Loop variable")) 7236 return false; 7237 7238 if (!gfc_check_vardef_context (iter->var, false, false, own_scope, 7239 _("iterator variable"))) 7240 return false; 7241 7242 if (!gfc_resolve_iterator_expr (iter->start, real_ok, 7243 "Start expression in DO loop")) 7244 return false; 7245 7246 if (!gfc_resolve_iterator_expr (iter->end, real_ok, 7247 "End expression in DO loop")) 7248 return false; 7249 7250 if (!gfc_resolve_iterator_expr (iter->step, real_ok, 7251 "Step expression in DO loop")) 7252 return false; 7253 7254 /* Convert start, end, and step to the same type as var. */ 7255 if (iter->start->ts.kind != iter->var->ts.kind 7256 || iter->start->ts.type != iter->var->ts.type) 7257 gfc_convert_type (iter->start, &iter->var->ts, 1); 7258 7259 if (iter->end->ts.kind != iter->var->ts.kind 7260 || iter->end->ts.type != iter->var->ts.type) 7261 gfc_convert_type (iter->end, &iter->var->ts, 1); 7262 7263 if (iter->step->ts.kind != iter->var->ts.kind 7264 || iter->step->ts.type != iter->var->ts.type) 7265 gfc_convert_type (iter->step, &iter->var->ts, 1); 7266 7267 if (iter->step->expr_type == EXPR_CONSTANT) 7268 { 7269 if ((iter->step->ts.type == BT_INTEGER 7270 && mpz_cmp_ui (iter->step->value.integer, 0) == 0) 7271 || (iter->step->ts.type == BT_REAL 7272 && mpfr_sgn (iter->step->value.real) == 0)) 7273 { 7274 gfc_error ("Step expression in DO loop at %L cannot be zero", 7275 &iter->step->where); 7276 return false; 7277 } 7278 } 7279 7280 if (iter->start->expr_type == EXPR_CONSTANT 7281 && iter->end->expr_type == EXPR_CONSTANT 7282 && iter->step->expr_type == EXPR_CONSTANT) 7283 { 7284 int sgn, cmp; 7285 if (iter->start->ts.type == BT_INTEGER) 7286 { 7287 sgn = mpz_cmp_ui (iter->step->value.integer, 0); 7288 cmp = mpz_cmp (iter->end->value.integer, iter->start->value.integer); 7289 } 7290 else 7291 { 7292 sgn = mpfr_sgn (iter->step->value.real); 7293 cmp = mpfr_cmp (iter->end->value.real, iter->start->value.real); 7294 } 7295 if (warn_zerotrip && ((sgn > 0 && cmp < 0) || (sgn < 0 && cmp > 0))) 7296 gfc_warning (OPT_Wzerotrip, 7297 "DO loop at %L will be executed zero times", 7298 &iter->step->where); 7299 } 7300 7301 if (iter->end->expr_type == EXPR_CONSTANT 7302 && iter->end->ts.type == BT_INTEGER 7303 && iter->step->expr_type == EXPR_CONSTANT 7304 && iter->step->ts.type == BT_INTEGER 7305 && (mpz_cmp_si (iter->step->value.integer, -1L) == 0 7306 || mpz_cmp_si (iter->step->value.integer, 1L) == 0)) 7307 { 7308 bool is_step_positive = mpz_cmp_ui (iter->step->value.integer, 1) == 0; 7309 int k = gfc_validate_kind (BT_INTEGER, iter->end->ts.kind, false); 7310 7311 if (is_step_positive 7312 && mpz_cmp (iter->end->value.integer, gfc_integer_kinds[k].huge) == 0) 7313 gfc_warning (OPT_Wundefined_do_loop, 7314 "DO loop at %L is undefined as it overflows", 7315 &iter->step->where); 7316 else if (!is_step_positive 7317 && mpz_cmp (iter->end->value.integer, 7318 gfc_integer_kinds[k].min_int) == 0) 7319 gfc_warning (OPT_Wundefined_do_loop, 7320 "DO loop at %L is undefined as it underflows", 7321 &iter->step->where); 7322 } 7323 7324 return true; 7325} 7326 7327 7328/* Traversal function for find_forall_index. f == 2 signals that 7329 that variable itself is not to be checked - only the references. */ 7330 7331static bool 7332forall_index (gfc_expr *expr, gfc_symbol *sym, int *f) 7333{ 7334 if (expr->expr_type != EXPR_VARIABLE) 7335 return false; 7336 7337 /* A scalar assignment */ 7338 if (!expr->ref || *f == 1) 7339 { 7340 if (expr->symtree->n.sym == sym) 7341 return true; 7342 else 7343 return false; 7344 } 7345 7346 if (*f == 2) 7347 *f = 1; 7348 return false; 7349} 7350 7351 7352/* Check whether the FORALL index appears in the expression or not. 7353 Returns true if SYM is found in EXPR. */ 7354 7355bool 7356find_forall_index (gfc_expr *expr, gfc_symbol *sym, int f) 7357{ 7358 if (gfc_traverse_expr (expr, sym, forall_index, f)) 7359 return true; 7360 else 7361 return false; 7362} 7363 7364 7365/* Resolve a list of FORALL iterators. The FORALL index-name is constrained 7366 to be a scalar INTEGER variable. The subscripts and stride are scalar 7367 INTEGERs, and if stride is a constant it must be nonzero. 7368 Furthermore "A subscript or stride in a forall-triplet-spec shall 7369 not contain a reference to any index-name in the 7370 forall-triplet-spec-list in which it appears." (7.5.4.1) */ 7371 7372static void 7373resolve_forall_iterators (gfc_forall_iterator *it) 7374{ 7375 gfc_forall_iterator *iter, *iter2; 7376 7377 for (iter = it; iter; iter = iter->next) 7378 { 7379 if (gfc_resolve_expr (iter->var) 7380 && (iter->var->ts.type != BT_INTEGER || iter->var->rank != 0)) 7381 gfc_error ("FORALL index-name at %L must be a scalar INTEGER", 7382 &iter->var->where); 7383 7384 if (gfc_resolve_expr (iter->start) 7385 && (iter->start->ts.type != BT_INTEGER || iter->start->rank != 0)) 7386 gfc_error ("FORALL start expression at %L must be a scalar INTEGER", 7387 &iter->start->where); 7388 if (iter->var->ts.kind != iter->start->ts.kind) 7389 gfc_convert_type (iter->start, &iter->var->ts, 1); 7390 7391 if (gfc_resolve_expr (iter->end) 7392 && (iter->end->ts.type != BT_INTEGER || iter->end->rank != 0)) 7393 gfc_error ("FORALL end expression at %L must be a scalar INTEGER", 7394 &iter->end->where); 7395 if (iter->var->ts.kind != iter->end->ts.kind) 7396 gfc_convert_type (iter->end, &iter->var->ts, 1); 7397 7398 if (gfc_resolve_expr (iter->stride)) 7399 { 7400 if (iter->stride->ts.type != BT_INTEGER || iter->stride->rank != 0) 7401 gfc_error ("FORALL stride expression at %L must be a scalar %s", 7402 &iter->stride->where, "INTEGER"); 7403 7404 if (iter->stride->expr_type == EXPR_CONSTANT 7405 && mpz_cmp_ui (iter->stride->value.integer, 0) == 0) 7406 gfc_error ("FORALL stride expression at %L cannot be zero", 7407 &iter->stride->where); 7408 } 7409 if (iter->var->ts.kind != iter->stride->ts.kind) 7410 gfc_convert_type (iter->stride, &iter->var->ts, 1); 7411 } 7412 7413 for (iter = it; iter; iter = iter->next) 7414 for (iter2 = iter; iter2; iter2 = iter2->next) 7415 { 7416 if (find_forall_index (iter2->start, iter->var->symtree->n.sym, 0) 7417 || find_forall_index (iter2->end, iter->var->symtree->n.sym, 0) 7418 || find_forall_index (iter2->stride, iter->var->symtree->n.sym, 0)) 7419 gfc_error ("FORALL index %qs may not appear in triplet " 7420 "specification at %L", iter->var->symtree->name, 7421 &iter2->start->where); 7422 } 7423} 7424 7425 7426/* Given a pointer to a symbol that is a derived type, see if it's 7427 inaccessible, i.e. if it's defined in another module and the components are 7428 PRIVATE. The search is recursive if necessary. Returns zero if no 7429 inaccessible components are found, nonzero otherwise. */ 7430 7431static int 7432derived_inaccessible (gfc_symbol *sym) 7433{ 7434 gfc_component *c; 7435 7436 if (sym->attr.use_assoc && sym->attr.private_comp) 7437 return 1; 7438 7439 for (c = sym->components; c; c = c->next) 7440 { 7441 /* Prevent an infinite loop through this function. */ 7442 if (c->ts.type == BT_DERIVED 7443 && (c->attr.pointer || c->attr.allocatable) 7444 && sym == c->ts.u.derived) 7445 continue; 7446 7447 if (c->ts.type == BT_DERIVED && derived_inaccessible (c->ts.u.derived)) 7448 return 1; 7449 } 7450 7451 return 0; 7452} 7453 7454 7455/* Resolve the argument of a deallocate expression. The expression must be 7456 a pointer or a full array. */ 7457 7458static bool 7459resolve_deallocate_expr (gfc_expr *e) 7460{ 7461 symbol_attribute attr; 7462 int allocatable, pointer; 7463 gfc_ref *ref; 7464 gfc_symbol *sym; 7465 gfc_component *c; 7466 bool unlimited; 7467 7468 if (!gfc_resolve_expr (e)) 7469 return false; 7470 7471 if (e->expr_type != EXPR_VARIABLE) 7472 goto bad; 7473 7474 sym = e->symtree->n.sym; 7475 unlimited = UNLIMITED_POLY(sym); 7476 7477 if (sym->ts.type == BT_CLASS) 7478 { 7479 allocatable = CLASS_DATA (sym)->attr.allocatable; 7480 pointer = CLASS_DATA (sym)->attr.class_pointer; 7481 } 7482 else 7483 { 7484 allocatable = sym->attr.allocatable; 7485 pointer = sym->attr.pointer; 7486 } 7487 for (ref = e->ref; ref; ref = ref->next) 7488 { 7489 switch (ref->type) 7490 { 7491 case REF_ARRAY: 7492 if (ref->u.ar.type != AR_FULL 7493 && !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0 7494 && ref->u.ar.codimen && gfc_ref_this_image (ref))) 7495 allocatable = 0; 7496 break; 7497 7498 case REF_COMPONENT: 7499 c = ref->u.c.component; 7500 if (c->ts.type == BT_CLASS) 7501 { 7502 allocatable = CLASS_DATA (c)->attr.allocatable; 7503 pointer = CLASS_DATA (c)->attr.class_pointer; 7504 } 7505 else 7506 { 7507 allocatable = c->attr.allocatable; 7508 pointer = c->attr.pointer; 7509 } 7510 break; 7511 7512 case REF_SUBSTRING: 7513 case REF_INQUIRY: 7514 allocatable = 0; 7515 break; 7516 } 7517 } 7518 7519 attr = gfc_expr_attr (e); 7520 7521 if (allocatable == 0 && attr.pointer == 0 && !unlimited) 7522 { 7523 bad: 7524 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", 7525 &e->where); 7526 return false; 7527 } 7528 7529 /* F2008, C644. */ 7530 if (gfc_is_coindexed (e)) 7531 { 7532 gfc_error ("Coindexed allocatable object at %L", &e->where); 7533 return false; 7534 } 7535 7536 if (pointer 7537 && !gfc_check_vardef_context (e, true, true, false, 7538 _("DEALLOCATE object"))) 7539 return false; 7540 if (!gfc_check_vardef_context (e, false, true, false, 7541 _("DEALLOCATE object"))) 7542 return false; 7543 7544 return true; 7545} 7546 7547 7548/* Returns true if the expression e contains a reference to the symbol sym. */ 7549static bool 7550sym_in_expr (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED) 7551{ 7552 if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym == sym) 7553 return true; 7554 7555 return false; 7556} 7557 7558bool 7559gfc_find_sym_in_expr (gfc_symbol *sym, gfc_expr *e) 7560{ 7561 return gfc_traverse_expr (e, sym, sym_in_expr, 0); 7562} 7563 7564 7565/* Given the expression node e for an allocatable/pointer of derived type to be 7566 allocated, get the expression node to be initialized afterwards (needed for 7567 derived types with default initializers, and derived types with allocatable 7568 components that need nullification.) */ 7569 7570gfc_expr * 7571gfc_expr_to_initialize (gfc_expr *e) 7572{ 7573 gfc_expr *result; 7574 gfc_ref *ref; 7575 int i; 7576 7577 result = gfc_copy_expr (e); 7578 7579 /* Change the last array reference from AR_ELEMENT to AR_FULL. */ 7580 for (ref = result->ref; ref; ref = ref->next) 7581 if (ref->type == REF_ARRAY && ref->next == NULL) 7582 { 7583 if (ref->u.ar.dimen == 0 7584 && ref->u.ar.as && ref->u.ar.as->corank) 7585 return result; 7586 7587 ref->u.ar.type = AR_FULL; 7588 7589 for (i = 0; i < ref->u.ar.dimen; i++) 7590 ref->u.ar.start[i] = ref->u.ar.end[i] = ref->u.ar.stride[i] = NULL; 7591 7592 break; 7593 } 7594 7595 gfc_free_shape (&result->shape, result->rank); 7596 7597 /* Recalculate rank, shape, etc. */ 7598 gfc_resolve_expr (result); 7599 return result; 7600} 7601 7602 7603/* If the last ref of an expression is an array ref, return a copy of the 7604 expression with that one removed. Otherwise, a copy of the original 7605 expression. This is used for allocate-expressions and pointer assignment 7606 LHS, where there may be an array specification that needs to be stripped 7607 off when using gfc_check_vardef_context. */ 7608 7609static gfc_expr* 7610remove_last_array_ref (gfc_expr* e) 7611{ 7612 gfc_expr* e2; 7613 gfc_ref** r; 7614 7615 e2 = gfc_copy_expr (e); 7616 for (r = &e2->ref; *r; r = &(*r)->next) 7617 if ((*r)->type == REF_ARRAY && !(*r)->next) 7618 { 7619 gfc_free_ref_list (*r); 7620 *r = NULL; 7621 break; 7622 } 7623 7624 return e2; 7625} 7626 7627 7628/* Used in resolve_allocate_expr to check that a allocation-object and 7629 a source-expr are conformable. This does not catch all possible 7630 cases; in particular a runtime checking is needed. */ 7631 7632static bool 7633conformable_arrays (gfc_expr *e1, gfc_expr *e2) 7634{ 7635 gfc_ref *tail; 7636 for (tail = e2->ref; tail && tail->next; tail = tail->next); 7637 7638 /* First compare rank. */ 7639 if ((tail && (!tail->u.ar.as || e1->rank != tail->u.ar.as->rank)) 7640 || (!tail && e1->rank != e2->rank)) 7641 { 7642 gfc_error ("Source-expr at %L must be scalar or have the " 7643 "same rank as the allocate-object at %L", 7644 &e1->where, &e2->where); 7645 return false; 7646 } 7647 7648 if (e1->shape) 7649 { 7650 int i; 7651 mpz_t s; 7652 7653 mpz_init (s); 7654 7655 for (i = 0; i < e1->rank; i++) 7656 { 7657 if (tail->u.ar.start[i] == NULL) 7658 break; 7659 7660 if (tail->u.ar.end[i]) 7661 { 7662 mpz_set (s, tail->u.ar.end[i]->value.integer); 7663 mpz_sub (s, s, tail->u.ar.start[i]->value.integer); 7664 mpz_add_ui (s, s, 1); 7665 } 7666 else 7667 { 7668 mpz_set (s, tail->u.ar.start[i]->value.integer); 7669 } 7670 7671 if (mpz_cmp (e1->shape[i], s) != 0) 7672 { 7673 gfc_error ("Source-expr at %L and allocate-object at %L must " 7674 "have the same shape", &e1->where, &e2->where); 7675 mpz_clear (s); 7676 return false; 7677 } 7678 } 7679 7680 mpz_clear (s); 7681 } 7682 7683 return true; 7684} 7685 7686 7687/* Resolve the expression in an ALLOCATE statement, doing the additional 7688 checks to see whether the expression is OK or not. The expression must 7689 have a trailing array reference that gives the size of the array. */ 7690 7691static bool 7692resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) 7693{ 7694 int i, pointer, allocatable, dimension, is_abstract; 7695 int codimension; 7696 bool coindexed; 7697 bool unlimited; 7698 symbol_attribute attr; 7699 gfc_ref *ref, *ref2; 7700 gfc_expr *e2; 7701 gfc_array_ref *ar; 7702 gfc_symbol *sym = NULL; 7703 gfc_alloc *a; 7704 gfc_component *c; 7705 bool t; 7706 7707 /* Mark the utmost array component as being in allocate to allow DIMEN_STAR 7708 checking of coarrays. */ 7709 for (ref = e->ref; ref; ref = ref->next) 7710 if (ref->next == NULL) 7711 break; 7712 7713 if (ref && ref->type == REF_ARRAY) 7714 ref->u.ar.in_allocate = true; 7715 7716 if (!gfc_resolve_expr (e)) 7717 goto failure; 7718 7719 /* Make sure the expression is allocatable or a pointer. If it is 7720 pointer, the next-to-last reference must be a pointer. */ 7721 7722 ref2 = NULL; 7723 if (e->symtree) 7724 sym = e->symtree->n.sym; 7725 7726 /* Check whether ultimate component is abstract and CLASS. */ 7727 is_abstract = 0; 7728 7729 /* Is the allocate-object unlimited polymorphic? */ 7730 unlimited = UNLIMITED_POLY(e); 7731 7732 if (e->expr_type != EXPR_VARIABLE) 7733 { 7734 allocatable = 0; 7735 attr = gfc_expr_attr (e); 7736 pointer = attr.pointer; 7737 dimension = attr.dimension; 7738 codimension = attr.codimension; 7739 } 7740 else 7741 { 7742 if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) 7743 { 7744 allocatable = CLASS_DATA (sym)->attr.allocatable; 7745 pointer = CLASS_DATA (sym)->attr.class_pointer; 7746 dimension = CLASS_DATA (sym)->attr.dimension; 7747 codimension = CLASS_DATA (sym)->attr.codimension; 7748 is_abstract = CLASS_DATA (sym)->attr.abstract; 7749 } 7750 else 7751 { 7752 allocatable = sym->attr.allocatable; 7753 pointer = sym->attr.pointer; 7754 dimension = sym->attr.dimension; 7755 codimension = sym->attr.codimension; 7756 } 7757 7758 coindexed = false; 7759 7760 for (ref = e->ref; ref; ref2 = ref, ref = ref->next) 7761 { 7762 switch (ref->type) 7763 { 7764 case REF_ARRAY: 7765 if (ref->u.ar.codimen > 0) 7766 { 7767 int n; 7768 for (n = ref->u.ar.dimen; 7769 n < ref->u.ar.dimen + ref->u.ar.codimen; n++) 7770 if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE) 7771 { 7772 coindexed = true; 7773 break; 7774 } 7775 } 7776 7777 if (ref->next != NULL) 7778 pointer = 0; 7779 break; 7780 7781 case REF_COMPONENT: 7782 /* F2008, C644. */ 7783 if (coindexed) 7784 { 7785 gfc_error ("Coindexed allocatable object at %L", 7786 &e->where); 7787 goto failure; 7788 } 7789 7790 c = ref->u.c.component; 7791 if (c->ts.type == BT_CLASS) 7792 { 7793 allocatable = CLASS_DATA (c)->attr.allocatable; 7794 pointer = CLASS_DATA (c)->attr.class_pointer; 7795 dimension = CLASS_DATA (c)->attr.dimension; 7796 codimension = CLASS_DATA (c)->attr.codimension; 7797 is_abstract = CLASS_DATA (c)->attr.abstract; 7798 } 7799 else 7800 { 7801 allocatable = c->attr.allocatable; 7802 pointer = c->attr.pointer; 7803 dimension = c->attr.dimension; 7804 codimension = c->attr.codimension; 7805 is_abstract = c->attr.abstract; 7806 } 7807 break; 7808 7809 case REF_SUBSTRING: 7810 case REF_INQUIRY: 7811 allocatable = 0; 7812 pointer = 0; 7813 break; 7814 } 7815 } 7816 } 7817 7818 /* Check for F08:C628. */ 7819 if (allocatable == 0 && pointer == 0 && !unlimited) 7820 { 7821 gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", 7822 &e->where); 7823 goto failure; 7824 } 7825 7826 /* Some checks for the SOURCE tag. */ 7827 if (code->expr3) 7828 { 7829 /* Check F03:C631. */ 7830 if (!gfc_type_compatible (&e->ts, &code->expr3->ts)) 7831 { 7832 gfc_error ("Type of entity at %L is type incompatible with " 7833 "source-expr at %L", &e->where, &code->expr3->where); 7834 goto failure; 7835 } 7836 7837 /* Check F03:C632 and restriction following Note 6.18. */ 7838 if (code->expr3->rank > 0 && !conformable_arrays (code->expr3, e)) 7839 goto failure; 7840 7841 /* Check F03:C633. */ 7842 if (code->expr3->ts.kind != e->ts.kind && !unlimited) 7843 { 7844 gfc_error ("The allocate-object at %L and the source-expr at %L " 7845 "shall have the same kind type parameter", 7846 &e->where, &code->expr3->where); 7847 goto failure; 7848 } 7849 7850 /* Check F2008, C642. */ 7851 if (code->expr3->ts.type == BT_DERIVED 7852 && ((codimension && gfc_expr_attr (code->expr3).lock_comp) 7853 || (code->expr3->ts.u.derived->from_intmod 7854 == INTMOD_ISO_FORTRAN_ENV 7855 && code->expr3->ts.u.derived->intmod_sym_id 7856 == ISOFORTRAN_LOCK_TYPE))) 7857 { 7858 gfc_error ("The source-expr at %L shall neither be of type " 7859 "LOCK_TYPE nor have a LOCK_TYPE component if " 7860 "allocate-object at %L is a coarray", 7861 &code->expr3->where, &e->where); 7862 goto failure; 7863 } 7864 7865 /* Check TS18508, C702/C703. */ 7866 if (code->expr3->ts.type == BT_DERIVED 7867 && ((codimension && gfc_expr_attr (code->expr3).event_comp) 7868 || (code->expr3->ts.u.derived->from_intmod 7869 == INTMOD_ISO_FORTRAN_ENV 7870 && code->expr3->ts.u.derived->intmod_sym_id 7871 == ISOFORTRAN_EVENT_TYPE))) 7872 { 7873 gfc_error ("The source-expr at %L shall neither be of type " 7874 "EVENT_TYPE nor have a EVENT_TYPE component if " 7875 "allocate-object at %L is a coarray", 7876 &code->expr3->where, &e->where); 7877 goto failure; 7878 } 7879 } 7880 7881 /* Check F08:C629. */ 7882 if (is_abstract && code->ext.alloc.ts.type == BT_UNKNOWN 7883 && !code->expr3) 7884 { 7885 gcc_assert (e->ts.type == BT_CLASS); 7886 gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " 7887 "type-spec or source-expr", sym->name, &e->where); 7888 goto failure; 7889 } 7890 7891 /* Check F08:C632. */ 7892 if (code->ext.alloc.ts.type == BT_CHARACTER && !e->ts.deferred 7893 && !UNLIMITED_POLY (e)) 7894 { 7895 int cmp; 7896 7897 if (!e->ts.u.cl->length) 7898 goto failure; 7899 7900 cmp = gfc_dep_compare_expr (e->ts.u.cl->length, 7901 code->ext.alloc.ts.u.cl->length); 7902 if (cmp == 1 || cmp == -1 || cmp == -3) 7903 { 7904 gfc_error ("Allocating %s at %L with type-spec requires the same " 7905 "character-length parameter as in the declaration", 7906 sym->name, &e->where); 7907 goto failure; 7908 } 7909 } 7910 7911 /* In the variable definition context checks, gfc_expr_attr is used 7912 on the expression. This is fooled by the array specification 7913 present in e, thus we have to eliminate that one temporarily. */ 7914 e2 = remove_last_array_ref (e); 7915 t = true; 7916 if (t && pointer) 7917 t = gfc_check_vardef_context (e2, true, true, false, 7918 _("ALLOCATE object")); 7919 if (t) 7920 t = gfc_check_vardef_context (e2, false, true, false, 7921 _("ALLOCATE object")); 7922 gfc_free_expr (e2); 7923 if (!t) 7924 goto failure; 7925 7926 if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension 7927 && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) 7928 { 7929 /* For class arrays, the initialization with SOURCE is done 7930 using _copy and trans_call. It is convenient to exploit that 7931 when the allocated type is different from the declared type but 7932 no SOURCE exists by setting expr3. */ 7933 code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); 7934 } 7935 else if (flag_coarray != GFC_FCOARRAY_LIB && e->ts.type == BT_DERIVED 7936 && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 7937 && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 7938 { 7939 /* We have to zero initialize the integer variable. */ 7940 code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0); 7941 } 7942 7943 if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3)) 7944 { 7945 /* Make sure the vtab symbol is present when 7946 the module variables are generated. */ 7947 gfc_typespec ts = e->ts; 7948 if (code->expr3) 7949 ts = code->expr3->ts; 7950 else if (code->ext.alloc.ts.type == BT_DERIVED) 7951 ts = code->ext.alloc.ts; 7952 7953 /* Finding the vtab also publishes the type's symbol. Therefore this 7954 statement is necessary. */ 7955 gfc_find_derived_vtab (ts.u.derived); 7956 } 7957 else if (unlimited && !UNLIMITED_POLY (code->expr3)) 7958 { 7959 /* Again, make sure the vtab symbol is present when 7960 the module variables are generated. */ 7961 gfc_typespec *ts = NULL; 7962 if (code->expr3) 7963 ts = &code->expr3->ts; 7964 else 7965 ts = &code->ext.alloc.ts; 7966 7967 gcc_assert (ts); 7968 7969 /* Finding the vtab also publishes the type's symbol. Therefore this 7970 statement is necessary. */ 7971 gfc_find_vtab (ts); 7972 } 7973 7974 if (dimension == 0 && codimension == 0) 7975 goto success; 7976 7977 /* Make sure the last reference node is an array specification. */ 7978 7979 if (!ref2 || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL 7980 || (dimension && ref2->u.ar.dimen == 0)) 7981 { 7982 /* F08:C633. */ 7983 if (code->expr3) 7984 { 7985 if (!gfc_notify_std (GFC_STD_F2008, "Array specification required " 7986 "in ALLOCATE statement at %L", &e->where)) 7987 goto failure; 7988 if (code->expr3->rank != 0) 7989 *array_alloc_wo_spec = true; 7990 else 7991 { 7992 gfc_error ("Array specification or array-valued SOURCE= " 7993 "expression required in ALLOCATE statement at %L", 7994 &e->where); 7995 goto failure; 7996 } 7997 } 7998 else 7999 { 8000 gfc_error ("Array specification required in ALLOCATE statement " 8001 "at %L", &e->where); 8002 goto failure; 8003 } 8004 } 8005 8006 /* Make sure that the array section reference makes sense in the 8007 context of an ALLOCATE specification. */ 8008 8009 ar = &ref2->u.ar; 8010 8011 if (codimension) 8012 for (i = ar->dimen; i < ar->dimen + ar->codimen; i++) 8013 { 8014 switch (ar->dimen_type[i]) 8015 { 8016 case DIMEN_THIS_IMAGE: 8017 gfc_error ("Coarray specification required in ALLOCATE statement " 8018 "at %L", &e->where); 8019 goto failure; 8020 8021 case DIMEN_RANGE: 8022 if (ar->start[i] == 0 || ar->end[i] == 0) 8023 { 8024 /* If ar->stride[i] is NULL, we issued a previous error. */ 8025 if (ar->stride[i] == NULL) 8026 gfc_error ("Bad array specification in ALLOCATE statement " 8027 "at %L", &e->where); 8028 goto failure; 8029 } 8030 else if (gfc_dep_compare_expr (ar->start[i], ar->end[i]) == 1) 8031 { 8032 gfc_error ("Upper cobound is less than lower cobound at %L", 8033 &ar->start[i]->where); 8034 goto failure; 8035 } 8036 break; 8037 8038 case DIMEN_ELEMENT: 8039 if (ar->start[i]->expr_type == EXPR_CONSTANT) 8040 { 8041 gcc_assert (ar->start[i]->ts.type == BT_INTEGER); 8042 if (mpz_cmp_si (ar->start[i]->value.integer, 1) < 0) 8043 { 8044 gfc_error ("Upper cobound is less than lower cobound " 8045 "of 1 at %L", &ar->start[i]->where); 8046 goto failure; 8047 } 8048 } 8049 break; 8050 8051 case DIMEN_STAR: 8052 break; 8053 8054 default: 8055 gfc_error ("Bad array specification in ALLOCATE statement at %L", 8056 &e->where); 8057 goto failure; 8058 8059 } 8060 } 8061 for (i = 0; i < ar->dimen; i++) 8062 { 8063 if (ar->type == AR_ELEMENT || ar->type == AR_FULL) 8064 goto check_symbols; 8065 8066 switch (ar->dimen_type[i]) 8067 { 8068 case DIMEN_ELEMENT: 8069 break; 8070 8071 case DIMEN_RANGE: 8072 if (ar->start[i] != NULL 8073 && ar->end[i] != NULL 8074 && ar->stride[i] == NULL) 8075 break; 8076 8077 /* Fall through. */ 8078 8079 case DIMEN_UNKNOWN: 8080 case DIMEN_VECTOR: 8081 case DIMEN_STAR: 8082 case DIMEN_THIS_IMAGE: 8083 gfc_error ("Bad array specification in ALLOCATE statement at %L", 8084 &e->where); 8085 goto failure; 8086 } 8087 8088check_symbols: 8089 for (a = code->ext.alloc.list; a; a = a->next) 8090 { 8091 sym = a->expr->symtree->n.sym; 8092 8093 /* TODO - check derived type components. */ 8094 if (gfc_bt_struct (sym->ts.type) || sym->ts.type == BT_CLASS) 8095 continue; 8096 8097 if ((ar->start[i] != NULL 8098 && gfc_find_sym_in_expr (sym, ar->start[i])) 8099 || (ar->end[i] != NULL 8100 && gfc_find_sym_in_expr (sym, ar->end[i]))) 8101 { 8102 gfc_error ("%qs must not appear in the array specification at " 8103 "%L in the same ALLOCATE statement where it is " 8104 "itself allocated", sym->name, &ar->where); 8105 goto failure; 8106 } 8107 } 8108 } 8109 8110 for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) 8111 { 8112 if (ar->dimen_type[i] == DIMEN_ELEMENT 8113 || ar->dimen_type[i] == DIMEN_RANGE) 8114 { 8115 if (i == (ar->dimen + ar->codimen - 1)) 8116 { 8117 gfc_error ("Expected '*' in coindex specification in ALLOCATE " 8118 "statement at %L", &e->where); 8119 goto failure; 8120 } 8121 continue; 8122 } 8123 8124 if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) 8125 && ar->stride[i] == NULL) 8126 break; 8127 8128 gfc_error ("Bad coarray specification in ALLOCATE statement at %L", 8129 &e->where); 8130 goto failure; 8131 } 8132 8133success: 8134 return true; 8135 8136failure: 8137 return false; 8138} 8139 8140 8141static void 8142resolve_allocate_deallocate (gfc_code *code, const char *fcn) 8143{ 8144 gfc_expr *stat, *errmsg, *pe, *qe; 8145 gfc_alloc *a, *p, *q; 8146 8147 stat = code->expr1; 8148 errmsg = code->expr2; 8149 8150 /* Check the stat variable. */ 8151 if (stat) 8152 { 8153 gfc_check_vardef_context (stat, false, false, false, 8154 _("STAT variable")); 8155 8156 if ((stat->ts.type != BT_INTEGER 8157 && !(stat->ref && (stat->ref->type == REF_ARRAY 8158 || stat->ref->type == REF_COMPONENT))) 8159 || stat->rank > 0) 8160 gfc_error ("Stat-variable at %L must be a scalar INTEGER " 8161 "variable", &stat->where); 8162 8163 for (p = code->ext.alloc.list; p; p = p->next) 8164 if (p->expr->symtree->n.sym->name == stat->symtree->n.sym->name) 8165 { 8166 gfc_ref *ref1, *ref2; 8167 bool found = true; 8168 8169 for (ref1 = p->expr->ref, ref2 = stat->ref; ref1 && ref2; 8170 ref1 = ref1->next, ref2 = ref2->next) 8171 { 8172 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) 8173 continue; 8174 if (ref1->u.c.component->name != ref2->u.c.component->name) 8175 { 8176 found = false; 8177 break; 8178 } 8179 } 8180 8181 if (found) 8182 { 8183 gfc_error ("Stat-variable at %L shall not be %sd within " 8184 "the same %s statement", &stat->where, fcn, fcn); 8185 break; 8186 } 8187 } 8188 } 8189 8190 /* Check the errmsg variable. */ 8191 if (errmsg) 8192 { 8193 if (!stat) 8194 gfc_warning (0, "ERRMSG at %L is useless without a STAT tag", 8195 &errmsg->where); 8196 8197 gfc_check_vardef_context (errmsg, false, false, false, 8198 _("ERRMSG variable")); 8199 8200 /* F18:R928 alloc-opt is ERRMSG = errmsg-variable 8201 F18:R930 errmsg-variable is scalar-default-char-variable 8202 F18:R906 default-char-variable is variable 8203 F18:C906 default-char-variable shall be default character. */ 8204 if ((errmsg->ts.type != BT_CHARACTER 8205 && !(errmsg->ref 8206 && (errmsg->ref->type == REF_ARRAY 8207 || errmsg->ref->type == REF_COMPONENT))) 8208 || errmsg->rank > 0 8209 || errmsg->ts.kind != gfc_default_character_kind) 8210 gfc_error ("ERRMSG variable at %L shall be a scalar default CHARACTER " 8211 "variable", &errmsg->where); 8212 8213 for (p = code->ext.alloc.list; p; p = p->next) 8214 if (p->expr->symtree->n.sym->name == errmsg->symtree->n.sym->name) 8215 { 8216 gfc_ref *ref1, *ref2; 8217 bool found = true; 8218 8219 for (ref1 = p->expr->ref, ref2 = errmsg->ref; ref1 && ref2; 8220 ref1 = ref1->next, ref2 = ref2->next) 8221 { 8222 if (ref1->type != REF_COMPONENT || ref2->type != REF_COMPONENT) 8223 continue; 8224 if (ref1->u.c.component->name != ref2->u.c.component->name) 8225 { 8226 found = false; 8227 break; 8228 } 8229 } 8230 8231 if (found) 8232 { 8233 gfc_error ("Errmsg-variable at %L shall not be %sd within " 8234 "the same %s statement", &errmsg->where, fcn, fcn); 8235 break; 8236 } 8237 } 8238 } 8239 8240 /* Check that an allocate-object appears only once in the statement. */ 8241 8242 for (p = code->ext.alloc.list; p; p = p->next) 8243 { 8244 pe = p->expr; 8245 for (q = p->next; q; q = q->next) 8246 { 8247 qe = q->expr; 8248 if (pe->symtree->n.sym->name == qe->symtree->n.sym->name) 8249 { 8250 /* This is a potential collision. */ 8251 gfc_ref *pr = pe->ref; 8252 gfc_ref *qr = qe->ref; 8253 8254 /* Follow the references until 8255 a) They start to differ, in which case there is no error; 8256 you can deallocate a%b and a%c in a single statement 8257 b) Both of them stop, which is an error 8258 c) One of them stops, which is also an error. */ 8259 while (1) 8260 { 8261 if (pr == NULL && qr == NULL) 8262 { 8263 gfc_error ("Allocate-object at %L also appears at %L", 8264 &pe->where, &qe->where); 8265 break; 8266 } 8267 else if (pr != NULL && qr == NULL) 8268 { 8269 gfc_error ("Allocate-object at %L is subobject of" 8270 " object at %L", &pe->where, &qe->where); 8271 break; 8272 } 8273 else if (pr == NULL && qr != NULL) 8274 { 8275 gfc_error ("Allocate-object at %L is subobject of" 8276 " object at %L", &qe->where, &pe->where); 8277 break; 8278 } 8279 /* Here, pr != NULL && qr != NULL */ 8280 gcc_assert(pr->type == qr->type); 8281 if (pr->type == REF_ARRAY) 8282 { 8283 /* Handle cases like allocate(v(3)%x(3), v(2)%x(3)), 8284 which are legal. */ 8285 gcc_assert (qr->type == REF_ARRAY); 8286 8287 if (pr->next && qr->next) 8288 { 8289 int i; 8290 gfc_array_ref *par = &(pr->u.ar); 8291 gfc_array_ref *qar = &(qr->u.ar); 8292 8293 for (i=0; i<par->dimen; i++) 8294 { 8295 if ((par->start[i] != NULL 8296 || qar->start[i] != NULL) 8297 && gfc_dep_compare_expr (par->start[i], 8298 qar->start[i]) != 0) 8299 goto break_label; 8300 } 8301 } 8302 } 8303 else 8304 { 8305 if (pr->u.c.component->name != qr->u.c.component->name) 8306 break; 8307 } 8308 8309 pr = pr->next; 8310 qr = qr->next; 8311 } 8312 break_label: 8313 ; 8314 } 8315 } 8316 } 8317 8318 if (strcmp (fcn, "ALLOCATE") == 0) 8319 { 8320 bool arr_alloc_wo_spec = false; 8321 8322 /* Resolving the expr3 in the loop over all objects to allocate would 8323 execute loop invariant code for each loop item. Therefore do it just 8324 once here. */ 8325 if (code->expr3 && code->expr3->mold 8326 && code->expr3->ts.type == BT_DERIVED) 8327 { 8328 /* Default initialization via MOLD (non-polymorphic). */ 8329 gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts); 8330 if (rhs != NULL) 8331 { 8332 gfc_resolve_expr (rhs); 8333 gfc_free_expr (code->expr3); 8334 code->expr3 = rhs; 8335 } 8336 } 8337 for (a = code->ext.alloc.list; a; a = a->next) 8338 resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec); 8339 8340 if (arr_alloc_wo_spec && code->expr3) 8341 { 8342 /* Mark the allocate to have to take the array specification 8343 from the expr3. */ 8344 code->ext.alloc.arr_spec_from_expr3 = 1; 8345 } 8346 } 8347 else 8348 { 8349 for (a = code->ext.alloc.list; a; a = a->next) 8350 resolve_deallocate_expr (a->expr); 8351 } 8352} 8353 8354 8355/************ SELECT CASE resolution subroutines ************/ 8356 8357/* Callback function for our mergesort variant. Determines interval 8358 overlaps for CASEs. Return <0 if op1 < op2, 0 for overlap, >0 for 8359 op1 > op2. Assumes we're not dealing with the default case. 8360 We have op1 = (:L), (K:L) or (K:) and op2 = (:N), (M:N) or (M:). 8361 There are nine situations to check. */ 8362 8363static int 8364compare_cases (const gfc_case *op1, const gfc_case *op2) 8365{ 8366 int retval; 8367 8368 if (op1->low == NULL) /* op1 = (:L) */ 8369 { 8370 /* op2 = (:N), so overlap. */ 8371 retval = 0; 8372 /* op2 = (M:) or (M:N), L < M */ 8373 if (op2->low != NULL 8374 && gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) 8375 retval = -1; 8376 } 8377 else if (op1->high == NULL) /* op1 = (K:) */ 8378 { 8379 /* op2 = (M:), so overlap. */ 8380 retval = 0; 8381 /* op2 = (:N) or (M:N), K > N */ 8382 if (op2->high != NULL 8383 && gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) 8384 retval = 1; 8385 } 8386 else /* op1 = (K:L) */ 8387 { 8388 if (op2->low == NULL) /* op2 = (:N), K > N */ 8389 retval = (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) 8390 ? 1 : 0; 8391 else if (op2->high == NULL) /* op2 = (M:), L < M */ 8392 retval = (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) 8393 ? -1 : 0; 8394 else /* op2 = (M:N) */ 8395 { 8396 retval = 0; 8397 /* L < M */ 8398 if (gfc_compare_expr (op1->high, op2->low, INTRINSIC_LT) < 0) 8399 retval = -1; 8400 /* K > N */ 8401 else if (gfc_compare_expr (op1->low, op2->high, INTRINSIC_GT) > 0) 8402 retval = 1; 8403 } 8404 } 8405 8406 return retval; 8407} 8408 8409 8410/* Merge-sort a double linked case list, detecting overlap in the 8411 process. LIST is the head of the double linked case list before it 8412 is sorted. Returns the head of the sorted list if we don't see any 8413 overlap, or NULL otherwise. */ 8414 8415static gfc_case * 8416check_case_overlap (gfc_case *list) 8417{ 8418 gfc_case *p, *q, *e, *tail; 8419 int insize, nmerges, psize, qsize, cmp, overlap_seen; 8420 8421 /* If the passed list was empty, return immediately. */ 8422 if (!list) 8423 return NULL; 8424 8425 overlap_seen = 0; 8426 insize = 1; 8427 8428 /* Loop unconditionally. The only exit from this loop is a return 8429 statement, when we've finished sorting the case list. */ 8430 for (;;) 8431 { 8432 p = list; 8433 list = NULL; 8434 tail = NULL; 8435 8436 /* Count the number of merges we do in this pass. */ 8437 nmerges = 0; 8438 8439 /* Loop while there exists a merge to be done. */ 8440 while (p) 8441 { 8442 int i; 8443 8444 /* Count this merge. */ 8445 nmerges++; 8446 8447 /* Cut the list in two pieces by stepping INSIZE places 8448 forward in the list, starting from P. */ 8449 psize = 0; 8450 q = p; 8451 for (i = 0; i < insize; i++) 8452 { 8453 psize++; 8454 q = q->right; 8455 if (!q) 8456 break; 8457 } 8458 qsize = insize; 8459 8460 /* Now we have two lists. Merge them! */ 8461 while (psize > 0 || (qsize > 0 && q != NULL)) 8462 { 8463 /* See from which the next case to merge comes from. */ 8464 if (psize == 0) 8465 { 8466 /* P is empty so the next case must come from Q. */ 8467 e = q; 8468 q = q->right; 8469 qsize--; 8470 } 8471 else if (qsize == 0 || q == NULL) 8472 { 8473 /* Q is empty. */ 8474 e = p; 8475 p = p->right; 8476 psize--; 8477 } 8478 else 8479 { 8480 cmp = compare_cases (p, q); 8481 if (cmp < 0) 8482 { 8483 /* The whole case range for P is less than the 8484 one for Q. */ 8485 e = p; 8486 p = p->right; 8487 psize--; 8488 } 8489 else if (cmp > 0) 8490 { 8491 /* The whole case range for Q is greater than 8492 the case range for P. */ 8493 e = q; 8494 q = q->right; 8495 qsize--; 8496 } 8497 else 8498 { 8499 /* The cases overlap, or they are the same 8500 element in the list. Either way, we must 8501 issue an error and get the next case from P. */ 8502 /* FIXME: Sort P and Q by line number. */ 8503 gfc_error ("CASE label at %L overlaps with CASE " 8504 "label at %L", &p->where, &q->where); 8505 overlap_seen = 1; 8506 e = p; 8507 p = p->right; 8508 psize--; 8509 } 8510 } 8511 8512 /* Add the next element to the merged list. */ 8513 if (tail) 8514 tail->right = e; 8515 else 8516 list = e; 8517 e->left = tail; 8518 tail = e; 8519 } 8520 8521 /* P has now stepped INSIZE places along, and so has Q. So 8522 they're the same. */ 8523 p = q; 8524 } 8525 tail->right = NULL; 8526 8527 /* If we have done only one merge or none at all, we've 8528 finished sorting the cases. */ 8529 if (nmerges <= 1) 8530 { 8531 if (!overlap_seen) 8532 return list; 8533 else 8534 return NULL; 8535 } 8536 8537 /* Otherwise repeat, merging lists twice the size. */ 8538 insize *= 2; 8539 } 8540} 8541 8542 8543/* Check to see if an expression is suitable for use in a CASE statement. 8544 Makes sure that all case expressions are scalar constants of the same 8545 type. Return false if anything is wrong. */ 8546 8547static bool 8548validate_case_label_expr (gfc_expr *e, gfc_expr *case_expr) 8549{ 8550 if (e == NULL) return true; 8551 8552 if (e->ts.type != case_expr->ts.type) 8553 { 8554 gfc_error ("Expression in CASE statement at %L must be of type %s", 8555 &e->where, gfc_basic_typename (case_expr->ts.type)); 8556 return false; 8557 } 8558 8559 /* C805 (R808) For a given case-construct, each case-value shall be of 8560 the same type as case-expr. For character type, length differences 8561 are allowed, but the kind type parameters shall be the same. */ 8562 8563 if (case_expr->ts.type == BT_CHARACTER && e->ts.kind != case_expr->ts.kind) 8564 { 8565 gfc_error ("Expression in CASE statement at %L must be of kind %d", 8566 &e->where, case_expr->ts.kind); 8567 return false; 8568 } 8569 8570 /* Convert the case value kind to that of case expression kind, 8571 if needed */ 8572 8573 if (e->ts.kind != case_expr->ts.kind) 8574 gfc_convert_type_warn (e, &case_expr->ts, 2, 0); 8575 8576 if (e->rank != 0) 8577 { 8578 gfc_error ("Expression in CASE statement at %L must be scalar", 8579 &e->where); 8580 return false; 8581 } 8582 8583 return true; 8584} 8585 8586 8587/* Given a completely parsed select statement, we: 8588 8589 - Validate all expressions and code within the SELECT. 8590 - Make sure that the selection expression is not of the wrong type. 8591 - Make sure that no case ranges overlap. 8592 - Eliminate unreachable cases and unreachable code resulting from 8593 removing case labels. 8594 8595 The standard does allow unreachable cases, e.g. CASE (5:3). But 8596 they are a hassle for code generation, and to prevent that, we just 8597 cut them out here. This is not necessary for overlapping cases 8598 because they are illegal and we never even try to generate code. 8599 8600 We have the additional caveat that a SELECT construct could have 8601 been a computed GOTO in the source code. Fortunately we can fairly 8602 easily work around that here: The case_expr for a "real" SELECT CASE 8603 is in code->expr1, but for a computed GOTO it is in code->expr2. All 8604 we have to do is make sure that the case_expr is a scalar integer 8605 expression. */ 8606 8607static void 8608resolve_select (gfc_code *code, bool select_type) 8609{ 8610 gfc_code *body; 8611 gfc_expr *case_expr; 8612 gfc_case *cp, *default_case, *tail, *head; 8613 int seen_unreachable; 8614 int seen_logical; 8615 int ncases; 8616 bt type; 8617 bool t; 8618 8619 if (code->expr1 == NULL) 8620 { 8621 /* This was actually a computed GOTO statement. */ 8622 case_expr = code->expr2; 8623 if (case_expr->ts.type != BT_INTEGER|| case_expr->rank != 0) 8624 gfc_error ("Selection expression in computed GOTO statement " 8625 "at %L must be a scalar integer expression", 8626 &case_expr->where); 8627 8628 /* Further checking is not necessary because this SELECT was built 8629 by the compiler, so it should always be OK. Just move the 8630 case_expr from expr2 to expr so that we can handle computed 8631 GOTOs as normal SELECTs from here on. */ 8632 code->expr1 = code->expr2; 8633 code->expr2 = NULL; 8634 return; 8635 } 8636 8637 case_expr = code->expr1; 8638 type = case_expr->ts.type; 8639 8640 /* F08:C830. */ 8641 if (type != BT_LOGICAL && type != BT_INTEGER && type != BT_CHARACTER) 8642 { 8643 gfc_error ("Argument of SELECT statement at %L cannot be %s", 8644 &case_expr->where, gfc_typename (case_expr)); 8645 8646 /* Punt. Going on here just produce more garbage error messages. */ 8647 return; 8648 } 8649 8650 /* F08:R842. */ 8651 if (!select_type && case_expr->rank != 0) 8652 { 8653 gfc_error ("Argument of SELECT statement at %L must be a scalar " 8654 "expression", &case_expr->where); 8655 8656 /* Punt. */ 8657 return; 8658 } 8659 8660 /* Raise a warning if an INTEGER case value exceeds the range of 8661 the case-expr. Later, all expressions will be promoted to the 8662 largest kind of all case-labels. */ 8663 8664 if (type == BT_INTEGER) 8665 for (body = code->block; body; body = body->block) 8666 for (cp = body->ext.block.case_list; cp; cp = cp->next) 8667 { 8668 if (cp->low 8669 && gfc_check_integer_range (cp->low->value.integer, 8670 case_expr->ts.kind) != ARITH_OK) 8671 gfc_warning (0, "Expression in CASE statement at %L is " 8672 "not in the range of %s", &cp->low->where, 8673 gfc_typename (case_expr)); 8674 8675 if (cp->high 8676 && cp->low != cp->high 8677 && gfc_check_integer_range (cp->high->value.integer, 8678 case_expr->ts.kind) != ARITH_OK) 8679 gfc_warning (0, "Expression in CASE statement at %L is " 8680 "not in the range of %s", &cp->high->where, 8681 gfc_typename (case_expr)); 8682 } 8683 8684 /* PR 19168 has a long discussion concerning a mismatch of the kinds 8685 of the SELECT CASE expression and its CASE values. Walk the lists 8686 of case values, and if we find a mismatch, promote case_expr to 8687 the appropriate kind. */ 8688 8689 if (type == BT_LOGICAL || type == BT_INTEGER) 8690 { 8691 for (body = code->block; body; body = body->block) 8692 { 8693 /* Walk the case label list. */ 8694 for (cp = body->ext.block.case_list; cp; cp = cp->next) 8695 { 8696 /* Intercept the DEFAULT case. It does not have a kind. */ 8697 if (cp->low == NULL && cp->high == NULL) 8698 continue; 8699 8700 /* Unreachable case ranges are discarded, so ignore. */ 8701 if (cp->low != NULL && cp->high != NULL 8702 && cp->low != cp->high 8703 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) 8704 continue; 8705 8706 if (cp->low != NULL 8707 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->low)) 8708 gfc_convert_type_warn (case_expr, &cp->low->ts, 2, 0); 8709 8710 if (cp->high != NULL 8711 && case_expr->ts.kind != gfc_kind_max(case_expr, cp->high)) 8712 gfc_convert_type_warn (case_expr, &cp->high->ts, 2, 0); 8713 } 8714 } 8715 } 8716 8717 /* Assume there is no DEFAULT case. */ 8718 default_case = NULL; 8719 head = tail = NULL; 8720 ncases = 0; 8721 seen_logical = 0; 8722 8723 for (body = code->block; body; body = body->block) 8724 { 8725 /* Assume the CASE list is OK, and all CASE labels can be matched. */ 8726 t = true; 8727 seen_unreachable = 0; 8728 8729 /* Walk the case label list, making sure that all case labels 8730 are legal. */ 8731 for (cp = body->ext.block.case_list; cp; cp = cp->next) 8732 { 8733 /* Count the number of cases in the whole construct. */ 8734 ncases++; 8735 8736 /* Intercept the DEFAULT case. */ 8737 if (cp->low == NULL && cp->high == NULL) 8738 { 8739 if (default_case != NULL) 8740 { 8741 gfc_error ("The DEFAULT CASE at %L cannot be followed " 8742 "by a second DEFAULT CASE at %L", 8743 &default_case->where, &cp->where); 8744 t = false; 8745 break; 8746 } 8747 else 8748 { 8749 default_case = cp; 8750 continue; 8751 } 8752 } 8753 8754 /* Deal with single value cases and case ranges. Errors are 8755 issued from the validation function. */ 8756 if (!validate_case_label_expr (cp->low, case_expr) 8757 || !validate_case_label_expr (cp->high, case_expr)) 8758 { 8759 t = false; 8760 break; 8761 } 8762 8763 if (type == BT_LOGICAL 8764 && ((cp->low == NULL || cp->high == NULL) 8765 || cp->low != cp->high)) 8766 { 8767 gfc_error ("Logical range in CASE statement at %L is not " 8768 "allowed", &cp->low->where); 8769 t = false; 8770 break; 8771 } 8772 8773 if (type == BT_LOGICAL && cp->low->expr_type == EXPR_CONSTANT) 8774 { 8775 int value; 8776 value = cp->low->value.logical == 0 ? 2 : 1; 8777 if (value & seen_logical) 8778 { 8779 gfc_error ("Constant logical value in CASE statement " 8780 "is repeated at %L", 8781 &cp->low->where); 8782 t = false; 8783 break; 8784 } 8785 seen_logical |= value; 8786 } 8787 8788 if (cp->low != NULL && cp->high != NULL 8789 && cp->low != cp->high 8790 && gfc_compare_expr (cp->low, cp->high, INTRINSIC_GT) > 0) 8791 { 8792 if (warn_surprising) 8793 gfc_warning (OPT_Wsurprising, 8794 "Range specification at %L can never be matched", 8795 &cp->where); 8796 8797 cp->unreachable = 1; 8798 seen_unreachable = 1; 8799 } 8800 else 8801 { 8802 /* If the case range can be matched, it can also overlap with 8803 other cases. To make sure it does not, we put it in a 8804 double linked list here. We sort that with a merge sort 8805 later on to detect any overlapping cases. */ 8806 if (!head) 8807 { 8808 head = tail = cp; 8809 head->right = head->left = NULL; 8810 } 8811 else 8812 { 8813 tail->right = cp; 8814 tail->right->left = tail; 8815 tail = tail->right; 8816 tail->right = NULL; 8817 } 8818 } 8819 } 8820 8821 /* It there was a failure in the previous case label, give up 8822 for this case label list. Continue with the next block. */ 8823 if (!t) 8824 continue; 8825 8826 /* See if any case labels that are unreachable have been seen. 8827 If so, we eliminate them. This is a bit of a kludge because 8828 the case lists for a single case statement (label) is a 8829 single forward linked lists. */ 8830 if (seen_unreachable) 8831 { 8832 /* Advance until the first case in the list is reachable. */ 8833 while (body->ext.block.case_list != NULL 8834 && body->ext.block.case_list->unreachable) 8835 { 8836 gfc_case *n = body->ext.block.case_list; 8837 body->ext.block.case_list = body->ext.block.case_list->next; 8838 n->next = NULL; 8839 gfc_free_case_list (n); 8840 } 8841 8842 /* Strip all other unreachable cases. */ 8843 if (body->ext.block.case_list) 8844 { 8845 for (cp = body->ext.block.case_list; cp && cp->next; cp = cp->next) 8846 { 8847 if (cp->next->unreachable) 8848 { 8849 gfc_case *n = cp->next; 8850 cp->next = cp->next->next; 8851 n->next = NULL; 8852 gfc_free_case_list (n); 8853 } 8854 } 8855 } 8856 } 8857 } 8858 8859 /* See if there were overlapping cases. If the check returns NULL, 8860 there was overlap. In that case we don't do anything. If head 8861 is non-NULL, we prepend the DEFAULT case. The sorted list can 8862 then used during code generation for SELECT CASE constructs with 8863 a case expression of a CHARACTER type. */ 8864 if (head) 8865 { 8866 head = check_case_overlap (head); 8867 8868 /* Prepend the default_case if it is there. */ 8869 if (head != NULL && default_case) 8870 { 8871 default_case->left = NULL; 8872 default_case->right = head; 8873 head->left = default_case; 8874 } 8875 } 8876 8877 /* Eliminate dead blocks that may be the result if we've seen 8878 unreachable case labels for a block. */ 8879 for (body = code; body && body->block; body = body->block) 8880 { 8881 if (body->block->ext.block.case_list == NULL) 8882 { 8883 /* Cut the unreachable block from the code chain. */ 8884 gfc_code *c = body->block; 8885 body->block = c->block; 8886 8887 /* Kill the dead block, but not the blocks below it. */ 8888 c->block = NULL; 8889 gfc_free_statements (c); 8890 } 8891 } 8892 8893 /* More than two cases is legal but insane for logical selects. 8894 Issue a warning for it. */ 8895 if (warn_surprising && type == BT_LOGICAL && ncases > 2) 8896 gfc_warning (OPT_Wsurprising, 8897 "Logical SELECT CASE block at %L has more that two cases", 8898 &code->loc); 8899} 8900 8901 8902/* Check if a derived type is extensible. */ 8903 8904bool 8905gfc_type_is_extensible (gfc_symbol *sym) 8906{ 8907 return !(sym->attr.is_bind_c || sym->attr.sequence 8908 || (sym->attr.is_class 8909 && sym->components->ts.u.derived->attr.unlimited_polymorphic)); 8910} 8911 8912 8913static void 8914resolve_types (gfc_namespace *ns); 8915 8916/* Resolve an associate-name: Resolve target and ensure the type-spec is 8917 correct as well as possibly the array-spec. */ 8918 8919static void 8920resolve_assoc_var (gfc_symbol* sym, bool resolve_target) 8921{ 8922 gfc_expr* target; 8923 8924 gcc_assert (sym->assoc); 8925 gcc_assert (sym->attr.flavor == FL_VARIABLE); 8926 8927 /* If this is for SELECT TYPE, the target may not yet be set. In that 8928 case, return. Resolution will be called later manually again when 8929 this is done. */ 8930 target = sym->assoc->target; 8931 if (!target) 8932 return; 8933 gcc_assert (!sym->assoc->dangling); 8934 8935 if (resolve_target && !gfc_resolve_expr (target)) 8936 return; 8937 8938 /* For variable targets, we get some attributes from the target. */ 8939 if (target->expr_type == EXPR_VARIABLE) 8940 { 8941 gfc_symbol *tsym, *dsym; 8942 8943 gcc_assert (target->symtree); 8944 tsym = target->symtree->n.sym; 8945 8946 if (gfc_expr_attr (target).proc_pointer) 8947 { 8948 gfc_error ("Associating entity %qs at %L is a procedure pointer", 8949 tsym->name, &target->where); 8950 return; 8951 } 8952 8953 if (tsym->attr.flavor == FL_PROCEDURE && tsym->generic 8954 && (dsym = gfc_find_dt_in_generic (tsym)) != NULL 8955 && dsym->attr.flavor == FL_DERIVED) 8956 { 8957 gfc_error ("Derived type %qs cannot be used as a variable at %L", 8958 tsym->name, &target->where); 8959 return; 8960 } 8961 8962 if (tsym->attr.flavor == FL_PROCEDURE) 8963 { 8964 bool is_error = true; 8965 if (tsym->attr.function && tsym->result == tsym) 8966 for (gfc_namespace *ns = sym->ns; ns; ns = ns->parent) 8967 if (tsym == ns->proc_name) 8968 { 8969 is_error = false; 8970 break; 8971 } 8972 if (is_error) 8973 { 8974 gfc_error ("Associating entity %qs at %L is a procedure name", 8975 tsym->name, &target->where); 8976 return; 8977 } 8978 } 8979 8980 sym->attr.asynchronous = tsym->attr.asynchronous; 8981 sym->attr.volatile_ = tsym->attr.volatile_; 8982 8983 sym->attr.target = tsym->attr.target 8984 || gfc_expr_attr (target).pointer; 8985 if (is_subref_array (target)) 8986 sym->attr.subref_array_pointer = 1; 8987 } 8988 else if (target->ts.type == BT_PROCEDURE) 8989 { 8990 gfc_error ("Associating selector-expression at %L yields a procedure", 8991 &target->where); 8992 return; 8993 } 8994 8995 if (target->expr_type == EXPR_NULL) 8996 { 8997 gfc_error ("Selector at %L cannot be NULL()", &target->where); 8998 return; 8999 } 9000 else if (target->ts.type == BT_UNKNOWN) 9001 { 9002 gfc_error ("Selector at %L has no type", &target->where); 9003 return; 9004 } 9005 9006 /* Get type if this was not already set. Note that it can be 9007 some other type than the target in case this is a SELECT TYPE 9008 selector! So we must not update when the type is already there. */ 9009 if (sym->ts.type == BT_UNKNOWN) 9010 sym->ts = target->ts; 9011 9012 gcc_assert (sym->ts.type != BT_UNKNOWN); 9013 9014 /* See if this is a valid association-to-variable. */ 9015 sym->assoc->variable = (target->expr_type == EXPR_VARIABLE 9016 && !gfc_has_vector_subscript (target)); 9017 9018 /* Finally resolve if this is an array or not. */ 9019 if (sym->attr.dimension && target->rank == 0) 9020 { 9021 /* primary.c makes the assumption that a reference to an associate 9022 name followed by a left parenthesis is an array reference. */ 9023 if (sym->ts.type != BT_CHARACTER) 9024 gfc_error ("Associate-name %qs at %L is used as array", 9025 sym->name, &sym->declared_at); 9026 sym->attr.dimension = 0; 9027 return; 9028 } 9029 9030 9031 /* We cannot deal with class selectors that need temporaries. */ 9032 if (target->ts.type == BT_CLASS 9033 && gfc_ref_needs_temporary_p (target->ref)) 9034 { 9035 gfc_error ("CLASS selector at %L needs a temporary which is not " 9036 "yet implemented", &target->where); 9037 return; 9038 } 9039 9040 if (target->ts.type == BT_CLASS) 9041 gfc_fix_class_refs (target); 9042 9043 if (target->rank != 0 && !sym->attr.select_rank_temporary) 9044 { 9045 gfc_array_spec *as; 9046 /* The rank may be incorrectly guessed at parsing, therefore make sure 9047 it is corrected now. */ 9048 if (sym->ts.type != BT_CLASS && (!sym->as || sym->assoc->rankguessed)) 9049 { 9050 if (!sym->as) 9051 sym->as = gfc_get_array_spec (); 9052 as = sym->as; 9053 as->rank = target->rank; 9054 as->type = AS_DEFERRED; 9055 as->corank = gfc_get_corank (target); 9056 sym->attr.dimension = 1; 9057 if (as->corank != 0) 9058 sym->attr.codimension = 1; 9059 } 9060 else if (sym->ts.type == BT_CLASS 9061 && CLASS_DATA (sym) 9062 && (!CLASS_DATA (sym)->as || sym->assoc->rankguessed)) 9063 { 9064 if (!CLASS_DATA (sym)->as) 9065 CLASS_DATA (sym)->as = gfc_get_array_spec (); 9066 as = CLASS_DATA (sym)->as; 9067 as->rank = target->rank; 9068 as->type = AS_DEFERRED; 9069 as->corank = gfc_get_corank (target); 9070 CLASS_DATA (sym)->attr.dimension = 1; 9071 if (as->corank != 0) 9072 CLASS_DATA (sym)->attr.codimension = 1; 9073 } 9074 } 9075 else if (!sym->attr.select_rank_temporary) 9076 { 9077 /* target's rank is 0, but the type of the sym is still array valued, 9078 which has to be corrected. */ 9079 if (sym->ts.type == BT_CLASS && sym->ts.u.derived 9080 && CLASS_DATA (sym) && CLASS_DATA (sym)->as) 9081 { 9082 gfc_array_spec *as; 9083 symbol_attribute attr; 9084 /* The associated variable's type is still the array type 9085 correct this now. */ 9086 gfc_typespec *ts = &target->ts; 9087 gfc_ref *ref; 9088 gfc_component *c; 9089 for (ref = target->ref; ref != NULL; ref = ref->next) 9090 { 9091 switch (ref->type) 9092 { 9093 case REF_COMPONENT: 9094 ts = &ref->u.c.component->ts; 9095 break; 9096 case REF_ARRAY: 9097 if (ts->type == BT_CLASS) 9098 ts = &ts->u.derived->components->ts; 9099 break; 9100 default: 9101 break; 9102 } 9103 } 9104 /* Create a scalar instance of the current class type. Because the 9105 rank of a class array goes into its name, the type has to be 9106 rebuild. The alternative of (re-)setting just the attributes 9107 and as in the current type, destroys the type also in other 9108 places. */ 9109 as = NULL; 9110 sym->ts = *ts; 9111 sym->ts.type = BT_CLASS; 9112 attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; 9113 attr.class_ok = 0; 9114 attr.associate_var = 1; 9115 attr.dimension = attr.codimension = 0; 9116 attr.class_pointer = 1; 9117 if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) 9118 gcc_unreachable (); 9119 /* Make sure the _vptr is set. */ 9120 c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); 9121 if (c->ts.u.derived == NULL) 9122 c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); 9123 CLASS_DATA (sym)->attr.pointer = 1; 9124 CLASS_DATA (sym)->attr.class_pointer = 1; 9125 gfc_set_sym_referenced (sym->ts.u.derived); 9126 gfc_commit_symbol (sym->ts.u.derived); 9127 /* _vptr now has the _vtab in it, change it to the _vtype. */ 9128 if (c->ts.u.derived->attr.vtab) 9129 c->ts.u.derived = c->ts.u.derived->ts.u.derived; 9130 c->ts.u.derived->ns->types_resolved = 0; 9131 resolve_types (c->ts.u.derived->ns); 9132 } 9133 } 9134 9135 /* Mark this as an associate variable. */ 9136 sym->attr.associate_var = 1; 9137 9138 /* Fix up the type-spec for CHARACTER types. */ 9139 if (sym->ts.type == BT_CHARACTER && !sym->attr.select_type_temporary) 9140 { 9141 if (!sym->ts.u.cl) 9142 sym->ts.u.cl = target->ts.u.cl; 9143 9144 if (sym->ts.deferred 9145 && sym->ts.u.cl == target->ts.u.cl) 9146 { 9147 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); 9148 sym->ts.deferred = 1; 9149 } 9150 9151 if (!sym->ts.u.cl->length 9152 && !sym->ts.deferred 9153 && target->expr_type == EXPR_CONSTANT) 9154 { 9155 sym->ts.u.cl->length = 9156 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 9157 target->value.character.length); 9158 } 9159 else if ((!sym->ts.u.cl->length 9160 || sym->ts.u.cl->length->expr_type != EXPR_CONSTANT) 9161 && target->expr_type != EXPR_VARIABLE) 9162 { 9163 if (!sym->ts.deferred) 9164 { 9165 sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL); 9166 sym->ts.deferred = 1; 9167 } 9168 9169 /* This is reset in trans-stmt.c after the assignment 9170 of the target expression to the associate name. */ 9171 sym->attr.allocatable = 1; 9172 } 9173 } 9174 9175 /* If the target is a good class object, so is the associate variable. */ 9176 if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) 9177 sym->attr.class_ok = 1; 9178} 9179 9180 9181/* Ensure that SELECT TYPE expressions have the correct rank and a full 9182 array reference, where necessary. The symbols are artificial and so 9183 the dimension attribute and arrayspec can also be set. In addition, 9184 sometimes the expr1 arrives as BT_DERIVED, when the symbol is BT_CLASS. 9185 This is corrected here as well.*/ 9186 9187static void 9188fixup_array_ref (gfc_expr **expr1, gfc_expr *expr2, 9189 int rank, gfc_ref *ref) 9190{ 9191 gfc_ref *nref = (*expr1)->ref; 9192 gfc_symbol *sym1 = (*expr1)->symtree->n.sym; 9193 gfc_symbol *sym2 = expr2 ? expr2->symtree->n.sym : NULL; 9194 (*expr1)->rank = rank; 9195 if (sym1->ts.type == BT_CLASS) 9196 { 9197 if ((*expr1)->ts.type != BT_CLASS) 9198 (*expr1)->ts = sym1->ts; 9199 9200 CLASS_DATA (sym1)->attr.dimension = 1; 9201 if (CLASS_DATA (sym1)->as == NULL && sym2) 9202 CLASS_DATA (sym1)->as 9203 = gfc_copy_array_spec (CLASS_DATA (sym2)->as); 9204 } 9205 else 9206 { 9207 sym1->attr.dimension = 1; 9208 if (sym1->as == NULL && sym2) 9209 sym1->as = gfc_copy_array_spec (sym2->as); 9210 } 9211 9212 for (; nref; nref = nref->next) 9213 if (nref->next == NULL) 9214 break; 9215 9216 if (ref && nref && nref->type != REF_ARRAY) 9217 nref->next = gfc_copy_ref (ref); 9218 else if (ref && !nref) 9219 (*expr1)->ref = gfc_copy_ref (ref); 9220} 9221 9222 9223static gfc_expr * 9224build_loc_call (gfc_expr *sym_expr) 9225{ 9226 gfc_expr *loc_call; 9227 loc_call = gfc_get_expr (); 9228 loc_call->expr_type = EXPR_FUNCTION; 9229 gfc_get_sym_tree ("_loc", gfc_current_ns, &loc_call->symtree, false); 9230 loc_call->symtree->n.sym->attr.flavor = FL_PROCEDURE; 9231 loc_call->symtree->n.sym->attr.intrinsic = 1; 9232 loc_call->symtree->n.sym->result = loc_call->symtree->n.sym; 9233 gfc_commit_symbol (loc_call->symtree->n.sym); 9234 loc_call->ts.type = BT_INTEGER; 9235 loc_call->ts.kind = gfc_index_integer_kind; 9236 loc_call->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_LOC); 9237 loc_call->value.function.actual = gfc_get_actual_arglist (); 9238 loc_call->value.function.actual->expr = sym_expr; 9239 loc_call->where = sym_expr->where; 9240 return loc_call; 9241} 9242 9243/* Resolve a SELECT TYPE statement. */ 9244 9245static void 9246resolve_select_type (gfc_code *code, gfc_namespace *old_ns) 9247{ 9248 gfc_symbol *selector_type; 9249 gfc_code *body, *new_st, *if_st, *tail; 9250 gfc_code *class_is = NULL, *default_case = NULL; 9251 gfc_case *c; 9252 gfc_symtree *st; 9253 char name[GFC_MAX_SYMBOL_LEN + 12 + 1]; 9254 gfc_namespace *ns; 9255 int error = 0; 9256 int rank = 0; 9257 gfc_ref* ref = NULL; 9258 gfc_expr *selector_expr = NULL; 9259 9260 ns = code->ext.block.ns; 9261 gfc_resolve (ns); 9262 9263 /* Check for F03:C813. */ 9264 if (code->expr1->ts.type != BT_CLASS 9265 && !(code->expr2 && code->expr2->ts.type == BT_CLASS)) 9266 { 9267 gfc_error ("Selector shall be polymorphic in SELECT TYPE statement " 9268 "at %L", &code->loc); 9269 return; 9270 } 9271 9272 if (!code->expr1->symtree->n.sym->attr.class_ok) 9273 return; 9274 9275 if (code->expr2) 9276 { 9277 gfc_ref *ref2 = NULL; 9278 for (ref = code->expr2->ref; ref != NULL; ref = ref->next) 9279 if (ref->type == REF_COMPONENT 9280 && ref->u.c.component->ts.type == BT_CLASS) 9281 ref2 = ref; 9282 9283 if (ref2) 9284 { 9285 if (code->expr1->symtree->n.sym->attr.untyped) 9286 code->expr1->symtree->n.sym->ts = ref2->u.c.component->ts; 9287 selector_type = CLASS_DATA (ref2->u.c.component)->ts.u.derived; 9288 } 9289 else 9290 { 9291 if (code->expr1->symtree->n.sym->attr.untyped) 9292 code->expr1->symtree->n.sym->ts = code->expr2->ts; 9293 selector_type = CLASS_DATA (code->expr2) 9294 ? CLASS_DATA (code->expr2)->ts.u.derived : code->expr2->ts.u.derived; 9295 } 9296 9297 if (code->expr2->rank 9298 && code->expr1->ts.type == BT_CLASS 9299 && CLASS_DATA (code->expr1)->as) 9300 CLASS_DATA (code->expr1)->as->rank = code->expr2->rank; 9301 9302 /* F2008: C803 The selector expression must not be coindexed. */ 9303 if (gfc_is_coindexed (code->expr2)) 9304 { 9305 gfc_error ("Selector at %L must not be coindexed", 9306 &code->expr2->where); 9307 return; 9308 } 9309 9310 } 9311 else 9312 { 9313 selector_type = CLASS_DATA (code->expr1)->ts.u.derived; 9314 9315 if (gfc_is_coindexed (code->expr1)) 9316 { 9317 gfc_error ("Selector at %L must not be coindexed", 9318 &code->expr1->where); 9319 return; 9320 } 9321 } 9322 9323 /* Loop over TYPE IS / CLASS IS cases. */ 9324 for (body = code->block; body; body = body->block) 9325 { 9326 c = body->ext.block.case_list; 9327 9328 if (!error) 9329 { 9330 /* Check for repeated cases. */ 9331 for (tail = code->block; tail; tail = tail->block) 9332 { 9333 gfc_case *d = tail->ext.block.case_list; 9334 if (tail == body) 9335 break; 9336 9337 if (c->ts.type == d->ts.type 9338 && ((c->ts.type == BT_DERIVED 9339 && c->ts.u.derived && d->ts.u.derived 9340 && !strcmp (c->ts.u.derived->name, 9341 d->ts.u.derived->name)) 9342 || c->ts.type == BT_UNKNOWN 9343 || (!(c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9344 && c->ts.kind == d->ts.kind))) 9345 { 9346 gfc_error ("TYPE IS at %L overlaps with TYPE IS at %L", 9347 &c->where, &d->where); 9348 return; 9349 } 9350 } 9351 } 9352 9353 /* Check F03:C815. */ 9354 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9355 && selector_type 9356 && !selector_type->attr.unlimited_polymorphic 9357 && !gfc_type_is_extensible (c->ts.u.derived)) 9358 { 9359 gfc_error ("Derived type %qs at %L must be extensible", 9360 c->ts.u.derived->name, &c->where); 9361 error++; 9362 continue; 9363 } 9364 9365 /* Check F03:C816. */ 9366 if (c->ts.type != BT_UNKNOWN 9367 && selector_type && !selector_type->attr.unlimited_polymorphic 9368 && ((c->ts.type != BT_DERIVED && c->ts.type != BT_CLASS) 9369 || !gfc_type_is_extension_of (selector_type, c->ts.u.derived))) 9370 { 9371 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9372 gfc_error ("Derived type %qs at %L must be an extension of %qs", 9373 c->ts.u.derived->name, &c->where, selector_type->name); 9374 else 9375 gfc_error ("Unexpected intrinsic type %qs at %L", 9376 gfc_basic_typename (c->ts.type), &c->where); 9377 error++; 9378 continue; 9379 } 9380 9381 /* Check F03:C814. */ 9382 if (c->ts.type == BT_CHARACTER 9383 && (c->ts.u.cl->length != NULL || c->ts.deferred)) 9384 { 9385 gfc_error ("The type-spec at %L shall specify that each length " 9386 "type parameter is assumed", &c->where); 9387 error++; 9388 continue; 9389 } 9390 9391 /* Intercept the DEFAULT case. */ 9392 if (c->ts.type == BT_UNKNOWN) 9393 { 9394 /* Check F03:C818. */ 9395 if (default_case) 9396 { 9397 gfc_error ("The DEFAULT CASE at %L cannot be followed " 9398 "by a second DEFAULT CASE at %L", 9399 &default_case->ext.block.case_list->where, &c->where); 9400 error++; 9401 continue; 9402 } 9403 9404 default_case = body; 9405 } 9406 } 9407 9408 if (error > 0) 9409 return; 9410 9411 /* Transform SELECT TYPE statement to BLOCK and associate selector to 9412 target if present. If there are any EXIT statements referring to the 9413 SELECT TYPE construct, this is no problem because the gfc_code 9414 reference stays the same and EXIT is equally possible from the BLOCK 9415 it is changed to. */ 9416 code->op = EXEC_BLOCK; 9417 if (code->expr2) 9418 { 9419 gfc_association_list* assoc; 9420 9421 assoc = gfc_get_association_list (); 9422 assoc->st = code->expr1->symtree; 9423 assoc->target = gfc_copy_expr (code->expr2); 9424 assoc->target->where = code->expr2->where; 9425 /* assoc->variable will be set by resolve_assoc_var. */ 9426 9427 code->ext.block.assoc = assoc; 9428 code->expr1->symtree->n.sym->assoc = assoc; 9429 9430 resolve_assoc_var (code->expr1->symtree->n.sym, false); 9431 } 9432 else 9433 code->ext.block.assoc = NULL; 9434 9435 /* Ensure that the selector rank and arrayspec are available to 9436 correct expressions in which they might be missing. */ 9437 if (code->expr2 && code->expr2->rank) 9438 { 9439 rank = code->expr2->rank; 9440 for (ref = code->expr2->ref; ref; ref = ref->next) 9441 if (ref->next == NULL) 9442 break; 9443 if (ref && ref->type == REF_ARRAY) 9444 ref = gfc_copy_ref (ref); 9445 9446 /* Fixup expr1 if necessary. */ 9447 if (rank) 9448 fixup_array_ref (&code->expr1, code->expr2, rank, ref); 9449 } 9450 else if (code->expr1->rank) 9451 { 9452 rank = code->expr1->rank; 9453 for (ref = code->expr1->ref; ref; ref = ref->next) 9454 if (ref->next == NULL) 9455 break; 9456 if (ref && ref->type == REF_ARRAY) 9457 ref = gfc_copy_ref (ref); 9458 } 9459 9460 /* Add EXEC_SELECT to switch on type. */ 9461 new_st = gfc_get_code (code->op); 9462 new_st->expr1 = code->expr1; 9463 new_st->expr2 = code->expr2; 9464 new_st->block = code->block; 9465 code->expr1 = code->expr2 = NULL; 9466 code->block = NULL; 9467 if (!ns->code) 9468 ns->code = new_st; 9469 else 9470 ns->code->next = new_st; 9471 code = new_st; 9472 code->op = EXEC_SELECT_TYPE; 9473 9474 /* Use the intrinsic LOC function to generate an integer expression 9475 for the vtable of the selector. Note that the rank of the selector 9476 expression has to be set to zero. */ 9477 gfc_add_vptr_component (code->expr1); 9478 code->expr1->rank = 0; 9479 code->expr1 = build_loc_call (code->expr1); 9480 selector_expr = code->expr1->value.function.actual->expr; 9481 9482 /* Loop over TYPE IS / CLASS IS cases. */ 9483 for (body = code->block; body; body = body->block) 9484 { 9485 gfc_symbol *vtab; 9486 gfc_expr *e; 9487 c = body->ext.block.case_list; 9488 9489 /* Generate an index integer expression for address of the 9490 TYPE/CLASS vtable and store it in c->low. The hash expression 9491 is stored in c->high and is used to resolve intrinsic cases. */ 9492 if (c->ts.type != BT_UNKNOWN) 9493 { 9494 if (c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 9495 { 9496 vtab = gfc_find_derived_vtab (c->ts.u.derived); 9497 gcc_assert (vtab); 9498 c->high = gfc_get_int_expr (gfc_integer_4_kind, NULL, 9499 c->ts.u.derived->hash_value); 9500 } 9501 else 9502 { 9503 vtab = gfc_find_vtab (&c->ts); 9504 gcc_assert (vtab && CLASS_DATA (vtab)->initializer); 9505 e = CLASS_DATA (vtab)->initializer; 9506 c->high = gfc_copy_expr (e); 9507 if (c->high->ts.kind != gfc_integer_4_kind) 9508 { 9509 gfc_typespec ts; 9510 ts.kind = gfc_integer_4_kind; 9511 ts.type = BT_INTEGER; 9512 gfc_convert_type_warn (c->high, &ts, 2, 0); 9513 } 9514 } 9515 9516 e = gfc_lval_expr_from_sym (vtab); 9517 c->low = build_loc_call (e); 9518 } 9519 else 9520 continue; 9521 9522 /* Associate temporary to selector. This should only be done 9523 when this case is actually true, so build a new ASSOCIATE 9524 that does precisely this here (instead of using the 9525 'global' one). */ 9526 9527 if (c->ts.type == BT_CLASS) 9528 sprintf (name, "__tmp_class_%s", c->ts.u.derived->name); 9529 else if (c->ts.type == BT_DERIVED) 9530 sprintf (name, "__tmp_type_%s", c->ts.u.derived->name); 9531 else if (c->ts.type == BT_CHARACTER) 9532 { 9533 HOST_WIDE_INT charlen = 0; 9534 if (c->ts.u.cl && c->ts.u.cl->length 9535 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) 9536 charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); 9537 snprintf (name, sizeof (name), 9538 "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d", 9539 gfc_basic_typename (c->ts.type), charlen, c->ts.kind); 9540 } 9541 else 9542 sprintf (name, "__tmp_%s_%d", gfc_basic_typename (c->ts.type), 9543 c->ts.kind); 9544 9545 st = gfc_find_symtree (ns->sym_root, name); 9546 gcc_assert (st->n.sym->assoc); 9547 st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); 9548 st->n.sym->assoc->target->where = selector_expr->where; 9549 if (c->ts.type != BT_CLASS && c->ts.type != BT_UNKNOWN) 9550 { 9551 gfc_add_data_component (st->n.sym->assoc->target); 9552 /* Fixup the target expression if necessary. */ 9553 if (rank) 9554 fixup_array_ref (&st->n.sym->assoc->target, NULL, rank, ref); 9555 } 9556 9557 new_st = gfc_get_code (EXEC_BLOCK); 9558 new_st->ext.block.ns = gfc_build_block_ns (ns); 9559 new_st->ext.block.ns->code = body->next; 9560 body->next = new_st; 9561 9562 /* Chain in the new list only if it is marked as dangling. Otherwise 9563 there is a CASE label overlap and this is already used. Just ignore, 9564 the error is diagnosed elsewhere. */ 9565 if (st->n.sym->assoc->dangling) 9566 { 9567 new_st->ext.block.assoc = st->n.sym->assoc; 9568 st->n.sym->assoc->dangling = 0; 9569 } 9570 9571 resolve_assoc_var (st->n.sym, false); 9572 } 9573 9574 /* Take out CLASS IS cases for separate treatment. */ 9575 body = code; 9576 while (body && body->block) 9577 { 9578 if (body->block->ext.block.case_list->ts.type == BT_CLASS) 9579 { 9580 /* Add to class_is list. */ 9581 if (class_is == NULL) 9582 { 9583 class_is = body->block; 9584 tail = class_is; 9585 } 9586 else 9587 { 9588 for (tail = class_is; tail->block; tail = tail->block) ; 9589 tail->block = body->block; 9590 tail = tail->block; 9591 } 9592 /* Remove from EXEC_SELECT list. */ 9593 body->block = body->block->block; 9594 tail->block = NULL; 9595 } 9596 else 9597 body = body->block; 9598 } 9599 9600 if (class_is) 9601 { 9602 gfc_symbol *vtab; 9603 9604 if (!default_case) 9605 { 9606 /* Add a default case to hold the CLASS IS cases. */ 9607 for (tail = code; tail->block; tail = tail->block) ; 9608 tail->block = gfc_get_code (EXEC_SELECT_TYPE); 9609 tail = tail->block; 9610 tail->ext.block.case_list = gfc_get_case (); 9611 tail->ext.block.case_list->ts.type = BT_UNKNOWN; 9612 tail->next = NULL; 9613 default_case = tail; 9614 } 9615 9616 /* More than one CLASS IS block? */ 9617 if (class_is->block) 9618 { 9619 gfc_code **c1,*c2; 9620 bool swapped; 9621 /* Sort CLASS IS blocks by extension level. */ 9622 do 9623 { 9624 swapped = false; 9625 for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) 9626 { 9627 c2 = (*c1)->block; 9628 /* F03:C817 (check for doubles). */ 9629 if ((*c1)->ext.block.case_list->ts.u.derived->hash_value 9630 == c2->ext.block.case_list->ts.u.derived->hash_value) 9631 { 9632 gfc_error ("Double CLASS IS block in SELECT TYPE " 9633 "statement at %L", 9634 &c2->ext.block.case_list->where); 9635 return; 9636 } 9637 if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension 9638 < c2->ext.block.case_list->ts.u.derived->attr.extension) 9639 { 9640 /* Swap. */ 9641 (*c1)->block = c2->block; 9642 c2->block = *c1; 9643 *c1 = c2; 9644 swapped = true; 9645 } 9646 } 9647 } 9648 while (swapped); 9649 } 9650 9651 /* Generate IF chain. */ 9652 if_st = gfc_get_code (EXEC_IF); 9653 new_st = if_st; 9654 for (body = class_is; body; body = body->block) 9655 { 9656 new_st->block = gfc_get_code (EXEC_IF); 9657 new_st = new_st->block; 9658 /* Set up IF condition: Call _gfortran_is_extension_of. */ 9659 new_st->expr1 = gfc_get_expr (); 9660 new_st->expr1->expr_type = EXPR_FUNCTION; 9661 new_st->expr1->ts.type = BT_LOGICAL; 9662 new_st->expr1->ts.kind = 4; 9663 new_st->expr1->value.function.name = gfc_get_string (PREFIX ("is_extension_of")); 9664 new_st->expr1->value.function.isym = XCNEW (gfc_intrinsic_sym); 9665 new_st->expr1->value.function.isym->id = GFC_ISYM_EXTENDS_TYPE_OF; 9666 /* Set up arguments. */ 9667 new_st->expr1->value.function.actual = gfc_get_actual_arglist (); 9668 new_st->expr1->value.function.actual->expr = gfc_get_variable_expr (selector_expr->symtree); 9669 new_st->expr1->value.function.actual->expr->where = code->loc; 9670 new_st->expr1->where = code->loc; 9671 gfc_add_vptr_component (new_st->expr1->value.function.actual->expr); 9672 vtab = gfc_find_derived_vtab (body->ext.block.case_list->ts.u.derived); 9673 st = gfc_find_symtree (vtab->ns->sym_root, vtab->name); 9674 new_st->expr1->value.function.actual->next = gfc_get_actual_arglist (); 9675 new_st->expr1->value.function.actual->next->expr = gfc_get_variable_expr (st); 9676 new_st->expr1->value.function.actual->next->expr->where = code->loc; 9677 new_st->next = body->next; 9678 } 9679 if (default_case->next) 9680 { 9681 new_st->block = gfc_get_code (EXEC_IF); 9682 new_st = new_st->block; 9683 new_st->next = default_case->next; 9684 } 9685 9686 /* Replace CLASS DEFAULT code by the IF chain. */ 9687 default_case->next = if_st; 9688 } 9689 9690 /* Resolve the internal code. This cannot be done earlier because 9691 it requires that the sym->assoc of selectors is set already. */ 9692 gfc_current_ns = ns; 9693 gfc_resolve_blocks (code->block, gfc_current_ns); 9694 gfc_current_ns = old_ns; 9695 9696 if (ref) 9697 free (ref); 9698} 9699 9700 9701/* Resolve a SELECT RANK statement. */ 9702 9703static void 9704resolve_select_rank (gfc_code *code, gfc_namespace *old_ns) 9705{ 9706 gfc_namespace *ns; 9707 gfc_code *body, *new_st, *tail; 9708 gfc_case *c; 9709 char tname[GFC_MAX_SYMBOL_LEN + 7]; 9710 char name[2 * GFC_MAX_SYMBOL_LEN]; 9711 gfc_symtree *st; 9712 gfc_expr *selector_expr = NULL; 9713 int case_value; 9714 HOST_WIDE_INT charlen = 0; 9715 9716 ns = code->ext.block.ns; 9717 gfc_resolve (ns); 9718 9719 code->op = EXEC_BLOCK; 9720 if (code->expr2) 9721 { 9722 gfc_association_list* assoc; 9723 9724 assoc = gfc_get_association_list (); 9725 assoc->st = code->expr1->symtree; 9726 assoc->target = gfc_copy_expr (code->expr2); 9727 assoc->target->where = code->expr2->where; 9728 /* assoc->variable will be set by resolve_assoc_var. */ 9729 9730 code->ext.block.assoc = assoc; 9731 code->expr1->symtree->n.sym->assoc = assoc; 9732 9733 resolve_assoc_var (code->expr1->symtree->n.sym, false); 9734 } 9735 else 9736 code->ext.block.assoc = NULL; 9737 9738 /* Loop over RANK cases. Note that returning on the errors causes a 9739 cascade of further errors because the case blocks do not compile 9740 correctly. */ 9741 for (body = code->block; body; body = body->block) 9742 { 9743 c = body->ext.block.case_list; 9744 if (c->low) 9745 case_value = (int) mpz_get_si (c->low->value.integer); 9746 else 9747 case_value = -2; 9748 9749 /* Check for repeated cases. */ 9750 for (tail = code->block; tail; tail = tail->block) 9751 { 9752 gfc_case *d = tail->ext.block.case_list; 9753 int case_value2; 9754 9755 if (tail == body) 9756 break; 9757 9758 /* Check F2018: C1153. */ 9759 if (!c->low && !d->low) 9760 gfc_error ("RANK DEFAULT at %L is repeated at %L", 9761 &c->where, &d->where); 9762 9763 if (!c->low || !d->low) 9764 continue; 9765 9766 /* Check F2018: C1153. */ 9767 case_value2 = (int) mpz_get_si (d->low->value.integer); 9768 if ((case_value == case_value2) && case_value == -1) 9769 gfc_error ("RANK (*) at %L is repeated at %L", 9770 &c->where, &d->where); 9771 else if (case_value == case_value2) 9772 gfc_error ("RANK (%i) at %L is repeated at %L", 9773 case_value, &c->where, &d->where); 9774 } 9775 9776 if (!c->low) 9777 continue; 9778 9779 /* Check F2018: C1155. */ 9780 if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable 9781 || gfc_expr_attr (code->expr1).pointer)) 9782 gfc_error ("RANK (*) at %L cannot be used with the pointer or " 9783 "allocatable selector at %L", &c->where, &code->expr1->where); 9784 9785 if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable 9786 || gfc_expr_attr (code->expr1).pointer)) 9787 gfc_error ("RANK (*) at %L cannot be used with the pointer or " 9788 "allocatable selector at %L", &c->where, &code->expr1->where); 9789 } 9790 9791 /* Add EXEC_SELECT to switch on rank. */ 9792 new_st = gfc_get_code (code->op); 9793 new_st->expr1 = code->expr1; 9794 new_st->expr2 = code->expr2; 9795 new_st->block = code->block; 9796 code->expr1 = code->expr2 = NULL; 9797 code->block = NULL; 9798 if (!ns->code) 9799 ns->code = new_st; 9800 else 9801 ns->code->next = new_st; 9802 code = new_st; 9803 code->op = EXEC_SELECT_RANK; 9804 9805 selector_expr = code->expr1; 9806 9807 /* Loop over SELECT RANK cases. */ 9808 for (body = code->block; body; body = body->block) 9809 { 9810 c = body->ext.block.case_list; 9811 int case_value; 9812 9813 /* Pass on the default case. */ 9814 if (c->low == NULL) 9815 continue; 9816 9817 /* Associate temporary to selector. This should only be done 9818 when this case is actually true, so build a new ASSOCIATE 9819 that does precisely this here (instead of using the 9820 'global' one). */ 9821 if (c->ts.type == BT_CHARACTER && c->ts.u.cl && c->ts.u.cl->length 9822 && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) 9823 charlen = gfc_mpz_get_hwi (c->ts.u.cl->length->value.integer); 9824 9825 if (c->ts.type == BT_CLASS) 9826 sprintf (tname, "class_%s", c->ts.u.derived->name); 9827 else if (c->ts.type == BT_DERIVED) 9828 sprintf (tname, "type_%s", c->ts.u.derived->name); 9829 else if (c->ts.type != BT_CHARACTER) 9830 sprintf (tname, "%s_%d", gfc_basic_typename (c->ts.type), c->ts.kind); 9831 else 9832 sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d", 9833 gfc_basic_typename (c->ts.type), charlen, c->ts.kind); 9834 9835 case_value = (int) mpz_get_si (c->low->value.integer); 9836 if (case_value >= 0) 9837 sprintf (name, "__tmp_%s_rank_%d", tname, case_value); 9838 else 9839 sprintf (name, "__tmp_%s_rank_m%d", tname, -case_value); 9840 9841 st = gfc_find_symtree (ns->sym_root, name); 9842 gcc_assert (st->n.sym->assoc); 9843 9844 st->n.sym->assoc->target = gfc_get_variable_expr (selector_expr->symtree); 9845 st->n.sym->assoc->target->where = selector_expr->where; 9846 9847 new_st = gfc_get_code (EXEC_BLOCK); 9848 new_st->ext.block.ns = gfc_build_block_ns (ns); 9849 new_st->ext.block.ns->code = body->next; 9850 body->next = new_st; 9851 9852 /* Chain in the new list only if it is marked as dangling. Otherwise 9853 there is a CASE label overlap and this is already used. Just ignore, 9854 the error is diagnosed elsewhere. */ 9855 if (st->n.sym->assoc->dangling) 9856 { 9857 new_st->ext.block.assoc = st->n.sym->assoc; 9858 st->n.sym->assoc->dangling = 0; 9859 } 9860 9861 resolve_assoc_var (st->n.sym, false); 9862 } 9863 9864 gfc_current_ns = ns; 9865 gfc_resolve_blocks (code->block, gfc_current_ns); 9866 gfc_current_ns = old_ns; 9867} 9868 9869 9870/* Resolve a transfer statement. This is making sure that: 9871 -- a derived type being transferred has only non-pointer components 9872 -- a derived type being transferred doesn't have private components, unless 9873 it's being transferred from the module where the type was defined 9874 -- we're not trying to transfer a whole assumed size array. */ 9875 9876static void 9877resolve_transfer (gfc_code *code) 9878{ 9879 gfc_symbol *sym, *derived; 9880 gfc_ref *ref; 9881 gfc_expr *exp; 9882 bool write = false; 9883 bool formatted = false; 9884 gfc_dt *dt = code->ext.dt; 9885 gfc_symbol *dtio_sub = NULL; 9886 9887 exp = code->expr1; 9888 9889 while (exp != NULL && exp->expr_type == EXPR_OP 9890 && exp->value.op.op == INTRINSIC_PARENTHESES) 9891 exp = exp->value.op.op1; 9892 9893 if (exp && exp->expr_type == EXPR_NULL 9894 && code->ext.dt) 9895 { 9896 gfc_error ("Invalid context for NULL () intrinsic at %L", 9897 &exp->where); 9898 return; 9899 } 9900 9901 if (exp == NULL || (exp->expr_type != EXPR_VARIABLE 9902 && exp->expr_type != EXPR_FUNCTION 9903 && exp->expr_type != EXPR_STRUCTURE)) 9904 return; 9905 9906 /* If we are reading, the variable will be changed. Note that 9907 code->ext.dt may be NULL if the TRANSFER is related to 9908 an INQUIRE statement -- but in this case, we are not reading, either. */ 9909 if (dt && dt->dt_io_kind->value.iokind == M_READ 9910 && !gfc_check_vardef_context (exp, false, false, false, 9911 _("item in READ"))) 9912 return; 9913 9914 const gfc_typespec *ts = exp->expr_type == EXPR_STRUCTURE 9915 || exp->expr_type == EXPR_FUNCTION 9916 ? &exp->ts : &exp->symtree->n.sym->ts; 9917 9918 /* Go to actual component transferred. */ 9919 for (ref = exp->ref; ref; ref = ref->next) 9920 if (ref->type == REF_COMPONENT) 9921 ts = &ref->u.c.component->ts; 9922 9923 if (dt && dt->dt_io_kind->value.iokind != M_INQUIRE 9924 && (ts->type == BT_DERIVED || ts->type == BT_CLASS)) 9925 { 9926 derived = ts->u.derived; 9927 9928 /* Determine when to use the formatted DTIO procedure. */ 9929 if (dt && (dt->format_expr || dt->format_label)) 9930 formatted = true; 9931 9932 write = dt->dt_io_kind->value.iokind == M_WRITE 9933 || dt->dt_io_kind->value.iokind == M_PRINT; 9934 dtio_sub = gfc_find_specific_dtio_proc (derived, write, formatted); 9935 9936 if (dtio_sub != NULL && exp->expr_type == EXPR_VARIABLE) 9937 { 9938 dt->udtio = exp; 9939 sym = exp->symtree->n.sym->ns->proc_name; 9940 /* Check to see if this is a nested DTIO call, with the 9941 dummy as the io-list object. */ 9942 if (sym && sym == dtio_sub && sym->formal 9943 && sym->formal->sym == exp->symtree->n.sym 9944 && exp->ref == NULL) 9945 { 9946 if (!sym->attr.recursive) 9947 { 9948 gfc_error ("DTIO %s procedure at %L must be recursive", 9949 sym->name, &sym->declared_at); 9950 return; 9951 } 9952 } 9953 } 9954 } 9955 9956 if (ts->type == BT_CLASS && dtio_sub == NULL) 9957 { 9958 gfc_error ("Data transfer element at %L cannot be polymorphic unless " 9959 "it is processed by a defined input/output procedure", 9960 &code->loc); 9961 return; 9962 } 9963 9964 if (ts->type == BT_DERIVED) 9965 { 9966 /* Check that transferred derived type doesn't contain POINTER 9967 components unless it is processed by a defined input/output 9968 procedure". */ 9969 if (ts->u.derived->attr.pointer_comp && dtio_sub == NULL) 9970 { 9971 gfc_error ("Data transfer element at %L cannot have POINTER " 9972 "components unless it is processed by a defined " 9973 "input/output procedure", &code->loc); 9974 return; 9975 } 9976 9977 /* F08:C935. */ 9978 if (ts->u.derived->attr.proc_pointer_comp) 9979 { 9980 gfc_error ("Data transfer element at %L cannot have " 9981 "procedure pointer components", &code->loc); 9982 return; 9983 } 9984 9985 if (ts->u.derived->attr.alloc_comp && dtio_sub == NULL) 9986 { 9987 gfc_error ("Data transfer element at %L cannot have ALLOCATABLE " 9988 "components unless it is processed by a defined " 9989 "input/output procedure", &code->loc); 9990 return; 9991 } 9992 9993 /* C_PTR and C_FUNPTR have private components which means they cannot 9994 be printed. However, if -std=gnu and not -pedantic, allow 9995 the component to be printed to help debugging. */ 9996 if (ts->u.derived->ts.f90_type == BT_VOID) 9997 { 9998 if (!gfc_notify_std (GFC_STD_GNU, "Data transfer element at %L " 9999 "cannot have PRIVATE components", &code->loc)) 10000 return; 10001 } 10002 else if (derived_inaccessible (ts->u.derived) && dtio_sub == NULL) 10003 { 10004 gfc_error ("Data transfer element at %L cannot have " 10005 "PRIVATE components unless it is processed by " 10006 "a defined input/output procedure", &code->loc); 10007 return; 10008 } 10009 } 10010 10011 if (exp->expr_type == EXPR_STRUCTURE) 10012 return; 10013 10014 sym = exp->symtree->n.sym; 10015 10016 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SIZE && exp->ref 10017 && exp->ref->type == REF_ARRAY && exp->ref->u.ar.type == AR_FULL) 10018 { 10019 gfc_error ("Data transfer element at %L cannot be a full reference to " 10020 "an assumed-size array", &code->loc); 10021 return; 10022 } 10023} 10024 10025 10026/*********** Toplevel code resolution subroutines ***********/ 10027 10028/* Find the set of labels that are reachable from this block. We also 10029 record the last statement in each block. */ 10030 10031static void 10032find_reachable_labels (gfc_code *block) 10033{ 10034 gfc_code *c; 10035 10036 if (!block) 10037 return; 10038 10039 cs_base->reachable_labels = bitmap_alloc (&labels_obstack); 10040 10041 /* Collect labels in this block. We don't keep those corresponding 10042 to END {IF|SELECT}, these are checked in resolve_branch by going 10043 up through the code_stack. */ 10044 for (c = block; c; c = c->next) 10045 { 10046 if (c->here && c->op != EXEC_END_NESTED_BLOCK) 10047 bitmap_set_bit (cs_base->reachable_labels, c->here->value); 10048 } 10049 10050 /* Merge with labels from parent block. */ 10051 if (cs_base->prev) 10052 { 10053 gcc_assert (cs_base->prev->reachable_labels); 10054 bitmap_ior_into (cs_base->reachable_labels, 10055 cs_base->prev->reachable_labels); 10056 } 10057} 10058 10059 10060static void 10061resolve_lock_unlock_event (gfc_code *code) 10062{ 10063 if (code->expr1->expr_type == EXPR_FUNCTION 10064 && code->expr1->value.function.isym 10065 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) 10066 remove_caf_get_intrinsic (code->expr1); 10067 10068 if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK) 10069 && (code->expr1->ts.type != BT_DERIVED 10070 || code->expr1->expr_type != EXPR_VARIABLE 10071 || code->expr1->ts.u.derived->from_intmod != INTMOD_ISO_FORTRAN_ENV 10072 || code->expr1->ts.u.derived->intmod_sym_id != ISOFORTRAN_LOCK_TYPE 10073 || code->expr1->rank != 0 10074 || (!gfc_is_coarray (code->expr1) && 10075 !gfc_is_coindexed (code->expr1)))) 10076 gfc_error ("Lock variable at %L must be a scalar of type LOCK_TYPE", 10077 &code->expr1->where); 10078 else if ((code->op == EXEC_EVENT_POST || code->op == EXEC_EVENT_WAIT) 10079 && (code->expr1->ts.type != BT_DERIVED 10080 || code->expr1->expr_type != EXPR_VARIABLE 10081 || code->expr1->ts.u.derived->from_intmod 10082 != INTMOD_ISO_FORTRAN_ENV 10083 || code->expr1->ts.u.derived->intmod_sym_id 10084 != ISOFORTRAN_EVENT_TYPE 10085 || code->expr1->rank != 0)) 10086 gfc_error ("Event variable at %L must be a scalar of type EVENT_TYPE", 10087 &code->expr1->where); 10088 else if (code->op == EXEC_EVENT_POST && !gfc_is_coarray (code->expr1) 10089 && !gfc_is_coindexed (code->expr1)) 10090 gfc_error ("Event variable argument at %L must be a coarray or coindexed", 10091 &code->expr1->where); 10092 else if (code->op == EXEC_EVENT_WAIT && !gfc_is_coarray (code->expr1)) 10093 gfc_error ("Event variable argument at %L must be a coarray but not " 10094 "coindexed", &code->expr1->where); 10095 10096 /* Check STAT. */ 10097 if (code->expr2 10098 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 10099 || code->expr2->expr_type != EXPR_VARIABLE)) 10100 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", 10101 &code->expr2->where); 10102 10103 if (code->expr2 10104 && !gfc_check_vardef_context (code->expr2, false, false, false, 10105 _("STAT variable"))) 10106 return; 10107 10108 /* Check ERRMSG. */ 10109 if (code->expr3 10110 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 10111 || code->expr3->expr_type != EXPR_VARIABLE)) 10112 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", 10113 &code->expr3->where); 10114 10115 if (code->expr3 10116 && !gfc_check_vardef_context (code->expr3, false, false, false, 10117 _("ERRMSG variable"))) 10118 return; 10119 10120 /* Check for LOCK the ACQUIRED_LOCK. */ 10121 if (code->op != EXEC_EVENT_WAIT && code->expr4 10122 && (code->expr4->ts.type != BT_LOGICAL || code->expr4->rank != 0 10123 || code->expr4->expr_type != EXPR_VARIABLE)) 10124 gfc_error ("ACQUIRED_LOCK= argument at %L must be a scalar LOGICAL " 10125 "variable", &code->expr4->where); 10126 10127 if (code->op != EXEC_EVENT_WAIT && code->expr4 10128 && !gfc_check_vardef_context (code->expr4, false, false, false, 10129 _("ACQUIRED_LOCK variable"))) 10130 return; 10131 10132 /* Check for EVENT WAIT the UNTIL_COUNT. */ 10133 if (code->op == EXEC_EVENT_WAIT && code->expr4) 10134 { 10135 if (!gfc_resolve_expr (code->expr4) || code->expr4->ts.type != BT_INTEGER 10136 || code->expr4->rank != 0) 10137 gfc_error ("UNTIL_COUNT= argument at %L must be a scalar INTEGER " 10138 "expression", &code->expr4->where); 10139 } 10140} 10141 10142 10143static void 10144resolve_critical (gfc_code *code) 10145{ 10146 gfc_symtree *symtree; 10147 gfc_symbol *lock_type; 10148 char name[GFC_MAX_SYMBOL_LEN]; 10149 static int serial = 0; 10150 10151 if (flag_coarray != GFC_FCOARRAY_LIB) 10152 return; 10153 10154 symtree = gfc_find_symtree (gfc_current_ns->sym_root, 10155 GFC_PREFIX ("lock_type")); 10156 if (symtree) 10157 lock_type = symtree->n.sym; 10158 else 10159 { 10160 if (gfc_get_sym_tree (GFC_PREFIX ("lock_type"), gfc_current_ns, &symtree, 10161 false) != 0) 10162 gcc_unreachable (); 10163 lock_type = symtree->n.sym; 10164 lock_type->attr.flavor = FL_DERIVED; 10165 lock_type->attr.zero_comp = 1; 10166 lock_type->from_intmod = INTMOD_ISO_FORTRAN_ENV; 10167 lock_type->intmod_sym_id = ISOFORTRAN_LOCK_TYPE; 10168 } 10169 10170 sprintf(name, GFC_PREFIX ("lock_var") "%d",serial++); 10171 if (gfc_get_sym_tree (name, gfc_current_ns, &symtree, false) != 0) 10172 gcc_unreachable (); 10173 10174 code->resolved_sym = symtree->n.sym; 10175 symtree->n.sym->attr.flavor = FL_VARIABLE; 10176 symtree->n.sym->attr.referenced = 1; 10177 symtree->n.sym->attr.artificial = 1; 10178 symtree->n.sym->attr.codimension = 1; 10179 symtree->n.sym->ts.type = BT_DERIVED; 10180 symtree->n.sym->ts.u.derived = lock_type; 10181 symtree->n.sym->as = gfc_get_array_spec (); 10182 symtree->n.sym->as->corank = 1; 10183 symtree->n.sym->as->type = AS_EXPLICIT; 10184 symtree->n.sym->as->cotype = AS_EXPLICIT; 10185 symtree->n.sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, 10186 NULL, 1); 10187 gfc_commit_symbols(); 10188} 10189 10190 10191static void 10192resolve_sync (gfc_code *code) 10193{ 10194 /* Check imageset. The * case matches expr1 == NULL. */ 10195 if (code->expr1) 10196 { 10197 if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) 10198 gfc_error ("Imageset argument at %L must be a scalar or rank-1 " 10199 "INTEGER expression", &code->expr1->where); 10200 if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 10201 && mpz_cmp_si (code->expr1->value.integer, 1) < 0) 10202 gfc_error ("Imageset argument at %L must between 1 and num_images()", 10203 &code->expr1->where); 10204 else if (code->expr1->expr_type == EXPR_ARRAY 10205 && gfc_simplify_expr (code->expr1, 0)) 10206 { 10207 gfc_constructor *cons; 10208 cons = gfc_constructor_first (code->expr1->value.constructor); 10209 for (; cons; cons = gfc_constructor_next (cons)) 10210 if (cons->expr->expr_type == EXPR_CONSTANT 10211 && mpz_cmp_si (cons->expr->value.integer, 1) < 0) 10212 gfc_error ("Imageset argument at %L must between 1 and " 10213 "num_images()", &cons->expr->where); 10214 } 10215 } 10216 10217 /* Check STAT. */ 10218 gfc_resolve_expr (code->expr2); 10219 if (code->expr2 10220 && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 10221 || code->expr2->expr_type != EXPR_VARIABLE)) 10222 gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", 10223 &code->expr2->where); 10224 10225 /* Check ERRMSG. */ 10226 gfc_resolve_expr (code->expr3); 10227 if (code->expr3 10228 && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 10229 || code->expr3->expr_type != EXPR_VARIABLE)) 10230 gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", 10231 &code->expr3->where); 10232} 10233 10234 10235/* Given a branch to a label, see if the branch is conforming. 10236 The code node describes where the branch is located. */ 10237 10238static void 10239resolve_branch (gfc_st_label *label, gfc_code *code) 10240{ 10241 code_stack *stack; 10242 10243 if (label == NULL) 10244 return; 10245 10246 /* Step one: is this a valid branching target? */ 10247 10248 if (label->defined == ST_LABEL_UNKNOWN) 10249 { 10250 gfc_error ("Label %d referenced at %L is never defined", label->value, 10251 &code->loc); 10252 return; 10253 } 10254 10255 if (label->defined != ST_LABEL_TARGET && label->defined != ST_LABEL_DO_TARGET) 10256 { 10257 gfc_error ("Statement at %L is not a valid branch target statement " 10258 "for the branch statement at %L", &label->where, &code->loc); 10259 return; 10260 } 10261 10262 /* Step two: make sure this branch is not a branch to itself ;-) */ 10263 10264 if (code->here == label) 10265 { 10266 gfc_warning (0, 10267 "Branch at %L may result in an infinite loop", &code->loc); 10268 return; 10269 } 10270 10271 /* Step three: See if the label is in the same block as the 10272 branching statement. The hard work has been done by setting up 10273 the bitmap reachable_labels. */ 10274 10275 if (bitmap_bit_p (cs_base->reachable_labels, label->value)) 10276 { 10277 /* Check now whether there is a CRITICAL construct; if so, check 10278 whether the label is still visible outside of the CRITICAL block, 10279 which is invalid. */ 10280 for (stack = cs_base; stack; stack = stack->prev) 10281 { 10282 if (stack->current->op == EXEC_CRITICAL 10283 && bitmap_bit_p (stack->reachable_labels, label->value)) 10284 gfc_error ("GOTO statement at %L leaves CRITICAL construct for " 10285 "label at %L", &code->loc, &label->where); 10286 else if (stack->current->op == EXEC_DO_CONCURRENT 10287 && bitmap_bit_p (stack->reachable_labels, label->value)) 10288 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct " 10289 "for label at %L", &code->loc, &label->where); 10290 } 10291 10292 return; 10293 } 10294 10295 /* Step four: If we haven't found the label in the bitmap, it may 10296 still be the label of the END of the enclosing block, in which 10297 case we find it by going up the code_stack. */ 10298 10299 for (stack = cs_base; stack; stack = stack->prev) 10300 { 10301 if (stack->current->next && stack->current->next->here == label) 10302 break; 10303 if (stack->current->op == EXEC_CRITICAL) 10304 { 10305 /* Note: A label at END CRITICAL does not leave the CRITICAL 10306 construct as END CRITICAL is still part of it. */ 10307 gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" 10308 " at %L", &code->loc, &label->where); 10309 return; 10310 } 10311 else if (stack->current->op == EXEC_DO_CONCURRENT) 10312 { 10313 gfc_error ("GOTO statement at %L leaves DO CONCURRENT construct for " 10314 "label at %L", &code->loc, &label->where); 10315 return; 10316 } 10317 } 10318 10319 if (stack) 10320 { 10321 gcc_assert (stack->current->next->op == EXEC_END_NESTED_BLOCK); 10322 return; 10323 } 10324 10325 /* The label is not in an enclosing block, so illegal. This was 10326 allowed in Fortran 66, so we allow it as extension. No 10327 further checks are necessary in this case. */ 10328 gfc_notify_std (GFC_STD_LEGACY, "Label at %L is not in the same block " 10329 "as the GOTO statement at %L", &label->where, 10330 &code->loc); 10331 return; 10332} 10333 10334 10335/* Check whether EXPR1 has the same shape as EXPR2. */ 10336 10337static bool 10338resolve_where_shape (gfc_expr *expr1, gfc_expr *expr2) 10339{ 10340 mpz_t shape[GFC_MAX_DIMENSIONS]; 10341 mpz_t shape2[GFC_MAX_DIMENSIONS]; 10342 bool result = false; 10343 int i; 10344 10345 /* Compare the rank. */ 10346 if (expr1->rank != expr2->rank) 10347 return result; 10348 10349 /* Compare the size of each dimension. */ 10350 for (i=0; i<expr1->rank; i++) 10351 { 10352 if (!gfc_array_dimen_size (expr1, i, &shape[i])) 10353 goto ignore; 10354 10355 if (!gfc_array_dimen_size (expr2, i, &shape2[i])) 10356 goto ignore; 10357 10358 if (mpz_cmp (shape[i], shape2[i])) 10359 goto over; 10360 } 10361 10362 /* When either of the two expression is an assumed size array, we 10363 ignore the comparison of dimension sizes. */ 10364ignore: 10365 result = true; 10366 10367over: 10368 gfc_clear_shape (shape, i); 10369 gfc_clear_shape (shape2, i); 10370 return result; 10371} 10372 10373 10374/* Check whether a WHERE assignment target or a WHERE mask expression 10375 has the same shape as the outmost WHERE mask expression. */ 10376 10377static void 10378resolve_where (gfc_code *code, gfc_expr *mask) 10379{ 10380 gfc_code *cblock; 10381 gfc_code *cnext; 10382 gfc_expr *e = NULL; 10383 10384 cblock = code->block; 10385 10386 /* Store the first WHERE mask-expr of the WHERE statement or construct. 10387 In case of nested WHERE, only the outmost one is stored. */ 10388 if (mask == NULL) /* outmost WHERE */ 10389 e = cblock->expr1; 10390 else /* inner WHERE */ 10391 e = mask; 10392 10393 while (cblock) 10394 { 10395 if (cblock->expr1) 10396 { 10397 /* Check if the mask-expr has a consistent shape with the 10398 outmost WHERE mask-expr. */ 10399 if (!resolve_where_shape (cblock->expr1, e)) 10400 gfc_error ("WHERE mask at %L has inconsistent shape", 10401 &cblock->expr1->where); 10402 } 10403 10404 /* the assignment statement of a WHERE statement, or the first 10405 statement in where-body-construct of a WHERE construct */ 10406 cnext = cblock->next; 10407 while (cnext) 10408 { 10409 switch (cnext->op) 10410 { 10411 /* WHERE assignment statement */ 10412 case EXEC_ASSIGN: 10413 10414 /* Check shape consistent for WHERE assignment target. */ 10415 if (e && !resolve_where_shape (cnext->expr1, e)) 10416 gfc_error ("WHERE assignment target at %L has " 10417 "inconsistent shape", &cnext->expr1->where); 10418 break; 10419 10420 10421 case EXEC_ASSIGN_CALL: 10422 resolve_call (cnext); 10423 if (!cnext->resolved_sym->attr.elemental) 10424 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", 10425 &cnext->ext.actual->expr->where); 10426 break; 10427 10428 /* WHERE or WHERE construct is part of a where-body-construct */ 10429 case EXEC_WHERE: 10430 resolve_where (cnext, e); 10431 break; 10432 10433 default: 10434 gfc_error ("Unsupported statement inside WHERE at %L", 10435 &cnext->loc); 10436 } 10437 /* the next statement within the same where-body-construct */ 10438 cnext = cnext->next; 10439 } 10440 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ 10441 cblock = cblock->block; 10442 } 10443} 10444 10445 10446/* Resolve assignment in FORALL construct. 10447 NVAR is the number of FORALL index variables, and VAR_EXPR records the 10448 FORALL index variables. */ 10449 10450static void 10451gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_expr) 10452{ 10453 int n; 10454 10455 for (n = 0; n < nvar; n++) 10456 { 10457 gfc_symbol *forall_index; 10458 10459 forall_index = var_expr[n]->symtree->n.sym; 10460 10461 /* Check whether the assignment target is one of the FORALL index 10462 variable. */ 10463 if ((code->expr1->expr_type == EXPR_VARIABLE) 10464 && (code->expr1->symtree->n.sym == forall_index)) 10465 gfc_error ("Assignment to a FORALL index variable at %L", 10466 &code->expr1->where); 10467 else 10468 { 10469 /* If one of the FORALL index variables doesn't appear in the 10470 assignment variable, then there could be a many-to-one 10471 assignment. Emit a warning rather than an error because the 10472 mask could be resolving this problem. */ 10473 if (!find_forall_index (code->expr1, forall_index, 0)) 10474 gfc_warning (0, "The FORALL with index %qs is not used on the " 10475 "left side of the assignment at %L and so might " 10476 "cause multiple assignment to this object", 10477 var_expr[n]->symtree->name, &code->expr1->where); 10478 } 10479 } 10480} 10481 10482 10483/* Resolve WHERE statement in FORALL construct. */ 10484 10485static void 10486gfc_resolve_where_code_in_forall (gfc_code *code, int nvar, 10487 gfc_expr **var_expr) 10488{ 10489 gfc_code *cblock; 10490 gfc_code *cnext; 10491 10492 cblock = code->block; 10493 while (cblock) 10494 { 10495 /* the assignment statement of a WHERE statement, or the first 10496 statement in where-body-construct of a WHERE construct */ 10497 cnext = cblock->next; 10498 while (cnext) 10499 { 10500 switch (cnext->op) 10501 { 10502 /* WHERE assignment statement */ 10503 case EXEC_ASSIGN: 10504 gfc_resolve_assign_in_forall (cnext, nvar, var_expr); 10505 break; 10506 10507 /* WHERE operator assignment statement */ 10508 case EXEC_ASSIGN_CALL: 10509 resolve_call (cnext); 10510 if (!cnext->resolved_sym->attr.elemental) 10511 gfc_error("Non-ELEMENTAL user-defined assignment in WHERE at %L", 10512 &cnext->ext.actual->expr->where); 10513 break; 10514 10515 /* WHERE or WHERE construct is part of a where-body-construct */ 10516 case EXEC_WHERE: 10517 gfc_resolve_where_code_in_forall (cnext, nvar, var_expr); 10518 break; 10519 10520 default: 10521 gfc_error ("Unsupported statement inside WHERE at %L", 10522 &cnext->loc); 10523 } 10524 /* the next statement within the same where-body-construct */ 10525 cnext = cnext->next; 10526 } 10527 /* the next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt */ 10528 cblock = cblock->block; 10529 } 10530} 10531 10532 10533/* Traverse the FORALL body to check whether the following errors exist: 10534 1. For assignment, check if a many-to-one assignment happens. 10535 2. For WHERE statement, check the WHERE body to see if there is any 10536 many-to-one assignment. */ 10537 10538static void 10539gfc_resolve_forall_body (gfc_code *code, int nvar, gfc_expr **var_expr) 10540{ 10541 gfc_code *c; 10542 10543 c = code->block->next; 10544 while (c) 10545 { 10546 switch (c->op) 10547 { 10548 case EXEC_ASSIGN: 10549 case EXEC_POINTER_ASSIGN: 10550 gfc_resolve_assign_in_forall (c, nvar, var_expr); 10551 break; 10552 10553 case EXEC_ASSIGN_CALL: 10554 resolve_call (c); 10555 break; 10556 10557 /* Because the gfc_resolve_blocks() will handle the nested FORALL, 10558 there is no need to handle it here. */ 10559 case EXEC_FORALL: 10560 break; 10561 case EXEC_WHERE: 10562 gfc_resolve_where_code_in_forall(c, nvar, var_expr); 10563 break; 10564 default: 10565 break; 10566 } 10567 /* The next statement in the FORALL body. */ 10568 c = c->next; 10569 } 10570} 10571 10572 10573/* Counts the number of iterators needed inside a forall construct, including 10574 nested forall constructs. This is used to allocate the needed memory 10575 in gfc_resolve_forall. */ 10576 10577static int 10578gfc_count_forall_iterators (gfc_code *code) 10579{ 10580 int max_iters, sub_iters, current_iters; 10581 gfc_forall_iterator *fa; 10582 10583 gcc_assert(code->op == EXEC_FORALL); 10584 max_iters = 0; 10585 current_iters = 0; 10586 10587 for (fa = code->ext.forall_iterator; fa; fa = fa->next) 10588 current_iters ++; 10589 10590 code = code->block->next; 10591 10592 while (code) 10593 { 10594 if (code->op == EXEC_FORALL) 10595 { 10596 sub_iters = gfc_count_forall_iterators (code); 10597 if (sub_iters > max_iters) 10598 max_iters = sub_iters; 10599 } 10600 code = code->next; 10601 } 10602 10603 return current_iters + max_iters; 10604} 10605 10606 10607/* Given a FORALL construct, first resolve the FORALL iterator, then call 10608 gfc_resolve_forall_body to resolve the FORALL body. */ 10609 10610static void 10611gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) 10612{ 10613 static gfc_expr **var_expr; 10614 static int total_var = 0; 10615 static int nvar = 0; 10616 int i, old_nvar, tmp; 10617 gfc_forall_iterator *fa; 10618 10619 old_nvar = nvar; 10620 10621 if (!gfc_notify_std (GFC_STD_F2018_OBS, "FORALL construct at %L", &code->loc)) 10622 return; 10623 10624 /* Start to resolve a FORALL construct */ 10625 if (forall_save == 0) 10626 { 10627 /* Count the total number of FORALL indices in the nested FORALL 10628 construct in order to allocate the VAR_EXPR with proper size. */ 10629 total_var = gfc_count_forall_iterators (code); 10630 10631 /* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */ 10632 var_expr = XCNEWVEC (gfc_expr *, total_var); 10633 } 10634 10635 /* The information about FORALL iterator, including FORALL indices start, end 10636 and stride. An outer FORALL indice cannot appear in start, end or stride. */ 10637 for (fa = code->ext.forall_iterator; fa; fa = fa->next) 10638 { 10639 /* Fortran 20008: C738 (R753). */ 10640 if (fa->var->ref && fa->var->ref->type == REF_ARRAY) 10641 { 10642 gfc_error ("FORALL index-name at %L must be a scalar variable " 10643 "of type integer", &fa->var->where); 10644 continue; 10645 } 10646 10647 /* Check if any outer FORALL index name is the same as the current 10648 one. */ 10649 for (i = 0; i < nvar; i++) 10650 { 10651 if (fa->var->symtree->n.sym == var_expr[i]->symtree->n.sym) 10652 gfc_error ("An outer FORALL construct already has an index " 10653 "with this name %L", &fa->var->where); 10654 } 10655 10656 /* Record the current FORALL index. */ 10657 var_expr[nvar] = gfc_copy_expr (fa->var); 10658 10659 nvar++; 10660 10661 /* No memory leak. */ 10662 gcc_assert (nvar <= total_var); 10663 } 10664 10665 /* Resolve the FORALL body. */ 10666 gfc_resolve_forall_body (code, nvar, var_expr); 10667 10668 /* May call gfc_resolve_forall to resolve the inner FORALL loop. */ 10669 gfc_resolve_blocks (code->block, ns); 10670 10671 tmp = nvar; 10672 nvar = old_nvar; 10673 /* Free only the VAR_EXPRs allocated in this frame. */ 10674 for (i = nvar; i < tmp; i++) 10675 gfc_free_expr (var_expr[i]); 10676 10677 if (nvar == 0) 10678 { 10679 /* We are in the outermost FORALL construct. */ 10680 gcc_assert (forall_save == 0); 10681 10682 /* VAR_EXPR is not needed any more. */ 10683 free (var_expr); 10684 total_var = 0; 10685 } 10686} 10687 10688 10689/* Resolve a BLOCK construct statement. */ 10690 10691static void 10692resolve_block_construct (gfc_code* code) 10693{ 10694 /* Resolve the BLOCK's namespace. */ 10695 gfc_resolve (code->ext.block.ns); 10696 10697 /* For an ASSOCIATE block, the associations (and their targets) are already 10698 resolved during resolve_symbol. */ 10699} 10700 10701 10702/* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and 10703 DO code nodes. */ 10704 10705void 10706gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) 10707{ 10708 bool t; 10709 10710 for (; b; b = b->block) 10711 { 10712 t = gfc_resolve_expr (b->expr1); 10713 if (!gfc_resolve_expr (b->expr2)) 10714 t = false; 10715 10716 switch (b->op) 10717 { 10718 case EXEC_IF: 10719 if (t && b->expr1 != NULL 10720 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank != 0)) 10721 gfc_error ("IF clause at %L requires a scalar LOGICAL expression", 10722 &b->expr1->where); 10723 break; 10724 10725 case EXEC_WHERE: 10726 if (t 10727 && b->expr1 != NULL 10728 && (b->expr1->ts.type != BT_LOGICAL || b->expr1->rank == 0)) 10729 gfc_error ("WHERE/ELSEWHERE clause at %L requires a LOGICAL array", 10730 &b->expr1->where); 10731 break; 10732 10733 case EXEC_GOTO: 10734 resolve_branch (b->label1, b); 10735 break; 10736 10737 case EXEC_BLOCK: 10738 resolve_block_construct (b); 10739 break; 10740 10741 case EXEC_SELECT: 10742 case EXEC_SELECT_TYPE: 10743 case EXEC_SELECT_RANK: 10744 case EXEC_FORALL: 10745 case EXEC_DO: 10746 case EXEC_DO_WHILE: 10747 case EXEC_DO_CONCURRENT: 10748 case EXEC_CRITICAL: 10749 case EXEC_READ: 10750 case EXEC_WRITE: 10751 case EXEC_IOLENGTH: 10752 case EXEC_WAIT: 10753 break; 10754 10755 case EXEC_OMP_ATOMIC: 10756 case EXEC_OACC_ATOMIC: 10757 { 10758 gfc_omp_atomic_op aop 10759 = (gfc_omp_atomic_op) (b->ext.omp_atomic & GFC_OMP_ATOMIC_MASK); 10760 10761 /* Verify this before calling gfc_resolve_code, which might 10762 change it. */ 10763 gcc_assert (b->next && b->next->op == EXEC_ASSIGN); 10764 gcc_assert (((aop != GFC_OMP_ATOMIC_CAPTURE) 10765 && b->next->next == NULL) 10766 || ((aop == GFC_OMP_ATOMIC_CAPTURE) 10767 && b->next->next != NULL 10768 && b->next->next->op == EXEC_ASSIGN 10769 && b->next->next->next == NULL)); 10770 } 10771 break; 10772 10773 case EXEC_OACC_PARALLEL_LOOP: 10774 case EXEC_OACC_PARALLEL: 10775 case EXEC_OACC_KERNELS_LOOP: 10776 case EXEC_OACC_KERNELS: 10777 case EXEC_OACC_SERIAL_LOOP: 10778 case EXEC_OACC_SERIAL: 10779 case EXEC_OACC_DATA: 10780 case EXEC_OACC_HOST_DATA: 10781 case EXEC_OACC_LOOP: 10782 case EXEC_OACC_UPDATE: 10783 case EXEC_OACC_WAIT: 10784 case EXEC_OACC_CACHE: 10785 case EXEC_OACC_ENTER_DATA: 10786 case EXEC_OACC_EXIT_DATA: 10787 case EXEC_OACC_ROUTINE: 10788 case EXEC_OMP_CRITICAL: 10789 case EXEC_OMP_DISTRIBUTE: 10790 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 10791 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 10792 case EXEC_OMP_DISTRIBUTE_SIMD: 10793 case EXEC_OMP_DO: 10794 case EXEC_OMP_DO_SIMD: 10795 case EXEC_OMP_MASTER: 10796 case EXEC_OMP_ORDERED: 10797 case EXEC_OMP_PARALLEL: 10798 case EXEC_OMP_PARALLEL_DO: 10799 case EXEC_OMP_PARALLEL_DO_SIMD: 10800 case EXEC_OMP_PARALLEL_SECTIONS: 10801 case EXEC_OMP_PARALLEL_WORKSHARE: 10802 case EXEC_OMP_SECTIONS: 10803 case EXEC_OMP_SIMD: 10804 case EXEC_OMP_SINGLE: 10805 case EXEC_OMP_TARGET: 10806 case EXEC_OMP_TARGET_DATA: 10807 case EXEC_OMP_TARGET_ENTER_DATA: 10808 case EXEC_OMP_TARGET_EXIT_DATA: 10809 case EXEC_OMP_TARGET_PARALLEL: 10810 case EXEC_OMP_TARGET_PARALLEL_DO: 10811 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 10812 case EXEC_OMP_TARGET_SIMD: 10813 case EXEC_OMP_TARGET_TEAMS: 10814 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 10815 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 10816 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 10817 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 10818 case EXEC_OMP_TARGET_UPDATE: 10819 case EXEC_OMP_TASK: 10820 case EXEC_OMP_TASKGROUP: 10821 case EXEC_OMP_TASKLOOP: 10822 case EXEC_OMP_TASKLOOP_SIMD: 10823 case EXEC_OMP_TASKWAIT: 10824 case EXEC_OMP_TASKYIELD: 10825 case EXEC_OMP_TEAMS: 10826 case EXEC_OMP_TEAMS_DISTRIBUTE: 10827 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 10828 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 10829 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 10830 case EXEC_OMP_WORKSHARE: 10831 break; 10832 10833 default: 10834 gfc_internal_error ("gfc_resolve_blocks(): Bad block type"); 10835 } 10836 10837 gfc_resolve_code (b->next, ns); 10838 } 10839} 10840 10841 10842/* Does everything to resolve an ordinary assignment. Returns true 10843 if this is an interface assignment. */ 10844static bool 10845resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) 10846{ 10847 bool rval = false; 10848 gfc_expr *lhs; 10849 gfc_expr *rhs; 10850 int n; 10851 gfc_ref *ref; 10852 symbol_attribute attr; 10853 10854 if (gfc_extend_assign (code, ns)) 10855 { 10856 gfc_expr** rhsptr; 10857 10858 if (code->op == EXEC_ASSIGN_CALL) 10859 { 10860 lhs = code->ext.actual->expr; 10861 rhsptr = &code->ext.actual->next->expr; 10862 } 10863 else 10864 { 10865 gfc_actual_arglist* args; 10866 gfc_typebound_proc* tbp; 10867 10868 gcc_assert (code->op == EXEC_COMPCALL); 10869 10870 args = code->expr1->value.compcall.actual; 10871 lhs = args->expr; 10872 rhsptr = &args->next->expr; 10873 10874 tbp = code->expr1->value.compcall.tbp; 10875 gcc_assert (!tbp->is_generic); 10876 } 10877 10878 /* Make a temporary rhs when there is a default initializer 10879 and rhs is the same symbol as the lhs. */ 10880 if ((*rhsptr)->expr_type == EXPR_VARIABLE 10881 && (*rhsptr)->symtree->n.sym->ts.type == BT_DERIVED 10882 && gfc_has_default_initializer ((*rhsptr)->symtree->n.sym->ts.u.derived) 10883 && (lhs->symtree->n.sym == (*rhsptr)->symtree->n.sym)) 10884 *rhsptr = gfc_get_parentheses (*rhsptr); 10885 10886 return true; 10887 } 10888 10889 lhs = code->expr1; 10890 rhs = code->expr2; 10891 10892 if ((gfc_numeric_ts (&lhs->ts) || lhs->ts.type == BT_LOGICAL) 10893 && rhs->ts.type == BT_CHARACTER 10894 && (rhs->expr_type != EXPR_CONSTANT || !flag_dec_char_conversions)) 10895 { 10896 /* Use of -fdec-char-conversions allows assignment of character data 10897 to non-character variables. This not permited for nonconstant 10898 strings. */ 10899 gfc_error ("Cannot convert %s to %s at %L", gfc_typename (rhs), 10900 gfc_typename (lhs), &rhs->where); 10901 return false; 10902 } 10903 10904 /* Handle the case of a BOZ literal on the RHS. */ 10905 if (rhs->ts.type == BT_BOZ) 10906 { 10907 if (gfc_invalid_boz ("BOZ literal constant at %L is neither a DATA " 10908 "statement value nor an actual argument of " 10909 "INT/REAL/DBLE/CMPLX intrinsic subprogram", 10910 &rhs->where)) 10911 return false; 10912 10913 switch (lhs->ts.type) 10914 { 10915 case BT_INTEGER: 10916 if (!gfc_boz2int (rhs, lhs->ts.kind)) 10917 return false; 10918 break; 10919 case BT_REAL: 10920 if (!gfc_boz2real (rhs, lhs->ts.kind)) 10921 return false; 10922 break; 10923 default: 10924 gfc_error ("Invalid use of BOZ literal constant at %L", &rhs->where); 10925 return false; 10926 } 10927 } 10928 10929 if (lhs->ts.type == BT_CHARACTER && warn_character_truncation) 10930 { 10931 HOST_WIDE_INT llen = 0, rlen = 0; 10932 if (lhs->ts.u.cl != NULL 10933 && lhs->ts.u.cl->length != NULL 10934 && lhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) 10935 llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer); 10936 10937 if (rhs->expr_type == EXPR_CONSTANT) 10938 rlen = rhs->value.character.length; 10939 10940 else if (rhs->ts.u.cl != NULL 10941 && rhs->ts.u.cl->length != NULL 10942 && rhs->ts.u.cl->length->expr_type == EXPR_CONSTANT) 10943 rlen = gfc_mpz_get_hwi (rhs->ts.u.cl->length->value.integer); 10944 10945 if (rlen && llen && rlen > llen) 10946 gfc_warning_now (OPT_Wcharacter_truncation, 10947 "CHARACTER expression will be truncated " 10948 "in assignment (%ld/%ld) at %L", 10949 (long) llen, (long) rlen, &code->loc); 10950 } 10951 10952 /* Ensure that a vector index expression for the lvalue is evaluated 10953 to a temporary if the lvalue symbol is referenced in it. */ 10954 if (lhs->rank) 10955 { 10956 for (ref = lhs->ref; ref; ref= ref->next) 10957 if (ref->type == REF_ARRAY) 10958 { 10959 for (n = 0; n < ref->u.ar.dimen; n++) 10960 if (ref->u.ar.dimen_type[n] == DIMEN_VECTOR 10961 && gfc_find_sym_in_expr (lhs->symtree->n.sym, 10962 ref->u.ar.start[n])) 10963 ref->u.ar.start[n] 10964 = gfc_get_parentheses (ref->u.ar.start[n]); 10965 } 10966 } 10967 10968 if (gfc_pure (NULL)) 10969 { 10970 if (lhs->ts.type == BT_DERIVED 10971 && lhs->expr_type == EXPR_VARIABLE 10972 && lhs->ts.u.derived->attr.pointer_comp 10973 && rhs->expr_type == EXPR_VARIABLE 10974 && (gfc_impure_variable (rhs->symtree->n.sym) 10975 || gfc_is_coindexed (rhs))) 10976 { 10977 /* F2008, C1283. */ 10978 if (gfc_is_coindexed (rhs)) 10979 gfc_error ("Coindexed expression at %L is assigned to " 10980 "a derived type variable with a POINTER " 10981 "component in a PURE procedure", 10982 &rhs->where); 10983 else 10984 /* F2008, C1283 (4). */ 10985 gfc_error ("In a pure subprogram an INTENT(IN) dummy argument " 10986 "shall not be used as the expr at %L of an intrinsic " 10987 "assignment statement in which the variable is of a " 10988 "derived type if the derived type has a pointer " 10989 "component at any level of component selection.", 10990 &rhs->where); 10991 return rval; 10992 } 10993 10994 /* Fortran 2008, C1283. */ 10995 if (gfc_is_coindexed (lhs)) 10996 { 10997 gfc_error ("Assignment to coindexed variable at %L in a PURE " 10998 "procedure", &rhs->where); 10999 return rval; 11000 } 11001 } 11002 11003 if (gfc_implicit_pure (NULL)) 11004 { 11005 if (lhs->expr_type == EXPR_VARIABLE 11006 && lhs->symtree->n.sym != gfc_current_ns->proc_name 11007 && lhs->symtree->n.sym->ns != gfc_current_ns) 11008 gfc_unset_implicit_pure (NULL); 11009 11010 if (lhs->ts.type == BT_DERIVED 11011 && lhs->expr_type == EXPR_VARIABLE 11012 && lhs->ts.u.derived->attr.pointer_comp 11013 && rhs->expr_type == EXPR_VARIABLE 11014 && (gfc_impure_variable (rhs->symtree->n.sym) 11015 || gfc_is_coindexed (rhs))) 11016 gfc_unset_implicit_pure (NULL); 11017 11018 /* Fortran 2008, C1283. */ 11019 if (gfc_is_coindexed (lhs)) 11020 gfc_unset_implicit_pure (NULL); 11021 } 11022 11023 /* F2008, 7.2.1.2. */ 11024 attr = gfc_expr_attr (lhs); 11025 if (lhs->ts.type == BT_CLASS && attr.allocatable) 11026 { 11027 if (attr.codimension) 11028 { 11029 gfc_error ("Assignment to polymorphic coarray at %L is not " 11030 "permitted", &lhs->where); 11031 return false; 11032 } 11033 if (!gfc_notify_std (GFC_STD_F2008, "Assignment to an allocatable " 11034 "polymorphic variable at %L", &lhs->where)) 11035 return false; 11036 if (!flag_realloc_lhs) 11037 { 11038 gfc_error ("Assignment to an allocatable polymorphic variable at %L " 11039 "requires %<-frealloc-lhs%>", &lhs->where); 11040 return false; 11041 } 11042 } 11043 else if (lhs->ts.type == BT_CLASS) 11044 { 11045 gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic " 11046 "assignment at %L - check that there is a matching specific " 11047 "subroutine for '=' operator", &lhs->where); 11048 return false; 11049 } 11050 11051 bool lhs_coindexed = gfc_is_coindexed (lhs); 11052 11053 /* F2008, Section 7.2.1.2. */ 11054 if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs)) 11055 { 11056 gfc_error ("Coindexed variable must not have an allocatable ultimate " 11057 "component in assignment at %L", &lhs->where); 11058 return false; 11059 } 11060 11061 /* Assign the 'data' of a class object to a derived type. */ 11062 if (lhs->ts.type == BT_DERIVED 11063 && rhs->ts.type == BT_CLASS 11064 && rhs->expr_type != EXPR_ARRAY) 11065 gfc_add_data_component (rhs); 11066 11067 /* Make sure there is a vtable and, in particular, a _copy for the 11068 rhs type. */ 11069 if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS) 11070 gfc_find_vtab (&rhs->ts); 11071 11072 bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB 11073 && (lhs_coindexed 11074 || (code->expr2->expr_type == EXPR_FUNCTION 11075 && code->expr2->value.function.isym 11076 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET 11077 && (code->expr1->rank == 0 || code->expr2->rank != 0) 11078 && !gfc_expr_attr (rhs).allocatable 11079 && !gfc_has_vector_subscript (rhs))); 11080 11081 gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send); 11082 11083 /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable. 11084 Additionally, insert this code when the RHS is a CAF as we then use the 11085 GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if 11086 the LHS is (re)allocatable or has a vector subscript. If the LHS is a 11087 noncoindexed array and the RHS is a coindexed scalar, use the normal code 11088 path. */ 11089 if (caf_convert_to_send) 11090 { 11091 if (code->expr2->expr_type == EXPR_FUNCTION 11092 && code->expr2->value.function.isym 11093 && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET) 11094 remove_caf_get_intrinsic (code->expr2); 11095 code->op = EXEC_CALL; 11096 gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true); 11097 code->resolved_sym = code->symtree->n.sym; 11098 code->resolved_sym->attr.flavor = FL_PROCEDURE; 11099 code->resolved_sym->attr.intrinsic = 1; 11100 code->resolved_sym->attr.subroutine = 1; 11101 code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND); 11102 gfc_commit_symbol (code->resolved_sym); 11103 code->ext.actual = gfc_get_actual_arglist (); 11104 code->ext.actual->expr = lhs; 11105 code->ext.actual->next = gfc_get_actual_arglist (); 11106 code->ext.actual->next->expr = rhs; 11107 code->expr1 = NULL; 11108 code->expr2 = NULL; 11109 } 11110 11111 return false; 11112} 11113 11114 11115/* Add a component reference onto an expression. */ 11116 11117static void 11118add_comp_ref (gfc_expr *e, gfc_component *c) 11119{ 11120 gfc_ref **ref; 11121 ref = &(e->ref); 11122 while (*ref) 11123 ref = &((*ref)->next); 11124 *ref = gfc_get_ref (); 11125 (*ref)->type = REF_COMPONENT; 11126 (*ref)->u.c.sym = e->ts.u.derived; 11127 (*ref)->u.c.component = c; 11128 e->ts = c->ts; 11129 11130 /* Add a full array ref, as necessary. */ 11131 if (c->as) 11132 { 11133 gfc_add_full_array_ref (e, c->as); 11134 e->rank = c->as->rank; 11135 } 11136} 11137 11138 11139/* Build an assignment. Keep the argument 'op' for future use, so that 11140 pointer assignments can be made. */ 11141 11142static gfc_code * 11143build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2, 11144 gfc_component *comp1, gfc_component *comp2, locus loc) 11145{ 11146 gfc_code *this_code; 11147 11148 this_code = gfc_get_code (op); 11149 this_code->next = NULL; 11150 this_code->expr1 = gfc_copy_expr (expr1); 11151 this_code->expr2 = gfc_copy_expr (expr2); 11152 this_code->loc = loc; 11153 if (comp1 && comp2) 11154 { 11155 add_comp_ref (this_code->expr1, comp1); 11156 add_comp_ref (this_code->expr2, comp2); 11157 } 11158 11159 return this_code; 11160} 11161 11162 11163/* Makes a temporary variable expression based on the characteristics of 11164 a given variable expression. */ 11165 11166static gfc_expr* 11167get_temp_from_expr (gfc_expr *e, gfc_namespace *ns) 11168{ 11169 static int serial = 0; 11170 char name[GFC_MAX_SYMBOL_LEN]; 11171 gfc_symtree *tmp; 11172 gfc_array_spec *as; 11173 gfc_array_ref *aref; 11174 gfc_ref *ref; 11175 11176 sprintf (name, GFC_PREFIX("DA%d"), serial++); 11177 gfc_get_sym_tree (name, ns, &tmp, false); 11178 gfc_add_type (tmp->n.sym, &e->ts, NULL); 11179 11180 if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER) 11181 tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, 11182 NULL, 11183 e->value.character.length); 11184 11185 as = NULL; 11186 ref = NULL; 11187 aref = NULL; 11188 11189 /* Obtain the arrayspec for the temporary. */ 11190 if (e->rank && e->expr_type != EXPR_ARRAY 11191 && e->expr_type != EXPR_FUNCTION 11192 && e->expr_type != EXPR_OP) 11193 { 11194 aref = gfc_find_array_ref (e); 11195 if (e->expr_type == EXPR_VARIABLE 11196 && e->symtree->n.sym->as == aref->as) 11197 as = aref->as; 11198 else 11199 { 11200 for (ref = e->ref; ref; ref = ref->next) 11201 if (ref->type == REF_COMPONENT 11202 && ref->u.c.component->as == aref->as) 11203 { 11204 as = aref->as; 11205 break; 11206 } 11207 } 11208 } 11209 11210 /* Add the attributes and the arrayspec to the temporary. */ 11211 tmp->n.sym->attr = gfc_expr_attr (e); 11212 tmp->n.sym->attr.function = 0; 11213 tmp->n.sym->attr.result = 0; 11214 tmp->n.sym->attr.flavor = FL_VARIABLE; 11215 tmp->n.sym->attr.dummy = 0; 11216 tmp->n.sym->attr.intent = INTENT_UNKNOWN; 11217 11218 if (as) 11219 { 11220 tmp->n.sym->as = gfc_copy_array_spec (as); 11221 if (!ref) 11222 ref = e->ref; 11223 if (as->type == AS_DEFERRED) 11224 tmp->n.sym->attr.allocatable = 1; 11225 } 11226 else if (e->rank && (e->expr_type == EXPR_ARRAY 11227 || e->expr_type == EXPR_FUNCTION 11228 || e->expr_type == EXPR_OP)) 11229 { 11230 tmp->n.sym->as = gfc_get_array_spec (); 11231 tmp->n.sym->as->type = AS_DEFERRED; 11232 tmp->n.sym->as->rank = e->rank; 11233 tmp->n.sym->attr.allocatable = 1; 11234 tmp->n.sym->attr.dimension = 1; 11235 } 11236 else 11237 tmp->n.sym->attr.dimension = 0; 11238 11239 gfc_set_sym_referenced (tmp->n.sym); 11240 gfc_commit_symbol (tmp->n.sym); 11241 e = gfc_lval_expr_from_sym (tmp->n.sym); 11242 11243 /* Should the lhs be a section, use its array ref for the 11244 temporary expression. */ 11245 if (aref && aref->type != AR_FULL) 11246 { 11247 gfc_free_ref_list (e->ref); 11248 e->ref = gfc_copy_ref (ref); 11249 } 11250 return e; 11251} 11252 11253 11254/* Add one line of code to the code chain, making sure that 'head' and 11255 'tail' are appropriately updated. */ 11256 11257static void 11258add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail) 11259{ 11260 gcc_assert (this_code); 11261 if (*head == NULL) 11262 *head = *tail = *this_code; 11263 else 11264 *tail = gfc_append_code (*tail, *this_code); 11265 *this_code = NULL; 11266} 11267 11268 11269/* Counts the potential number of part array references that would 11270 result from resolution of typebound defined assignments. */ 11271 11272static int 11273nonscalar_typebound_assign (gfc_symbol *derived, int depth) 11274{ 11275 gfc_component *c; 11276 int c_depth = 0, t_depth; 11277 11278 for (c= derived->components; c; c = c->next) 11279 { 11280 if ((!gfc_bt_struct (c->ts.type) 11281 || c->attr.pointer 11282 || c->attr.allocatable 11283 || c->attr.proc_pointer_comp 11284 || c->attr.class_pointer 11285 || c->attr.proc_pointer) 11286 && !c->attr.defined_assign_comp) 11287 continue; 11288 11289 if (c->as && c_depth == 0) 11290 c_depth = 1; 11291 11292 if (c->ts.u.derived->attr.defined_assign_comp) 11293 t_depth = nonscalar_typebound_assign (c->ts.u.derived, 11294 c->as ? 1 : 0); 11295 else 11296 t_depth = 0; 11297 11298 c_depth = t_depth > c_depth ? t_depth : c_depth; 11299 } 11300 return depth + c_depth; 11301} 11302 11303 11304/* Implement 7.2.1.3 of the F08 standard: 11305 "An intrinsic assignment where the variable is of derived type is 11306 performed as if each component of the variable were assigned from the 11307 corresponding component of expr using pointer assignment (7.2.2) for 11308 each pointer component, defined assignment for each nonpointer 11309 nonallocatable component of a type that has a type-bound defined 11310 assignment consistent with the component, intrinsic assignment for 11311 each other nonpointer nonallocatable component, ..." 11312 11313 The pointer assignments are taken care of by the intrinsic 11314 assignment of the structure itself. This function recursively adds 11315 defined assignments where required. The recursion is accomplished 11316 by calling gfc_resolve_code. 11317 11318 When the lhs in a defined assignment has intent INOUT, we need a 11319 temporary for the lhs. In pseudo-code: 11320 11321 ! Only call function lhs once. 11322 if (lhs is not a constant or an variable) 11323 temp_x = expr2 11324 expr2 => temp_x 11325 ! Do the intrinsic assignment 11326 expr1 = expr2 11327 ! Now do the defined assignments 11328 do over components with typebound defined assignment [%cmp] 11329 #if one component's assignment procedure is INOUT 11330 t1 = expr1 11331 #if expr2 non-variable 11332 temp_x = expr2 11333 expr2 => temp_x 11334 # endif 11335 expr1 = expr2 11336 # for each cmp 11337 t1%cmp {defined=} expr2%cmp 11338 expr1%cmp = t1%cmp 11339 #else 11340 expr1 = expr2 11341 11342 # for each cmp 11343 expr1%cmp {defined=} expr2%cmp 11344 #endif 11345 */ 11346 11347/* The temporary assignments have to be put on top of the additional 11348 code to avoid the result being changed by the intrinsic assignment. 11349 */ 11350static int component_assignment_level = 0; 11351static gfc_code *tmp_head = NULL, *tmp_tail = NULL; 11352 11353static void 11354generate_component_assignments (gfc_code **code, gfc_namespace *ns) 11355{ 11356 gfc_component *comp1, *comp2; 11357 gfc_code *this_code = NULL, *head = NULL, *tail = NULL; 11358 gfc_expr *t1; 11359 int error_count, depth; 11360 11361 gfc_get_errors (NULL, &error_count); 11362 11363 /* Filter out continuing processing after an error. */ 11364 if (error_count 11365 || (*code)->expr1->ts.type != BT_DERIVED 11366 || (*code)->expr2->ts.type != BT_DERIVED) 11367 return; 11368 11369 /* TODO: Handle more than one part array reference in assignments. */ 11370 depth = nonscalar_typebound_assign ((*code)->expr1->ts.u.derived, 11371 (*code)->expr1->rank ? 1 : 0); 11372 if (depth > 1) 11373 { 11374 gfc_warning (0, "TODO: type-bound defined assignment(s) at %L not " 11375 "done because multiple part array references would " 11376 "occur in intermediate expressions.", &(*code)->loc); 11377 return; 11378 } 11379 11380 component_assignment_level++; 11381 11382 /* Create a temporary so that functions get called only once. */ 11383 if ((*code)->expr2->expr_type != EXPR_VARIABLE 11384 && (*code)->expr2->expr_type != EXPR_CONSTANT) 11385 { 11386 gfc_expr *tmp_expr; 11387 11388 /* Assign the rhs to the temporary. */ 11389 tmp_expr = get_temp_from_expr ((*code)->expr1, ns); 11390 this_code = build_assignment (EXEC_ASSIGN, 11391 tmp_expr, (*code)->expr2, 11392 NULL, NULL, (*code)->loc); 11393 /* Add the code and substitute the rhs expression. */ 11394 add_code_to_chain (&this_code, &tmp_head, &tmp_tail); 11395 gfc_free_expr ((*code)->expr2); 11396 (*code)->expr2 = tmp_expr; 11397 } 11398 11399 /* Do the intrinsic assignment. This is not needed if the lhs is one 11400 of the temporaries generated here, since the intrinsic assignment 11401 to the final result already does this. */ 11402 if ((*code)->expr1->symtree->n.sym->name[2] != '@') 11403 { 11404 this_code = build_assignment (EXEC_ASSIGN, 11405 (*code)->expr1, (*code)->expr2, 11406 NULL, NULL, (*code)->loc); 11407 add_code_to_chain (&this_code, &head, &tail); 11408 } 11409 11410 comp1 = (*code)->expr1->ts.u.derived->components; 11411 comp2 = (*code)->expr2->ts.u.derived->components; 11412 11413 t1 = NULL; 11414 for (; comp1; comp1 = comp1->next, comp2 = comp2->next) 11415 { 11416 bool inout = false; 11417 11418 /* The intrinsic assignment does the right thing for pointers 11419 of all kinds and allocatable components. */ 11420 if (!gfc_bt_struct (comp1->ts.type) 11421 || comp1->attr.pointer 11422 || comp1->attr.allocatable 11423 || comp1->attr.proc_pointer_comp 11424 || comp1->attr.class_pointer 11425 || comp1->attr.proc_pointer) 11426 continue; 11427 11428 /* Make an assigment for this component. */ 11429 this_code = build_assignment (EXEC_ASSIGN, 11430 (*code)->expr1, (*code)->expr2, 11431 comp1, comp2, (*code)->loc); 11432 11433 /* Convert the assignment if there is a defined assignment for 11434 this type. Otherwise, using the call from gfc_resolve_code, 11435 recurse into its components. */ 11436 gfc_resolve_code (this_code, ns); 11437 11438 if (this_code->op == EXEC_ASSIGN_CALL) 11439 { 11440 gfc_formal_arglist *dummy_args; 11441 gfc_symbol *rsym; 11442 /* Check that there is a typebound defined assignment. If not, 11443 then this must be a module defined assignment. We cannot 11444 use the defined_assign_comp attribute here because it must 11445 be this derived type that has the defined assignment and not 11446 a parent type. */ 11447 if (!(comp1->ts.u.derived->f2k_derived 11448 && comp1->ts.u.derived->f2k_derived 11449 ->tb_op[INTRINSIC_ASSIGN])) 11450 { 11451 gfc_free_statements (this_code); 11452 this_code = NULL; 11453 continue; 11454 } 11455 11456 /* If the first argument of the subroutine has intent INOUT 11457 a temporary must be generated and used instead. */ 11458 rsym = this_code->resolved_sym; 11459 dummy_args = gfc_sym_get_dummy_args (rsym); 11460 if (dummy_args 11461 && dummy_args->sym->attr.intent == INTENT_INOUT) 11462 { 11463 gfc_code *temp_code; 11464 inout = true; 11465 11466 /* Build the temporary required for the assignment and put 11467 it at the head of the generated code. */ 11468 if (!t1) 11469 { 11470 t1 = get_temp_from_expr ((*code)->expr1, ns); 11471 temp_code = build_assignment (EXEC_ASSIGN, 11472 t1, (*code)->expr1, 11473 NULL, NULL, (*code)->loc); 11474 11475 /* For allocatable LHS, check whether it is allocated. Note 11476 that allocatable components with defined assignment are 11477 not yet support. See PR 57696. */ 11478 if ((*code)->expr1->symtree->n.sym->attr.allocatable) 11479 { 11480 gfc_code *block; 11481 gfc_expr *e = 11482 gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); 11483 block = gfc_get_code (EXEC_IF); 11484 block->block = gfc_get_code (EXEC_IF); 11485 block->block->expr1 11486 = gfc_build_intrinsic_call (ns, 11487 GFC_ISYM_ALLOCATED, "allocated", 11488 (*code)->loc, 1, e); 11489 block->block->next = temp_code; 11490 temp_code = block; 11491 } 11492 add_code_to_chain (&temp_code, &tmp_head, &tmp_tail); 11493 } 11494 11495 /* Replace the first actual arg with the component of the 11496 temporary. */ 11497 gfc_free_expr (this_code->ext.actual->expr); 11498 this_code->ext.actual->expr = gfc_copy_expr (t1); 11499 add_comp_ref (this_code->ext.actual->expr, comp1); 11500 11501 /* If the LHS variable is allocatable and wasn't allocated and 11502 the temporary is allocatable, pointer assign the address of 11503 the freshly allocated LHS to the temporary. */ 11504 if ((*code)->expr1->symtree->n.sym->attr.allocatable 11505 && gfc_expr_attr ((*code)->expr1).allocatable) 11506 { 11507 gfc_code *block; 11508 gfc_expr *cond; 11509 11510 cond = gfc_get_expr (); 11511 cond->ts.type = BT_LOGICAL; 11512 cond->ts.kind = gfc_default_logical_kind; 11513 cond->expr_type = EXPR_OP; 11514 cond->where = (*code)->loc; 11515 cond->value.op.op = INTRINSIC_NOT; 11516 cond->value.op.op1 = gfc_build_intrinsic_call (ns, 11517 GFC_ISYM_ALLOCATED, "allocated", 11518 (*code)->loc, 1, gfc_copy_expr (t1)); 11519 block = gfc_get_code (EXEC_IF); 11520 block->block = gfc_get_code (EXEC_IF); 11521 block->block->expr1 = cond; 11522 block->block->next = build_assignment (EXEC_POINTER_ASSIGN, 11523 t1, (*code)->expr1, 11524 NULL, NULL, (*code)->loc); 11525 add_code_to_chain (&block, &head, &tail); 11526 } 11527 } 11528 } 11529 else if (this_code->op == EXEC_ASSIGN && !this_code->next) 11530 { 11531 /* Don't add intrinsic assignments since they are already 11532 effected by the intrinsic assignment of the structure. */ 11533 gfc_free_statements (this_code); 11534 this_code = NULL; 11535 continue; 11536 } 11537 11538 add_code_to_chain (&this_code, &head, &tail); 11539 11540 if (t1 && inout) 11541 { 11542 /* Transfer the value to the final result. */ 11543 this_code = build_assignment (EXEC_ASSIGN, 11544 (*code)->expr1, t1, 11545 comp1, comp2, (*code)->loc); 11546 add_code_to_chain (&this_code, &head, &tail); 11547 } 11548 } 11549 11550 /* Put the temporary assignments at the top of the generated code. */ 11551 if (tmp_head && component_assignment_level == 1) 11552 { 11553 gfc_append_code (tmp_head, head); 11554 head = tmp_head; 11555 tmp_head = tmp_tail = NULL; 11556 } 11557 11558 // If we did a pointer assignment - thus, we need to ensure that the LHS is 11559 // not accidentally deallocated. Hence, nullify t1. 11560 if (t1 && (*code)->expr1->symtree->n.sym->attr.allocatable 11561 && gfc_expr_attr ((*code)->expr1).allocatable) 11562 { 11563 gfc_code *block; 11564 gfc_expr *cond; 11565 gfc_expr *e; 11566 11567 e = gfc_lval_expr_from_sym ((*code)->expr1->symtree->n.sym); 11568 cond = gfc_build_intrinsic_call (ns, GFC_ISYM_ASSOCIATED, "associated", 11569 (*code)->loc, 2, gfc_copy_expr (t1), e); 11570 block = gfc_get_code (EXEC_IF); 11571 block->block = gfc_get_code (EXEC_IF); 11572 block->block->expr1 = cond; 11573 block->block->next = build_assignment (EXEC_POINTER_ASSIGN, 11574 t1, gfc_get_null_expr (&(*code)->loc), 11575 NULL, NULL, (*code)->loc); 11576 gfc_append_code (tail, block); 11577 tail = block; 11578 } 11579 11580 /* Now attach the remaining code chain to the input code. Step on 11581 to the end of the new code since resolution is complete. */ 11582 gcc_assert ((*code)->op == EXEC_ASSIGN); 11583 tail->next = (*code)->next; 11584 /* Overwrite 'code' because this would place the intrinsic assignment 11585 before the temporary for the lhs is created. */ 11586 gfc_free_expr ((*code)->expr1); 11587 gfc_free_expr ((*code)->expr2); 11588 **code = *head; 11589 if (head != tail) 11590 free (head); 11591 *code = tail; 11592 11593 component_assignment_level--; 11594} 11595 11596 11597/* F2008: Pointer function assignments are of the form: 11598 ptr_fcn (args) = expr 11599 This function breaks these assignments into two statements: 11600 temporary_pointer => ptr_fcn(args) 11601 temporary_pointer = expr */ 11602 11603static bool 11604resolve_ptr_fcn_assign (gfc_code **code, gfc_namespace *ns) 11605{ 11606 gfc_expr *tmp_ptr_expr; 11607 gfc_code *this_code; 11608 gfc_component *comp; 11609 gfc_symbol *s; 11610 11611 if ((*code)->expr1->expr_type != EXPR_FUNCTION) 11612 return false; 11613 11614 /* Even if standard does not support this feature, continue to build 11615 the two statements to avoid upsetting frontend_passes.c. */ 11616 gfc_notify_std (GFC_STD_F2008, "Pointer procedure assignment at " 11617 "%L", &(*code)->loc); 11618 11619 comp = gfc_get_proc_ptr_comp ((*code)->expr1); 11620 11621 if (comp) 11622 s = comp->ts.interface; 11623 else 11624 s = (*code)->expr1->symtree->n.sym; 11625 11626 if (s == NULL || !s->result->attr.pointer) 11627 { 11628 gfc_error ("The function result on the lhs of the assignment at " 11629 "%L must have the pointer attribute.", 11630 &(*code)->expr1->where); 11631 (*code)->op = EXEC_NOP; 11632 return false; 11633 } 11634 11635 tmp_ptr_expr = get_temp_from_expr ((*code)->expr2, ns); 11636 11637 /* get_temp_from_expression is set up for ordinary assignments. To that 11638 end, where array bounds are not known, arrays are made allocatable. 11639 Change the temporary to a pointer here. */ 11640 tmp_ptr_expr->symtree->n.sym->attr.pointer = 1; 11641 tmp_ptr_expr->symtree->n.sym->attr.allocatable = 0; 11642 tmp_ptr_expr->where = (*code)->loc; 11643 11644 this_code = build_assignment (EXEC_ASSIGN, 11645 tmp_ptr_expr, (*code)->expr2, 11646 NULL, NULL, (*code)->loc); 11647 this_code->next = (*code)->next; 11648 (*code)->next = this_code; 11649 (*code)->op = EXEC_POINTER_ASSIGN; 11650 (*code)->expr2 = (*code)->expr1; 11651 (*code)->expr1 = tmp_ptr_expr; 11652 11653 return true; 11654} 11655 11656 11657/* Deferred character length assignments from an operator expression 11658 require a temporary because the character length of the lhs can 11659 change in the course of the assignment. */ 11660 11661static bool 11662deferred_op_assign (gfc_code **code, gfc_namespace *ns) 11663{ 11664 gfc_expr *tmp_expr; 11665 gfc_code *this_code; 11666 11667 if (!((*code)->expr1->ts.type == BT_CHARACTER 11668 && (*code)->expr1->ts.deferred && (*code)->expr1->rank 11669 && (*code)->expr2->expr_type == EXPR_OP)) 11670 return false; 11671 11672 if (!gfc_check_dependency ((*code)->expr1, (*code)->expr2, 1)) 11673 return false; 11674 11675 if (gfc_expr_attr ((*code)->expr1).pointer) 11676 return false; 11677 11678 tmp_expr = get_temp_from_expr ((*code)->expr1, ns); 11679 tmp_expr->where = (*code)->loc; 11680 11681 /* A new charlen is required to ensure that the variable string 11682 length is different to that of the original lhs. */ 11683 tmp_expr->ts.u.cl = gfc_get_charlen(); 11684 tmp_expr->symtree->n.sym->ts.u.cl = tmp_expr->ts.u.cl; 11685 tmp_expr->ts.u.cl->next = (*code)->expr2->ts.u.cl->next; 11686 (*code)->expr2->ts.u.cl->next = tmp_expr->ts.u.cl; 11687 11688 tmp_expr->symtree->n.sym->ts.deferred = 1; 11689 11690 this_code = build_assignment (EXEC_ASSIGN, 11691 (*code)->expr1, 11692 gfc_copy_expr (tmp_expr), 11693 NULL, NULL, (*code)->loc); 11694 11695 (*code)->expr1 = tmp_expr; 11696 11697 this_code->next = (*code)->next; 11698 (*code)->next = this_code; 11699 11700 return true; 11701} 11702 11703 11704/* Given a block of code, recursively resolve everything pointed to by this 11705 code block. */ 11706 11707void 11708gfc_resolve_code (gfc_code *code, gfc_namespace *ns) 11709{ 11710 int omp_workshare_save; 11711 int forall_save, do_concurrent_save; 11712 code_stack frame; 11713 bool t; 11714 11715 frame.prev = cs_base; 11716 frame.head = code; 11717 cs_base = &frame; 11718 11719 find_reachable_labels (code); 11720 11721 for (; code; code = code->next) 11722 { 11723 frame.current = code; 11724 forall_save = forall_flag; 11725 do_concurrent_save = gfc_do_concurrent_flag; 11726 11727 if (code->op == EXEC_FORALL) 11728 { 11729 forall_flag = 1; 11730 gfc_resolve_forall (code, ns, forall_save); 11731 forall_flag = 2; 11732 } 11733 else if (code->block) 11734 { 11735 omp_workshare_save = -1; 11736 switch (code->op) 11737 { 11738 case EXEC_OACC_PARALLEL_LOOP: 11739 case EXEC_OACC_PARALLEL: 11740 case EXEC_OACC_KERNELS_LOOP: 11741 case EXEC_OACC_KERNELS: 11742 case EXEC_OACC_SERIAL_LOOP: 11743 case EXEC_OACC_SERIAL: 11744 case EXEC_OACC_DATA: 11745 case EXEC_OACC_HOST_DATA: 11746 case EXEC_OACC_LOOP: 11747 gfc_resolve_oacc_blocks (code, ns); 11748 break; 11749 case EXEC_OMP_PARALLEL_WORKSHARE: 11750 omp_workshare_save = omp_workshare_flag; 11751 omp_workshare_flag = 1; 11752 gfc_resolve_omp_parallel_blocks (code, ns); 11753 break; 11754 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 11755 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 11756 case EXEC_OMP_PARALLEL: 11757 case EXEC_OMP_PARALLEL_DO: 11758 case EXEC_OMP_PARALLEL_DO_SIMD: 11759 case EXEC_OMP_PARALLEL_SECTIONS: 11760 case EXEC_OMP_TARGET_PARALLEL: 11761 case EXEC_OMP_TARGET_PARALLEL_DO: 11762 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 11763 case EXEC_OMP_TARGET_TEAMS: 11764 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 11765 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 11766 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 11767 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 11768 case EXEC_OMP_TASK: 11769 case EXEC_OMP_TASKLOOP: 11770 case EXEC_OMP_TASKLOOP_SIMD: 11771 case EXEC_OMP_TEAMS: 11772 case EXEC_OMP_TEAMS_DISTRIBUTE: 11773 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 11774 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 11775 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 11776 omp_workshare_save = omp_workshare_flag; 11777 omp_workshare_flag = 0; 11778 gfc_resolve_omp_parallel_blocks (code, ns); 11779 break; 11780 case EXEC_OMP_DISTRIBUTE: 11781 case EXEC_OMP_DISTRIBUTE_SIMD: 11782 case EXEC_OMP_DO: 11783 case EXEC_OMP_DO_SIMD: 11784 case EXEC_OMP_SIMD: 11785 case EXEC_OMP_TARGET_SIMD: 11786 gfc_resolve_omp_do_blocks (code, ns); 11787 break; 11788 case EXEC_SELECT_TYPE: 11789 case EXEC_SELECT_RANK: 11790 /* Blocks are handled in resolve_select_type/rank because we 11791 have to transform the SELECT TYPE into ASSOCIATE first. */ 11792 break; 11793 case EXEC_DO_CONCURRENT: 11794 gfc_do_concurrent_flag = 1; 11795 gfc_resolve_blocks (code->block, ns); 11796 gfc_do_concurrent_flag = 2; 11797 break; 11798 case EXEC_OMP_WORKSHARE: 11799 omp_workshare_save = omp_workshare_flag; 11800 omp_workshare_flag = 1; 11801 /* FALL THROUGH */ 11802 default: 11803 gfc_resolve_blocks (code->block, ns); 11804 break; 11805 } 11806 11807 if (omp_workshare_save != -1) 11808 omp_workshare_flag = omp_workshare_save; 11809 } 11810start: 11811 t = true; 11812 if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC) 11813 t = gfc_resolve_expr (code->expr1); 11814 forall_flag = forall_save; 11815 gfc_do_concurrent_flag = do_concurrent_save; 11816 11817 if (!gfc_resolve_expr (code->expr2)) 11818 t = false; 11819 11820 if (code->op == EXEC_ALLOCATE 11821 && !gfc_resolve_expr (code->expr3)) 11822 t = false; 11823 11824 switch (code->op) 11825 { 11826 case EXEC_NOP: 11827 case EXEC_END_BLOCK: 11828 case EXEC_END_NESTED_BLOCK: 11829 case EXEC_CYCLE: 11830 case EXEC_PAUSE: 11831 case EXEC_STOP: 11832 case EXEC_ERROR_STOP: 11833 case EXEC_EXIT: 11834 case EXEC_CONTINUE: 11835 case EXEC_DT_END: 11836 case EXEC_ASSIGN_CALL: 11837 break; 11838 11839 case EXEC_CRITICAL: 11840 resolve_critical (code); 11841 break; 11842 11843 case EXEC_SYNC_ALL: 11844 case EXEC_SYNC_IMAGES: 11845 case EXEC_SYNC_MEMORY: 11846 resolve_sync (code); 11847 break; 11848 11849 case EXEC_LOCK: 11850 case EXEC_UNLOCK: 11851 case EXEC_EVENT_POST: 11852 case EXEC_EVENT_WAIT: 11853 resolve_lock_unlock_event (code); 11854 break; 11855 11856 case EXEC_FAIL_IMAGE: 11857 case EXEC_FORM_TEAM: 11858 case EXEC_CHANGE_TEAM: 11859 case EXEC_END_TEAM: 11860 case EXEC_SYNC_TEAM: 11861 break; 11862 11863 case EXEC_ENTRY: 11864 /* Keep track of which entry we are up to. */ 11865 current_entry_id = code->ext.entry->id; 11866 break; 11867 11868 case EXEC_WHERE: 11869 resolve_where (code, NULL); 11870 break; 11871 11872 case EXEC_GOTO: 11873 if (code->expr1 != NULL) 11874 { 11875 if (code->expr1->expr_type != EXPR_VARIABLE 11876 || code->expr1->ts.type != BT_INTEGER 11877 || (code->expr1->ref 11878 && code->expr1->ref->type == REF_ARRAY) 11879 || code->expr1->symtree == NULL 11880 || (code->expr1->symtree->n.sym 11881 && (code->expr1->symtree->n.sym->attr.flavor 11882 == FL_PARAMETER))) 11883 gfc_error ("ASSIGNED GOTO statement at %L requires a " 11884 "scalar INTEGER variable", &code->expr1->where); 11885 else if (code->expr1->symtree->n.sym 11886 && code->expr1->symtree->n.sym->attr.assign != 1) 11887 gfc_error ("Variable %qs has not been assigned a target " 11888 "label at %L", code->expr1->symtree->n.sym->name, 11889 &code->expr1->where); 11890 } 11891 else 11892 resolve_branch (code->label1, code); 11893 break; 11894 11895 case EXEC_RETURN: 11896 if (code->expr1 != NULL 11897 && (code->expr1->ts.type != BT_INTEGER || code->expr1->rank)) 11898 gfc_error ("Alternate RETURN statement at %L requires a SCALAR-" 11899 "INTEGER return specifier", &code->expr1->where); 11900 break; 11901 11902 case EXEC_INIT_ASSIGN: 11903 case EXEC_END_PROCEDURE: 11904 break; 11905 11906 case EXEC_ASSIGN: 11907 if (!t) 11908 break; 11909 11910 if (code->expr1->ts.type == BT_CLASS) 11911 gfc_find_vtab (&code->expr2->ts); 11912 11913 /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on 11914 the LHS. */ 11915 if (code->expr1->expr_type == EXPR_FUNCTION 11916 && code->expr1->value.function.isym 11917 && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET) 11918 remove_caf_get_intrinsic (code->expr1); 11919 11920 /* If this is a pointer function in an lvalue variable context, 11921 the new code will have to be resolved afresh. This is also the 11922 case with an error, where the code is transformed into NOP to 11923 prevent ICEs downstream. */ 11924 if (resolve_ptr_fcn_assign (&code, ns) 11925 || code->op == EXEC_NOP) 11926 goto start; 11927 11928 if (!gfc_check_vardef_context (code->expr1, false, false, false, 11929 _("assignment"))) 11930 break; 11931 11932 if (resolve_ordinary_assign (code, ns)) 11933 { 11934 if (code->op == EXEC_COMPCALL) 11935 goto compcall; 11936 else 11937 goto call; 11938 } 11939 11940 /* Check for dependencies in deferred character length array 11941 assignments and generate a temporary, if necessary. */ 11942 if (code->op == EXEC_ASSIGN && deferred_op_assign (&code, ns)) 11943 break; 11944 11945 /* F03 7.4.1.3 for non-allocatable, non-pointer components. */ 11946 if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED 11947 && code->expr1->ts.u.derived 11948 && code->expr1->ts.u.derived->attr.defined_assign_comp) 11949 generate_component_assignments (&code, ns); 11950 11951 break; 11952 11953 case EXEC_LABEL_ASSIGN: 11954 if (code->label1->defined == ST_LABEL_UNKNOWN) 11955 gfc_error ("Label %d referenced at %L is never defined", 11956 code->label1->value, &code->label1->where); 11957 if (t 11958 && (code->expr1->expr_type != EXPR_VARIABLE 11959 || code->expr1->symtree->n.sym->ts.type != BT_INTEGER 11960 || code->expr1->symtree->n.sym->ts.kind 11961 != gfc_default_integer_kind 11962 || code->expr1->symtree->n.sym->as != NULL)) 11963 gfc_error ("ASSIGN statement at %L requires a scalar " 11964 "default INTEGER variable", &code->expr1->where); 11965 break; 11966 11967 case EXEC_POINTER_ASSIGN: 11968 { 11969 gfc_expr* e; 11970 11971 if (!t) 11972 break; 11973 11974 /* This is both a variable definition and pointer assignment 11975 context, so check both of them. For rank remapping, a final 11976 array ref may be present on the LHS and fool gfc_expr_attr 11977 used in gfc_check_vardef_context. Remove it. */ 11978 e = remove_last_array_ref (code->expr1); 11979 t = gfc_check_vardef_context (e, true, false, false, 11980 _("pointer assignment")); 11981 if (t) 11982 t = gfc_check_vardef_context (e, false, false, false, 11983 _("pointer assignment")); 11984 gfc_free_expr (e); 11985 11986 t = gfc_check_pointer_assign (code->expr1, code->expr2, !t) && t; 11987 11988 if (!t) 11989 break; 11990 11991 /* Assigning a class object always is a regular assign. */ 11992 if (code->expr2->ts.type == BT_CLASS 11993 && code->expr1->ts.type == BT_CLASS 11994 && !CLASS_DATA (code->expr2)->attr.dimension 11995 && !(gfc_expr_attr (code->expr1).proc_pointer 11996 && code->expr2->expr_type == EXPR_VARIABLE 11997 && code->expr2->symtree->n.sym->attr.flavor 11998 == FL_PROCEDURE)) 11999 code->op = EXEC_ASSIGN; 12000 break; 12001 } 12002 12003 case EXEC_ARITHMETIC_IF: 12004 { 12005 gfc_expr *e = code->expr1; 12006 12007 gfc_resolve_expr (e); 12008 if (e->expr_type == EXPR_NULL) 12009 gfc_error ("Invalid NULL at %L", &e->where); 12010 12011 if (t && (e->rank > 0 12012 || !(e->ts.type == BT_REAL || e->ts.type == BT_INTEGER))) 12013 gfc_error ("Arithmetic IF statement at %L requires a scalar " 12014 "REAL or INTEGER expression", &e->where); 12015 12016 resolve_branch (code->label1, code); 12017 resolve_branch (code->label2, code); 12018 resolve_branch (code->label3, code); 12019 } 12020 break; 12021 12022 case EXEC_IF: 12023 if (t && code->expr1 != NULL 12024 && (code->expr1->ts.type != BT_LOGICAL 12025 || code->expr1->rank != 0)) 12026 gfc_error ("IF clause at %L requires a scalar LOGICAL expression", 12027 &code->expr1->where); 12028 break; 12029 12030 case EXEC_CALL: 12031 call: 12032 resolve_call (code); 12033 break; 12034 12035 case EXEC_COMPCALL: 12036 compcall: 12037 resolve_typebound_subroutine (code); 12038 break; 12039 12040 case EXEC_CALL_PPC: 12041 resolve_ppc_call (code); 12042 break; 12043 12044 case EXEC_SELECT: 12045 /* Select is complicated. Also, a SELECT construct could be 12046 a transformed computed GOTO. */ 12047 resolve_select (code, false); 12048 break; 12049 12050 case EXEC_SELECT_TYPE: 12051 resolve_select_type (code, ns); 12052 break; 12053 12054 case EXEC_SELECT_RANK: 12055 resolve_select_rank (code, ns); 12056 break; 12057 12058 case EXEC_BLOCK: 12059 resolve_block_construct (code); 12060 break; 12061 12062 case EXEC_DO: 12063 if (code->ext.iterator != NULL) 12064 { 12065 gfc_iterator *iter = code->ext.iterator; 12066 if (gfc_resolve_iterator (iter, true, false)) 12067 gfc_resolve_do_iterator (code, iter->var->symtree->n.sym, 12068 true); 12069 } 12070 break; 12071 12072 case EXEC_DO_WHILE: 12073 if (code->expr1 == NULL) 12074 gfc_internal_error ("gfc_resolve_code(): No expression on " 12075 "DO WHILE"); 12076 if (t 12077 && (code->expr1->rank != 0 12078 || code->expr1->ts.type != BT_LOGICAL)) 12079 gfc_error ("Exit condition of DO WHILE loop at %L must be " 12080 "a scalar LOGICAL expression", &code->expr1->where); 12081 break; 12082 12083 case EXEC_ALLOCATE: 12084 if (t) 12085 resolve_allocate_deallocate (code, "ALLOCATE"); 12086 12087 break; 12088 12089 case EXEC_DEALLOCATE: 12090 if (t) 12091 resolve_allocate_deallocate (code, "DEALLOCATE"); 12092 12093 break; 12094 12095 case EXEC_OPEN: 12096 if (!gfc_resolve_open (code->ext.open, &code->loc)) 12097 break; 12098 12099 resolve_branch (code->ext.open->err, code); 12100 break; 12101 12102 case EXEC_CLOSE: 12103 if (!gfc_resolve_close (code->ext.close, &code->loc)) 12104 break; 12105 12106 resolve_branch (code->ext.close->err, code); 12107 break; 12108 12109 case EXEC_BACKSPACE: 12110 case EXEC_ENDFILE: 12111 case EXEC_REWIND: 12112 case EXEC_FLUSH: 12113 if (!gfc_resolve_filepos (code->ext.filepos, &code->loc)) 12114 break; 12115 12116 resolve_branch (code->ext.filepos->err, code); 12117 break; 12118 12119 case EXEC_INQUIRE: 12120 if (!gfc_resolve_inquire (code->ext.inquire)) 12121 break; 12122 12123 resolve_branch (code->ext.inquire->err, code); 12124 break; 12125 12126 case EXEC_IOLENGTH: 12127 gcc_assert (code->ext.inquire != NULL); 12128 if (!gfc_resolve_inquire (code->ext.inquire)) 12129 break; 12130 12131 resolve_branch (code->ext.inquire->err, code); 12132 break; 12133 12134 case EXEC_WAIT: 12135 if (!gfc_resolve_wait (code->ext.wait)) 12136 break; 12137 12138 resolve_branch (code->ext.wait->err, code); 12139 resolve_branch (code->ext.wait->end, code); 12140 resolve_branch (code->ext.wait->eor, code); 12141 break; 12142 12143 case EXEC_READ: 12144 case EXEC_WRITE: 12145 if (!gfc_resolve_dt (code, code->ext.dt, &code->loc)) 12146 break; 12147 12148 resolve_branch (code->ext.dt->err, code); 12149 resolve_branch (code->ext.dt->end, code); 12150 resolve_branch (code->ext.dt->eor, code); 12151 break; 12152 12153 case EXEC_TRANSFER: 12154 resolve_transfer (code); 12155 break; 12156 12157 case EXEC_DO_CONCURRENT: 12158 case EXEC_FORALL: 12159 resolve_forall_iterators (code->ext.forall_iterator); 12160 12161 if (code->expr1 != NULL 12162 && (code->expr1->ts.type != BT_LOGICAL || code->expr1->rank)) 12163 gfc_error ("FORALL mask clause at %L requires a scalar LOGICAL " 12164 "expression", &code->expr1->where); 12165 break; 12166 12167 case EXEC_OACC_PARALLEL_LOOP: 12168 case EXEC_OACC_PARALLEL: 12169 case EXEC_OACC_KERNELS_LOOP: 12170 case EXEC_OACC_KERNELS: 12171 case EXEC_OACC_SERIAL_LOOP: 12172 case EXEC_OACC_SERIAL: 12173 case EXEC_OACC_DATA: 12174 case EXEC_OACC_HOST_DATA: 12175 case EXEC_OACC_LOOP: 12176 case EXEC_OACC_UPDATE: 12177 case EXEC_OACC_WAIT: 12178 case EXEC_OACC_CACHE: 12179 case EXEC_OACC_ENTER_DATA: 12180 case EXEC_OACC_EXIT_DATA: 12181 case EXEC_OACC_ATOMIC: 12182 case EXEC_OACC_DECLARE: 12183 gfc_resolve_oacc_directive (code, ns); 12184 break; 12185 12186 case EXEC_OMP_ATOMIC: 12187 case EXEC_OMP_BARRIER: 12188 case EXEC_OMP_CANCEL: 12189 case EXEC_OMP_CANCELLATION_POINT: 12190 case EXEC_OMP_CRITICAL: 12191 case EXEC_OMP_FLUSH: 12192 case EXEC_OMP_DISTRIBUTE: 12193 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO: 12194 case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: 12195 case EXEC_OMP_DISTRIBUTE_SIMD: 12196 case EXEC_OMP_DO: 12197 case EXEC_OMP_DO_SIMD: 12198 case EXEC_OMP_MASTER: 12199 case EXEC_OMP_ORDERED: 12200 case EXEC_OMP_SECTIONS: 12201 case EXEC_OMP_SIMD: 12202 case EXEC_OMP_SINGLE: 12203 case EXEC_OMP_TARGET: 12204 case EXEC_OMP_TARGET_DATA: 12205 case EXEC_OMP_TARGET_ENTER_DATA: 12206 case EXEC_OMP_TARGET_EXIT_DATA: 12207 case EXEC_OMP_TARGET_PARALLEL: 12208 case EXEC_OMP_TARGET_PARALLEL_DO: 12209 case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: 12210 case EXEC_OMP_TARGET_SIMD: 12211 case EXEC_OMP_TARGET_TEAMS: 12212 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE: 12213 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: 12214 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 12215 case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: 12216 case EXEC_OMP_TARGET_UPDATE: 12217 case EXEC_OMP_TASK: 12218 case EXEC_OMP_TASKGROUP: 12219 case EXEC_OMP_TASKLOOP: 12220 case EXEC_OMP_TASKLOOP_SIMD: 12221 case EXEC_OMP_TASKWAIT: 12222 case EXEC_OMP_TASKYIELD: 12223 case EXEC_OMP_TEAMS: 12224 case EXEC_OMP_TEAMS_DISTRIBUTE: 12225 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: 12226 case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: 12227 case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD: 12228 case EXEC_OMP_WORKSHARE: 12229 gfc_resolve_omp_directive (code, ns); 12230 break; 12231 12232 case EXEC_OMP_PARALLEL: 12233 case EXEC_OMP_PARALLEL_DO: 12234 case EXEC_OMP_PARALLEL_DO_SIMD: 12235 case EXEC_OMP_PARALLEL_SECTIONS: 12236 case EXEC_OMP_PARALLEL_WORKSHARE: 12237 omp_workshare_save = omp_workshare_flag; 12238 omp_workshare_flag = 0; 12239 gfc_resolve_omp_directive (code, ns); 12240 omp_workshare_flag = omp_workshare_save; 12241 break; 12242 12243 default: 12244 gfc_internal_error ("gfc_resolve_code(): Bad statement code"); 12245 } 12246 } 12247 12248 cs_base = frame.prev; 12249} 12250 12251 12252/* Resolve initial values and make sure they are compatible with 12253 the variable. */ 12254 12255static void 12256resolve_values (gfc_symbol *sym) 12257{ 12258 bool t; 12259 12260 if (sym->value == NULL) 12261 return; 12262 12263 if (sym->value->expr_type == EXPR_STRUCTURE) 12264 t= resolve_structure_cons (sym->value, 1); 12265 else 12266 t = gfc_resolve_expr (sym->value); 12267 12268 if (!t) 12269 return; 12270 12271 gfc_check_assign_symbol (sym, NULL, sym->value); 12272} 12273 12274 12275/* Verify any BIND(C) derived types in the namespace so we can report errors 12276 for them once, rather than for each variable declared of that type. */ 12277 12278static void 12279resolve_bind_c_derived_types (gfc_symbol *derived_sym) 12280{ 12281 if (derived_sym != NULL && derived_sym->attr.flavor == FL_DERIVED 12282 && derived_sym->attr.is_bind_c == 1) 12283 verify_bind_c_derived_type (derived_sym); 12284 12285 return; 12286} 12287 12288 12289/* Check the interfaces of DTIO procedures associated with derived 12290 type 'sym'. These procedures can either have typebound bindings or 12291 can appear in DTIO generic interfaces. */ 12292 12293static void 12294gfc_verify_DTIO_procedures (gfc_symbol *sym) 12295{ 12296 if (!sym || sym->attr.flavor != FL_DERIVED) 12297 return; 12298 12299 gfc_check_dtio_interfaces (sym); 12300 12301 return; 12302} 12303 12304/* Verify that any binding labels used in a given namespace do not collide 12305 with the names or binding labels of any global symbols. Multiple INTERFACE 12306 for the same procedure are permitted. */ 12307 12308static void 12309gfc_verify_binding_labels (gfc_symbol *sym) 12310{ 12311 gfc_gsymbol *gsym; 12312 const char *module; 12313 12314 if (!sym || !sym->attr.is_bind_c || sym->attr.is_iso_c 12315 || sym->attr.flavor == FL_DERIVED || !sym->binding_label) 12316 return; 12317 12318 gsym = gfc_find_case_gsymbol (gfc_gsym_root, sym->binding_label); 12319 12320 if (sym->module) 12321 module = sym->module; 12322 else if (sym->ns && sym->ns->proc_name 12323 && sym->ns->proc_name->attr.flavor == FL_MODULE) 12324 module = sym->ns->proc_name->name; 12325 else if (sym->ns && sym->ns->parent 12326 && sym->ns && sym->ns->parent->proc_name 12327 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) 12328 module = sym->ns->parent->proc_name->name; 12329 else 12330 module = NULL; 12331 12332 if (!gsym 12333 || (!gsym->defined 12334 && (gsym->type == GSYM_FUNCTION || gsym->type == GSYM_SUBROUTINE))) 12335 { 12336 if (!gsym) 12337 gsym = gfc_get_gsymbol (sym->binding_label, true); 12338 gsym->where = sym->declared_at; 12339 gsym->sym_name = sym->name; 12340 gsym->binding_label = sym->binding_label; 12341 gsym->ns = sym->ns; 12342 gsym->mod_name = module; 12343 if (sym->attr.function) 12344 gsym->type = GSYM_FUNCTION; 12345 else if (sym->attr.subroutine) 12346 gsym->type = GSYM_SUBROUTINE; 12347 /* Mark as variable/procedure as defined, unless its an INTERFACE. */ 12348 gsym->defined = sym->attr.if_source != IFSRC_IFBODY; 12349 return; 12350 } 12351 12352 if (sym->attr.flavor == FL_VARIABLE && gsym->type != GSYM_UNKNOWN) 12353 { 12354 gfc_error ("Variable %qs with binding label %qs at %L uses the same global " 12355 "identifier as entity at %L", sym->name, 12356 sym->binding_label, &sym->declared_at, &gsym->where); 12357 /* Clear the binding label to prevent checking multiple times. */ 12358 sym->binding_label = NULL; 12359 return; 12360 } 12361 12362 if (sym->attr.flavor == FL_VARIABLE && module 12363 && (strcmp (module, gsym->mod_name) != 0 12364 || strcmp (sym->name, gsym->sym_name) != 0)) 12365 { 12366 /* This can only happen if the variable is defined in a module - if it 12367 isn't the same module, reject it. */ 12368 gfc_error ("Variable %qs from module %qs with binding label %qs at %L " 12369 "uses the same global identifier as entity at %L from module %qs", 12370 sym->name, module, sym->binding_label, 12371 &sym->declared_at, &gsym->where, gsym->mod_name); 12372 sym->binding_label = NULL; 12373 return; 12374 } 12375 12376 if ((sym->attr.function || sym->attr.subroutine) 12377 && ((gsym->type != GSYM_SUBROUTINE && gsym->type != GSYM_FUNCTION) 12378 || (gsym->defined && sym->attr.if_source != IFSRC_IFBODY)) 12379 && (sym != gsym->ns->proc_name && sym->attr.entry == 0) 12380 && (module != gsym->mod_name 12381 || strcmp (gsym->sym_name, sym->name) != 0 12382 || (module && strcmp (module, gsym->mod_name) != 0))) 12383 { 12384 /* Print an error if the procedure is defined multiple times; we have to 12385 exclude references to the same procedure via module association or 12386 multiple checks for the same procedure. */ 12387 gfc_error ("Procedure %qs with binding label %qs at %L uses the same " 12388 "global identifier as entity at %L", sym->name, 12389 sym->binding_label, &sym->declared_at, &gsym->where); 12390 sym->binding_label = NULL; 12391 } 12392} 12393 12394 12395/* Resolve an index expression. */ 12396 12397static bool 12398resolve_index_expr (gfc_expr *e) 12399{ 12400 if (!gfc_resolve_expr (e)) 12401 return false; 12402 12403 if (!gfc_simplify_expr (e, 0)) 12404 return false; 12405 12406 if (!gfc_specification_expr (e)) 12407 return false; 12408 12409 return true; 12410} 12411 12412 12413/* Resolve a charlen structure. */ 12414 12415static bool 12416resolve_charlen (gfc_charlen *cl) 12417{ 12418 int k; 12419 bool saved_specification_expr; 12420 12421 if (cl->resolved) 12422 return true; 12423 12424 cl->resolved = 1; 12425 saved_specification_expr = specification_expr; 12426 specification_expr = true; 12427 12428 if (cl->length_from_typespec) 12429 { 12430 if (!gfc_resolve_expr (cl->length)) 12431 { 12432 specification_expr = saved_specification_expr; 12433 return false; 12434 } 12435 12436 if (!gfc_simplify_expr (cl->length, 0)) 12437 { 12438 specification_expr = saved_specification_expr; 12439 return false; 12440 } 12441 12442 /* cl->length has been resolved. It should have an integer type. */ 12443 if (cl->length 12444 && (cl->length->ts.type != BT_INTEGER || cl->length->rank != 0)) 12445 { 12446 gfc_error ("Scalar INTEGER expression expected at %L", 12447 &cl->length->where); 12448 return false; 12449 } 12450 } 12451 else 12452 { 12453 if (!resolve_index_expr (cl->length)) 12454 { 12455 specification_expr = saved_specification_expr; 12456 return false; 12457 } 12458 } 12459 12460 /* F2008, 4.4.3.2: If the character length parameter value evaluates to 12461 a negative value, the length of character entities declared is zero. */ 12462 if (cl->length && cl->length->expr_type == EXPR_CONSTANT 12463 && mpz_sgn (cl->length->value.integer) < 0) 12464 gfc_replace_expr (cl->length, 12465 gfc_get_int_expr (gfc_charlen_int_kind, NULL, 0)); 12466 12467 /* Check that the character length is not too large. */ 12468 k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false); 12469 if (cl->length && cl->length->expr_type == EXPR_CONSTANT 12470 && cl->length->ts.type == BT_INTEGER 12471 && mpz_cmp (cl->length->value.integer, gfc_integer_kinds[k].huge) > 0) 12472 { 12473 gfc_error ("String length at %L is too large", &cl->length->where); 12474 specification_expr = saved_specification_expr; 12475 return false; 12476 } 12477 12478 specification_expr = saved_specification_expr; 12479 return true; 12480} 12481 12482 12483/* Test for non-constant shape arrays. */ 12484 12485static bool 12486is_non_constant_shape_array (gfc_symbol *sym) 12487{ 12488 gfc_expr *e; 12489 int i; 12490 bool not_constant; 12491 12492 not_constant = false; 12493 if (sym->as != NULL) 12494 { 12495 /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that 12496 has not been simplified; parameter array references. Do the 12497 simplification now. */ 12498 for (i = 0; i < sym->as->rank + sym->as->corank; i++) 12499 { 12500 if (i == GFC_MAX_DIMENSIONS) 12501 break; 12502 12503 e = sym->as->lower[i]; 12504 if (e && (!resolve_index_expr(e) 12505 || !gfc_is_constant_expr (e))) 12506 not_constant = true; 12507 e = sym->as->upper[i]; 12508 if (e && (!resolve_index_expr(e) 12509 || !gfc_is_constant_expr (e))) 12510 not_constant = true; 12511 } 12512 } 12513 return not_constant; 12514} 12515 12516/* Given a symbol and an initialization expression, add code to initialize 12517 the symbol to the function entry. */ 12518static void 12519build_init_assign (gfc_symbol *sym, gfc_expr *init) 12520{ 12521 gfc_expr *lval; 12522 gfc_code *init_st; 12523 gfc_namespace *ns = sym->ns; 12524 12525 /* Search for the function namespace if this is a contained 12526 function without an explicit result. */ 12527 if (sym->attr.function && sym == sym->result 12528 && sym->name != sym->ns->proc_name->name) 12529 { 12530 ns = ns->contained; 12531 for (;ns; ns = ns->sibling) 12532 if (strcmp (ns->proc_name->name, sym->name) == 0) 12533 break; 12534 } 12535 12536 if (ns == NULL) 12537 { 12538 gfc_free_expr (init); 12539 return; 12540 } 12541 12542 /* Build an l-value expression for the result. */ 12543 lval = gfc_lval_expr_from_sym (sym); 12544 12545 /* Add the code at scope entry. */ 12546 init_st = gfc_get_code (EXEC_INIT_ASSIGN); 12547 init_st->next = ns->code; 12548 ns->code = init_st; 12549 12550 /* Assign the default initializer to the l-value. */ 12551 init_st->loc = sym->declared_at; 12552 init_st->expr1 = lval; 12553 init_st->expr2 = init; 12554} 12555 12556 12557/* Whether or not we can generate a default initializer for a symbol. */ 12558 12559static bool 12560can_generate_init (gfc_symbol *sym) 12561{ 12562 symbol_attribute *a; 12563 if (!sym) 12564 return false; 12565 a = &sym->attr; 12566 12567 /* These symbols should never have a default initialization. */ 12568 return !( 12569 a->allocatable 12570 || a->external 12571 || a->pointer 12572 || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) 12573 && (CLASS_DATA (sym)->attr.class_pointer 12574 || CLASS_DATA (sym)->attr.proc_pointer)) 12575 || a->in_equivalence 12576 || a->in_common 12577 || a->data 12578 || sym->module 12579 || a->cray_pointee 12580 || a->cray_pointer 12581 || sym->assoc 12582 || (!a->referenced && !a->result) 12583 || (a->dummy && a->intent != INTENT_OUT) 12584 || (a->function && sym != sym->result) 12585 ); 12586} 12587 12588 12589/* Assign the default initializer to a derived type variable or result. */ 12590 12591static void 12592apply_default_init (gfc_symbol *sym) 12593{ 12594 gfc_expr *init = NULL; 12595 12596 if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function) 12597 return; 12598 12599 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived) 12600 init = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); 12601 12602 if (init == NULL && sym->ts.type != BT_CLASS) 12603 return; 12604 12605 build_init_assign (sym, init); 12606 sym->attr.referenced = 1; 12607} 12608 12609 12610/* Build an initializer for a local. Returns null if the symbol should not have 12611 a default initialization. */ 12612 12613static gfc_expr * 12614build_default_init_expr (gfc_symbol *sym) 12615{ 12616 /* These symbols should never have a default initialization. */ 12617 if (sym->attr.allocatable 12618 || sym->attr.external 12619 || sym->attr.dummy 12620 || sym->attr.pointer 12621 || sym->attr.in_equivalence 12622 || sym->attr.in_common 12623 || sym->attr.data 12624 || sym->module 12625 || sym->attr.cray_pointee 12626 || sym->attr.cray_pointer 12627 || sym->assoc) 12628 return NULL; 12629 12630 /* Get the appropriate init expression. */ 12631 return gfc_build_default_init_expr (&sym->ts, &sym->declared_at); 12632} 12633 12634/* Add an initialization expression to a local variable. */ 12635static void 12636apply_default_init_local (gfc_symbol *sym) 12637{ 12638 gfc_expr *init = NULL; 12639 12640 /* The symbol should be a variable or a function return value. */ 12641 if ((sym->attr.flavor != FL_VARIABLE && !sym->attr.function) 12642 || (sym->attr.function && sym->result != sym)) 12643 return; 12644 12645 /* Try to build the initializer expression. If we can't initialize 12646 this symbol, then init will be NULL. */ 12647 init = build_default_init_expr (sym); 12648 if (init == NULL) 12649 return; 12650 12651 /* For saved variables, we don't want to add an initializer at function 12652 entry, so we just add a static initializer. Note that automatic variables 12653 are stack allocated even with -fno-automatic; we have also to exclude 12654 result variable, which are also nonstatic. */ 12655 if (!sym->attr.automatic 12656 && (sym->attr.save || sym->ns->save_all 12657 || (flag_max_stack_var_size == 0 && !sym->attr.result 12658 && (sym->ns->proc_name && !sym->ns->proc_name->attr.recursive) 12659 && (!sym->attr.dimension || !is_non_constant_shape_array (sym))))) 12660 { 12661 /* Don't clobber an existing initializer! */ 12662 gcc_assert (sym->value == NULL); 12663 sym->value = init; 12664 return; 12665 } 12666 12667 build_init_assign (sym, init); 12668} 12669 12670 12671/* Resolution of common features of flavors variable and procedure. */ 12672 12673static bool 12674resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag) 12675{ 12676 gfc_array_spec *as; 12677 12678 if (sym->ts.type == BT_CLASS && sym->attr.class_ok 12679 && sym->ts.u.derived && CLASS_DATA (sym)) 12680 as = CLASS_DATA (sym)->as; 12681 else 12682 as = sym->as; 12683 12684 /* Constraints on deferred shape variable. */ 12685 if (as == NULL || as->type != AS_DEFERRED) 12686 { 12687 bool pointer, allocatable, dimension; 12688 12689 if (sym->ts.type == BT_CLASS && sym->attr.class_ok 12690 && sym->ts.u.derived && CLASS_DATA (sym)) 12691 { 12692 pointer = CLASS_DATA (sym)->attr.class_pointer; 12693 allocatable = CLASS_DATA (sym)->attr.allocatable; 12694 dimension = CLASS_DATA (sym)->attr.dimension; 12695 } 12696 else 12697 { 12698 pointer = sym->attr.pointer && !sym->attr.select_type_temporary; 12699 allocatable = sym->attr.allocatable; 12700 dimension = sym->attr.dimension; 12701 } 12702 12703 if (allocatable) 12704 { 12705 if (dimension && as->type != AS_ASSUMED_RANK) 12706 { 12707 gfc_error ("Allocatable array %qs at %L must have a deferred " 12708 "shape or assumed rank", sym->name, &sym->declared_at); 12709 return false; 12710 } 12711 else if (!gfc_notify_std (GFC_STD_F2003, "Scalar object " 12712 "%qs at %L may not be ALLOCATABLE", 12713 sym->name, &sym->declared_at)) 12714 return false; 12715 } 12716 12717 if (pointer && dimension && as->type != AS_ASSUMED_RANK) 12718 { 12719 gfc_error ("Array pointer %qs at %L must have a deferred shape or " 12720 "assumed rank", sym->name, &sym->declared_at); 12721 sym->error = 1; 12722 return false; 12723 } 12724 } 12725 else 12726 { 12727 if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer 12728 && sym->ts.type != BT_CLASS && !sym->assoc) 12729 { 12730 gfc_error ("Array %qs at %L cannot have a deferred shape", 12731 sym->name, &sym->declared_at); 12732 return false; 12733 } 12734 } 12735 12736 /* Constraints on polymorphic variables. */ 12737 if (sym->ts.type == BT_CLASS && !(sym->result && sym->result != sym)) 12738 { 12739 /* F03:C502. */ 12740 if (sym->attr.class_ok 12741 && sym->ts.u.derived 12742 && !sym->attr.select_type_temporary 12743 && !UNLIMITED_POLY (sym) 12744 && !gfc_type_is_extensible (CLASS_DATA (sym)->ts.u.derived)) 12745 { 12746 gfc_error ("Type %qs of CLASS variable %qs at %L is not extensible", 12747 CLASS_DATA (sym)->ts.u.derived->name, sym->name, 12748 &sym->declared_at); 12749 return false; 12750 } 12751 12752 /* F03:C509. */ 12753 /* Assume that use associated symbols were checked in the module ns. 12754 Class-variables that are associate-names are also something special 12755 and excepted from the test. */ 12756 if (!sym->attr.class_ok && !sym->attr.use_assoc && !sym->assoc) 12757 { 12758 gfc_error ("CLASS variable %qs at %L must be dummy, allocatable " 12759 "or pointer", sym->name, &sym->declared_at); 12760 return false; 12761 } 12762 } 12763 12764 return true; 12765} 12766 12767 12768/* Additional checks for symbols with flavor variable and derived 12769 type. To be called from resolve_fl_variable. */ 12770 12771static bool 12772resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) 12773{ 12774 gcc_assert (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS); 12775 12776 /* Check to see if a derived type is blocked from being host 12777 associated by the presence of another class I symbol in the same 12778 namespace. 14.6.1.3 of the standard and the discussion on 12779 comp.lang.fortran. */ 12780 if (sym->ts.u.derived 12781 && sym->ns != sym->ts.u.derived->ns 12782 && !sym->ts.u.derived->attr.use_assoc 12783 && sym->ns->proc_name->attr.if_source != IFSRC_IFBODY) 12784 { 12785 gfc_symbol *s; 12786 gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s); 12787 if (s && s->attr.generic) 12788 s = gfc_find_dt_in_generic (s); 12789 if (s && !gfc_fl_struct (s->attr.flavor)) 12790 { 12791 gfc_error ("The type %qs cannot be host associated at %L " 12792 "because it is blocked by an incompatible object " 12793 "of the same name declared at %L", 12794 sym->ts.u.derived->name, &sym->declared_at, 12795 &s->declared_at); 12796 return false; 12797 } 12798 } 12799 12800 /* 4th constraint in section 11.3: "If an object of a type for which 12801 component-initialization is specified (R429) appears in the 12802 specification-part of a module and does not have the ALLOCATABLE 12803 or POINTER attribute, the object shall have the SAVE attribute." 12804 12805 The check for initializers is performed with 12806 gfc_has_default_initializer because gfc_default_initializer generates 12807 a hidden default for allocatable components. */ 12808 if (!(sym->value || no_init_flag) && sym->ns->proc_name 12809 && sym->ns->proc_name->attr.flavor == FL_MODULE 12810 && !(sym->ns->save_all && !sym->attr.automatic) && !sym->attr.save 12811 && !sym->attr.pointer && !sym->attr.allocatable 12812 && gfc_has_default_initializer (sym->ts.u.derived) 12813 && !gfc_notify_std (GFC_STD_F2008, "Implied SAVE for module variable " 12814 "%qs at %L, needed due to the default " 12815 "initialization", sym->name, &sym->declared_at)) 12816 return false; 12817 12818 /* Assign default initializer. */ 12819 if (!(sym->value || sym->attr.pointer || sym->attr.allocatable) 12820 && (!no_init_flag || sym->attr.intent == INTENT_OUT)) 12821 sym->value = gfc_generate_initializer (&sym->ts, can_generate_init (sym)); 12822 12823 return true; 12824} 12825 12826 12827/* F2008, C402 (R401): A colon shall not be used as a type-param-value 12828 except in the declaration of an entity or component that has the POINTER 12829 or ALLOCATABLE attribute. */ 12830 12831static bool 12832deferred_requirements (gfc_symbol *sym) 12833{ 12834 if (sym->ts.deferred 12835 && !(sym->attr.pointer 12836 || sym->attr.allocatable 12837 || sym->attr.associate_var 12838 || sym->attr.omp_udr_artificial_var)) 12839 { 12840 /* If a function has a result variable, only check the variable. */ 12841 if (sym->result && sym->name != sym->result->name) 12842 return true; 12843 12844 gfc_error ("Entity %qs at %L has a deferred type parameter and " 12845 "requires either the POINTER or ALLOCATABLE attribute", 12846 sym->name, &sym->declared_at); 12847 return false; 12848 } 12849 return true; 12850} 12851 12852 12853/* Resolve symbols with flavor variable. */ 12854 12855static bool 12856resolve_fl_variable (gfc_symbol *sym, int mp_flag) 12857{ 12858 const char *auto_save_msg = "Automatic object %qs at %L cannot have the " 12859 "SAVE attribute"; 12860 12861 if (!resolve_fl_var_and_proc (sym, mp_flag)) 12862 return false; 12863 12864 /* Set this flag to check that variables are parameters of all entries. 12865 This check is effected by the call to gfc_resolve_expr through 12866 is_non_constant_shape_array. */ 12867 bool saved_specification_expr = specification_expr; 12868 specification_expr = true; 12869 12870 if (sym->ns->proc_name 12871 && (sym->ns->proc_name->attr.flavor == FL_MODULE 12872 || sym->ns->proc_name->attr.is_main_program) 12873 && !sym->attr.use_assoc 12874 && !sym->attr.allocatable 12875 && !sym->attr.pointer 12876 && is_non_constant_shape_array (sym)) 12877 { 12878 /* F08:C541. The shape of an array defined in a main program or module 12879 * needs to be constant. */ 12880 gfc_error ("The module or main program array %qs at %L must " 12881 "have constant shape", sym->name, &sym->declared_at); 12882 specification_expr = saved_specification_expr; 12883 return false; 12884 } 12885 12886 /* Constraints on deferred type parameter. */ 12887 if (!deferred_requirements (sym)) 12888 return false; 12889 12890 if (sym->ts.type == BT_CHARACTER && !sym->attr.associate_var) 12891 { 12892 /* Make sure that character string variables with assumed length are 12893 dummy arguments. */ 12894 gfc_expr *e = NULL; 12895 12896 if (sym->ts.u.cl) 12897 e = sym->ts.u.cl->length; 12898 else 12899 return false; 12900 12901 if (e == NULL && !sym->attr.dummy && !sym->attr.result 12902 && !sym->ts.deferred && !sym->attr.select_type_temporary 12903 && !sym->attr.omp_udr_artificial_var) 12904 { 12905 gfc_error ("Entity with assumed character length at %L must be a " 12906 "dummy argument or a PARAMETER", &sym->declared_at); 12907 specification_expr = saved_specification_expr; 12908 return false; 12909 } 12910 12911 if (e && sym->attr.save == SAVE_EXPLICIT && !gfc_is_constant_expr (e)) 12912 { 12913 gfc_error (auto_save_msg, sym->name, &sym->declared_at); 12914 specification_expr = saved_specification_expr; 12915 return false; 12916 } 12917 12918 if (!gfc_is_constant_expr (e) 12919 && !(e->expr_type == EXPR_VARIABLE 12920 && e->symtree->n.sym->attr.flavor == FL_PARAMETER)) 12921 { 12922 if (!sym->attr.use_assoc && sym->ns->proc_name 12923 && (sym->ns->proc_name->attr.flavor == FL_MODULE 12924 || sym->ns->proc_name->attr.is_main_program)) 12925 { 12926 gfc_error ("%qs at %L must have constant character length " 12927 "in this context", sym->name, &sym->declared_at); 12928 specification_expr = saved_specification_expr; 12929 return false; 12930 } 12931 if (sym->attr.in_common) 12932 { 12933 gfc_error ("COMMON variable %qs at %L must have constant " 12934 "character length", sym->name, &sym->declared_at); 12935 specification_expr = saved_specification_expr; 12936 return false; 12937 } 12938 } 12939 } 12940 12941 if (sym->value == NULL && sym->attr.referenced) 12942 apply_default_init_local (sym); /* Try to apply a default initialization. */ 12943 12944 /* Determine if the symbol may not have an initializer. */ 12945 int no_init_flag = 0, automatic_flag = 0; 12946 if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy 12947 || sym->attr.intrinsic || sym->attr.result) 12948 no_init_flag = 1; 12949 else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer 12950 && is_non_constant_shape_array (sym)) 12951 { 12952 no_init_flag = automatic_flag = 1; 12953 12954 /* Also, they must not have the SAVE attribute. 12955 SAVE_IMPLICIT is checked below. */ 12956 if (sym->as && sym->attr.codimension) 12957 { 12958 int corank = sym->as->corank; 12959 sym->as->corank = 0; 12960 no_init_flag = automatic_flag = is_non_constant_shape_array (sym); 12961 sym->as->corank = corank; 12962 } 12963 if (automatic_flag && sym->attr.save == SAVE_EXPLICIT) 12964 { 12965 gfc_error (auto_save_msg, sym->name, &sym->declared_at); 12966 specification_expr = saved_specification_expr; 12967 return false; 12968 } 12969 } 12970 12971 /* Ensure that any initializer is simplified. */ 12972 if (sym->value) 12973 gfc_simplify_expr (sym->value, 1); 12974 12975 /* Reject illegal initializers. */ 12976 if (!sym->mark && sym->value) 12977 { 12978 if (sym->attr.allocatable || (sym->ts.type == BT_CLASS 12979 && CLASS_DATA (sym)->attr.allocatable)) 12980 gfc_error ("Allocatable %qs at %L cannot have an initializer", 12981 sym->name, &sym->declared_at); 12982 else if (sym->attr.external) 12983 gfc_error ("External %qs at %L cannot have an initializer", 12984 sym->name, &sym->declared_at); 12985 else if (sym->attr.dummy 12986 && !(sym->ts.type == BT_DERIVED && sym->attr.intent == INTENT_OUT)) 12987 gfc_error ("Dummy %qs at %L cannot have an initializer", 12988 sym->name, &sym->declared_at); 12989 else if (sym->attr.intrinsic) 12990 gfc_error ("Intrinsic %qs at %L cannot have an initializer", 12991 sym->name, &sym->declared_at); 12992 else if (sym->attr.result) 12993 gfc_error ("Function result %qs at %L cannot have an initializer", 12994 sym->name, &sym->declared_at); 12995 else if (automatic_flag) 12996 gfc_error ("Automatic array %qs at %L cannot have an initializer", 12997 sym->name, &sym->declared_at); 12998 else 12999 goto no_init_error; 13000 specification_expr = saved_specification_expr; 13001 return false; 13002 } 13003 13004no_init_error: 13005 if (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 13006 { 13007 bool res = resolve_fl_variable_derived (sym, no_init_flag); 13008 specification_expr = saved_specification_expr; 13009 return res; 13010 } 13011 13012 specification_expr = saved_specification_expr; 13013 return true; 13014} 13015 13016 13017/* Compare the dummy characteristics of a module procedure interface 13018 declaration with the corresponding declaration in a submodule. */ 13019static gfc_formal_arglist *new_formal; 13020static char errmsg[200]; 13021 13022static void 13023compare_fsyms (gfc_symbol *sym) 13024{ 13025 gfc_symbol *fsym; 13026 13027 if (sym == NULL || new_formal == NULL) 13028 return; 13029 13030 fsym = new_formal->sym; 13031 13032 if (sym == fsym) 13033 return; 13034 13035 if (strcmp (sym->name, fsym->name) == 0) 13036 { 13037 if (!gfc_check_dummy_characteristics (fsym, sym, true, errmsg, 200)) 13038 gfc_error ("%s at %L", errmsg, &fsym->declared_at); 13039 } 13040} 13041 13042 13043/* Resolve a procedure. */ 13044 13045static bool 13046resolve_fl_procedure (gfc_symbol *sym, int mp_flag) 13047{ 13048 gfc_formal_arglist *arg; 13049 bool allocatable_or_pointer; 13050 13051 if (sym->attr.function 13052 && !resolve_fl_var_and_proc (sym, mp_flag)) 13053 return false; 13054 13055 /* Constraints on deferred type parameter. */ 13056 if (!deferred_requirements (sym)) 13057 return false; 13058 13059 if (sym->ts.type == BT_CHARACTER) 13060 { 13061 gfc_charlen *cl = sym->ts.u.cl; 13062 13063 if (cl && cl->length && gfc_is_constant_expr (cl->length) 13064 && !resolve_charlen (cl)) 13065 return false; 13066 13067 if ((!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) 13068 && sym->attr.proc == PROC_ST_FUNCTION) 13069 { 13070 gfc_error ("Character-valued statement function %qs at %L must " 13071 "have constant length", sym->name, &sym->declared_at); 13072 return false; 13073 } 13074 } 13075 13076 /* Ensure that derived type for are not of a private type. Internal 13077 module procedures are excluded by 2.2.3.3 - i.e., they are not 13078 externally accessible and can access all the objects accessible in 13079 the host. */ 13080 if (!(sym->ns->parent && sym->ns->parent->proc_name 13081 && sym->ns->parent->proc_name->attr.flavor == FL_MODULE) 13082 && gfc_check_symbol_access (sym)) 13083 { 13084 gfc_interface *iface; 13085 13086 for (arg = gfc_sym_get_dummy_args (sym); arg; arg = arg->next) 13087 { 13088 if (arg->sym 13089 && arg->sym->ts.type == BT_DERIVED 13090 && arg->sym->ts.u.derived 13091 && !arg->sym->ts.u.derived->attr.use_assoc 13092 && !gfc_check_symbol_access (arg->sym->ts.u.derived) 13093 && !gfc_notify_std (GFC_STD_F2003, "%qs is of a PRIVATE type " 13094 "and cannot be a dummy argument" 13095 " of %qs, which is PUBLIC at %L", 13096 arg->sym->name, sym->name, 13097 &sym->declared_at)) 13098 { 13099 /* Stop this message from recurring. */ 13100 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; 13101 return false; 13102 } 13103 } 13104 13105 /* PUBLIC interfaces may expose PRIVATE procedures that take types 13106 PRIVATE to the containing module. */ 13107 for (iface = sym->generic; iface; iface = iface->next) 13108 { 13109 for (arg = gfc_sym_get_dummy_args (iface->sym); arg; arg = arg->next) 13110 { 13111 if (arg->sym 13112 && arg->sym->ts.type == BT_DERIVED 13113 && !arg->sym->ts.u.derived->attr.use_assoc 13114 && !gfc_check_symbol_access (arg->sym->ts.u.derived) 13115 && !gfc_notify_std (GFC_STD_F2003, "Procedure %qs in " 13116 "PUBLIC interface %qs at %L " 13117 "takes dummy arguments of %qs which " 13118 "is PRIVATE", iface->sym->name, 13119 sym->name, &iface->sym->declared_at, 13120 gfc_typename(&arg->sym->ts))) 13121 { 13122 /* Stop this message from recurring. */ 13123 arg->sym->ts.u.derived->attr.access = ACCESS_PUBLIC; 13124 return false; 13125 } 13126 } 13127 } 13128 } 13129 13130 if (sym->attr.function && sym->value && sym->attr.proc != PROC_ST_FUNCTION 13131 && !sym->attr.proc_pointer) 13132 { 13133 gfc_error ("Function %qs at %L cannot have an initializer", 13134 sym->name, &sym->declared_at); 13135 13136 /* Make sure no second error is issued for this. */ 13137 sym->value->error = 1; 13138 return false; 13139 } 13140 13141 /* An external symbol may not have an initializer because it is taken to be 13142 a procedure. Exception: Procedure Pointers. */ 13143 if (sym->attr.external && sym->value && !sym->attr.proc_pointer) 13144 { 13145 gfc_error ("External object %qs at %L may not have an initializer", 13146 sym->name, &sym->declared_at); 13147 return false; 13148 } 13149 13150 /* An elemental function is required to return a scalar 12.7.1 */ 13151 if (sym->attr.elemental && sym->attr.function 13152 && (sym->as || (sym->ts.type == BT_CLASS && sym->attr.class_ok 13153 && CLASS_DATA (sym)->as))) 13154 { 13155 gfc_error ("ELEMENTAL function %qs at %L must have a scalar " 13156 "result", sym->name, &sym->declared_at); 13157 /* Reset so that the error only occurs once. */ 13158 sym->attr.elemental = 0; 13159 return false; 13160 } 13161 13162 if (sym->attr.proc == PROC_ST_FUNCTION 13163 && (sym->attr.allocatable || sym->attr.pointer)) 13164 { 13165 gfc_error ("Statement function %qs at %L may not have pointer or " 13166 "allocatable attribute", sym->name, &sym->declared_at); 13167 return false; 13168 } 13169 13170 /* 5.1.1.5 of the Standard: A function name declared with an asterisk 13171 char-len-param shall not be array-valued, pointer-valued, recursive 13172 or pure. ....snip... A character value of * may only be used in the 13173 following ways: (i) Dummy arg of procedure - dummy associates with 13174 actual length; (ii) To declare a named constant; or (iii) External 13175 function - but length must be declared in calling scoping unit. */ 13176 if (sym->attr.function 13177 && sym->ts.type == BT_CHARACTER && !sym->ts.deferred 13178 && sym->ts.u.cl && sym->ts.u.cl->length == NULL) 13179 { 13180 if ((sym->as && sym->as->rank) || (sym->attr.pointer) 13181 || (sym->attr.recursive) || (sym->attr.pure)) 13182 { 13183 if (sym->as && sym->as->rank) 13184 gfc_error ("CHARACTER(*) function %qs at %L cannot be " 13185 "array-valued", sym->name, &sym->declared_at); 13186 13187 if (sym->attr.pointer) 13188 gfc_error ("CHARACTER(*) function %qs at %L cannot be " 13189 "pointer-valued", sym->name, &sym->declared_at); 13190 13191 if (sym->attr.pure) 13192 gfc_error ("CHARACTER(*) function %qs at %L cannot be " 13193 "pure", sym->name, &sym->declared_at); 13194 13195 if (sym->attr.recursive) 13196 gfc_error ("CHARACTER(*) function %qs at %L cannot be " 13197 "recursive", sym->name, &sym->declared_at); 13198 13199 return false; 13200 } 13201 13202 /* Appendix B.2 of the standard. Contained functions give an 13203 error anyway. Deferred character length is an F2003 feature. 13204 Don't warn on intrinsic conversion functions, which start 13205 with two underscores. */ 13206 if (!sym->attr.contained && !sym->ts.deferred 13207 && (sym->name[0] != '_' || sym->name[1] != '_')) 13208 gfc_notify_std (GFC_STD_F95_OBS, 13209 "CHARACTER(*) function %qs at %L", 13210 sym->name, &sym->declared_at); 13211 } 13212 13213 /* F2008, C1218. */ 13214 if (sym->attr.elemental) 13215 { 13216 if (sym->attr.proc_pointer) 13217 { 13218 const char* name = (sym->attr.result ? sym->ns->proc_name->name 13219 : sym->name); 13220 gfc_error ("Procedure pointer %qs at %L shall not be elemental", 13221 name, &sym->declared_at); 13222 return false; 13223 } 13224 if (sym->attr.dummy) 13225 { 13226 gfc_error ("Dummy procedure %qs at %L shall not be elemental", 13227 sym->name, &sym->declared_at); 13228 return false; 13229 } 13230 } 13231 13232 /* F2018, C15100: "The result of an elemental function shall be scalar, 13233 and shall not have the POINTER or ALLOCATABLE attribute." The scalar 13234 pointer is tested and caught elsewhere. */ 13235 if (sym->result) 13236 allocatable_or_pointer = sym->result->ts.type == BT_CLASS 13237 && CLASS_DATA (sym->result) ? 13238 (CLASS_DATA (sym->result)->attr.allocatable 13239 || CLASS_DATA (sym->result)->attr.pointer) : 13240 (sym->result->attr.allocatable 13241 || sym->result->attr.pointer); 13242 13243 if (sym->attr.elemental && sym->result 13244 && allocatable_or_pointer) 13245 { 13246 gfc_error ("Function result variable %qs at %L of elemental " 13247 "function %qs shall not have an ALLOCATABLE or POINTER " 13248 "attribute", sym->result->name, 13249 &sym->result->declared_at, sym->name); 13250 return false; 13251 } 13252 13253 if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1) 13254 { 13255 gfc_formal_arglist *curr_arg; 13256 int has_non_interop_arg = 0; 13257 13258 if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 13259 sym->common_block)) 13260 { 13261 /* Clear these to prevent looking at them again if there was an 13262 error. */ 13263 sym->attr.is_bind_c = 0; 13264 sym->attr.is_c_interop = 0; 13265 sym->ts.is_c_interop = 0; 13266 } 13267 else 13268 { 13269 /* So far, no errors have been found. */ 13270 sym->attr.is_c_interop = 1; 13271 sym->ts.is_c_interop = 1; 13272 } 13273 13274 curr_arg = gfc_sym_get_dummy_args (sym); 13275 while (curr_arg != NULL) 13276 { 13277 /* Skip implicitly typed dummy args here. */ 13278 if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0) 13279 if (!gfc_verify_c_interop_param (curr_arg->sym)) 13280 /* If something is found to fail, record the fact so we 13281 can mark the symbol for the procedure as not being 13282 BIND(C) to try and prevent multiple errors being 13283 reported. */ 13284 has_non_interop_arg = 1; 13285 13286 curr_arg = curr_arg->next; 13287 } 13288 13289 /* See if any of the arguments were not interoperable and if so, clear 13290 the procedure symbol to prevent duplicate error messages. */ 13291 if (has_non_interop_arg != 0) 13292 { 13293 sym->attr.is_c_interop = 0; 13294 sym->ts.is_c_interop = 0; 13295 sym->attr.is_bind_c = 0; 13296 } 13297 } 13298 13299 if (!sym->attr.proc_pointer) 13300 { 13301 if (sym->attr.save == SAVE_EXPLICIT) 13302 { 13303 gfc_error ("PROCEDURE attribute conflicts with SAVE attribute " 13304 "in %qs at %L", sym->name, &sym->declared_at); 13305 return false; 13306 } 13307 if (sym->attr.intent) 13308 { 13309 gfc_error ("PROCEDURE attribute conflicts with INTENT attribute " 13310 "in %qs at %L", sym->name, &sym->declared_at); 13311 return false; 13312 } 13313 if (sym->attr.subroutine && sym->attr.result) 13314 { 13315 gfc_error ("PROCEDURE attribute conflicts with RESULT attribute " 13316 "in %qs at %L", sym->ns->proc_name->name, &sym->declared_at); 13317 return false; 13318 } 13319 if (sym->attr.external && sym->attr.function && !sym->attr.module_procedure 13320 && ((sym->attr.if_source == IFSRC_DECL && !sym->attr.procedure) 13321 || sym->attr.contained)) 13322 { 13323 gfc_error ("EXTERNAL attribute conflicts with FUNCTION attribute " 13324 "in %qs at %L", sym->name, &sym->declared_at); 13325 return false; 13326 } 13327 if (strcmp ("ppr@", sym->name) == 0) 13328 { 13329 gfc_error ("Procedure pointer result %qs at %L " 13330 "is missing the pointer attribute", 13331 sym->ns->proc_name->name, &sym->declared_at); 13332 return false; 13333 } 13334 } 13335 13336 /* Assume that a procedure whose body is not known has references 13337 to external arrays. */ 13338 if (sym->attr.if_source != IFSRC_DECL) 13339 sym->attr.array_outer_dependency = 1; 13340 13341 /* Compare the characteristics of a module procedure with the 13342 interface declaration. Ideally this would be done with 13343 gfc_compare_interfaces but, at present, the formal interface 13344 cannot be copied to the ts.interface. */ 13345 if (sym->attr.module_procedure 13346 && sym->attr.if_source == IFSRC_DECL) 13347 { 13348 gfc_symbol *iface; 13349 char name[2*GFC_MAX_SYMBOL_LEN + 1]; 13350 char *module_name; 13351 char *submodule_name; 13352 strcpy (name, sym->ns->proc_name->name); 13353 module_name = strtok (name, "."); 13354 submodule_name = strtok (NULL, "."); 13355 13356 iface = sym->tlink; 13357 sym->tlink = NULL; 13358 13359 /* Make sure that the result uses the correct charlen for deferred 13360 length results. */ 13361 if (iface && sym->result 13362 && iface->ts.type == BT_CHARACTER 13363 && iface->ts.deferred) 13364 sym->result->ts.u.cl = iface->ts.u.cl; 13365 13366 if (iface == NULL) 13367 goto check_formal; 13368 13369 /* Check the procedure characteristics. */ 13370 if (sym->attr.elemental != iface->attr.elemental) 13371 { 13372 gfc_error ("Mismatch in ELEMENTAL attribute between MODULE " 13373 "PROCEDURE at %L and its interface in %s", 13374 &sym->declared_at, module_name); 13375 return false; 13376 } 13377 13378 if (sym->attr.pure != iface->attr.pure) 13379 { 13380 gfc_error ("Mismatch in PURE attribute between MODULE " 13381 "PROCEDURE at %L and its interface in %s", 13382 &sym->declared_at, module_name); 13383 return false; 13384 } 13385 13386 if (sym->attr.recursive != iface->attr.recursive) 13387 { 13388 gfc_error ("Mismatch in RECURSIVE attribute between MODULE " 13389 "PROCEDURE at %L and its interface in %s", 13390 &sym->declared_at, module_name); 13391 return false; 13392 } 13393 13394 /* Check the result characteristics. */ 13395 if (!gfc_check_result_characteristics (sym, iface, errmsg, 200)) 13396 { 13397 gfc_error ("%s between the MODULE PROCEDURE declaration " 13398 "in MODULE %qs and the declaration at %L in " 13399 "(SUB)MODULE %qs", 13400 errmsg, module_name, &sym->declared_at, 13401 submodule_name ? submodule_name : module_name); 13402 return false; 13403 } 13404 13405check_formal: 13406 /* Check the characteristics of the formal arguments. */ 13407 if (sym->formal && sym->formal_ns) 13408 { 13409 for (arg = sym->formal; arg && arg->sym; arg = arg->next) 13410 { 13411 new_formal = arg; 13412 gfc_traverse_ns (sym->formal_ns, compare_fsyms); 13413 } 13414 } 13415 } 13416 13417 /* F2018:15.4.2.2 requires an explicit interface for procedures with the 13418 BIND(C) attribute. */ 13419 if (sym->attr.is_bind_c && sym->attr.if_source == IFSRC_UNKNOWN) 13420 { 13421 gfc_error ("Interface of %qs at %L must be explicit", 13422 sym->name, &sym->declared_at); 13423 return false; 13424 } 13425 13426 return true; 13427} 13428 13429 13430/* Resolve a list of finalizer procedures. That is, after they have hopefully 13431 been defined and we now know their defined arguments, check that they fulfill 13432 the requirements of the standard for procedures used as finalizers. */ 13433 13434static bool 13435gfc_resolve_finalizers (gfc_symbol* derived, bool *finalizable) 13436{ 13437 gfc_finalizer* list; 13438 gfc_finalizer** prev_link; /* For removing wrong entries from the list. */ 13439 bool result = true; 13440 bool seen_scalar = false; 13441 gfc_symbol *vtab; 13442 gfc_component *c; 13443 gfc_symbol *parent = gfc_get_derived_super_type (derived); 13444 13445 if (parent) 13446 gfc_resolve_finalizers (parent, finalizable); 13447 13448 /* Ensure that derived-type components have a their finalizers resolved. */ 13449 bool has_final = derived->f2k_derived && derived->f2k_derived->finalizers; 13450 for (c = derived->components; c; c = c->next) 13451 if (c->ts.type == BT_DERIVED 13452 && !c->attr.pointer && !c->attr.proc_pointer && !c->attr.allocatable) 13453 { 13454 bool has_final2 = false; 13455 if (!gfc_resolve_finalizers (c->ts.u.derived, &has_final2)) 13456 return false; /* Error. */ 13457 has_final = has_final || has_final2; 13458 } 13459 /* Return early if not finalizable. */ 13460 if (!has_final) 13461 { 13462 if (finalizable) 13463 *finalizable = false; 13464 return true; 13465 } 13466 13467 /* Walk over the list of finalizer-procedures, check them, and if any one 13468 does not fit in with the standard's definition, print an error and remove 13469 it from the list. */ 13470 prev_link = &derived->f2k_derived->finalizers; 13471 for (list = derived->f2k_derived->finalizers; list; list = *prev_link) 13472 { 13473 gfc_formal_arglist *dummy_args; 13474 gfc_symbol* arg; 13475 gfc_finalizer* i; 13476 int my_rank; 13477 13478 /* Skip this finalizer if we already resolved it. */ 13479 if (list->proc_tree) 13480 { 13481 if (list->proc_tree->n.sym->formal->sym->as == NULL 13482 || list->proc_tree->n.sym->formal->sym->as->rank == 0) 13483 seen_scalar = true; 13484 prev_link = &(list->next); 13485 continue; 13486 } 13487 13488 /* Check this exists and is a SUBROUTINE. */ 13489 if (!list->proc_sym->attr.subroutine) 13490 { 13491 gfc_error ("FINAL procedure %qs at %L is not a SUBROUTINE", 13492 list->proc_sym->name, &list->where); 13493 goto error; 13494 } 13495 13496 /* We should have exactly one argument. */ 13497 dummy_args = gfc_sym_get_dummy_args (list->proc_sym); 13498 if (!dummy_args || dummy_args->next) 13499 { 13500 gfc_error ("FINAL procedure at %L must have exactly one argument", 13501 &list->where); 13502 goto error; 13503 } 13504 arg = dummy_args->sym; 13505 13506 /* This argument must be of our type. */ 13507 if (arg->ts.type != BT_DERIVED || arg->ts.u.derived != derived) 13508 { 13509 gfc_error ("Argument of FINAL procedure at %L must be of type %qs", 13510 &arg->declared_at, derived->name); 13511 goto error; 13512 } 13513 13514 /* It must neither be a pointer nor allocatable nor optional. */ 13515 if (arg->attr.pointer) 13516 { 13517 gfc_error ("Argument of FINAL procedure at %L must not be a POINTER", 13518 &arg->declared_at); 13519 goto error; 13520 } 13521 if (arg->attr.allocatable) 13522 { 13523 gfc_error ("Argument of FINAL procedure at %L must not be" 13524 " ALLOCATABLE", &arg->declared_at); 13525 goto error; 13526 } 13527 if (arg->attr.optional) 13528 { 13529 gfc_error ("Argument of FINAL procedure at %L must not be OPTIONAL", 13530 &arg->declared_at); 13531 goto error; 13532 } 13533 13534 /* It must not be INTENT(OUT). */ 13535 if (arg->attr.intent == INTENT_OUT) 13536 { 13537 gfc_error ("Argument of FINAL procedure at %L must not be" 13538 " INTENT(OUT)", &arg->declared_at); 13539 goto error; 13540 } 13541 13542 /* Warn if the procedure is non-scalar and not assumed shape. */ 13543 if (warn_surprising && arg->as && arg->as->rank != 0 13544 && arg->as->type != AS_ASSUMED_SHAPE) 13545 gfc_warning (OPT_Wsurprising, 13546 "Non-scalar FINAL procedure at %L should have assumed" 13547 " shape argument", &arg->declared_at); 13548 13549 /* Check that it does not match in kind and rank with a FINAL procedure 13550 defined earlier. To really loop over the *earlier* declarations, 13551 we need to walk the tail of the list as new ones were pushed at the 13552 front. */ 13553 /* TODO: Handle kind parameters once they are implemented. */ 13554 my_rank = (arg->as ? arg->as->rank : 0); 13555 for (i = list->next; i; i = i->next) 13556 { 13557 gfc_formal_arglist *dummy_args; 13558 13559 /* Argument list might be empty; that is an error signalled earlier, 13560 but we nevertheless continued resolving. */ 13561 dummy_args = gfc_sym_get_dummy_args (i->proc_sym); 13562 if (dummy_args) 13563 { 13564 gfc_symbol* i_arg = dummy_args->sym; 13565 const int i_rank = (i_arg->as ? i_arg->as->rank : 0); 13566 if (i_rank == my_rank) 13567 { 13568 gfc_error ("FINAL procedure %qs declared at %L has the same" 13569 " rank (%d) as %qs", 13570 list->proc_sym->name, &list->where, my_rank, 13571 i->proc_sym->name); 13572 goto error; 13573 } 13574 } 13575 } 13576 13577 /* Is this the/a scalar finalizer procedure? */ 13578 if (my_rank == 0) 13579 seen_scalar = true; 13580 13581 /* Find the symtree for this procedure. */ 13582 gcc_assert (!list->proc_tree); 13583 list->proc_tree = gfc_find_sym_in_symtree (list->proc_sym); 13584 13585 prev_link = &list->next; 13586 continue; 13587 13588 /* Remove wrong nodes immediately from the list so we don't risk any 13589 troubles in the future when they might fail later expectations. */ 13590error: 13591 i = list; 13592 *prev_link = list->next; 13593 gfc_free_finalizer (i); 13594 result = false; 13595 } 13596 13597 if (result == false) 13598 return false; 13599 13600 /* Warn if we haven't seen a scalar finalizer procedure (but we know there 13601 were nodes in the list, must have been for arrays. It is surely a good 13602 idea to have a scalar version there if there's something to finalize. */ 13603 if (warn_surprising && derived->f2k_derived->finalizers && !seen_scalar) 13604 gfc_warning (OPT_Wsurprising, 13605 "Only array FINAL procedures declared for derived type %qs" 13606 " defined at %L, suggest also scalar one", 13607 derived->name, &derived->declared_at); 13608 13609 vtab = gfc_find_derived_vtab (derived); 13610 c = vtab->ts.u.derived->components->next->next->next->next->next; 13611 gfc_set_sym_referenced (c->initializer->symtree->n.sym); 13612 13613 if (finalizable) 13614 *finalizable = true; 13615 13616 return true; 13617} 13618 13619 13620/* Check if two GENERIC targets are ambiguous and emit an error is they are. */ 13621 13622static bool 13623check_generic_tbp_ambiguity (gfc_tbp_generic* t1, gfc_tbp_generic* t2, 13624 const char* generic_name, locus where) 13625{ 13626 gfc_symbol *sym1, *sym2; 13627 const char *pass1, *pass2; 13628 gfc_formal_arglist *dummy_args; 13629 13630 gcc_assert (t1->specific && t2->specific); 13631 gcc_assert (!t1->specific->is_generic); 13632 gcc_assert (!t2->specific->is_generic); 13633 gcc_assert (t1->is_operator == t2->is_operator); 13634 13635 sym1 = t1->specific->u.specific->n.sym; 13636 sym2 = t2->specific->u.specific->n.sym; 13637 13638 if (sym1 == sym2) 13639 return true; 13640 13641 /* Both must be SUBROUTINEs or both must be FUNCTIONs. */ 13642 if (sym1->attr.subroutine != sym2->attr.subroutine 13643 || sym1->attr.function != sym2->attr.function) 13644 { 13645 gfc_error ("%qs and %qs cannot be mixed FUNCTION/SUBROUTINE for" 13646 " GENERIC %qs at %L", 13647 sym1->name, sym2->name, generic_name, &where); 13648 return false; 13649 } 13650 13651 /* Determine PASS arguments. */ 13652 if (t1->specific->nopass) 13653 pass1 = NULL; 13654 else if (t1->specific->pass_arg) 13655 pass1 = t1->specific->pass_arg; 13656 else 13657 { 13658 dummy_args = gfc_sym_get_dummy_args (t1->specific->u.specific->n.sym); 13659 if (dummy_args) 13660 pass1 = dummy_args->sym->name; 13661 else 13662 pass1 = NULL; 13663 } 13664 if (t2->specific->nopass) 13665 pass2 = NULL; 13666 else if (t2->specific->pass_arg) 13667 pass2 = t2->specific->pass_arg; 13668 else 13669 { 13670 dummy_args = gfc_sym_get_dummy_args (t2->specific->u.specific->n.sym); 13671 if (dummy_args) 13672 pass2 = dummy_args->sym->name; 13673 else 13674 pass2 = NULL; 13675 } 13676 13677 /* Compare the interfaces. */ 13678 if (gfc_compare_interfaces (sym1, sym2, sym2->name, !t1->is_operator, 0, 13679 NULL, 0, pass1, pass2)) 13680 { 13681 gfc_error ("%qs and %qs for GENERIC %qs at %L are ambiguous", 13682 sym1->name, sym2->name, generic_name, &where); 13683 return false; 13684 } 13685 13686 return true; 13687} 13688 13689 13690/* Worker function for resolving a generic procedure binding; this is used to 13691 resolve GENERIC as well as user and intrinsic OPERATOR typebound procedures. 13692 13693 The difference between those cases is finding possible inherited bindings 13694 that are overridden, as one has to look for them in tb_sym_root, 13695 tb_uop_root or tb_op, respectively. Thus the caller must already find 13696 the super-type and set p->overridden correctly. */ 13697 13698static bool 13699resolve_tb_generic_targets (gfc_symbol* super_type, 13700 gfc_typebound_proc* p, const char* name) 13701{ 13702 gfc_tbp_generic* target; 13703 gfc_symtree* first_target; 13704 gfc_symtree* inherited; 13705 13706 gcc_assert (p && p->is_generic); 13707 13708 /* Try to find the specific bindings for the symtrees in our target-list. */ 13709 gcc_assert (p->u.generic); 13710 for (target = p->u.generic; target; target = target->next) 13711 if (!target->specific) 13712 { 13713 gfc_typebound_proc* overridden_tbp; 13714 gfc_tbp_generic* g; 13715 const char* target_name; 13716 13717 target_name = target->specific_st->name; 13718 13719 /* Defined for this type directly. */ 13720 if (target->specific_st->n.tb && !target->specific_st->n.tb->error) 13721 { 13722 target->specific = target->specific_st->n.tb; 13723 goto specific_found; 13724 } 13725 13726 /* Look for an inherited specific binding. */ 13727 if (super_type) 13728 { 13729 inherited = gfc_find_typebound_proc (super_type, NULL, target_name, 13730 true, NULL); 13731 13732 if (inherited) 13733 { 13734 gcc_assert (inherited->n.tb); 13735 target->specific = inherited->n.tb; 13736 goto specific_found; 13737 } 13738 } 13739 13740 gfc_error ("Undefined specific binding %qs as target of GENERIC %qs" 13741 " at %L", target_name, name, &p->where); 13742 return false; 13743 13744 /* Once we've found the specific binding, check it is not ambiguous with 13745 other specifics already found or inherited for the same GENERIC. */ 13746specific_found: 13747 gcc_assert (target->specific); 13748 13749 /* This must really be a specific binding! */ 13750 if (target->specific->is_generic) 13751 { 13752 gfc_error ("GENERIC %qs at %L must target a specific binding," 13753 " %qs is GENERIC, too", name, &p->where, target_name); 13754 return false; 13755 } 13756 13757 /* Check those already resolved on this type directly. */ 13758 for (g = p->u.generic; g; g = g->next) 13759 if (g != target && g->specific 13760 && !check_generic_tbp_ambiguity (target, g, name, p->where)) 13761 return false; 13762 13763 /* Check for ambiguity with inherited specific targets. */ 13764 for (overridden_tbp = p->overridden; overridden_tbp; 13765 overridden_tbp = overridden_tbp->overridden) 13766 if (overridden_tbp->is_generic) 13767 { 13768 for (g = overridden_tbp->u.generic; g; g = g->next) 13769 { 13770 gcc_assert (g->specific); 13771 if (!check_generic_tbp_ambiguity (target, g, name, p->where)) 13772 return false; 13773 } 13774 } 13775 } 13776 13777 /* If we attempt to "overwrite" a specific binding, this is an error. */ 13778 if (p->overridden && !p->overridden->is_generic) 13779 { 13780 gfc_error ("GENERIC %qs at %L cannot overwrite specific binding with" 13781 " the same name", name, &p->where); 13782 return false; 13783 } 13784 13785 /* Take the SUBROUTINE/FUNCTION attributes of the first specific target, as 13786 all must have the same attributes here. */ 13787 first_target = p->u.generic->specific->u.specific; 13788 gcc_assert (first_target); 13789 p->subroutine = first_target->n.sym->attr.subroutine; 13790 p->function = first_target->n.sym->attr.function; 13791 13792 return true; 13793} 13794 13795 13796/* Resolve a GENERIC procedure binding for a derived type. */ 13797 13798static bool 13799resolve_typebound_generic (gfc_symbol* derived, gfc_symtree* st) 13800{ 13801 gfc_symbol* super_type; 13802 13803 /* Find the overridden binding if any. */ 13804 st->n.tb->overridden = NULL; 13805 super_type = gfc_get_derived_super_type (derived); 13806 if (super_type) 13807 { 13808 gfc_symtree* overridden; 13809 overridden = gfc_find_typebound_proc (super_type, NULL, st->name, 13810 true, NULL); 13811 13812 if (overridden && overridden->n.tb) 13813 st->n.tb->overridden = overridden->n.tb; 13814 } 13815 13816 /* Resolve using worker function. */ 13817 return resolve_tb_generic_targets (super_type, st->n.tb, st->name); 13818} 13819 13820 13821/* Retrieve the target-procedure of an operator binding and do some checks in 13822 common for intrinsic and user-defined type-bound operators. */ 13823 13824static gfc_symbol* 13825get_checked_tb_operator_target (gfc_tbp_generic* target, locus where) 13826{ 13827 gfc_symbol* target_proc; 13828 13829 gcc_assert (target->specific && !target->specific->is_generic); 13830 target_proc = target->specific->u.specific->n.sym; 13831 gcc_assert (target_proc); 13832 13833 /* F08:C468. All operator bindings must have a passed-object dummy argument. */ 13834 if (target->specific->nopass) 13835 { 13836 gfc_error ("Type-bound operator at %L cannot be NOPASS", &where); 13837 return NULL; 13838 } 13839 13840 return target_proc; 13841} 13842 13843 13844/* Resolve a type-bound intrinsic operator. */ 13845 13846static bool 13847resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op, 13848 gfc_typebound_proc* p) 13849{ 13850 gfc_symbol* super_type; 13851 gfc_tbp_generic* target; 13852 13853 /* If there's already an error here, do nothing (but don't fail again). */ 13854 if (p->error) 13855 return true; 13856 13857 /* Operators should always be GENERIC bindings. */ 13858 gcc_assert (p->is_generic); 13859 13860 /* Look for an overridden binding. */ 13861 super_type = gfc_get_derived_super_type (derived); 13862 if (super_type && super_type->f2k_derived) 13863 p->overridden = gfc_find_typebound_intrinsic_op (super_type, NULL, 13864 op, true, NULL); 13865 else 13866 p->overridden = NULL; 13867 13868 /* Resolve general GENERIC properties using worker function. */ 13869 if (!resolve_tb_generic_targets (super_type, p, gfc_op2string(op))) 13870 goto error; 13871 13872 /* Check the targets to be procedures of correct interface. */ 13873 for (target = p->u.generic; target; target = target->next) 13874 { 13875 gfc_symbol* target_proc; 13876 13877 target_proc = get_checked_tb_operator_target (target, p->where); 13878 if (!target_proc) 13879 goto error; 13880 13881 if (!gfc_check_operator_interface (target_proc, op, p->where)) 13882 goto error; 13883 13884 /* Add target to non-typebound operator list. */ 13885 if (!target->specific->deferred && !derived->attr.use_assoc 13886 && p->access != ACCESS_PRIVATE && derived->ns == gfc_current_ns) 13887 { 13888 gfc_interface *head, *intr; 13889 13890 /* Preempt 'gfc_check_new_interface' for submodules, where the 13891 mechanism for handling module procedures winds up resolving 13892 operator interfaces twice and would otherwise cause an error. */ 13893 for (intr = derived->ns->op[op]; intr; intr = intr->next) 13894 if (intr->sym == target_proc 13895 && target_proc->attr.used_in_submodule) 13896 return true; 13897 13898 if (!gfc_check_new_interface (derived->ns->op[op], 13899 target_proc, p->where)) 13900 return false; 13901 head = derived->ns->op[op]; 13902 intr = gfc_get_interface (); 13903 intr->sym = target_proc; 13904 intr->where = p->where; 13905 intr->next = head; 13906 derived->ns->op[op] = intr; 13907 } 13908 } 13909 13910 return true; 13911 13912error: 13913 p->error = 1; 13914 return false; 13915} 13916 13917 13918/* Resolve a type-bound user operator (tree-walker callback). */ 13919 13920static gfc_symbol* resolve_bindings_derived; 13921static bool resolve_bindings_result; 13922 13923static bool check_uop_procedure (gfc_symbol* sym, locus where); 13924 13925static void 13926resolve_typebound_user_op (gfc_symtree* stree) 13927{ 13928 gfc_symbol* super_type; 13929 gfc_tbp_generic* target; 13930 13931 gcc_assert (stree && stree->n.tb); 13932 13933 if (stree->n.tb->error) 13934 return; 13935 13936 /* Operators should always be GENERIC bindings. */ 13937 gcc_assert (stree->n.tb->is_generic); 13938 13939 /* Find overridden procedure, if any. */ 13940 super_type = gfc_get_derived_super_type (resolve_bindings_derived); 13941 if (super_type && super_type->f2k_derived) 13942 { 13943 gfc_symtree* overridden; 13944 overridden = gfc_find_typebound_user_op (super_type, NULL, 13945 stree->name, true, NULL); 13946 13947 if (overridden && overridden->n.tb) 13948 stree->n.tb->overridden = overridden->n.tb; 13949 } 13950 else 13951 stree->n.tb->overridden = NULL; 13952 13953 /* Resolve basically using worker function. */ 13954 if (!resolve_tb_generic_targets (super_type, stree->n.tb, stree->name)) 13955 goto error; 13956 13957 /* Check the targets to be functions of correct interface. */ 13958 for (target = stree->n.tb->u.generic; target; target = target->next) 13959 { 13960 gfc_symbol* target_proc; 13961 13962 target_proc = get_checked_tb_operator_target (target, stree->n.tb->where); 13963 if (!target_proc) 13964 goto error; 13965 13966 if (!check_uop_procedure (target_proc, stree->n.tb->where)) 13967 goto error; 13968 } 13969 13970 return; 13971 13972error: 13973 resolve_bindings_result = false; 13974 stree->n.tb->error = 1; 13975} 13976 13977 13978/* Resolve the type-bound procedures for a derived type. */ 13979 13980static void 13981resolve_typebound_procedure (gfc_symtree* stree) 13982{ 13983 gfc_symbol* proc; 13984 locus where; 13985 gfc_symbol* me_arg; 13986 gfc_symbol* super_type; 13987 gfc_component* comp; 13988 13989 gcc_assert (stree); 13990 13991 /* Undefined specific symbol from GENERIC target definition. */ 13992 if (!stree->n.tb) 13993 return; 13994 13995 if (stree->n.tb->error) 13996 return; 13997 13998 /* If this is a GENERIC binding, use that routine. */ 13999 if (stree->n.tb->is_generic) 14000 { 14001 if (!resolve_typebound_generic (resolve_bindings_derived, stree)) 14002 goto error; 14003 return; 14004 } 14005 14006 /* Get the target-procedure to check it. */ 14007 gcc_assert (!stree->n.tb->is_generic); 14008 gcc_assert (stree->n.tb->u.specific); 14009 proc = stree->n.tb->u.specific->n.sym; 14010 where = stree->n.tb->where; 14011 14012 /* Default access should already be resolved from the parser. */ 14013 gcc_assert (stree->n.tb->access != ACCESS_UNKNOWN); 14014 14015 if (stree->n.tb->deferred) 14016 { 14017 if (!check_proc_interface (proc, &where)) 14018 goto error; 14019 } 14020 else 14021 { 14022 /* If proc has not been resolved at this point, proc->name may 14023 actually be a USE associated entity. See PR fortran/89647. */ 14024 if (!proc->resolve_symbol_called 14025 && proc->attr.function == 0 && proc->attr.subroutine == 0) 14026 { 14027 gfc_symbol *tmp; 14028 gfc_find_symbol (proc->name, gfc_current_ns->parent, 1, &tmp); 14029 if (tmp && tmp->attr.use_assoc) 14030 { 14031 proc->module = tmp->module; 14032 proc->attr.proc = tmp->attr.proc; 14033 proc->attr.function = tmp->attr.function; 14034 proc->attr.subroutine = tmp->attr.subroutine; 14035 proc->attr.use_assoc = tmp->attr.use_assoc; 14036 proc->ts = tmp->ts; 14037 proc->result = tmp->result; 14038 } 14039 } 14040 14041 /* Check for F08:C465. */ 14042 if ((!proc->attr.subroutine && !proc->attr.function) 14043 || (proc->attr.proc != PROC_MODULE 14044 && proc->attr.if_source != IFSRC_IFBODY) 14045 || proc->attr.abstract) 14046 { 14047 gfc_error ("%qs must be a module procedure or an external " 14048 "procedure with an explicit interface at %L", 14049 proc->name, &where); 14050 goto error; 14051 } 14052 } 14053 14054 stree->n.tb->subroutine = proc->attr.subroutine; 14055 stree->n.tb->function = proc->attr.function; 14056 14057 /* Find the super-type of the current derived type. We could do this once and 14058 store in a global if speed is needed, but as long as not I believe this is 14059 more readable and clearer. */ 14060 super_type = gfc_get_derived_super_type (resolve_bindings_derived); 14061 14062 /* If PASS, resolve and check arguments if not already resolved / loaded 14063 from a .mod file. */ 14064 if (!stree->n.tb->nopass && stree->n.tb->pass_arg_num == 0) 14065 { 14066 gfc_formal_arglist *dummy_args; 14067 14068 dummy_args = gfc_sym_get_dummy_args (proc); 14069 if (stree->n.tb->pass_arg) 14070 { 14071 gfc_formal_arglist *i; 14072 14073 /* If an explicit passing argument name is given, walk the arg-list 14074 and look for it. */ 14075 14076 me_arg = NULL; 14077 stree->n.tb->pass_arg_num = 1; 14078 for (i = dummy_args; i; i = i->next) 14079 { 14080 if (!strcmp (i->sym->name, stree->n.tb->pass_arg)) 14081 { 14082 me_arg = i->sym; 14083 break; 14084 } 14085 ++stree->n.tb->pass_arg_num; 14086 } 14087 14088 if (!me_arg) 14089 { 14090 gfc_error ("Procedure %qs with PASS(%s) at %L has no" 14091 " argument %qs", 14092 proc->name, stree->n.tb->pass_arg, &where, 14093 stree->n.tb->pass_arg); 14094 goto error; 14095 } 14096 } 14097 else 14098 { 14099 /* Otherwise, take the first one; there should in fact be at least 14100 one. */ 14101 stree->n.tb->pass_arg_num = 1; 14102 if (!dummy_args) 14103 { 14104 gfc_error ("Procedure %qs with PASS at %L must have at" 14105 " least one argument", proc->name, &where); 14106 goto error; 14107 } 14108 me_arg = dummy_args->sym; 14109 } 14110 14111 /* Now check that the argument-type matches and the passed-object 14112 dummy argument is generally fine. */ 14113 14114 gcc_assert (me_arg); 14115 14116 if (me_arg->ts.type != BT_CLASS) 14117 { 14118 gfc_error ("Non-polymorphic passed-object dummy argument of %qs" 14119 " at %L", proc->name, &where); 14120 goto error; 14121 } 14122 14123 if (CLASS_DATA (me_arg)->ts.u.derived 14124 != resolve_bindings_derived) 14125 { 14126 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" 14127 " the derived-type %qs", me_arg->name, proc->name, 14128 me_arg->name, &where, resolve_bindings_derived->name); 14129 goto error; 14130 } 14131 14132 gcc_assert (me_arg->ts.type == BT_CLASS); 14133 if (CLASS_DATA (me_arg)->as && CLASS_DATA (me_arg)->as->rank != 0) 14134 { 14135 gfc_error ("Passed-object dummy argument of %qs at %L must be" 14136 " scalar", proc->name, &where); 14137 goto error; 14138 } 14139 if (CLASS_DATA (me_arg)->attr.allocatable) 14140 { 14141 gfc_error ("Passed-object dummy argument of %qs at %L must not" 14142 " be ALLOCATABLE", proc->name, &where); 14143 goto error; 14144 } 14145 if (CLASS_DATA (me_arg)->attr.class_pointer) 14146 { 14147 gfc_error ("Passed-object dummy argument of %qs at %L must not" 14148 " be POINTER", proc->name, &where); 14149 goto error; 14150 } 14151 } 14152 14153 /* If we are extending some type, check that we don't override a procedure 14154 flagged NON_OVERRIDABLE. */ 14155 stree->n.tb->overridden = NULL; 14156 if (super_type) 14157 { 14158 gfc_symtree* overridden; 14159 overridden = gfc_find_typebound_proc (super_type, NULL, 14160 stree->name, true, NULL); 14161 14162 if (overridden) 14163 { 14164 if (overridden->n.tb) 14165 stree->n.tb->overridden = overridden->n.tb; 14166 14167 if (!gfc_check_typebound_override (stree, overridden)) 14168 goto error; 14169 } 14170 } 14171 14172 /* See if there's a name collision with a component directly in this type. */ 14173 for (comp = resolve_bindings_derived->components; comp; comp = comp->next) 14174 if (!strcmp (comp->name, stree->name)) 14175 { 14176 gfc_error ("Procedure %qs at %L has the same name as a component of" 14177 " %qs", 14178 stree->name, &where, resolve_bindings_derived->name); 14179 goto error; 14180 } 14181 14182 /* Try to find a name collision with an inherited component. */ 14183 if (super_type && gfc_find_component (super_type, stree->name, true, true, 14184 NULL)) 14185 { 14186 gfc_error ("Procedure %qs at %L has the same name as an inherited" 14187 " component of %qs", 14188 stree->name, &where, resolve_bindings_derived->name); 14189 goto error; 14190 } 14191 14192 stree->n.tb->error = 0; 14193 return; 14194 14195error: 14196 resolve_bindings_result = false; 14197 stree->n.tb->error = 1; 14198} 14199 14200 14201static bool 14202resolve_typebound_procedures (gfc_symbol* derived) 14203{ 14204 int op; 14205 gfc_symbol* super_type; 14206 14207 if (!derived->f2k_derived || !derived->f2k_derived->tb_sym_root) 14208 return true; 14209 14210 super_type = gfc_get_derived_super_type (derived); 14211 if (super_type) 14212 resolve_symbol (super_type); 14213 14214 resolve_bindings_derived = derived; 14215 resolve_bindings_result = true; 14216 14217 if (derived->f2k_derived->tb_sym_root) 14218 gfc_traverse_symtree (derived->f2k_derived->tb_sym_root, 14219 &resolve_typebound_procedure); 14220 14221 if (derived->f2k_derived->tb_uop_root) 14222 gfc_traverse_symtree (derived->f2k_derived->tb_uop_root, 14223 &resolve_typebound_user_op); 14224 14225 for (op = 0; op != GFC_INTRINSIC_OPS; ++op) 14226 { 14227 gfc_typebound_proc* p = derived->f2k_derived->tb_op[op]; 14228 if (p && !resolve_typebound_intrinsic_op (derived, 14229 (gfc_intrinsic_op)op, p)) 14230 resolve_bindings_result = false; 14231 } 14232 14233 return resolve_bindings_result; 14234} 14235 14236 14237/* Add a derived type to the dt_list. The dt_list is used in trans-types.c 14238 to give all identical derived types the same backend_decl. */ 14239static void 14240add_dt_to_dt_list (gfc_symbol *derived) 14241{ 14242 if (!derived->dt_next) 14243 { 14244 if (gfc_derived_types) 14245 { 14246 derived->dt_next = gfc_derived_types->dt_next; 14247 gfc_derived_types->dt_next = derived; 14248 } 14249 else 14250 { 14251 derived->dt_next = derived; 14252 } 14253 gfc_derived_types = derived; 14254 } 14255} 14256 14257 14258/* Ensure that a derived-type is really not abstract, meaning that every 14259 inherited DEFERRED binding is overridden by a non-DEFERRED one. */ 14260 14261static bool 14262ensure_not_abstract_walker (gfc_symbol* sub, gfc_symtree* st) 14263{ 14264 if (!st) 14265 return true; 14266 14267 if (!ensure_not_abstract_walker (sub, st->left)) 14268 return false; 14269 if (!ensure_not_abstract_walker (sub, st->right)) 14270 return false; 14271 14272 if (st->n.tb && st->n.tb->deferred) 14273 { 14274 gfc_symtree* overriding; 14275 overriding = gfc_find_typebound_proc (sub, NULL, st->name, true, NULL); 14276 if (!overriding) 14277 return false; 14278 gcc_assert (overriding->n.tb); 14279 if (overriding->n.tb->deferred) 14280 { 14281 gfc_error ("Derived-type %qs declared at %L must be ABSTRACT because" 14282 " %qs is DEFERRED and not overridden", 14283 sub->name, &sub->declared_at, st->name); 14284 return false; 14285 } 14286 } 14287 14288 return true; 14289} 14290 14291static bool 14292ensure_not_abstract (gfc_symbol* sub, gfc_symbol* ancestor) 14293{ 14294 /* The algorithm used here is to recursively travel up the ancestry of sub 14295 and for each ancestor-type, check all bindings. If any of them is 14296 DEFERRED, look it up starting from sub and see if the found (overriding) 14297 binding is not DEFERRED. 14298 This is not the most efficient way to do this, but it should be ok and is 14299 clearer than something sophisticated. */ 14300 14301 gcc_assert (ancestor && !sub->attr.abstract); 14302 14303 if (!ancestor->attr.abstract) 14304 return true; 14305 14306 /* Walk bindings of this ancestor. */ 14307 if (ancestor->f2k_derived) 14308 { 14309 bool t; 14310 t = ensure_not_abstract_walker (sub, ancestor->f2k_derived->tb_sym_root); 14311 if (!t) 14312 return false; 14313 } 14314 14315 /* Find next ancestor type and recurse on it. */ 14316 ancestor = gfc_get_derived_super_type (ancestor); 14317 if (ancestor) 14318 return ensure_not_abstract (sub, ancestor); 14319 14320 return true; 14321} 14322 14323 14324/* This check for typebound defined assignments is done recursively 14325 since the order in which derived types are resolved is not always in 14326 order of the declarations. */ 14327 14328static void 14329check_defined_assignments (gfc_symbol *derived) 14330{ 14331 gfc_component *c; 14332 14333 for (c = derived->components; c; c = c->next) 14334 { 14335 if (!gfc_bt_struct (c->ts.type) 14336 || c->attr.pointer 14337 || c->attr.allocatable 14338 || c->attr.proc_pointer_comp 14339 || c->attr.class_pointer 14340 || c->attr.proc_pointer) 14341 continue; 14342 14343 if (c->ts.u.derived->attr.defined_assign_comp 14344 || (c->ts.u.derived->f2k_derived 14345 && c->ts.u.derived->f2k_derived->tb_op[INTRINSIC_ASSIGN])) 14346 { 14347 derived->attr.defined_assign_comp = 1; 14348 return; 14349 } 14350 14351 check_defined_assignments (c->ts.u.derived); 14352 if (c->ts.u.derived->attr.defined_assign_comp) 14353 { 14354 derived->attr.defined_assign_comp = 1; 14355 return; 14356 } 14357 } 14358} 14359 14360 14361/* Resolve a single component of a derived type or structure. */ 14362 14363static bool 14364resolve_component (gfc_component *c, gfc_symbol *sym) 14365{ 14366 gfc_symbol *super_type; 14367 symbol_attribute *attr; 14368 14369 if (c->attr.artificial) 14370 return true; 14371 14372 /* Do not allow vtype components to be resolved in nameless namespaces 14373 such as block data because the procedure pointers will cause ICEs 14374 and vtables are not needed in these contexts. */ 14375 if (sym->attr.vtype && sym->attr.use_assoc 14376 && sym->ns->proc_name == NULL) 14377 return true; 14378 14379 /* F2008, C442. */ 14380 if ((!sym->attr.is_class || c != sym->components) 14381 && c->attr.codimension 14382 && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) 14383 { 14384 gfc_error ("Coarray component %qs at %L must be allocatable with " 14385 "deferred shape", c->name, &c->loc); 14386 return false; 14387 } 14388 14389 /* F2008, C443. */ 14390 if (c->attr.codimension && c->ts.type == BT_DERIVED 14391 && c->ts.u.derived->ts.is_iso_c) 14392 { 14393 gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " 14394 "shall not be a coarray", c->name, &c->loc); 14395 return false; 14396 } 14397 14398 /* F2008, C444. */ 14399 if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp 14400 && (c->attr.codimension || c->attr.pointer || c->attr.dimension 14401 || c->attr.allocatable)) 14402 { 14403 gfc_error ("Component %qs at %L with coarray component " 14404 "shall be a nonpointer, nonallocatable scalar", 14405 c->name, &c->loc); 14406 return false; 14407 } 14408 14409 /* F2008, C448. */ 14410 if (c->ts.type == BT_CLASS) 14411 { 14412 if (c->attr.class_ok && CLASS_DATA (c)) 14413 { 14414 attr = &(CLASS_DATA (c)->attr); 14415 14416 /* Fix up contiguous attribute. */ 14417 if (c->attr.contiguous) 14418 attr->contiguous = 1; 14419 } 14420 else 14421 attr = NULL; 14422 } 14423 else 14424 attr = &c->attr; 14425 14426 if (attr && attr->contiguous && (!attr->dimension || !attr->pointer)) 14427 { 14428 gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but " 14429 "is not an array pointer", c->name, &c->loc); 14430 return false; 14431 } 14432 14433 /* F2003, 15.2.1 - length has to be one. */ 14434 if (sym->attr.is_bind_c && c->ts.type == BT_CHARACTER 14435 && (c->ts.u.cl == NULL || c->ts.u.cl->length == NULL 14436 || !gfc_is_constant_expr (c->ts.u.cl->length) 14437 || mpz_cmp_si (c->ts.u.cl->length->value.integer, 1) != 0)) 14438 { 14439 gfc_error ("Component %qs of BIND(C) type at %L must have length one", 14440 c->name, &c->loc); 14441 return false; 14442 } 14443 14444 if (c->attr.proc_pointer && c->ts.interface) 14445 { 14446 gfc_symbol *ifc = c->ts.interface; 14447 14448 if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc)) 14449 { 14450 c->tb->error = 1; 14451 return false; 14452 } 14453 14454 if (ifc->attr.if_source || ifc->attr.intrinsic) 14455 { 14456 /* Resolve interface and copy attributes. */ 14457 if (ifc->formal && !ifc->formal_ns) 14458 resolve_symbol (ifc); 14459 if (ifc->attr.intrinsic) 14460 gfc_resolve_intrinsic (ifc, &ifc->declared_at); 14461 14462 if (ifc->result) 14463 { 14464 c->ts = ifc->result->ts; 14465 c->attr.allocatable = ifc->result->attr.allocatable; 14466 c->attr.pointer = ifc->result->attr.pointer; 14467 c->attr.dimension = ifc->result->attr.dimension; 14468 c->as = gfc_copy_array_spec (ifc->result->as); 14469 c->attr.class_ok = ifc->result->attr.class_ok; 14470 } 14471 else 14472 { 14473 c->ts = ifc->ts; 14474 c->attr.allocatable = ifc->attr.allocatable; 14475 c->attr.pointer = ifc->attr.pointer; 14476 c->attr.dimension = ifc->attr.dimension; 14477 c->as = gfc_copy_array_spec (ifc->as); 14478 c->attr.class_ok = ifc->attr.class_ok; 14479 } 14480 c->ts.interface = ifc; 14481 c->attr.function = ifc->attr.function; 14482 c->attr.subroutine = ifc->attr.subroutine; 14483 14484 c->attr.pure = ifc->attr.pure; 14485 c->attr.elemental = ifc->attr.elemental; 14486 c->attr.recursive = ifc->attr.recursive; 14487 c->attr.always_explicit = ifc->attr.always_explicit; 14488 c->attr.ext_attr |= ifc->attr.ext_attr; 14489 /* Copy char length. */ 14490 if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl) 14491 { 14492 gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl); 14493 if (cl->length && !cl->resolved 14494 && !gfc_resolve_expr (cl->length)) 14495 { 14496 c->tb->error = 1; 14497 return false; 14498 } 14499 c->ts.u.cl = cl; 14500 } 14501 } 14502 } 14503 else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN) 14504 { 14505 /* Since PPCs are not implicitly typed, a PPC without an explicit 14506 interface must be a subroutine. */ 14507 gfc_add_subroutine (&c->attr, c->name, &c->loc); 14508 } 14509 14510 /* Procedure pointer components: Check PASS arg. */ 14511 if (c->attr.proc_pointer && !c->tb->nopass && c->tb->pass_arg_num == 0 14512 && !sym->attr.vtype) 14513 { 14514 gfc_symbol* me_arg; 14515 14516 if (c->tb->pass_arg) 14517 { 14518 gfc_formal_arglist* i; 14519 14520 /* If an explicit passing argument name is given, walk the arg-list 14521 and look for it. */ 14522 14523 me_arg = NULL; 14524 c->tb->pass_arg_num = 1; 14525 for (i = c->ts.interface->formal; i; i = i->next) 14526 { 14527 if (!strcmp (i->sym->name, c->tb->pass_arg)) 14528 { 14529 me_arg = i->sym; 14530 break; 14531 } 14532 c->tb->pass_arg_num++; 14533 } 14534 14535 if (!me_arg) 14536 { 14537 gfc_error ("Procedure pointer component %qs with PASS(%s) " 14538 "at %L has no argument %qs", c->name, 14539 c->tb->pass_arg, &c->loc, c->tb->pass_arg); 14540 c->tb->error = 1; 14541 return false; 14542 } 14543 } 14544 else 14545 { 14546 /* Otherwise, take the first one; there should in fact be at least 14547 one. */ 14548 c->tb->pass_arg_num = 1; 14549 if (!c->ts.interface->formal) 14550 { 14551 gfc_error ("Procedure pointer component %qs with PASS at %L " 14552 "must have at least one argument", 14553 c->name, &c->loc); 14554 c->tb->error = 1; 14555 return false; 14556 } 14557 me_arg = c->ts.interface->formal->sym; 14558 } 14559 14560 /* Now check that the argument-type matches. */ 14561 gcc_assert (me_arg); 14562 if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS) 14563 || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym) 14564 || (me_arg->ts.type == BT_CLASS 14565 && CLASS_DATA (me_arg)->ts.u.derived != sym)) 14566 { 14567 gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of" 14568 " the derived type %qs", me_arg->name, c->name, 14569 me_arg->name, &c->loc, sym->name); 14570 c->tb->error = 1; 14571 return false; 14572 } 14573 14574 /* Check for F03:C453. */ 14575 if (CLASS_DATA (me_arg)->attr.dimension) 14576 { 14577 gfc_error ("Argument %qs of %qs with PASS(%s) at %L " 14578 "must be scalar", me_arg->name, c->name, me_arg->name, 14579 &c->loc); 14580 c->tb->error = 1; 14581 return false; 14582 } 14583 14584 if (CLASS_DATA (me_arg)->attr.class_pointer) 14585 { 14586 gfc_error ("Argument %qs of %qs with PASS(%s) at %L " 14587 "may not have the POINTER attribute", me_arg->name, 14588 c->name, me_arg->name, &c->loc); 14589 c->tb->error = 1; 14590 return false; 14591 } 14592 14593 if (CLASS_DATA (me_arg)->attr.allocatable) 14594 { 14595 gfc_error ("Argument %qs of %qs with PASS(%s) at %L " 14596 "may not be ALLOCATABLE", me_arg->name, c->name, 14597 me_arg->name, &c->loc); 14598 c->tb->error = 1; 14599 return false; 14600 } 14601 14602 if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) 14603 { 14604 gfc_error ("Non-polymorphic passed-object dummy argument of %qs" 14605 " at %L", c->name, &c->loc); 14606 return false; 14607 } 14608 14609 } 14610 14611 /* Check type-spec if this is not the parent-type component. */ 14612 if (((sym->attr.is_class 14613 && (!sym->components->ts.u.derived->attr.extension 14614 || c != sym->components->ts.u.derived->components)) 14615 || (!sym->attr.is_class 14616 && (!sym->attr.extension || c != sym->components))) 14617 && !sym->attr.vtype 14618 && !resolve_typespec_used (&c->ts, &c->loc, c->name)) 14619 return false; 14620 14621 super_type = gfc_get_derived_super_type (sym); 14622 14623 /* If this type is an extension, set the accessibility of the parent 14624 component. */ 14625 if (super_type 14626 && ((sym->attr.is_class 14627 && c == sym->components->ts.u.derived->components) 14628 || (!sym->attr.is_class && c == sym->components)) 14629 && strcmp (super_type->name, c->name) == 0) 14630 c->attr.access = super_type->attr.access; 14631 14632 /* If this type is an extension, see if this component has the same name 14633 as an inherited type-bound procedure. */ 14634 if (super_type && !sym->attr.is_class 14635 && gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL)) 14636 { 14637 gfc_error ("Component %qs of %qs at %L has the same name as an" 14638 " inherited type-bound procedure", 14639 c->name, sym->name, &c->loc); 14640 return false; 14641 } 14642 14643 if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer 14644 && !c->ts.deferred) 14645 { 14646 if (c->ts.u.cl->length == NULL 14647 || (!resolve_charlen(c->ts.u.cl)) 14648 || !gfc_is_constant_expr (c->ts.u.cl->length)) 14649 { 14650 gfc_error ("Character length of component %qs needs to " 14651 "be a constant specification expression at %L", 14652 c->name, 14653 c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc); 14654 return false; 14655 } 14656 14657 if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER) 14658 { 14659 if (!c->ts.u.cl->length->error) 14660 { 14661 gfc_error ("Character length expression of component %qs at %L " 14662 "must be of INTEGER type, found %s", 14663 c->name, &c->ts.u.cl->length->where, 14664 gfc_basic_typename (c->ts.u.cl->length->ts.type)); 14665 c->ts.u.cl->length->error = 1; 14666 } 14667 return false; 14668 } 14669 } 14670 14671 if (c->ts.type == BT_CHARACTER && c->ts.deferred 14672 && !c->attr.pointer && !c->attr.allocatable) 14673 { 14674 gfc_error ("Character component %qs of %qs at %L with deferred " 14675 "length must be a POINTER or ALLOCATABLE", 14676 c->name, sym->name, &c->loc); 14677 return false; 14678 } 14679 14680 /* Add the hidden deferred length field. */ 14681 if (c->ts.type == BT_CHARACTER 14682 && (c->ts.deferred || c->attr.pdt_string) 14683 && !c->attr.function 14684 && !sym->attr.is_class) 14685 { 14686 char name[GFC_MAX_SYMBOL_LEN+9]; 14687 gfc_component *strlen; 14688 sprintf (name, "_%s_length", c->name); 14689 strlen = gfc_find_component (sym, name, true, true, NULL); 14690 if (strlen == NULL) 14691 { 14692 if (!gfc_add_component (sym, name, &strlen)) 14693 return false; 14694 strlen->ts.type = BT_INTEGER; 14695 strlen->ts.kind = gfc_charlen_int_kind; 14696 strlen->attr.access = ACCESS_PRIVATE; 14697 strlen->attr.artificial = 1; 14698 } 14699 } 14700 14701 if (c->ts.type == BT_DERIVED 14702 && sym->component_access != ACCESS_PRIVATE 14703 && gfc_check_symbol_access (sym) 14704 && !is_sym_host_assoc (c->ts.u.derived, sym->ns) 14705 && !c->ts.u.derived->attr.use_assoc 14706 && !gfc_check_symbol_access (c->ts.u.derived) 14707 && !gfc_notify_std (GFC_STD_F2003, "the component %qs is a " 14708 "PRIVATE type and cannot be a component of " 14709 "%qs, which is PUBLIC at %L", c->name, 14710 sym->name, &sym->declared_at)) 14711 return false; 14712 14713 if ((sym->attr.sequence || sym->attr.is_bind_c) && c->ts.type == BT_CLASS) 14714 { 14715 gfc_error ("Polymorphic component %s at %L in SEQUENCE or BIND(C) " 14716 "type %s", c->name, &c->loc, sym->name); 14717 return false; 14718 } 14719 14720 if (sym->attr.sequence) 14721 { 14722 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0) 14723 { 14724 gfc_error ("Component %s of SEQUENCE type declared at %L does " 14725 "not have the SEQUENCE attribute", 14726 c->ts.u.derived->name, &sym->declared_at); 14727 return false; 14728 } 14729 } 14730 14731 if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic) 14732 c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived); 14733 else if (c->ts.type == BT_CLASS && c->attr.class_ok 14734 && CLASS_DATA (c)->ts.u.derived->attr.generic) 14735 CLASS_DATA (c)->ts.u.derived 14736 = gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived); 14737 14738 /* If an allocatable component derived type is of the same type as 14739 the enclosing derived type, we need a vtable generating so that 14740 the __deallocate procedure is created. */ 14741 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 14742 && c->ts.u.derived == sym && c->attr.allocatable == 1) 14743 gfc_find_vtab (&c->ts); 14744 14745 /* Ensure that all the derived type components are put on the 14746 derived type list; even in formal namespaces, where derived type 14747 pointer components might not have been declared. */ 14748 if (c->ts.type == BT_DERIVED 14749 && c->ts.u.derived 14750 && c->ts.u.derived->components 14751 && c->attr.pointer 14752 && sym != c->ts.u.derived) 14753 add_dt_to_dt_list (c->ts.u.derived); 14754 14755 if (!gfc_resolve_array_spec (c->as, 14756 !(c->attr.pointer || c->attr.proc_pointer 14757 || c->attr.allocatable))) 14758 return false; 14759 14760 if (c->initializer && !sym->attr.vtype 14761 && !c->attr.pdt_kind && !c->attr.pdt_len 14762 && !gfc_check_assign_symbol (sym, c, c->initializer)) 14763 return false; 14764 14765 return true; 14766} 14767 14768 14769/* Be nice about the locus for a structure expression - show the locus of the 14770 first non-null sub-expression if we can. */ 14771 14772static locus * 14773cons_where (gfc_expr *struct_expr) 14774{ 14775 gfc_constructor *cons; 14776 14777 gcc_assert (struct_expr && struct_expr->expr_type == EXPR_STRUCTURE); 14778 14779 cons = gfc_constructor_first (struct_expr->value.constructor); 14780 for (; cons; cons = gfc_constructor_next (cons)) 14781 { 14782 if (cons->expr && cons->expr->expr_type != EXPR_NULL) 14783 return &cons->expr->where; 14784 } 14785 14786 return &struct_expr->where; 14787} 14788 14789/* Resolve the components of a structure type. Much less work than derived 14790 types. */ 14791 14792static bool 14793resolve_fl_struct (gfc_symbol *sym) 14794{ 14795 gfc_component *c; 14796 gfc_expr *init = NULL; 14797 bool success; 14798 14799 /* Make sure UNIONs do not have overlapping initializers. */ 14800 if (sym->attr.flavor == FL_UNION) 14801 { 14802 for (c = sym->components; c; c = c->next) 14803 { 14804 if (init && c->initializer) 14805 { 14806 gfc_error ("Conflicting initializers in union at %L and %L", 14807 cons_where (init), cons_where (c->initializer)); 14808 gfc_free_expr (c->initializer); 14809 c->initializer = NULL; 14810 } 14811 if (init == NULL) 14812 init = c->initializer; 14813 } 14814 } 14815 14816 success = true; 14817 for (c = sym->components; c; c = c->next) 14818 if (!resolve_component (c, sym)) 14819 success = false; 14820 14821 if (!success) 14822 return false; 14823 14824 if (sym->components) 14825 add_dt_to_dt_list (sym); 14826 14827 return true; 14828} 14829 14830 14831/* Resolve the components of a derived type. This does not have to wait until 14832 resolution stage, but can be done as soon as the dt declaration has been 14833 parsed. */ 14834 14835static bool 14836resolve_fl_derived0 (gfc_symbol *sym) 14837{ 14838 gfc_symbol* super_type; 14839 gfc_component *c; 14840 gfc_formal_arglist *f; 14841 bool success; 14842 14843 if (sym->attr.unlimited_polymorphic) 14844 return true; 14845 14846 super_type = gfc_get_derived_super_type (sym); 14847 14848 /* F2008, C432. */ 14849 if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) 14850 { 14851 gfc_error ("As extending type %qs at %L has a coarray component, " 14852 "parent type %qs shall also have one", sym->name, 14853 &sym->declared_at, super_type->name); 14854 return false; 14855 } 14856 14857 /* Ensure the extended type gets resolved before we do. */ 14858 if (super_type && !resolve_fl_derived0 (super_type)) 14859 return false; 14860 14861 /* An ABSTRACT type must be extensible. */ 14862 if (sym->attr.abstract && !gfc_type_is_extensible (sym)) 14863 { 14864 gfc_error ("Non-extensible derived-type %qs at %L must not be ABSTRACT", 14865 sym->name, &sym->declared_at); 14866 return false; 14867 } 14868 14869 c = (sym->attr.is_class) ? sym->components->ts.u.derived->components 14870 : sym->components; 14871 14872 success = true; 14873 for ( ; c != NULL; c = c->next) 14874 if (!resolve_component (c, sym)) 14875 success = false; 14876 14877 if (!success) 14878 return false; 14879 14880 /* Now add the caf token field, where needed. */ 14881 if (flag_coarray != GFC_FCOARRAY_NONE 14882 && !sym->attr.is_class && !sym->attr.vtype) 14883 { 14884 for (c = sym->components; c; c = c->next) 14885 if (!c->attr.dimension && !c->attr.codimension 14886 && (c->attr.allocatable || c->attr.pointer)) 14887 { 14888 char name[GFC_MAX_SYMBOL_LEN+9]; 14889 gfc_component *token; 14890 sprintf (name, "_caf_%s", c->name); 14891 token = gfc_find_component (sym, name, true, true, NULL); 14892 if (token == NULL) 14893 { 14894 if (!gfc_add_component (sym, name, &token)) 14895 return false; 14896 token->ts.type = BT_VOID; 14897 token->ts.kind = gfc_default_integer_kind; 14898 token->attr.access = ACCESS_PRIVATE; 14899 token->attr.artificial = 1; 14900 token->attr.caf_token = 1; 14901 } 14902 } 14903 } 14904 14905 check_defined_assignments (sym); 14906 14907 if (!sym->attr.defined_assign_comp && super_type) 14908 sym->attr.defined_assign_comp 14909 = super_type->attr.defined_assign_comp; 14910 14911 /* If this is a non-ABSTRACT type extending an ABSTRACT one, ensure that 14912 all DEFERRED bindings are overridden. */ 14913 if (super_type && super_type->attr.abstract && !sym->attr.abstract 14914 && !sym->attr.is_class 14915 && !ensure_not_abstract (sym, super_type)) 14916 return false; 14917 14918 /* Check that there is a component for every PDT parameter. */ 14919 if (sym->attr.pdt_template) 14920 { 14921 for (f = sym->formal; f; f = f->next) 14922 { 14923 if (!f->sym) 14924 continue; 14925 c = gfc_find_component (sym, f->sym->name, true, true, NULL); 14926 if (c == NULL) 14927 { 14928 gfc_error ("Parameterized type %qs does not have a component " 14929 "corresponding to parameter %qs at %L", sym->name, 14930 f->sym->name, &sym->declared_at); 14931 break; 14932 } 14933 } 14934 } 14935 14936 /* Add derived type to the derived type list. */ 14937 add_dt_to_dt_list (sym); 14938 14939 return true; 14940} 14941 14942 14943/* The following procedure does the full resolution of a derived type, 14944 including resolution of all type-bound procedures (if present). In contrast 14945 to 'resolve_fl_derived0' this can only be done after the module has been 14946 parsed completely. */ 14947 14948static bool 14949resolve_fl_derived (gfc_symbol *sym) 14950{ 14951 gfc_symbol *gen_dt = NULL; 14952 14953 if (sym->attr.unlimited_polymorphic) 14954 return true; 14955 14956 if (!sym->attr.is_class) 14957 gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt); 14958 if (gen_dt && gen_dt->generic && gen_dt->generic->next 14959 && (!gen_dt->generic->sym->attr.use_assoc 14960 || gen_dt->generic->sym->module != gen_dt->generic->next->sym->module) 14961 && !gfc_notify_std (GFC_STD_F2003, "Generic name %qs of function " 14962 "%qs at %L being the same name as derived " 14963 "type at %L", sym->name, 14964 gen_dt->generic->sym == sym 14965 ? gen_dt->generic->next->sym->name 14966 : gen_dt->generic->sym->name, 14967 gen_dt->generic->sym == sym 14968 ? &gen_dt->generic->next->sym->declared_at 14969 : &gen_dt->generic->sym->declared_at, 14970 &sym->declared_at)) 14971 return false; 14972 14973 if (sym->components == NULL && !sym->attr.zero_comp && !sym->attr.use_assoc) 14974 { 14975 gfc_error ("Derived type %qs at %L has not been declared", 14976 sym->name, &sym->declared_at); 14977 return false; 14978 } 14979 14980 /* Resolve the finalizer procedures. */ 14981 if (!gfc_resolve_finalizers (sym, NULL)) 14982 return false; 14983 14984 if (sym->attr.is_class && sym->ts.u.derived == NULL) 14985 { 14986 /* Fix up incomplete CLASS symbols. */ 14987 gfc_component *data = gfc_find_component (sym, "_data", true, true, NULL); 14988 gfc_component *vptr = gfc_find_component (sym, "_vptr", true, true, NULL); 14989 14990 /* Nothing more to do for unlimited polymorphic entities. */ 14991 if (data->ts.u.derived->attr.unlimited_polymorphic) 14992 return true; 14993 else if (vptr->ts.u.derived == NULL) 14994 { 14995 gfc_symbol *vtab = gfc_find_derived_vtab (data->ts.u.derived); 14996 gcc_assert (vtab); 14997 vptr->ts.u.derived = vtab->ts.u.derived; 14998 if (!resolve_fl_derived0 (vptr->ts.u.derived)) 14999 return false; 15000 } 15001 } 15002 15003 if (!resolve_fl_derived0 (sym)) 15004 return false; 15005 15006 /* Resolve the type-bound procedures. */ 15007 if (!resolve_typebound_procedures (sym)) 15008 return false; 15009 15010 /* Generate module vtables subject to their accessibility and their not 15011 being vtables or pdt templates. If this is not done class declarations 15012 in external procedures wind up with their own version and so SELECT TYPE 15013 fails because the vptrs do not have the same address. */ 15014 if (gfc_option.allow_std & GFC_STD_F2003 15015 && sym->ns->proc_name 15016 && sym->ns->proc_name->attr.flavor == FL_MODULE 15017 && sym->attr.access != ACCESS_PRIVATE 15018 && !(sym->attr.use_assoc || sym->attr.vtype || sym->attr.pdt_template)) 15019 { 15020 gfc_symbol *vtab = gfc_find_derived_vtab (sym); 15021 gfc_set_sym_referenced (vtab); 15022 } 15023 15024 return true; 15025} 15026 15027 15028static bool 15029resolve_fl_namelist (gfc_symbol *sym) 15030{ 15031 gfc_namelist *nl; 15032 gfc_symbol *nlsym; 15033 15034 for (nl = sym->namelist; nl; nl = nl->next) 15035 { 15036 /* Check again, the check in match only works if NAMELIST comes 15037 after the decl. */ 15038 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE) 15039 { 15040 gfc_error ("Assumed size array %qs in namelist %qs at %L is not " 15041 "allowed", nl->sym->name, sym->name, &sym->declared_at); 15042 return false; 15043 } 15044 15045 if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SHAPE 15046 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " 15047 "with assumed shape in namelist %qs at %L", 15048 nl->sym->name, sym->name, &sym->declared_at)) 15049 return false; 15050 15051 if (is_non_constant_shape_array (nl->sym) 15052 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST array object %qs " 15053 "with nonconstant shape in namelist %qs at %L", 15054 nl->sym->name, sym->name, &sym->declared_at)) 15055 return false; 15056 15057 if (nl->sym->ts.type == BT_CHARACTER 15058 && (nl->sym->ts.u.cl->length == NULL 15059 || !gfc_is_constant_expr (nl->sym->ts.u.cl->length)) 15060 && !gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs with " 15061 "nonconstant character length in " 15062 "namelist %qs at %L", nl->sym->name, 15063 sym->name, &sym->declared_at)) 15064 return false; 15065 15066 } 15067 15068 /* Reject PRIVATE objects in a PUBLIC namelist. */ 15069 if (gfc_check_symbol_access (sym)) 15070 { 15071 for (nl = sym->namelist; nl; nl = nl->next) 15072 { 15073 if (!nl->sym->attr.use_assoc 15074 && !is_sym_host_assoc (nl->sym, sym->ns) 15075 && !gfc_check_symbol_access (nl->sym)) 15076 { 15077 gfc_error ("NAMELIST object %qs was declared PRIVATE and " 15078 "cannot be member of PUBLIC namelist %qs at %L", 15079 nl->sym->name, sym->name, &sym->declared_at); 15080 return false; 15081 } 15082 15083 if (nl->sym->ts.type == BT_DERIVED 15084 && (nl->sym->ts.u.derived->attr.alloc_comp 15085 || nl->sym->ts.u.derived->attr.pointer_comp)) 15086 { 15087 if (!gfc_notify_std (GFC_STD_F2003, "NAMELIST object %qs in " 15088 "namelist %qs at %L with ALLOCATABLE " 15089 "or POINTER components", nl->sym->name, 15090 sym->name, &sym->declared_at)) 15091 return false; 15092 return true; 15093 } 15094 15095 /* Types with private components that came here by USE-association. */ 15096 if (nl->sym->ts.type == BT_DERIVED 15097 && derived_inaccessible (nl->sym->ts.u.derived)) 15098 { 15099 gfc_error ("NAMELIST object %qs has use-associated PRIVATE " 15100 "components and cannot be member of namelist %qs at %L", 15101 nl->sym->name, sym->name, &sym->declared_at); 15102 return false; 15103 } 15104 15105 /* Types with private components that are defined in the same module. */ 15106 if (nl->sym->ts.type == BT_DERIVED 15107 && !is_sym_host_assoc (nl->sym->ts.u.derived, sym->ns) 15108 && nl->sym->ts.u.derived->attr.private_comp) 15109 { 15110 gfc_error ("NAMELIST object %qs has PRIVATE components and " 15111 "cannot be a member of PUBLIC namelist %qs at %L", 15112 nl->sym->name, sym->name, &sym->declared_at); 15113 return false; 15114 } 15115 } 15116 } 15117 15118 15119 /* 14.1.2 A module or internal procedure represent local entities 15120 of the same type as a namelist member and so are not allowed. */ 15121 for (nl = sym->namelist; nl; nl = nl->next) 15122 { 15123 if (nl->sym->ts.kind != 0 && nl->sym->attr.flavor == FL_VARIABLE) 15124 continue; 15125 15126 if (nl->sym->attr.function && nl->sym == nl->sym->result) 15127 if ((nl->sym == sym->ns->proc_name) 15128 || 15129 (sym->ns->parent && nl->sym == sym->ns->parent->proc_name)) 15130 continue; 15131 15132 nlsym = NULL; 15133 if (nl->sym->name) 15134 gfc_find_symbol (nl->sym->name, sym->ns, 1, &nlsym); 15135 if (nlsym && nlsym->attr.flavor == FL_PROCEDURE) 15136 { 15137 gfc_error ("PROCEDURE attribute conflicts with NAMELIST " 15138 "attribute in %qs at %L", nlsym->name, 15139 &sym->declared_at); 15140 return false; 15141 } 15142 } 15143 15144 return true; 15145} 15146 15147 15148static bool 15149resolve_fl_parameter (gfc_symbol *sym) 15150{ 15151 /* A parameter array's shape needs to be constant. */ 15152 if (sym->as != NULL 15153 && (sym->as->type == AS_DEFERRED 15154 || is_non_constant_shape_array (sym))) 15155 { 15156 gfc_error ("Parameter array %qs at %L cannot be automatic " 15157 "or of deferred shape", sym->name, &sym->declared_at); 15158 return false; 15159 } 15160 15161 /* Constraints on deferred type parameter. */ 15162 if (!deferred_requirements (sym)) 15163 return false; 15164 15165 /* Make sure a parameter that has been implicitly typed still 15166 matches the implicit type, since PARAMETER statements can precede 15167 IMPLICIT statements. */ 15168 if (sym->attr.implicit_type 15169 && !gfc_compare_types (&sym->ts, gfc_get_default_type (sym->name, 15170 sym->ns))) 15171 { 15172 gfc_error ("Implicitly typed PARAMETER %qs at %L doesn't match a " 15173 "later IMPLICIT type", sym->name, &sym->declared_at); 15174 return false; 15175 } 15176 15177 /* Make sure the types of derived parameters are consistent. This 15178 type checking is deferred until resolution because the type may 15179 refer to a derived type from the host. */ 15180 if (sym->ts.type == BT_DERIVED 15181 && !gfc_compare_types (&sym->ts, &sym->value->ts)) 15182 { 15183 gfc_error ("Incompatible derived type in PARAMETER at %L", 15184 &sym->value->where); 15185 return false; 15186 } 15187 15188 /* F03:C509,C514. */ 15189 if (sym->ts.type == BT_CLASS) 15190 { 15191 gfc_error ("CLASS variable %qs at %L cannot have the PARAMETER attribute", 15192 sym->name, &sym->declared_at); 15193 return false; 15194 } 15195 15196 return true; 15197} 15198 15199 15200/* Called by resolve_symbol to check PDTs. */ 15201 15202static void 15203resolve_pdt (gfc_symbol* sym) 15204{ 15205 gfc_symbol *derived = NULL; 15206 gfc_actual_arglist *param; 15207 gfc_component *c; 15208 bool const_len_exprs = true; 15209 bool assumed_len_exprs = false; 15210 symbol_attribute *attr; 15211 15212 if (sym->ts.type == BT_DERIVED) 15213 { 15214 derived = sym->ts.u.derived; 15215 attr = &(sym->attr); 15216 } 15217 else if (sym->ts.type == BT_CLASS) 15218 { 15219 derived = CLASS_DATA (sym)->ts.u.derived; 15220 attr = &(CLASS_DATA (sym)->attr); 15221 } 15222 else 15223 gcc_unreachable (); 15224 15225 gcc_assert (derived->attr.pdt_type); 15226 15227 for (param = sym->param_list; param; param = param->next) 15228 { 15229 c = gfc_find_component (derived, param->name, false, true, NULL); 15230 gcc_assert (c); 15231 if (c->attr.pdt_kind) 15232 continue; 15233 15234 if (param->expr && !gfc_is_constant_expr (param->expr) 15235 && c->attr.pdt_len) 15236 const_len_exprs = false; 15237 else if (param->spec_type == SPEC_ASSUMED) 15238 assumed_len_exprs = true; 15239 15240 if (param->spec_type == SPEC_DEFERRED 15241 && !attr->allocatable && !attr->pointer) 15242 gfc_error ("The object %qs at %L has a deferred LEN " 15243 "parameter %qs and is neither allocatable " 15244 "nor a pointer", sym->name, &sym->declared_at, 15245 param->name); 15246 15247 } 15248 15249 if (!const_len_exprs 15250 && (sym->ns->proc_name->attr.is_main_program 15251 || sym->ns->proc_name->attr.flavor == FL_MODULE 15252 || sym->attr.save != SAVE_NONE)) 15253 gfc_error ("The AUTOMATIC object %qs at %L must not have the " 15254 "SAVE attribute or be a variable declared in the " 15255 "main program, a module or a submodule(F08/C513)", 15256 sym->name, &sym->declared_at); 15257 15258 if (assumed_len_exprs && !(sym->attr.dummy 15259 || sym->attr.select_type_temporary || sym->attr.associate_var)) 15260 gfc_error ("The object %qs at %L with ASSUMED type parameters " 15261 "must be a dummy or a SELECT TYPE selector(F08/4.2)", 15262 sym->name, &sym->declared_at); 15263} 15264 15265 15266/* Do anything necessary to resolve a symbol. Right now, we just 15267 assume that an otherwise unknown symbol is a variable. This sort 15268 of thing commonly happens for symbols in module. */ 15269 15270static void 15271resolve_symbol (gfc_symbol *sym) 15272{ 15273 int check_constant, mp_flag; 15274 gfc_symtree *symtree; 15275 gfc_symtree *this_symtree; 15276 gfc_namespace *ns; 15277 gfc_component *c; 15278 symbol_attribute class_attr; 15279 gfc_array_spec *as; 15280 bool saved_specification_expr; 15281 15282 if (sym->resolve_symbol_called >= 1) 15283 return; 15284 sym->resolve_symbol_called = 1; 15285 15286 /* No symbol will ever have union type; only components can be unions. 15287 Union type declaration symbols have type BT_UNKNOWN but flavor FL_UNION 15288 (just like derived type declaration symbols have flavor FL_DERIVED). */ 15289 gcc_assert (sym->ts.type != BT_UNION); 15290 15291 /* Coarrayed polymorphic objects with allocatable or pointer components are 15292 yet unsupported for -fcoarray=lib. */ 15293 if (flag_coarray == GFC_FCOARRAY_LIB && sym->ts.type == BT_CLASS 15294 && sym->ts.u.derived && CLASS_DATA (sym) 15295 && CLASS_DATA (sym)->attr.codimension 15296 && CLASS_DATA (sym)->ts.u.derived 15297 && (CLASS_DATA (sym)->ts.u.derived->attr.alloc_comp 15298 || CLASS_DATA (sym)->ts.u.derived->attr.pointer_comp)) 15299 { 15300 gfc_error ("Sorry, allocatable/pointer components in polymorphic (CLASS) " 15301 "type coarrays at %L are unsupported", &sym->declared_at); 15302 return; 15303 } 15304 15305 if (sym->attr.artificial) 15306 return; 15307 15308 if (sym->attr.unlimited_polymorphic) 15309 return; 15310 15311 if (sym->attr.flavor == FL_UNKNOWN 15312 || (sym->attr.flavor == FL_PROCEDURE && !sym->attr.intrinsic 15313 && !sym->attr.generic && !sym->attr.external 15314 && sym->attr.if_source == IFSRC_UNKNOWN 15315 && sym->ts.type == BT_UNKNOWN)) 15316 { 15317 15318 /* If we find that a flavorless symbol is an interface in one of the 15319 parent namespaces, find its symtree in this namespace, free the 15320 symbol and set the symtree to point to the interface symbol. */ 15321 for (ns = gfc_current_ns->parent; ns; ns = ns->parent) 15322 { 15323 symtree = gfc_find_symtree (ns->sym_root, sym->name); 15324 if (symtree && (symtree->n.sym->generic || 15325 (symtree->n.sym->attr.flavor == FL_PROCEDURE 15326 && sym->ns->construct_entities))) 15327 { 15328 this_symtree = gfc_find_symtree (gfc_current_ns->sym_root, 15329 sym->name); 15330 if (this_symtree->n.sym == sym) 15331 { 15332 symtree->n.sym->refs++; 15333 gfc_release_symbol (sym); 15334 this_symtree->n.sym = symtree->n.sym; 15335 return; 15336 } 15337 } 15338 } 15339 15340 /* Otherwise give it a flavor according to such attributes as 15341 it has. */ 15342 if (sym->attr.flavor == FL_UNKNOWN && sym->attr.external == 0 15343 && sym->attr.intrinsic == 0) 15344 sym->attr.flavor = FL_VARIABLE; 15345 else if (sym->attr.flavor == FL_UNKNOWN) 15346 { 15347 sym->attr.flavor = FL_PROCEDURE; 15348 if (sym->attr.dimension) 15349 sym->attr.function = 1; 15350 } 15351 } 15352 15353 if (sym->attr.external && sym->ts.type != BT_UNKNOWN && !sym->attr.function) 15354 gfc_add_function (&sym->attr, sym->name, &sym->declared_at); 15355 15356 if (sym->attr.procedure && sym->attr.if_source != IFSRC_DECL 15357 && !resolve_procedure_interface (sym)) 15358 return; 15359 15360 if (sym->attr.is_protected && !sym->attr.proc_pointer 15361 && (sym->attr.procedure || sym->attr.external)) 15362 { 15363 if (sym->attr.external) 15364 gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute " 15365 "at %L", &sym->declared_at); 15366 else 15367 gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute " 15368 "at %L", &sym->declared_at); 15369 15370 return; 15371 } 15372 15373 if (sym->attr.flavor == FL_DERIVED && !resolve_fl_derived (sym)) 15374 return; 15375 15376 else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION) 15377 && !resolve_fl_struct (sym)) 15378 return; 15379 15380 /* Symbols that are module procedures with results (functions) have 15381 the types and array specification copied for type checking in 15382 procedures that call them, as well as for saving to a module 15383 file. These symbols can't stand the scrutiny that their results 15384 can. */ 15385 mp_flag = (sym->result != NULL && sym->result != sym); 15386 15387 /* Make sure that the intrinsic is consistent with its internal 15388 representation. This needs to be done before assigning a default 15389 type to avoid spurious warnings. */ 15390 if (sym->attr.flavor != FL_MODULE && sym->attr.intrinsic 15391 && !gfc_resolve_intrinsic (sym, &sym->declared_at)) 15392 return; 15393 15394 /* Resolve associate names. */ 15395 if (sym->assoc) 15396 resolve_assoc_var (sym, true); 15397 15398 /* Assign default type to symbols that need one and don't have one. */ 15399 if (sym->ts.type == BT_UNKNOWN) 15400 { 15401 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER) 15402 { 15403 gfc_set_default_type (sym, 1, NULL); 15404 } 15405 15406 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.external 15407 && !sym->attr.function && !sym->attr.subroutine 15408 && gfc_get_default_type (sym->name, sym->ns)->type == BT_UNKNOWN) 15409 gfc_add_subroutine (&sym->attr, sym->name, &sym->declared_at); 15410 15411 if (sym->attr.flavor == FL_PROCEDURE && sym->attr.function) 15412 { 15413 /* The specific case of an external procedure should emit an error 15414 in the case that there is no implicit type. */ 15415 if (!mp_flag) 15416 { 15417 if (!sym->attr.mixed_entry_master) 15418 gfc_set_default_type (sym, sym->attr.external, NULL); 15419 } 15420 else 15421 { 15422 /* Result may be in another namespace. */ 15423 resolve_symbol (sym->result); 15424 15425 if (!sym->result->attr.proc_pointer) 15426 { 15427 sym->ts = sym->result->ts; 15428 sym->as = gfc_copy_array_spec (sym->result->as); 15429 sym->attr.dimension = sym->result->attr.dimension; 15430 sym->attr.pointer = sym->result->attr.pointer; 15431 sym->attr.allocatable = sym->result->attr.allocatable; 15432 sym->attr.contiguous = sym->result->attr.contiguous; 15433 } 15434 } 15435 } 15436 } 15437 else if (mp_flag && sym->attr.flavor == FL_PROCEDURE && sym->attr.function) 15438 { 15439 bool saved_specification_expr = specification_expr; 15440 specification_expr = true; 15441 gfc_resolve_array_spec (sym->result->as, false); 15442 specification_expr = saved_specification_expr; 15443 } 15444 15445 if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived) 15446 { 15447 as = CLASS_DATA (sym)->as; 15448 class_attr = CLASS_DATA (sym)->attr; 15449 class_attr.pointer = class_attr.class_pointer; 15450 } 15451 else 15452 { 15453 class_attr = sym->attr; 15454 as = sym->as; 15455 } 15456 15457 /* F2008, C530. */ 15458 if (sym->attr.contiguous 15459 && (!class_attr.dimension 15460 || (as->type != AS_ASSUMED_SHAPE && as->type != AS_ASSUMED_RANK 15461 && !class_attr.pointer))) 15462 { 15463 gfc_error ("%qs at %L has the CONTIGUOUS attribute but is not an " 15464 "array pointer or an assumed-shape or assumed-rank array", 15465 sym->name, &sym->declared_at); 15466 return; 15467 } 15468 15469 /* Assumed size arrays and assumed shape arrays must be dummy 15470 arguments. Array-spec's of implied-shape should have been resolved to 15471 AS_EXPLICIT already. */ 15472 15473 if (as) 15474 { 15475 /* If AS_IMPLIED_SHAPE makes it to here, it must be a bad 15476 specification expression. */ 15477 if (as->type == AS_IMPLIED_SHAPE) 15478 { 15479 int i; 15480 for (i=0; i<as->rank; i++) 15481 { 15482 if (as->lower[i] != NULL && as->upper[i] == NULL) 15483 { 15484 gfc_error ("Bad specification for assumed size array at %L", 15485 &as->lower[i]->where); 15486 return; 15487 } 15488 } 15489 gcc_unreachable(); 15490 } 15491 15492 if (((as->type == AS_ASSUMED_SIZE && !as->cp_was_assumed) 15493 || as->type == AS_ASSUMED_SHAPE) 15494 && !sym->attr.dummy && !sym->attr.select_type_temporary) 15495 { 15496 if (as->type == AS_ASSUMED_SIZE) 15497 gfc_error ("Assumed size array at %L must be a dummy argument", 15498 &sym->declared_at); 15499 else 15500 gfc_error ("Assumed shape array at %L must be a dummy argument", 15501 &sym->declared_at); 15502 return; 15503 } 15504 /* TS 29113, C535a. */ 15505 if (as->type == AS_ASSUMED_RANK && !sym->attr.dummy 15506 && !sym->attr.select_type_temporary 15507 && !(cs_base && cs_base->current 15508 && cs_base->current->op == EXEC_SELECT_RANK)) 15509 { 15510 gfc_error ("Assumed-rank array at %L must be a dummy argument", 15511 &sym->declared_at); 15512 return; 15513 } 15514 if (as->type == AS_ASSUMED_RANK 15515 && (sym->attr.codimension || sym->attr.value)) 15516 { 15517 gfc_error ("Assumed-rank array at %L may not have the VALUE or " 15518 "CODIMENSION attribute", &sym->declared_at); 15519 return; 15520 } 15521 } 15522 15523 /* Make sure symbols with known intent or optional are really dummy 15524 variable. Because of ENTRY statement, this has to be deferred 15525 until resolution time. */ 15526 15527 if (!sym->attr.dummy 15528 && (sym->attr.optional || sym->attr.intent != INTENT_UNKNOWN)) 15529 { 15530 gfc_error ("Symbol at %L is not a DUMMY variable", &sym->declared_at); 15531 return; 15532 } 15533 15534 if (sym->attr.value && !sym->attr.dummy) 15535 { 15536 gfc_error ("%qs at %L cannot have the VALUE attribute because " 15537 "it is not a dummy argument", sym->name, &sym->declared_at); 15538 return; 15539 } 15540 15541 if (sym->attr.value && sym->ts.type == BT_CHARACTER) 15542 { 15543 gfc_charlen *cl = sym->ts.u.cl; 15544 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT) 15545 { 15546 gfc_error ("Character dummy variable %qs at %L with VALUE " 15547 "attribute must have constant length", 15548 sym->name, &sym->declared_at); 15549 return; 15550 } 15551 15552 if (sym->ts.is_c_interop 15553 && mpz_cmp_si (cl->length->value.integer, 1) != 0) 15554 { 15555 gfc_error ("C interoperable character dummy variable %qs at %L " 15556 "with VALUE attribute must have length one", 15557 sym->name, &sym->declared_at); 15558 return; 15559 } 15560 } 15561 15562 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c 15563 && sym->ts.u.derived->attr.generic) 15564 { 15565 sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived); 15566 if (!sym->ts.u.derived) 15567 { 15568 gfc_error ("The derived type %qs at %L is of type %qs, " 15569 "which has not been defined", sym->name, 15570 &sym->declared_at, sym->ts.u.derived->name); 15571 sym->ts.type = BT_UNKNOWN; 15572 return; 15573 } 15574 } 15575 15576 /* Use the same constraints as TYPE(*), except for the type check 15577 and that only scalars and assumed-size arrays are permitted. */ 15578 if (sym->attr.ext_attr & (1 << EXT_ATTR_NO_ARG_CHECK)) 15579 { 15580 if (!sym->attr.dummy) 15581 { 15582 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " 15583 "a dummy argument", sym->name, &sym->declared_at); 15584 return; 15585 } 15586 15587 if (sym->ts.type != BT_ASSUMED && sym->ts.type != BT_INTEGER 15588 && sym->ts.type != BT_REAL && sym->ts.type != BT_LOGICAL 15589 && sym->ts.type != BT_COMPLEX) 15590 { 15591 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall be " 15592 "of type TYPE(*) or of an numeric intrinsic type", 15593 sym->name, &sym->declared_at); 15594 return; 15595 } 15596 15597 if (sym->attr.allocatable || sym->attr.codimension 15598 || sym->attr.pointer || sym->attr.value) 15599 { 15600 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " 15601 "have the ALLOCATABLE, CODIMENSION, POINTER or VALUE " 15602 "attribute", sym->name, &sym->declared_at); 15603 return; 15604 } 15605 15606 if (sym->attr.intent == INTENT_OUT) 15607 { 15608 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute may not " 15609 "have the INTENT(OUT) attribute", 15610 sym->name, &sym->declared_at); 15611 return; 15612 } 15613 if (sym->attr.dimension && sym->as->type != AS_ASSUMED_SIZE) 15614 { 15615 gfc_error ("Variable %s at %L with NO_ARG_CHECK attribute shall " 15616 "either be a scalar or an assumed-size array", 15617 sym->name, &sym->declared_at); 15618 return; 15619 } 15620 15621 /* Set the type to TYPE(*) and add a dimension(*) to ensure 15622 NO_ARG_CHECK is correctly handled in trans*.c, e.g. with 15623 packing. */ 15624 sym->ts.type = BT_ASSUMED; 15625 sym->as = gfc_get_array_spec (); 15626 sym->as->type = AS_ASSUMED_SIZE; 15627 sym->as->rank = 1; 15628 sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 15629 } 15630 else if (sym->ts.type == BT_ASSUMED) 15631 { 15632 /* TS 29113, C407a. */ 15633 if (!sym->attr.dummy) 15634 { 15635 gfc_error ("Assumed type of variable %s at %L is only permitted " 15636 "for dummy variables", sym->name, &sym->declared_at); 15637 return; 15638 } 15639 if (sym->attr.allocatable || sym->attr.codimension 15640 || sym->attr.pointer || sym->attr.value) 15641 { 15642 gfc_error ("Assumed-type variable %s at %L may not have the " 15643 "ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute", 15644 sym->name, &sym->declared_at); 15645 return; 15646 } 15647 if (sym->attr.intent == INTENT_OUT) 15648 { 15649 gfc_error ("Assumed-type variable %s at %L may not have the " 15650 "INTENT(OUT) attribute", 15651 sym->name, &sym->declared_at); 15652 return; 15653 } 15654 if (sym->attr.dimension && sym->as->type == AS_EXPLICIT) 15655 { 15656 gfc_error ("Assumed-type variable %s at %L shall not be an " 15657 "explicit-shape array", sym->name, &sym->declared_at); 15658 return; 15659 } 15660 } 15661 15662 /* If the symbol is marked as bind(c), that it is declared at module level 15663 scope and verify its type and kind. Do not do the latter for symbols 15664 that are implicitly typed because that is handled in 15665 gfc_set_default_type. Handle dummy arguments and procedure definitions 15666 separately. Also, anything that is use associated is not handled here 15667 but instead is handled in the module it is declared in. Finally, derived 15668 type definitions are allowed to be BIND(C) since that only implies that 15669 they're interoperable, and they are checked fully for interoperability 15670 when a variable is declared of that type. */ 15671 if (sym->attr.is_bind_c && sym->attr.use_assoc == 0 15672 && sym->attr.dummy == 0 && sym->attr.flavor != FL_PROCEDURE 15673 && sym->attr.flavor != FL_DERIVED) 15674 { 15675 bool t = true; 15676 15677 /* First, make sure the variable is declared at the 15678 module-level scope (J3/04-007, Section 15.3). */ 15679 if (!(sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE) 15680 && !sym->attr.in_common) 15681 { 15682 gfc_error ("Variable %qs at %L cannot be BIND(C) because it " 15683 "is neither a COMMON block nor declared at the " 15684 "module level scope", sym->name, &(sym->declared_at)); 15685 t = false; 15686 } 15687 else if (sym->ts.type == BT_CHARACTER 15688 && (sym->ts.u.cl == NULL || sym->ts.u.cl->length == NULL 15689 || !gfc_is_constant_expr (sym->ts.u.cl->length) 15690 || mpz_cmp_si (sym->ts.u.cl->length->value.integer, 1) != 0)) 15691 { 15692 gfc_error ("BIND(C) Variable %qs at %L must have length one", 15693 sym->name, &sym->declared_at); 15694 t = false; 15695 } 15696 else if (sym->common_head != NULL && sym->attr.implicit_type == 0) 15697 { 15698 t = verify_com_block_vars_c_interop (sym->common_head); 15699 } 15700 else if (sym->attr.implicit_type == 0) 15701 { 15702 /* If type() declaration, we need to verify that the components 15703 of the given type are all C interoperable, etc. */ 15704 if (sym->ts.type == BT_DERIVED && 15705 sym->ts.u.derived->attr.is_c_interop != 1) 15706 { 15707 /* Make sure the user marked the derived type as BIND(C). If 15708 not, call the verify routine. This could print an error 15709 for the derived type more than once if multiple variables 15710 of that type are declared. */ 15711 if (sym->ts.u.derived->attr.is_bind_c != 1) 15712 verify_bind_c_derived_type (sym->ts.u.derived); 15713 t = false; 15714 } 15715 15716 /* Verify the variable itself as C interoperable if it 15717 is BIND(C). It is not possible for this to succeed if 15718 the verify_bind_c_derived_type failed, so don't have to handle 15719 any error returned by verify_bind_c_derived_type. */ 15720 t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 15721 sym->common_block); 15722 } 15723 15724 if (!t) 15725 { 15726 /* clear the is_bind_c flag to prevent reporting errors more than 15727 once if something failed. */ 15728 sym->attr.is_bind_c = 0; 15729 return; 15730 } 15731 } 15732 15733 /* If a derived type symbol has reached this point, without its 15734 type being declared, we have an error. Notice that most 15735 conditions that produce undefined derived types have already 15736 been dealt with. However, the likes of: 15737 implicit type(t) (t) ..... call foo (t) will get us here if 15738 the type is not declared in the scope of the implicit 15739 statement. Change the type to BT_UNKNOWN, both because it is so 15740 and to prevent an ICE. */ 15741 if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c 15742 && sym->ts.u.derived->components == NULL 15743 && !sym->ts.u.derived->attr.zero_comp) 15744 { 15745 gfc_error ("The derived type %qs at %L is of type %qs, " 15746 "which has not been defined", sym->name, 15747 &sym->declared_at, sym->ts.u.derived->name); 15748 sym->ts.type = BT_UNKNOWN; 15749 return; 15750 } 15751 15752 /* Make sure that the derived type has been resolved and that the 15753 derived type is visible in the symbol's namespace, if it is a 15754 module function and is not PRIVATE. */ 15755 if (sym->ts.type == BT_DERIVED 15756 && sym->ts.u.derived->attr.use_assoc 15757 && sym->ns->proc_name 15758 && sym->ns->proc_name->attr.flavor == FL_MODULE 15759 && !resolve_fl_derived (sym->ts.u.derived)) 15760 return; 15761 15762 /* Unless the derived-type declaration is use associated, Fortran 95 15763 does not allow public entries of private derived types. 15764 See 4.4.1 (F95) and 4.5.1.1 (F2003); and related interpretation 15765 161 in 95-006r3. */ 15766 if (sym->ts.type == BT_DERIVED 15767 && sym->ns->proc_name && sym->ns->proc_name->attr.flavor == FL_MODULE 15768 && !sym->ts.u.derived->attr.use_assoc 15769 && gfc_check_symbol_access (sym) 15770 && !gfc_check_symbol_access (sym->ts.u.derived) 15771 && !gfc_notify_std (GFC_STD_F2003, "PUBLIC %s %qs at %L of PRIVATE " 15772 "derived type %qs", 15773 (sym->attr.flavor == FL_PARAMETER) 15774 ? "parameter" : "variable", 15775 sym->name, &sym->declared_at, 15776 sym->ts.u.derived->name)) 15777 return; 15778 15779 /* F2008, C1302. */ 15780 if (sym->ts.type == BT_DERIVED 15781 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 15782 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE) 15783 || sym->ts.u.derived->attr.lock_comp) 15784 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) 15785 { 15786 gfc_error ("Variable %s at %L of type LOCK_TYPE or with subcomponent of " 15787 "type LOCK_TYPE must be a coarray", sym->name, 15788 &sym->declared_at); 15789 return; 15790 } 15791 15792 /* TS18508, C702/C703. */ 15793 if (sym->ts.type == BT_DERIVED 15794 && ((sym->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV 15795 && sym->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE) 15796 || sym->ts.u.derived->attr.event_comp) 15797 && !sym->attr.codimension && !sym->ts.u.derived->attr.coarray_comp) 15798 { 15799 gfc_error ("Variable %s at %L of type EVENT_TYPE or with subcomponent of " 15800 "type EVENT_TYPE must be a coarray", sym->name, 15801 &sym->declared_at); 15802 return; 15803 } 15804 15805 /* An assumed-size array with INTENT(OUT) shall not be of a type for which 15806 default initialization is defined (5.1.2.4.4). */ 15807 if (sym->ts.type == BT_DERIVED 15808 && sym->attr.dummy 15809 && sym->attr.intent == INTENT_OUT 15810 && sym->as 15811 && sym->as->type == AS_ASSUMED_SIZE) 15812 { 15813 for (c = sym->ts.u.derived->components; c; c = c->next) 15814 { 15815 if (c->initializer) 15816 { 15817 gfc_error ("The INTENT(OUT) dummy argument %qs at %L is " 15818 "ASSUMED SIZE and so cannot have a default initializer", 15819 sym->name, &sym->declared_at); 15820 return; 15821 } 15822 } 15823 } 15824 15825 /* F2008, C542. */ 15826 if (sym->ts.type == BT_DERIVED && sym->attr.dummy 15827 && sym->attr.intent == INTENT_OUT && sym->attr.lock_comp) 15828 { 15829 gfc_error ("Dummy argument %qs at %L of LOCK_TYPE shall not be " 15830 "INTENT(OUT)", sym->name, &sym->declared_at); 15831 return; 15832 } 15833 15834 /* TS18508. */ 15835 if (sym->ts.type == BT_DERIVED && sym->attr.dummy 15836 && sym->attr.intent == INTENT_OUT && sym->attr.event_comp) 15837 { 15838 gfc_error ("Dummy argument %qs at %L of EVENT_TYPE shall not be " 15839 "INTENT(OUT)", sym->name, &sym->declared_at); 15840 return; 15841 } 15842 15843 /* F2008, C525. */ 15844 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) 15845 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 15846 && sym->ts.u.derived && CLASS_DATA (sym) 15847 && CLASS_DATA (sym)->attr.coarray_comp)) 15848 || class_attr.codimension) 15849 && (sym->attr.result || sym->result == sym)) 15850 { 15851 gfc_error ("Function result %qs at %L shall not be a coarray or have " 15852 "a coarray component", sym->name, &sym->declared_at); 15853 return; 15854 } 15855 15856 /* F2008, C524. */ 15857 if (sym->attr.codimension && sym->ts.type == BT_DERIVED 15858 && sym->ts.u.derived->ts.is_iso_c) 15859 { 15860 gfc_error ("Variable %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " 15861 "shall not be a coarray", sym->name, &sym->declared_at); 15862 return; 15863 } 15864 15865 /* F2008, C525. */ 15866 if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) 15867 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 15868 && sym->ts.u.derived && CLASS_DATA (sym) 15869 && CLASS_DATA (sym)->attr.coarray_comp)) 15870 && (class_attr.codimension || class_attr.pointer || class_attr.dimension 15871 || class_attr.allocatable)) 15872 { 15873 gfc_error ("Variable %qs at %L with coarray component shall be a " 15874 "nonpointer, nonallocatable scalar, which is not a coarray", 15875 sym->name, &sym->declared_at); 15876 return; 15877 } 15878 15879 /* F2008, C526. The function-result case was handled above. */ 15880 if (class_attr.codimension 15881 && !(class_attr.allocatable || sym->attr.dummy || sym->attr.save 15882 || sym->attr.select_type_temporary 15883 || sym->attr.associate_var 15884 || (sym->ns->save_all && !sym->attr.automatic) 15885 || sym->ns->proc_name->attr.flavor == FL_MODULE 15886 || sym->ns->proc_name->attr.is_main_program 15887 || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) 15888 { 15889 gfc_error ("Variable %qs at %L is a coarray and is not ALLOCATABLE, SAVE " 15890 "nor a dummy argument", sym->name, &sym->declared_at); 15891 return; 15892 } 15893 /* F2008, C528. */ 15894 else if (class_attr.codimension && !sym->attr.select_type_temporary 15895 && !class_attr.allocatable && as && as->cotype == AS_DEFERRED) 15896 { 15897 gfc_error ("Coarray variable %qs at %L shall not have codimensions with " 15898 "deferred shape", sym->name, &sym->declared_at); 15899 return; 15900 } 15901 else if (class_attr.codimension && class_attr.allocatable && as 15902 && (as->cotype != AS_DEFERRED || as->type != AS_DEFERRED)) 15903 { 15904 gfc_error ("Allocatable coarray variable %qs at %L must have " 15905 "deferred shape", sym->name, &sym->declared_at); 15906 return; 15907 } 15908 15909 /* F2008, C541. */ 15910 if ((((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) 15911 || (sym->ts.type == BT_CLASS && sym->attr.class_ok 15912 && sym->ts.u.derived && CLASS_DATA (sym) 15913 && CLASS_DATA (sym)->attr.coarray_comp)) 15914 || (class_attr.codimension && class_attr.allocatable)) 15915 && sym->attr.dummy && sym->attr.intent == INTENT_OUT) 15916 { 15917 gfc_error ("Variable %qs at %L is INTENT(OUT) and can thus not be an " 15918 "allocatable coarray or have coarray components", 15919 sym->name, &sym->declared_at); 15920 return; 15921 } 15922 15923 if (class_attr.codimension && sym->attr.dummy 15924 && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) 15925 { 15926 gfc_error ("Coarray dummy variable %qs at %L not allowed in BIND(C) " 15927 "procedure %qs", sym->name, &sym->declared_at, 15928 sym->ns->proc_name->name); 15929 return; 15930 } 15931 15932 if (sym->ts.type == BT_LOGICAL 15933 && ((sym->attr.function && sym->attr.is_bind_c && sym->result == sym) 15934 || ((sym->attr.dummy || sym->attr.result) && sym->ns->proc_name 15935 && sym->ns->proc_name->attr.is_bind_c))) 15936 { 15937 int i; 15938 for (i = 0; gfc_logical_kinds[i].kind; i++) 15939 if (gfc_logical_kinds[i].kind == sym->ts.kind) 15940 break; 15941 if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy 15942 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at " 15943 "%L with non-C_Bool kind in BIND(C) procedure " 15944 "%qs", sym->name, &sym->declared_at, 15945 sym->ns->proc_name->name)) 15946 return; 15947 else if (!gfc_logical_kinds[i].c_bool 15948 && !gfc_notify_std (GFC_STD_GNU, "LOGICAL result variable " 15949 "%qs at %L with non-C_Bool kind in " 15950 "BIND(C) procedure %qs", sym->name, 15951 &sym->declared_at, 15952 sym->attr.function ? sym->name 15953 : sym->ns->proc_name->name)) 15954 return; 15955 } 15956 15957 switch (sym->attr.flavor) 15958 { 15959 case FL_VARIABLE: 15960 if (!resolve_fl_variable (sym, mp_flag)) 15961 return; 15962 break; 15963 15964 case FL_PROCEDURE: 15965 if (sym->formal && !sym->formal_ns) 15966 { 15967 /* Check that none of the arguments are a namelist. */ 15968 gfc_formal_arglist *formal = sym->formal; 15969 15970 for (; formal; formal = formal->next) 15971 if (formal->sym && formal->sym->attr.flavor == FL_NAMELIST) 15972 { 15973 gfc_error ("Namelist %qs cannot be an argument to " 15974 "subroutine or function at %L", 15975 formal->sym->name, &sym->declared_at); 15976 return; 15977 } 15978 } 15979 15980 if (!resolve_fl_procedure (sym, mp_flag)) 15981 return; 15982 break; 15983 15984 case FL_NAMELIST: 15985 if (!resolve_fl_namelist (sym)) 15986 return; 15987 break; 15988 15989 case FL_PARAMETER: 15990 if (!resolve_fl_parameter (sym)) 15991 return; 15992 break; 15993 15994 default: 15995 break; 15996 } 15997 15998 /* Resolve array specifier. Check as well some constraints 15999 on COMMON blocks. */ 16000 16001 check_constant = sym->attr.in_common && !sym->attr.pointer; 16002 16003 /* Set the formal_arg_flag so that check_conflict will not throw 16004 an error for host associated variables in the specification 16005 expression for an array_valued function. */ 16006 if ((sym->attr.function || sym->attr.result) && sym->as) 16007 formal_arg_flag = true; 16008 16009 saved_specification_expr = specification_expr; 16010 specification_expr = true; 16011 gfc_resolve_array_spec (sym->as, check_constant); 16012 specification_expr = saved_specification_expr; 16013 16014 formal_arg_flag = false; 16015 16016 /* Resolve formal namespaces. */ 16017 if (sym->formal_ns && sym->formal_ns != gfc_current_ns 16018 && !sym->attr.contained && !sym->attr.intrinsic) 16019 gfc_resolve (sym->formal_ns); 16020 16021 /* Make sure the formal namespace is present. */ 16022 if (sym->formal && !sym->formal_ns) 16023 { 16024 gfc_formal_arglist *formal = sym->formal; 16025 while (formal && !formal->sym) 16026 formal = formal->next; 16027 16028 if (formal) 16029 { 16030 sym->formal_ns = formal->sym->ns; 16031 if (sym->formal_ns && sym->ns != formal->sym->ns) 16032 sym->formal_ns->refs++; 16033 } 16034 } 16035 16036 /* Check threadprivate restrictions. */ 16037 if (sym->attr.threadprivate && !sym->attr.save 16038 && !(sym->ns->save_all && !sym->attr.automatic) 16039 && (!sym->attr.in_common 16040 && sym->module == NULL 16041 && (sym->ns->proc_name == NULL 16042 || sym->ns->proc_name->attr.flavor != FL_MODULE))) 16043 gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at); 16044 16045 /* Check omp declare target restrictions. */ 16046 if (sym->attr.omp_declare_target 16047 && sym->attr.flavor == FL_VARIABLE 16048 && !sym->attr.save 16049 && !(sym->ns->save_all && !sym->attr.automatic) 16050 && (!sym->attr.in_common 16051 && sym->module == NULL 16052 && (sym->ns->proc_name == NULL 16053 || sym->ns->proc_name->attr.flavor != FL_MODULE))) 16054 gfc_error ("!$OMP DECLARE TARGET variable %qs at %L isn't SAVEd", 16055 sym->name, &sym->declared_at); 16056 16057 /* If we have come this far we can apply default-initializers, as 16058 described in 14.7.5, to those variables that have not already 16059 been assigned one. */ 16060 if (sym->ts.type == BT_DERIVED 16061 && !sym->value 16062 && !sym->attr.allocatable 16063 && !sym->attr.alloc_comp) 16064 { 16065 symbol_attribute *a = &sym->attr; 16066 16067 if ((!a->save && !a->dummy && !a->pointer 16068 && !a->in_common && !a->use_assoc 16069 && a->referenced 16070 && !((a->function || a->result) 16071 && (!a->dimension 16072 || sym->ts.u.derived->attr.alloc_comp 16073 || sym->ts.u.derived->attr.pointer_comp)) 16074 && !(a->function && sym != sym->result)) 16075 || (a->dummy && a->intent == INTENT_OUT && !a->pointer)) 16076 apply_default_init (sym); 16077 else if (a->function && sym->result && a->access != ACCESS_PRIVATE 16078 && (sym->ts.u.derived->attr.alloc_comp 16079 || sym->ts.u.derived->attr.pointer_comp)) 16080 /* Mark the result symbol to be referenced, when it has allocatable 16081 components. */ 16082 sym->result->attr.referenced = 1; 16083 } 16084 16085 if (sym->ts.type == BT_CLASS && sym->ns == gfc_current_ns 16086 && sym->attr.dummy && sym->attr.intent == INTENT_OUT 16087 && !CLASS_DATA (sym)->attr.class_pointer 16088 && !CLASS_DATA (sym)->attr.allocatable) 16089 apply_default_init (sym); 16090 16091 /* If this symbol has a type-spec, check it. */ 16092 if (sym->attr.flavor == FL_VARIABLE || sym->attr.flavor == FL_PARAMETER 16093 || (sym->attr.flavor == FL_PROCEDURE && sym->attr.function)) 16094 if (!resolve_typespec_used (&sym->ts, &sym->declared_at, sym->name)) 16095 return; 16096 16097 if (sym->param_list) 16098 resolve_pdt (sym); 16099} 16100 16101 16102/************* Resolve DATA statements *************/ 16103 16104static struct 16105{ 16106 gfc_data_value *vnode; 16107 mpz_t left; 16108} 16109values; 16110 16111 16112/* Advance the values structure to point to the next value in the data list. */ 16113 16114static bool 16115next_data_value (void) 16116{ 16117 while (mpz_cmp_ui (values.left, 0) == 0) 16118 { 16119 16120 if (values.vnode->next == NULL) 16121 return false; 16122 16123 values.vnode = values.vnode->next; 16124 mpz_set (values.left, values.vnode->repeat); 16125 } 16126 16127 return true; 16128} 16129 16130 16131static bool 16132check_data_variable (gfc_data_variable *var, locus *where) 16133{ 16134 gfc_expr *e; 16135 mpz_t size; 16136 mpz_t offset; 16137 bool t; 16138 ar_type mark = AR_UNKNOWN; 16139 int i; 16140 mpz_t section_index[GFC_MAX_DIMENSIONS]; 16141 gfc_ref *ref; 16142 gfc_array_ref *ar; 16143 gfc_symbol *sym; 16144 int has_pointer; 16145 16146 if (!gfc_resolve_expr (var->expr)) 16147 return false; 16148 16149 ar = NULL; 16150 mpz_init_set_si (offset, 0); 16151 e = var->expr; 16152 16153 if (e->expr_type == EXPR_FUNCTION && e->value.function.isym 16154 && e->value.function.isym->id == GFC_ISYM_CAF_GET) 16155 e = e->value.function.actual->expr; 16156 16157 if (e->expr_type != EXPR_VARIABLE) 16158 { 16159 gfc_error ("Expecting definable entity near %L", where); 16160 return false; 16161 } 16162 16163 sym = e->symtree->n.sym; 16164 16165 if (sym->ns->is_block_data && !sym->attr.in_common) 16166 { 16167 gfc_error ("BLOCK DATA element %qs at %L must be in COMMON", 16168 sym->name, &sym->declared_at); 16169 return false; 16170 } 16171 16172 if (e->ref == NULL && sym->as) 16173 { 16174 gfc_error ("DATA array %qs at %L must be specified in a previous" 16175 " declaration", sym->name, where); 16176 return false; 16177 } 16178 16179 if (gfc_is_coindexed (e)) 16180 { 16181 gfc_error ("DATA element %qs at %L cannot have a coindex", sym->name, 16182 where); 16183 return false; 16184 } 16185 16186 has_pointer = sym->attr.pointer; 16187 16188 for (ref = e->ref; ref; ref = ref->next) 16189 { 16190 if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) 16191 has_pointer = 1; 16192 16193 if (has_pointer) 16194 { 16195 if (ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) 16196 { 16197 gfc_error ("DATA element %qs at %L is a pointer and so must " 16198 "be a full array", sym->name, where); 16199 return false; 16200 } 16201 16202 if (values.vnode->expr->expr_type == EXPR_CONSTANT) 16203 { 16204 gfc_error ("DATA object near %L has the pointer attribute " 16205 "and the corresponding DATA value is not a valid " 16206 "initial-data-target", where); 16207 return false; 16208 } 16209 } 16210 } 16211 16212 if (e->rank == 0 || has_pointer) 16213 { 16214 mpz_init_set_ui (size, 1); 16215 ref = NULL; 16216 } 16217 else 16218 { 16219 ref = e->ref; 16220 16221 /* Find the array section reference. */ 16222 for (ref = e->ref; ref; ref = ref->next) 16223 { 16224 if (ref->type != REF_ARRAY) 16225 continue; 16226 if (ref->u.ar.type == AR_ELEMENT) 16227 continue; 16228 break; 16229 } 16230 gcc_assert (ref); 16231 16232 /* Set marks according to the reference pattern. */ 16233 switch (ref->u.ar.type) 16234 { 16235 case AR_FULL: 16236 mark = AR_FULL; 16237 break; 16238 16239 case AR_SECTION: 16240 ar = &ref->u.ar; 16241 /* Get the start position of array section. */ 16242 gfc_get_section_index (ar, section_index, &offset); 16243 mark = AR_SECTION; 16244 break; 16245 16246 default: 16247 gcc_unreachable (); 16248 } 16249 16250 if (!gfc_array_size (e, &size)) 16251 { 16252 gfc_error ("Nonconstant array section at %L in DATA statement", 16253 where); 16254 mpz_clear (offset); 16255 return false; 16256 } 16257 } 16258 16259 t = true; 16260 16261 while (mpz_cmp_ui (size, 0) > 0) 16262 { 16263 if (!next_data_value ()) 16264 { 16265 gfc_error ("DATA statement at %L has more variables than values", 16266 where); 16267 t = false; 16268 break; 16269 } 16270 16271 t = gfc_check_assign (var->expr, values.vnode->expr, 0); 16272 if (!t) 16273 break; 16274 16275 /* If we have more than one element left in the repeat count, 16276 and we have more than one element left in the target variable, 16277 then create a range assignment. */ 16278 /* FIXME: Only done for full arrays for now, since array sections 16279 seem tricky. */ 16280 if (mark == AR_FULL && ref && ref->next == NULL 16281 && mpz_cmp_ui (values.left, 1) > 0 && mpz_cmp_ui (size, 1) > 0) 16282 { 16283 mpz_t range; 16284 16285 if (mpz_cmp (size, values.left) >= 0) 16286 { 16287 mpz_init_set (range, values.left); 16288 mpz_sub (size, size, values.left); 16289 mpz_set_ui (values.left, 0); 16290 } 16291 else 16292 { 16293 mpz_init_set (range, size); 16294 mpz_sub (values.left, values.left, size); 16295 mpz_set_ui (size, 0); 16296 } 16297 16298 t = gfc_assign_data_value (var->expr, values.vnode->expr, 16299 offset, &range); 16300 16301 mpz_add (offset, offset, range); 16302 mpz_clear (range); 16303 16304 if (!t) 16305 break; 16306 } 16307 16308 /* Assign initial value to symbol. */ 16309 else 16310 { 16311 mpz_sub_ui (values.left, values.left, 1); 16312 mpz_sub_ui (size, size, 1); 16313 16314 t = gfc_assign_data_value (var->expr, values.vnode->expr, 16315 offset, NULL); 16316 if (!t) 16317 break; 16318 16319 if (mark == AR_FULL) 16320 mpz_add_ui (offset, offset, 1); 16321 16322 /* Modify the array section indexes and recalculate the offset 16323 for next element. */ 16324 else if (mark == AR_SECTION) 16325 gfc_advance_section (section_index, ar, &offset); 16326 } 16327 } 16328 16329 if (mark == AR_SECTION) 16330 { 16331 for (i = 0; i < ar->dimen; i++) 16332 mpz_clear (section_index[i]); 16333 } 16334 16335 mpz_clear (size); 16336 mpz_clear (offset); 16337 16338 return t; 16339} 16340 16341 16342static bool traverse_data_var (gfc_data_variable *, locus *); 16343 16344/* Iterate over a list of elements in a DATA statement. */ 16345 16346static bool 16347traverse_data_list (gfc_data_variable *var, locus *where) 16348{ 16349 mpz_t trip; 16350 iterator_stack frame; 16351 gfc_expr *e, *start, *end, *step; 16352 bool retval = true; 16353 16354 mpz_init (frame.value); 16355 mpz_init (trip); 16356 16357 start = gfc_copy_expr (var->iter.start); 16358 end = gfc_copy_expr (var->iter.end); 16359 step = gfc_copy_expr (var->iter.step); 16360 16361 if (!gfc_simplify_expr (start, 1) 16362 || start->expr_type != EXPR_CONSTANT) 16363 { 16364 gfc_error ("start of implied-do loop at %L could not be " 16365 "simplified to a constant value", &start->where); 16366 retval = false; 16367 goto cleanup; 16368 } 16369 if (!gfc_simplify_expr (end, 1) 16370 || end->expr_type != EXPR_CONSTANT) 16371 { 16372 gfc_error ("end of implied-do loop at %L could not be " 16373 "simplified to a constant value", &end->where); 16374 retval = false; 16375 goto cleanup; 16376 } 16377 if (!gfc_simplify_expr (step, 1) 16378 || step->expr_type != EXPR_CONSTANT) 16379 { 16380 gfc_error ("step of implied-do loop at %L could not be " 16381 "simplified to a constant value", &step->where); 16382 retval = false; 16383 goto cleanup; 16384 } 16385 if (mpz_cmp_si (step->value.integer, 0) == 0) 16386 { 16387 gfc_error ("step of implied-do loop at %L shall not be zero", 16388 &step->where); 16389 retval = false; 16390 goto cleanup; 16391 } 16392 16393 mpz_set (trip, end->value.integer); 16394 mpz_sub (trip, trip, start->value.integer); 16395 mpz_add (trip, trip, step->value.integer); 16396 16397 mpz_div (trip, trip, step->value.integer); 16398 16399 mpz_set (frame.value, start->value.integer); 16400 16401 frame.prev = iter_stack; 16402 frame.variable = var->iter.var->symtree; 16403 iter_stack = &frame; 16404 16405 while (mpz_cmp_ui (trip, 0) > 0) 16406 { 16407 if (!traverse_data_var (var->list, where)) 16408 { 16409 retval = false; 16410 goto cleanup; 16411 } 16412 16413 e = gfc_copy_expr (var->expr); 16414 if (!gfc_simplify_expr (e, 1)) 16415 { 16416 gfc_free_expr (e); 16417 retval = false; 16418 goto cleanup; 16419 } 16420 16421 mpz_add (frame.value, frame.value, step->value.integer); 16422 16423 mpz_sub_ui (trip, trip, 1); 16424 } 16425 16426cleanup: 16427 mpz_clear (frame.value); 16428 mpz_clear (trip); 16429 16430 gfc_free_expr (start); 16431 gfc_free_expr (end); 16432 gfc_free_expr (step); 16433 16434 iter_stack = frame.prev; 16435 return retval; 16436} 16437 16438 16439/* Type resolve variables in the variable list of a DATA statement. */ 16440 16441static bool 16442traverse_data_var (gfc_data_variable *var, locus *where) 16443{ 16444 bool t; 16445 16446 for (; var; var = var->next) 16447 { 16448 if (var->expr == NULL) 16449 t = traverse_data_list (var, where); 16450 else 16451 t = check_data_variable (var, where); 16452 16453 if (!t) 16454 return false; 16455 } 16456 16457 return true; 16458} 16459 16460 16461/* Resolve the expressions and iterators associated with a data statement. 16462 This is separate from the assignment checking because data lists should 16463 only be resolved once. */ 16464 16465static bool 16466resolve_data_variables (gfc_data_variable *d) 16467{ 16468 for (; d; d = d->next) 16469 { 16470 if (d->list == NULL) 16471 { 16472 if (!gfc_resolve_expr (d->expr)) 16473 return false; 16474 } 16475 else 16476 { 16477 if (!gfc_resolve_iterator (&d->iter, false, true)) 16478 return false; 16479 16480 if (!resolve_data_variables (d->list)) 16481 return false; 16482 } 16483 } 16484 16485 return true; 16486} 16487 16488 16489/* Resolve a single DATA statement. We implement this by storing a pointer to 16490 the value list into static variables, and then recursively traversing the 16491 variables list, expanding iterators and such. */ 16492 16493static void 16494resolve_data (gfc_data *d) 16495{ 16496 16497 if (!resolve_data_variables (d->var)) 16498 return; 16499 16500 values.vnode = d->value; 16501 if (d->value == NULL) 16502 mpz_set_ui (values.left, 0); 16503 else 16504 mpz_set (values.left, d->value->repeat); 16505 16506 if (!traverse_data_var (d->var, &d->where)) 16507 return; 16508 16509 /* At this point, we better not have any values left. */ 16510 16511 if (next_data_value ()) 16512 gfc_error ("DATA statement at %L has more values than variables", 16513 &d->where); 16514} 16515 16516 16517/* 12.6 Constraint: In a pure subprogram any variable which is in common or 16518 accessed by host or use association, is a dummy argument to a pure function, 16519 is a dummy argument with INTENT (IN) to a pure subroutine, or an object that 16520 is storage associated with any such variable, shall not be used in the 16521 following contexts: (clients of this function). */ 16522 16523/* Determines if a variable is not 'pure', i.e., not assignable within a pure 16524 procedure. Returns zero if assignment is OK, nonzero if there is a 16525 problem. */ 16526int 16527gfc_impure_variable (gfc_symbol *sym) 16528{ 16529 gfc_symbol *proc; 16530 gfc_namespace *ns; 16531 16532 if (sym->attr.use_assoc || sym->attr.in_common) 16533 return 1; 16534 16535 /* Check if the symbol's ns is inside the pure procedure. */ 16536 for (ns = gfc_current_ns; ns; ns = ns->parent) 16537 { 16538 if (ns == sym->ns) 16539 break; 16540 if (ns->proc_name->attr.flavor == FL_PROCEDURE && !sym->attr.function) 16541 return 1; 16542 } 16543 16544 proc = sym->ns->proc_name; 16545 if (sym->attr.dummy 16546 && !sym->attr.value 16547 && ((proc->attr.subroutine && sym->attr.intent == INTENT_IN) 16548 || proc->attr.function)) 16549 return 1; 16550 16551 /* TODO: Sort out what can be storage associated, if anything, and include 16552 it here. In principle equivalences should be scanned but it does not 16553 seem to be possible to storage associate an impure variable this way. */ 16554 return 0; 16555} 16556 16557 16558/* Test whether a symbol is pure or not. For a NULL pointer, checks if the 16559 current namespace is inside a pure procedure. */ 16560 16561int 16562gfc_pure (gfc_symbol *sym) 16563{ 16564 symbol_attribute attr; 16565 gfc_namespace *ns; 16566 16567 if (sym == NULL) 16568 { 16569 /* Check if the current namespace or one of its parents 16570 belongs to a pure procedure. */ 16571 for (ns = gfc_current_ns; ns; ns = ns->parent) 16572 { 16573 sym = ns->proc_name; 16574 if (sym == NULL) 16575 return 0; 16576 attr = sym->attr; 16577 if (attr.flavor == FL_PROCEDURE && attr.pure) 16578 return 1; 16579 } 16580 return 0; 16581 } 16582 16583 attr = sym->attr; 16584 16585 return attr.flavor == FL_PROCEDURE && attr.pure; 16586} 16587 16588 16589/* Test whether a symbol is implicitly pure or not. For a NULL pointer, 16590 checks if the current namespace is implicitly pure. Note that this 16591 function returns false for a PURE procedure. */ 16592 16593int 16594gfc_implicit_pure (gfc_symbol *sym) 16595{ 16596 gfc_namespace *ns; 16597 16598 if (sym == NULL) 16599 { 16600 /* Check if the current procedure is implicit_pure. Walk up 16601 the procedure list until we find a procedure. */ 16602 for (ns = gfc_current_ns; ns; ns = ns->parent) 16603 { 16604 sym = ns->proc_name; 16605 if (sym == NULL) 16606 return 0; 16607 16608 if (sym->attr.flavor == FL_PROCEDURE) 16609 break; 16610 } 16611 } 16612 16613 return sym->attr.flavor == FL_PROCEDURE && sym->attr.implicit_pure 16614 && !sym->attr.pure; 16615} 16616 16617 16618void 16619gfc_unset_implicit_pure (gfc_symbol *sym) 16620{ 16621 gfc_namespace *ns; 16622 16623 if (sym == NULL) 16624 { 16625 /* Check if the current procedure is implicit_pure. Walk up 16626 the procedure list until we find a procedure. */ 16627 for (ns = gfc_current_ns; ns; ns = ns->parent) 16628 { 16629 sym = ns->proc_name; 16630 if (sym == NULL) 16631 return; 16632 16633 if (sym->attr.flavor == FL_PROCEDURE) 16634 break; 16635 } 16636 } 16637 16638 if (sym->attr.flavor == FL_PROCEDURE) 16639 sym->attr.implicit_pure = 0; 16640 else 16641 sym->attr.pure = 0; 16642} 16643 16644 16645/* Test whether the current procedure is elemental or not. */ 16646 16647int 16648gfc_elemental (gfc_symbol *sym) 16649{ 16650 symbol_attribute attr; 16651 16652 if (sym == NULL) 16653 sym = gfc_current_ns->proc_name; 16654 if (sym == NULL) 16655 return 0; 16656 attr = sym->attr; 16657 16658 return attr.flavor == FL_PROCEDURE && attr.elemental; 16659} 16660 16661 16662/* Warn about unused labels. */ 16663 16664static void 16665warn_unused_fortran_label (gfc_st_label *label) 16666{ 16667 if (label == NULL) 16668 return; 16669 16670 warn_unused_fortran_label (label->left); 16671 16672 if (label->defined == ST_LABEL_UNKNOWN) 16673 return; 16674 16675 switch (label->referenced) 16676 { 16677 case ST_LABEL_UNKNOWN: 16678 gfc_warning (OPT_Wunused_label, "Label %d at %L defined but not used", 16679 label->value, &label->where); 16680 break; 16681 16682 case ST_LABEL_BAD_TARGET: 16683 gfc_warning (OPT_Wunused_label, 16684 "Label %d at %L defined but cannot be used", 16685 label->value, &label->where); 16686 break; 16687 16688 default: 16689 break; 16690 } 16691 16692 warn_unused_fortran_label (label->right); 16693} 16694 16695 16696/* Returns the sequence type of a symbol or sequence. */ 16697 16698static seq_type 16699sequence_type (gfc_typespec ts) 16700{ 16701 seq_type result; 16702 gfc_component *c; 16703 16704 switch (ts.type) 16705 { 16706 case BT_DERIVED: 16707 16708 if (ts.u.derived->components == NULL) 16709 return SEQ_NONDEFAULT; 16710 16711 result = sequence_type (ts.u.derived->components->ts); 16712 for (c = ts.u.derived->components->next; c; c = c->next) 16713 if (sequence_type (c->ts) != result) 16714 return SEQ_MIXED; 16715 16716 return result; 16717 16718 case BT_CHARACTER: 16719 if (ts.kind != gfc_default_character_kind) 16720 return SEQ_NONDEFAULT; 16721 16722 return SEQ_CHARACTER; 16723 16724 case BT_INTEGER: 16725 if (ts.kind != gfc_default_integer_kind) 16726 return SEQ_NONDEFAULT; 16727 16728 return SEQ_NUMERIC; 16729 16730 case BT_REAL: 16731 if (!(ts.kind == gfc_default_real_kind 16732 || ts.kind == gfc_default_double_kind)) 16733 return SEQ_NONDEFAULT; 16734 16735 return SEQ_NUMERIC; 16736 16737 case BT_COMPLEX: 16738 if (ts.kind != gfc_default_complex_kind) 16739 return SEQ_NONDEFAULT; 16740 16741 return SEQ_NUMERIC; 16742 16743 case BT_LOGICAL: 16744 if (ts.kind != gfc_default_logical_kind) 16745 return SEQ_NONDEFAULT; 16746 16747 return SEQ_NUMERIC; 16748 16749 default: 16750 return SEQ_NONDEFAULT; 16751 } 16752} 16753 16754 16755/* Resolve derived type EQUIVALENCE object. */ 16756 16757static bool 16758resolve_equivalence_derived (gfc_symbol *derived, gfc_symbol *sym, gfc_expr *e) 16759{ 16760 gfc_component *c = derived->components; 16761 16762 if (!derived) 16763 return true; 16764 16765 /* Shall not be an object of nonsequence derived type. */ 16766 if (!derived->attr.sequence) 16767 { 16768 gfc_error ("Derived type variable %qs at %L must have SEQUENCE " 16769 "attribute to be an EQUIVALENCE object", sym->name, 16770 &e->where); 16771 return false; 16772 } 16773 16774 /* Shall not have allocatable components. */ 16775 if (derived->attr.alloc_comp) 16776 { 16777 gfc_error ("Derived type variable %qs at %L cannot have ALLOCATABLE " 16778 "components to be an EQUIVALENCE object",sym->name, 16779 &e->where); 16780 return false; 16781 } 16782 16783 if (sym->attr.in_common && gfc_has_default_initializer (sym->ts.u.derived)) 16784 { 16785 gfc_error ("Derived type variable %qs at %L with default " 16786 "initialization cannot be in EQUIVALENCE with a variable " 16787 "in COMMON", sym->name, &e->where); 16788 return false; 16789 } 16790 16791 for (; c ; c = c->next) 16792 { 16793 if (gfc_bt_struct (c->ts.type) 16794 && (!resolve_equivalence_derived(c->ts.u.derived, sym, e))) 16795 return false; 16796 16797 /* Shall not be an object of sequence derived type containing a pointer 16798 in the structure. */ 16799 if (c->attr.pointer) 16800 { 16801 gfc_error ("Derived type variable %qs at %L with pointer " 16802 "component(s) cannot be an EQUIVALENCE object", 16803 sym->name, &e->where); 16804 return false; 16805 } 16806 } 16807 return true; 16808} 16809 16810 16811/* Resolve equivalence object. 16812 An EQUIVALENCE object shall not be a dummy argument, a pointer, a target, 16813 an allocatable array, an object of nonsequence derived type, an object of 16814 sequence derived type containing a pointer at any level of component 16815 selection, an automatic object, a function name, an entry name, a result 16816 name, a named constant, a structure component, or a subobject of any of 16817 the preceding objects. A substring shall not have length zero. A 16818 derived type shall not have components with default initialization nor 16819 shall two objects of an equivalence group be initialized. 16820 Either all or none of the objects shall have an protected attribute. 16821 The simple constraints are done in symbol.c(check_conflict) and the rest 16822 are implemented here. */ 16823 16824static void 16825resolve_equivalence (gfc_equiv *eq) 16826{ 16827 gfc_symbol *sym; 16828 gfc_symbol *first_sym; 16829 gfc_expr *e; 16830 gfc_ref *r; 16831 locus *last_where = NULL; 16832 seq_type eq_type, last_eq_type; 16833 gfc_typespec *last_ts; 16834 int object, cnt_protected; 16835 const char *msg; 16836 16837 last_ts = &eq->expr->symtree->n.sym->ts; 16838 16839 first_sym = eq->expr->symtree->n.sym; 16840 16841 cnt_protected = 0; 16842 16843 for (object = 1; eq; eq = eq->eq, object++) 16844 { 16845 e = eq->expr; 16846 16847 e->ts = e->symtree->n.sym->ts; 16848 /* match_varspec might not know yet if it is seeing 16849 array reference or substring reference, as it doesn't 16850 know the types. */ 16851 if (e->ref && e->ref->type == REF_ARRAY) 16852 { 16853 gfc_ref *ref = e->ref; 16854 sym = e->symtree->n.sym; 16855 16856 if (sym->attr.dimension) 16857 { 16858 ref->u.ar.as = sym->as; 16859 ref = ref->next; 16860 } 16861 16862 /* For substrings, convert REF_ARRAY into REF_SUBSTRING. */ 16863 if (e->ts.type == BT_CHARACTER 16864 && ref 16865 && ref->type == REF_ARRAY 16866 && ref->u.ar.dimen == 1 16867 && ref->u.ar.dimen_type[0] == DIMEN_RANGE 16868 && ref->u.ar.stride[0] == NULL) 16869 { 16870 gfc_expr *start = ref->u.ar.start[0]; 16871 gfc_expr *end = ref->u.ar.end[0]; 16872 void *mem = NULL; 16873 16874 /* Optimize away the (:) reference. */ 16875 if (start == NULL && end == NULL) 16876 { 16877 if (e->ref == ref) 16878 e->ref = ref->next; 16879 else 16880 e->ref->next = ref->next; 16881 mem = ref; 16882 } 16883 else 16884 { 16885 ref->type = REF_SUBSTRING; 16886 if (start == NULL) 16887 start = gfc_get_int_expr (gfc_charlen_int_kind, 16888 NULL, 1); 16889 ref->u.ss.start = start; 16890 if (end == NULL && e->ts.u.cl) 16891 end = gfc_copy_expr (e->ts.u.cl->length); 16892 ref->u.ss.end = end; 16893 ref->u.ss.length = e->ts.u.cl; 16894 e->ts.u.cl = NULL; 16895 } 16896 ref = ref->next; 16897 free (mem); 16898 } 16899 16900 /* Any further ref is an error. */ 16901 if (ref) 16902 { 16903 gcc_assert (ref->type == REF_ARRAY); 16904 gfc_error ("Syntax error in EQUIVALENCE statement at %L", 16905 &ref->u.ar.where); 16906 continue; 16907 } 16908 } 16909 16910 if (!gfc_resolve_expr (e)) 16911 continue; 16912 16913 sym = e->symtree->n.sym; 16914 16915 if (sym->attr.is_protected) 16916 cnt_protected++; 16917 if (cnt_protected > 0 && cnt_protected != object) 16918 { 16919 gfc_error ("Either all or none of the objects in the " 16920 "EQUIVALENCE set at %L shall have the " 16921 "PROTECTED attribute", 16922 &e->where); 16923 break; 16924 } 16925 16926 /* Shall not equivalence common block variables in a PURE procedure. */ 16927 if (sym->ns->proc_name 16928 && sym->ns->proc_name->attr.pure 16929 && sym->attr.in_common) 16930 { 16931 /* Need to check for symbols that may have entered the pure 16932 procedure via a USE statement. */ 16933 bool saw_sym = false; 16934 if (sym->ns->use_stmts) 16935 { 16936 gfc_use_rename *r; 16937 for (r = sym->ns->use_stmts->rename; r; r = r->next) 16938 if (strcmp(r->use_name, sym->name) == 0) saw_sym = true; 16939 } 16940 else 16941 saw_sym = true; 16942 16943 if (saw_sym) 16944 gfc_error ("COMMON block member %qs at %L cannot be an " 16945 "EQUIVALENCE object in the pure procedure %qs", 16946 sym->name, &e->where, sym->ns->proc_name->name); 16947 break; 16948 } 16949 16950 /* Shall not be a named constant. */ 16951 if (e->expr_type == EXPR_CONSTANT) 16952 { 16953 gfc_error ("Named constant %qs at %L cannot be an EQUIVALENCE " 16954 "object", sym->name, &e->where); 16955 continue; 16956 } 16957 16958 if (e->ts.type == BT_DERIVED 16959 && !resolve_equivalence_derived (e->ts.u.derived, sym, e)) 16960 continue; 16961 16962 /* Check that the types correspond correctly: 16963 Note 5.28: 16964 A numeric sequence structure may be equivalenced to another sequence 16965 structure, an object of default integer type, default real type, double 16966 precision real type, default logical type such that components of the 16967 structure ultimately only become associated to objects of the same 16968 kind. A character sequence structure may be equivalenced to an object 16969 of default character kind or another character sequence structure. 16970 Other objects may be equivalenced only to objects of the same type and 16971 kind parameters. */ 16972 16973 /* Identical types are unconditionally OK. */ 16974 if (object == 1 || gfc_compare_types (last_ts, &sym->ts)) 16975 goto identical_types; 16976 16977 last_eq_type = sequence_type (*last_ts); 16978 eq_type = sequence_type (sym->ts); 16979 16980 /* Since the pair of objects is not of the same type, mixed or 16981 non-default sequences can be rejected. */ 16982 16983 msg = "Sequence %s with mixed components in EQUIVALENCE " 16984 "statement at %L with different type objects"; 16985 if ((object ==2 16986 && last_eq_type == SEQ_MIXED 16987 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) 16988 || (eq_type == SEQ_MIXED 16989 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) 16990 continue; 16991 16992 msg = "Non-default type object or sequence %s in EQUIVALENCE " 16993 "statement at %L with objects of different type"; 16994 if ((object ==2 16995 && last_eq_type == SEQ_NONDEFAULT 16996 && !gfc_notify_std (GFC_STD_GNU, msg, first_sym->name, last_where)) 16997 || (eq_type == SEQ_NONDEFAULT 16998 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where))) 16999 continue; 17000 17001 msg ="Non-CHARACTER object %qs in default CHARACTER " 17002 "EQUIVALENCE statement at %L"; 17003 if (last_eq_type == SEQ_CHARACTER 17004 && eq_type != SEQ_CHARACTER 17005 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) 17006 continue; 17007 17008 msg ="Non-NUMERIC object %qs in default NUMERIC " 17009 "EQUIVALENCE statement at %L"; 17010 if (last_eq_type == SEQ_NUMERIC 17011 && eq_type != SEQ_NUMERIC 17012 && !gfc_notify_std (GFC_STD_GNU, msg, sym->name, &e->where)) 17013 continue; 17014 17015identical_types: 17016 17017 last_ts =&sym->ts; 17018 last_where = &e->where; 17019 17020 if (!e->ref) 17021 continue; 17022 17023 /* Shall not be an automatic array. */ 17024 if (e->ref->type == REF_ARRAY && is_non_constant_shape_array (sym)) 17025 { 17026 gfc_error ("Array %qs at %L with non-constant bounds cannot be " 17027 "an EQUIVALENCE object", sym->name, &e->where); 17028 continue; 17029 } 17030 17031 r = e->ref; 17032 while (r) 17033 { 17034 /* Shall not be a structure component. */ 17035 if (r->type == REF_COMPONENT) 17036 { 17037 gfc_error ("Structure component %qs at %L cannot be an " 17038 "EQUIVALENCE object", 17039 r->u.c.component->name, &e->where); 17040 break; 17041 } 17042 17043 /* A substring shall not have length zero. */ 17044 if (r->type == REF_SUBSTRING) 17045 { 17046 if (compare_bound (r->u.ss.start, r->u.ss.end) == CMP_GT) 17047 { 17048 gfc_error ("Substring at %L has length zero", 17049 &r->u.ss.start->where); 17050 break; 17051 } 17052 } 17053 r = r->next; 17054 } 17055 } 17056} 17057 17058 17059/* Function called by resolve_fntype to flag other symbols used in the 17060 length type parameter specification of function results. */ 17061 17062static bool 17063flag_fn_result_spec (gfc_expr *expr, 17064 gfc_symbol *sym, 17065 int *f ATTRIBUTE_UNUSED) 17066{ 17067 gfc_namespace *ns; 17068 gfc_symbol *s; 17069 17070 if (expr->expr_type == EXPR_VARIABLE) 17071 { 17072 s = expr->symtree->n.sym; 17073 for (ns = s->ns; ns; ns = ns->parent) 17074 if (!ns->parent) 17075 break; 17076 17077 if (sym == s) 17078 { 17079 gfc_error ("Self reference in character length expression " 17080 "for %qs at %L", sym->name, &expr->where); 17081 return true; 17082 } 17083 17084 if (!s->fn_result_spec 17085 && s->attr.flavor == FL_PARAMETER) 17086 { 17087 /* Function contained in a module.... */ 17088 if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE) 17089 { 17090 gfc_symtree *st; 17091 s->fn_result_spec = 1; 17092 /* Make sure that this symbol is translated as a module 17093 variable. */ 17094 st = gfc_get_unique_symtree (ns); 17095 st->n.sym = s; 17096 s->refs++; 17097 } 17098 /* ... which is use associated and called. */ 17099 else if (s->attr.use_assoc || s->attr.used_in_submodule 17100 || 17101 /* External function matched with an interface. */ 17102 (s->ns->proc_name 17103 && ((s->ns == ns 17104 && s->ns->proc_name->attr.if_source == IFSRC_DECL) 17105 || s->ns->proc_name->attr.if_source == IFSRC_IFBODY) 17106 && s->ns->proc_name->attr.function)) 17107 s->fn_result_spec = 1; 17108 } 17109 } 17110 return false; 17111} 17112 17113 17114/* Resolve function and ENTRY types, issue diagnostics if needed. */ 17115 17116static void 17117resolve_fntype (gfc_namespace *ns) 17118{ 17119 gfc_entry_list *el; 17120 gfc_symbol *sym; 17121 17122 if (ns->proc_name == NULL || !ns->proc_name->attr.function) 17123 return; 17124 17125 /* If there are any entries, ns->proc_name is the entry master 17126 synthetic symbol and ns->entries->sym actual FUNCTION symbol. */ 17127 if (ns->entries) 17128 sym = ns->entries->sym; 17129 else 17130 sym = ns->proc_name; 17131 if (sym->result == sym 17132 && sym->ts.type == BT_UNKNOWN 17133 && !gfc_set_default_type (sym, 0, NULL) 17134 && !sym->attr.untyped) 17135 { 17136 gfc_error ("Function %qs at %L has no IMPLICIT type", 17137 sym->name, &sym->declared_at); 17138 sym->attr.untyped = 1; 17139 } 17140 17141 if (sym->ts.type == BT_DERIVED && !sym->ts.u.derived->attr.use_assoc 17142 && !sym->attr.contained 17143 && !gfc_check_symbol_access (sym->ts.u.derived) 17144 && gfc_check_symbol_access (sym)) 17145 { 17146 gfc_notify_std (GFC_STD_F2003, "PUBLIC function %qs at " 17147 "%L of PRIVATE type %qs", sym->name, 17148 &sym->declared_at, sym->ts.u.derived->name); 17149 } 17150 17151 if (ns->entries) 17152 for (el = ns->entries->next; el; el = el->next) 17153 { 17154 if (el->sym->result == el->sym 17155 && el->sym->ts.type == BT_UNKNOWN 17156 && !gfc_set_default_type (el->sym, 0, NULL) 17157 && !el->sym->attr.untyped) 17158 { 17159 gfc_error ("ENTRY %qs at %L has no IMPLICIT type", 17160 el->sym->name, &el->sym->declared_at); 17161 el->sym->attr.untyped = 1; 17162 } 17163 } 17164 17165 if (sym->ts.type == BT_CHARACTER 17166 && sym->ts.u.cl->length 17167 && sym->ts.u.cl->length->ts.type == BT_INTEGER) 17168 gfc_traverse_expr (sym->ts.u.cl->length, sym, flag_fn_result_spec, 0); 17169} 17170 17171 17172/* 12.3.2.1.1 Defined operators. */ 17173 17174static bool 17175check_uop_procedure (gfc_symbol *sym, locus where) 17176{ 17177 gfc_formal_arglist *formal; 17178 17179 if (!sym->attr.function) 17180 { 17181 gfc_error ("User operator procedure %qs at %L must be a FUNCTION", 17182 sym->name, &where); 17183 return false; 17184 } 17185 17186 if (sym->ts.type == BT_CHARACTER 17187 && !((sym->ts.u.cl && sym->ts.u.cl->length) || sym->ts.deferred) 17188 && !(sym->result && ((sym->result->ts.u.cl 17189 && sym->result->ts.u.cl->length) || sym->result->ts.deferred))) 17190 { 17191 gfc_error ("User operator procedure %qs at %L cannot be assumed " 17192 "character length", sym->name, &where); 17193 return false; 17194 } 17195 17196 formal = gfc_sym_get_dummy_args (sym); 17197 if (!formal || !formal->sym) 17198 { 17199 gfc_error ("User operator procedure %qs at %L must have at least " 17200 "one argument", sym->name, &where); 17201 return false; 17202 } 17203 17204 if (formal->sym->attr.intent != INTENT_IN) 17205 { 17206 gfc_error ("First argument of operator interface at %L must be " 17207 "INTENT(IN)", &where); 17208 return false; 17209 } 17210 17211 if (formal->sym->attr.optional) 17212 { 17213 gfc_error ("First argument of operator interface at %L cannot be " 17214 "optional", &where); 17215 return false; 17216 } 17217 17218 formal = formal->next; 17219 if (!formal || !formal->sym) 17220 return true; 17221 17222 if (formal->sym->attr.intent != INTENT_IN) 17223 { 17224 gfc_error ("Second argument of operator interface at %L must be " 17225 "INTENT(IN)", &where); 17226 return false; 17227 } 17228 17229 if (formal->sym->attr.optional) 17230 { 17231 gfc_error ("Second argument of operator interface at %L cannot be " 17232 "optional", &where); 17233 return false; 17234 } 17235 17236 if (formal->next) 17237 { 17238 gfc_error ("Operator interface at %L must have, at most, two " 17239 "arguments", &where); 17240 return false; 17241 } 17242 17243 return true; 17244} 17245 17246static void 17247gfc_resolve_uops (gfc_symtree *symtree) 17248{ 17249 gfc_interface *itr; 17250 17251 if (symtree == NULL) 17252 return; 17253 17254 gfc_resolve_uops (symtree->left); 17255 gfc_resolve_uops (symtree->right); 17256 17257 for (itr = symtree->n.uop->op; itr; itr = itr->next) 17258 check_uop_procedure (itr->sym, itr->sym->declared_at); 17259} 17260 17261 17262/* Examine all of the expressions associated with a program unit, 17263 assign types to all intermediate expressions, make sure that all 17264 assignments are to compatible types and figure out which names 17265 refer to which functions or subroutines. It doesn't check code 17266 block, which is handled by gfc_resolve_code. */ 17267 17268static void 17269resolve_types (gfc_namespace *ns) 17270{ 17271 gfc_namespace *n; 17272 gfc_charlen *cl; 17273 gfc_data *d; 17274 gfc_equiv *eq; 17275 gfc_namespace* old_ns = gfc_current_ns; 17276 bool recursive = ns->proc_name && ns->proc_name->attr.recursive; 17277 17278 if (ns->types_resolved) 17279 return; 17280 17281 /* Check that all IMPLICIT types are ok. */ 17282 if (!ns->seen_implicit_none) 17283 { 17284 unsigned letter; 17285 for (letter = 0; letter != GFC_LETTERS; ++letter) 17286 if (ns->set_flag[letter] 17287 && !resolve_typespec_used (&ns->default_type[letter], 17288 &ns->implicit_loc[letter], NULL)) 17289 return; 17290 } 17291 17292 gfc_current_ns = ns; 17293 17294 resolve_entries (ns); 17295 17296 resolve_common_vars (&ns->blank_common, false); 17297 resolve_common_blocks (ns->common_root); 17298 17299 resolve_contained_functions (ns); 17300 17301 if (ns->proc_name && ns->proc_name->attr.flavor == FL_PROCEDURE 17302 && ns->proc_name->attr.if_source == IFSRC_IFBODY) 17303 gfc_resolve_formal_arglist (ns->proc_name); 17304 17305 gfc_traverse_ns (ns, resolve_bind_c_derived_types); 17306 17307 for (cl = ns->cl_list; cl; cl = cl->next) 17308 resolve_charlen (cl); 17309 17310 gfc_traverse_ns (ns, resolve_symbol); 17311 17312 resolve_fntype (ns); 17313 17314 for (n = ns->contained; n; n = n->sibling) 17315 { 17316 if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)) 17317 gfc_error ("Contained procedure %qs at %L of a PURE procedure must " 17318 "also be PURE", n->proc_name->name, 17319 &n->proc_name->declared_at); 17320 17321 resolve_types (n); 17322 } 17323 17324 forall_flag = 0; 17325 gfc_do_concurrent_flag = 0; 17326 gfc_check_interfaces (ns); 17327 17328 gfc_traverse_ns (ns, resolve_values); 17329 17330 if (ns->save_all || (!flag_automatic && !recursive)) 17331 gfc_save_all (ns); 17332 17333 iter_stack = NULL; 17334 for (d = ns->data; d; d = d->next) 17335 resolve_data (d); 17336 17337 iter_stack = NULL; 17338 gfc_traverse_ns (ns, gfc_formalize_init_value); 17339 17340 gfc_traverse_ns (ns, gfc_verify_binding_labels); 17341 17342 for (eq = ns->equiv; eq; eq = eq->next) 17343 resolve_equivalence (eq); 17344 17345 /* Warn about unused labels. */ 17346 if (warn_unused_label) 17347 warn_unused_fortran_label (ns->st_labels); 17348 17349 gfc_resolve_uops (ns->uop_root); 17350 17351 gfc_traverse_ns (ns, gfc_verify_DTIO_procedures); 17352 17353 gfc_resolve_omp_declare_simd (ns); 17354 17355 gfc_resolve_omp_udrs (ns->omp_udr_root); 17356 17357 ns->types_resolved = 1; 17358 17359 gfc_current_ns = old_ns; 17360} 17361 17362 17363/* Call gfc_resolve_code recursively. */ 17364 17365static void 17366resolve_codes (gfc_namespace *ns) 17367{ 17368 gfc_namespace *n; 17369 bitmap_obstack old_obstack; 17370 17371 if (ns->resolved == 1) 17372 return; 17373 17374 for (n = ns->contained; n; n = n->sibling) 17375 resolve_codes (n); 17376 17377 gfc_current_ns = ns; 17378 17379 /* Don't clear 'cs_base' if this is the namespace of a BLOCK construct. */ 17380 if (!(ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)) 17381 cs_base = NULL; 17382 17383 /* Set to an out of range value. */ 17384 current_entry_id = -1; 17385 17386 old_obstack = labels_obstack; 17387 bitmap_obstack_initialize (&labels_obstack); 17388 17389 gfc_resolve_oacc_declare (ns); 17390 gfc_resolve_oacc_routines (ns); 17391 gfc_resolve_omp_local_vars (ns); 17392 gfc_resolve_code (ns->code, ns); 17393 17394 bitmap_obstack_release (&labels_obstack); 17395 labels_obstack = old_obstack; 17396} 17397 17398 17399/* This function is called after a complete program unit has been compiled. 17400 Its purpose is to examine all of the expressions associated with a program 17401 unit, assign types to all intermediate expressions, make sure that all 17402 assignments are to compatible types and figure out which names refer to 17403 which functions or subroutines. */ 17404 17405void 17406gfc_resolve (gfc_namespace *ns) 17407{ 17408 gfc_namespace *old_ns; 17409 code_stack *old_cs_base; 17410 struct gfc_omp_saved_state old_omp_state; 17411 17412 if (ns->resolved) 17413 return; 17414 17415 ns->resolved = -1; 17416 old_ns = gfc_current_ns; 17417 old_cs_base = cs_base; 17418 17419 /* As gfc_resolve can be called during resolution of an OpenMP construct 17420 body, we should clear any state associated to it, so that say NS's 17421 DO loops are not interpreted as OpenMP loops. */ 17422 if (!ns->construct_entities) 17423 gfc_omp_save_and_clear_state (&old_omp_state); 17424 17425 resolve_types (ns); 17426 component_assignment_level = 0; 17427 resolve_codes (ns); 17428 17429 gfc_current_ns = old_ns; 17430 cs_base = old_cs_base; 17431 ns->resolved = 1; 17432 17433 gfc_run_passes (ns); 17434 17435 if (!ns->construct_entities) 17436 gfc_omp_restore_state (&old_omp_state); 17437} 17438