1/* Declaration statement matcher 2 Copyright (C) 2002-2022 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "options.h" 25#include "tree.h" 26#include "gfortran.h" 27#include "stringpool.h" 28#include "match.h" 29#include "parse.h" 30#include "constructor.h" 31#include "target.h" 32 33/* Macros to access allocate memory for gfc_data_variable, 34 gfc_data_value and gfc_data. */ 35#define gfc_get_data_variable() XCNEW (gfc_data_variable) 36#define gfc_get_data_value() XCNEW (gfc_data_value) 37#define gfc_get_data() XCNEW (gfc_data) 38 39 40static bool set_binding_label (const char **, const char *, int); 41 42 43/* This flag is set if an old-style length selector is matched 44 during a type-declaration statement. */ 45 46static int old_char_selector; 47 48/* When variables acquire types and attributes from a declaration 49 statement, they get them from the following static variables. The 50 first part of a declaration sets these variables and the second 51 part copies these into symbol structures. */ 52 53static gfc_typespec current_ts; 54 55static symbol_attribute current_attr; 56static gfc_array_spec *current_as; 57static int colon_seen; 58static int attr_seen; 59 60/* The current binding label (if any). */ 61static const char* curr_binding_label; 62/* Need to know how many identifiers are on the current data declaration 63 line in case we're given the BIND(C) attribute with a NAME= specifier. */ 64static int num_idents_on_line; 65/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we 66 can supply a name if the curr_binding_label is nil and NAME= was not. */ 67static int has_name_equals = 0; 68 69/* Initializer of the previous enumerator. */ 70 71static gfc_expr *last_initializer; 72 73/* History of all the enumerators is maintained, so that 74 kind values of all the enumerators could be updated depending 75 upon the maximum initialized value. */ 76 77typedef struct enumerator_history 78{ 79 gfc_symbol *sym; 80 gfc_expr *initializer; 81 struct enumerator_history *next; 82} 83enumerator_history; 84 85/* Header of enum history chain. */ 86 87static enumerator_history *enum_history = NULL; 88 89/* Pointer of enum history node containing largest initializer. */ 90 91static enumerator_history *max_enum = NULL; 92 93/* gfc_new_block points to the symbol of a newly matched block. */ 94 95gfc_symbol *gfc_new_block; 96 97bool gfc_matching_function; 98 99/* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */ 100int directive_unroll = -1; 101 102/* Set upon parsing supported !GCC$ pragmas for use in the next loop. */ 103bool directive_ivdep = false; 104bool directive_vector = false; 105bool directive_novector = false; 106 107/* Map of middle-end built-ins that should be vectorized. */ 108hash_map<nofree_string_hash, int> *gfc_vectorized_builtins; 109 110/* If a kind expression of a component of a parameterized derived type is 111 parameterized, temporarily store the expression here. */ 112static gfc_expr *saved_kind_expr = NULL; 113 114/* Used to store the parameter list arising in a PDT declaration and 115 in the typespec of a PDT variable or component. */ 116static gfc_actual_arglist *decl_type_param_list; 117static gfc_actual_arglist *type_param_spec_list; 118 119/********************* DATA statement subroutines *********************/ 120 121static bool in_match_data = false; 122 123bool 124gfc_in_match_data (void) 125{ 126 return in_match_data; 127} 128 129static void 130set_in_match_data (bool set_value) 131{ 132 in_match_data = set_value; 133} 134 135/* Free a gfc_data_variable structure and everything beneath it. */ 136 137static void 138free_variable (gfc_data_variable *p) 139{ 140 gfc_data_variable *q; 141 142 for (; p; p = q) 143 { 144 q = p->next; 145 gfc_free_expr (p->expr); 146 gfc_free_iterator (&p->iter, 0); 147 free_variable (p->list); 148 free (p); 149 } 150} 151 152 153/* Free a gfc_data_value structure and everything beneath it. */ 154 155static void 156free_value (gfc_data_value *p) 157{ 158 gfc_data_value *q; 159 160 for (; p; p = q) 161 { 162 q = p->next; 163 mpz_clear (p->repeat); 164 gfc_free_expr (p->expr); 165 free (p); 166 } 167} 168 169 170/* Free a list of gfc_data structures. */ 171 172void 173gfc_free_data (gfc_data *p) 174{ 175 gfc_data *q; 176 177 for (; p; p = q) 178 { 179 q = p->next; 180 free_variable (p->var); 181 free_value (p->value); 182 free (p); 183 } 184} 185 186 187/* Free all data in a namespace. */ 188 189static void 190gfc_free_data_all (gfc_namespace *ns) 191{ 192 gfc_data *d; 193 194 for (;ns->data;) 195 { 196 d = ns->data->next; 197 free (ns->data); 198 ns->data = d; 199 } 200} 201 202/* Reject data parsed since the last restore point was marked. */ 203 204void 205gfc_reject_data (gfc_namespace *ns) 206{ 207 gfc_data *d; 208 209 while (ns->data && ns->data != ns->old_data) 210 { 211 d = ns->data->next; 212 free (ns->data); 213 ns->data = d; 214 } 215} 216 217static match var_element (gfc_data_variable *); 218 219/* Match a list of variables terminated by an iterator and a right 220 parenthesis. */ 221 222static match 223var_list (gfc_data_variable *parent) 224{ 225 gfc_data_variable *tail, var; 226 match m; 227 228 m = var_element (&var); 229 if (m == MATCH_ERROR) 230 return MATCH_ERROR; 231 if (m == MATCH_NO) 232 goto syntax; 233 234 tail = gfc_get_data_variable (); 235 *tail = var; 236 237 parent->list = tail; 238 239 for (;;) 240 { 241 if (gfc_match_char (',') != MATCH_YES) 242 goto syntax; 243 244 m = gfc_match_iterator (&parent->iter, 1); 245 if (m == MATCH_YES) 246 break; 247 if (m == MATCH_ERROR) 248 return MATCH_ERROR; 249 250 m = var_element (&var); 251 if (m == MATCH_ERROR) 252 return MATCH_ERROR; 253 if (m == MATCH_NO) 254 goto syntax; 255 256 tail->next = gfc_get_data_variable (); 257 tail = tail->next; 258 259 *tail = var; 260 } 261 262 if (gfc_match_char (')') != MATCH_YES) 263 goto syntax; 264 return MATCH_YES; 265 266syntax: 267 gfc_syntax_error (ST_DATA); 268 return MATCH_ERROR; 269} 270 271 272/* Match a single element in a data variable list, which can be a 273 variable-iterator list. */ 274 275static match 276var_element (gfc_data_variable *new_var) 277{ 278 match m; 279 gfc_symbol *sym; 280 281 memset (new_var, 0, sizeof (gfc_data_variable)); 282 283 if (gfc_match_char ('(') == MATCH_YES) 284 return var_list (new_var); 285 286 m = gfc_match_variable (&new_var->expr, 0); 287 if (m != MATCH_YES) 288 return m; 289 290 if (new_var->expr->expr_type == EXPR_CONSTANT 291 && new_var->expr->symtree == NULL) 292 { 293 gfc_error ("Inquiry parameter cannot appear in a " 294 "data-stmt-object-list at %C"); 295 return MATCH_ERROR; 296 } 297 298 sym = new_var->expr->symtree->n.sym; 299 300 /* Symbol should already have an associated type. */ 301 if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus)) 302 return MATCH_ERROR; 303 304 if (!sym->attr.function && gfc_current_ns->parent 305 && gfc_current_ns->parent == sym->ns) 306 { 307 gfc_error ("Host associated variable %qs may not be in the DATA " 308 "statement at %C", sym->name); 309 return MATCH_ERROR; 310 } 311 312 if (gfc_current_state () != COMP_BLOCK_DATA 313 && sym->attr.in_common 314 && !gfc_notify_std (GFC_STD_GNU, "initialization of " 315 "common block variable %qs in DATA statement at %C", 316 sym->name)) 317 return MATCH_ERROR; 318 319 if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where)) 320 return MATCH_ERROR; 321 322 return MATCH_YES; 323} 324 325 326/* Match the top-level list of data variables. */ 327 328static match 329top_var_list (gfc_data *d) 330{ 331 gfc_data_variable var, *tail, *new_var; 332 match m; 333 334 tail = NULL; 335 336 for (;;) 337 { 338 m = var_element (&var); 339 if (m == MATCH_NO) 340 goto syntax; 341 if (m == MATCH_ERROR) 342 return MATCH_ERROR; 343 344 new_var = gfc_get_data_variable (); 345 *new_var = var; 346 if (new_var->expr) 347 new_var->expr->where = gfc_current_locus; 348 349 if (tail == NULL) 350 d->var = new_var; 351 else 352 tail->next = new_var; 353 354 tail = new_var; 355 356 if (gfc_match_char ('/') == MATCH_YES) 357 break; 358 if (gfc_match_char (',') != MATCH_YES) 359 goto syntax; 360 } 361 362 return MATCH_YES; 363 364syntax: 365 gfc_syntax_error (ST_DATA); 366 gfc_free_data_all (gfc_current_ns); 367 return MATCH_ERROR; 368} 369 370 371static match 372match_data_constant (gfc_expr **result) 373{ 374 char name[GFC_MAX_SYMBOL_LEN + 1]; 375 gfc_symbol *sym, *dt_sym = NULL; 376 gfc_expr *expr; 377 match m; 378 locus old_loc; 379 380 m = gfc_match_literal_constant (&expr, 1); 381 if (m == MATCH_YES) 382 { 383 *result = expr; 384 return MATCH_YES; 385 } 386 387 if (m == MATCH_ERROR) 388 return MATCH_ERROR; 389 390 m = gfc_match_null (result); 391 if (m != MATCH_NO) 392 return m; 393 394 old_loc = gfc_current_locus; 395 396 /* Should this be a structure component, try to match it 397 before matching a name. */ 398 m = gfc_match_rvalue (result); 399 if (m == MATCH_ERROR) 400 return m; 401 402 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE) 403 { 404 if (!gfc_simplify_expr (*result, 0)) 405 m = MATCH_ERROR; 406 return m; 407 } 408 else if (m == MATCH_YES) 409 { 410 /* If a parameter inquiry ends up here, symtree is NULL but **result 411 contains the right constant expression. Check here. */ 412 if ((*result)->symtree == NULL 413 && (*result)->expr_type == EXPR_CONSTANT 414 && ((*result)->ts.type == BT_INTEGER 415 || (*result)->ts.type == BT_REAL)) 416 return m; 417 418 /* F2018:R845 data-stmt-constant is initial-data-target. 419 A data-stmt-constant shall be ... initial-data-target if and 420 only if the corresponding data-stmt-object has the POINTER 421 attribute. ... If data-stmt-constant is initial-data-target 422 the corresponding data statement object shall be 423 data-pointer-initialization compatible (7.5.4.6) with the initial 424 data target; the data statement object is initially associated 425 with the target. */ 426 if ((*result)->symtree->n.sym->attr.save 427 && (*result)->symtree->n.sym->attr.target) 428 return m; 429 gfc_free_expr (*result); 430 } 431 432 gfc_current_locus = old_loc; 433 434 m = gfc_match_name (name); 435 if (m != MATCH_YES) 436 return m; 437 438 if (gfc_find_symbol (name, NULL, 1, &sym)) 439 return MATCH_ERROR; 440 441 if (sym && sym->attr.generic) 442 dt_sym = gfc_find_dt_in_generic (sym); 443 444 if (sym == NULL 445 || (sym->attr.flavor != FL_PARAMETER 446 && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor)))) 447 { 448 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", 449 name); 450 *result = NULL; 451 return MATCH_ERROR; 452 } 453 else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)) 454 return gfc_match_structure_constructor (dt_sym, result); 455 456 /* Check to see if the value is an initialization array expression. */ 457 if (sym->value->expr_type == EXPR_ARRAY) 458 { 459 gfc_current_locus = old_loc; 460 461 m = gfc_match_init_expr (result); 462 if (m == MATCH_ERROR) 463 return m; 464 465 if (m == MATCH_YES) 466 { 467 if (!gfc_simplify_expr (*result, 0)) 468 m = MATCH_ERROR; 469 470 if ((*result)->expr_type == EXPR_CONSTANT) 471 return m; 472 else 473 { 474 gfc_error ("Invalid initializer %s in Data statement at %C", name); 475 return MATCH_ERROR; 476 } 477 } 478 } 479 480 *result = gfc_copy_expr (sym->value); 481 return MATCH_YES; 482} 483 484 485/* Match a list of values in a DATA statement. The leading '/' has 486 already been seen at this point. */ 487 488static match 489top_val_list (gfc_data *data) 490{ 491 gfc_data_value *new_val, *tail; 492 gfc_expr *expr; 493 match m; 494 495 tail = NULL; 496 497 for (;;) 498 { 499 m = match_data_constant (&expr); 500 if (m == MATCH_NO) 501 goto syntax; 502 if (m == MATCH_ERROR) 503 return MATCH_ERROR; 504 505 new_val = gfc_get_data_value (); 506 mpz_init (new_val->repeat); 507 508 if (tail == NULL) 509 data->value = new_val; 510 else 511 tail->next = new_val; 512 513 tail = new_val; 514 515 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) 516 { 517 tail->expr = expr; 518 mpz_set_ui (tail->repeat, 1); 519 } 520 else 521 { 522 mpz_set (tail->repeat, expr->value.integer); 523 gfc_free_expr (expr); 524 525 m = match_data_constant (&tail->expr); 526 if (m == MATCH_NO) 527 goto syntax; 528 if (m == MATCH_ERROR) 529 return MATCH_ERROR; 530 } 531 532 if (gfc_match_char ('/') == MATCH_YES) 533 break; 534 if (gfc_match_char (',') == MATCH_NO) 535 goto syntax; 536 } 537 538 return MATCH_YES; 539 540syntax: 541 gfc_syntax_error (ST_DATA); 542 gfc_free_data_all (gfc_current_ns); 543 return MATCH_ERROR; 544} 545 546 547/* Matches an old style initialization. */ 548 549static match 550match_old_style_init (const char *name) 551{ 552 match m; 553 gfc_symtree *st; 554 gfc_symbol *sym; 555 gfc_data *newdata, *nd; 556 557 /* Set up data structure to hold initializers. */ 558 gfc_find_sym_tree (name, NULL, 0, &st); 559 sym = st->n.sym; 560 561 newdata = gfc_get_data (); 562 newdata->var = gfc_get_data_variable (); 563 newdata->var->expr = gfc_get_variable_expr (st); 564 newdata->var->expr->where = sym->declared_at; 565 newdata->where = gfc_current_locus; 566 567 /* Match initial value list. This also eats the terminal '/'. */ 568 m = top_val_list (newdata); 569 if (m != MATCH_YES) 570 { 571 free (newdata); 572 return m; 573 } 574 575 /* Check that a BOZ did not creep into an old-style initialization. */ 576 for (nd = newdata; nd; nd = nd->next) 577 { 578 if (nd->value->expr->ts.type == BT_BOZ 579 && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style " 580 "initialization"), &nd->value->expr->where)) 581 return MATCH_ERROR; 582 583 if (nd->var->expr->ts.type != BT_INTEGER 584 && nd->var->expr->ts.type != BT_REAL 585 && nd->value->expr->ts.type == BT_BOZ) 586 { 587 gfc_error (G_("BOZ literal constant near %L cannot be assigned to " 588 "a %qs variable in an old-style initialization"), 589 &nd->value->expr->where, 590 gfc_typename (&nd->value->expr->ts)); 591 return MATCH_ERROR; 592 } 593 } 594 595 if (gfc_pure (NULL)) 596 { 597 gfc_error ("Initialization at %C is not allowed in a PURE procedure"); 598 free (newdata); 599 return MATCH_ERROR; 600 } 601 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 602 603 /* Mark the variable as having appeared in a data statement. */ 604 if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at)) 605 { 606 free (newdata); 607 return MATCH_ERROR; 608 } 609 610 /* Chain in namespace list of DATA initializers. */ 611 newdata->next = gfc_current_ns->data; 612 gfc_current_ns->data = newdata; 613 614 return m; 615} 616 617 618/* Match the stuff following a DATA statement. If ERROR_FLAG is set, 619 we are matching a DATA statement and are therefore issuing an error 620 if we encounter something unexpected, if not, we're trying to match 621 an old-style initialization expression of the form INTEGER I /2/. */ 622 623match 624gfc_match_data (void) 625{ 626 gfc_data *new_data; 627 gfc_expr *e; 628 gfc_ref *ref; 629 match m; 630 char c; 631 632 /* DATA has been matched. In free form source code, the next character 633 needs to be whitespace or '(' from an implied do-loop. Check that 634 here. */ 635 c = gfc_peek_ascii_char (); 636 if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(') 637 return MATCH_NO; 638 639 /* Before parsing the rest of a DATA statement, check F2008:c1206. */ 640 if ((gfc_current_state () == COMP_FUNCTION 641 || gfc_current_state () == COMP_SUBROUTINE) 642 && gfc_state_stack->previous->state == COMP_INTERFACE) 643 { 644 gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); 645 return MATCH_ERROR; 646 } 647 648 set_in_match_data (true); 649 650 for (;;) 651 { 652 new_data = gfc_get_data (); 653 new_data->where = gfc_current_locus; 654 655 m = top_var_list (new_data); 656 if (m != MATCH_YES) 657 goto cleanup; 658 659 if (new_data->var->iter.var 660 && new_data->var->iter.var->ts.type == BT_INTEGER 661 && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1 662 && new_data->var->list 663 && new_data->var->list->expr 664 && new_data->var->list->expr->ts.type == BT_CHARACTER 665 && new_data->var->list->expr->ref 666 && new_data->var->list->expr->ref->type == REF_SUBSTRING) 667 { 668 gfc_error ("Invalid substring in data-implied-do at %L in DATA " 669 "statement", &new_data->var->list->expr->where); 670 goto cleanup; 671 } 672 673 /* Check for an entity with an allocatable component, which is not 674 allowed. */ 675 e = new_data->var->expr; 676 if (e) 677 { 678 bool invalid; 679 680 invalid = false; 681 for (ref = e->ref; ref; ref = ref->next) 682 if ((ref->type == REF_COMPONENT 683 && ref->u.c.component->attr.allocatable) 684 || (ref->type == REF_ARRAY 685 && e->symtree->n.sym->attr.pointer != 1 686 && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED)) 687 invalid = true; 688 689 if (invalid) 690 { 691 gfc_error ("Allocatable component or deferred-shaped array " 692 "near %C in DATA statement"); 693 goto cleanup; 694 } 695 696 /* F2008:C567 (R536) A data-i-do-object or a variable that appears 697 as a data-stmt-object shall not be an object designator in which 698 a pointer appears other than as the entire rightmost part-ref. */ 699 if (!e->ref && e->ts.type == BT_DERIVED 700 && e->symtree->n.sym->attr.pointer) 701 goto partref; 702 703 ref = e->ref; 704 if (e->symtree->n.sym->ts.type == BT_DERIVED 705 && e->symtree->n.sym->attr.pointer 706 && ref->type == REF_COMPONENT) 707 goto partref; 708 709 for (; ref; ref = ref->next) 710 if (ref->type == REF_COMPONENT 711 && ref->u.c.component->attr.pointer 712 && ref->next) 713 goto partref; 714 } 715 716 m = top_val_list (new_data); 717 if (m != MATCH_YES) 718 goto cleanup; 719 720 new_data->next = gfc_current_ns->data; 721 gfc_current_ns->data = new_data; 722 723 /* A BOZ literal constant cannot appear in a structure constructor. 724 Check for that here for a data statement value. */ 725 if (new_data->value->expr->ts.type == BT_DERIVED 726 && new_data->value->expr->value.constructor) 727 { 728 gfc_constructor *c; 729 c = gfc_constructor_first (new_data->value->expr->value.constructor); 730 for (; c; c = gfc_constructor_next (c)) 731 if (c->expr && c->expr->ts.type == BT_BOZ) 732 { 733 gfc_error ("BOZ literal constant at %L cannot appear in a " 734 "structure constructor", &c->expr->where); 735 return MATCH_ERROR; 736 } 737 } 738 739 if (gfc_match_eos () == MATCH_YES) 740 break; 741 742 gfc_match_char (','); /* Optional comma */ 743 } 744 745 set_in_match_data (false); 746 747 if (gfc_pure (NULL)) 748 { 749 gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); 750 return MATCH_ERROR; 751 } 752 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 753 754 return MATCH_YES; 755 756partref: 757 758 gfc_error ("part-ref with pointer attribute near %L is not " 759 "rightmost part-ref of data-stmt-object", 760 &e->where); 761 762cleanup: 763 set_in_match_data (false); 764 gfc_free_data (new_data); 765 return MATCH_ERROR; 766} 767 768 769/************************ Declaration statements *********************/ 770 771 772/* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization 773 list). The difference here is the expression is a list of constants 774 and is surrounded by '/'. 775 The typespec ts must match the typespec of the variable which the 776 clist is initializing. 777 The arrayspec tells whether this should match a list of constants 778 corresponding to array elements or a scalar (as == NULL). */ 779 780static match 781match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) 782{ 783 gfc_constructor_base array_head = NULL; 784 gfc_expr *expr = NULL; 785 match m = MATCH_ERROR; 786 locus where; 787 mpz_t repeat, cons_size, as_size; 788 bool scalar; 789 int cmp; 790 791 gcc_assert (ts); 792 793 /* We have already matched '/' - now look for a constant list, as with 794 top_val_list from decl.cc, but append the result to an array. */ 795 if (gfc_match ("/") == MATCH_YES) 796 { 797 gfc_error ("Empty old style initializer list at %C"); 798 return MATCH_ERROR; 799 } 800 801 where = gfc_current_locus; 802 scalar = !as || !as->rank; 803 804 if (!scalar && !spec_size (as, &as_size)) 805 { 806 gfc_error ("Array in initializer list at %L must have an explicit shape", 807 as->type == AS_EXPLICIT ? &as->upper[0]->where : &where); 808 /* Nothing to cleanup yet. */ 809 return MATCH_ERROR; 810 } 811 812 mpz_init_set_ui (repeat, 0); 813 814 for (;;) 815 { 816 m = match_data_constant (&expr); 817 if (m != MATCH_YES) 818 expr = NULL; /* match_data_constant may set expr to garbage */ 819 if (m == MATCH_NO) 820 goto syntax; 821 if (m == MATCH_ERROR) 822 goto cleanup; 823 824 /* Found r in repeat spec r*c; look for the constant to repeat. */ 825 if ( gfc_match_char ('*') == MATCH_YES) 826 { 827 if (scalar) 828 { 829 gfc_error ("Repeat spec invalid in scalar initializer at %C"); 830 goto cleanup; 831 } 832 if (expr->ts.type != BT_INTEGER) 833 { 834 gfc_error ("Repeat spec must be an integer at %C"); 835 goto cleanup; 836 } 837 mpz_set (repeat, expr->value.integer); 838 gfc_free_expr (expr); 839 expr = NULL; 840 841 m = match_data_constant (&expr); 842 if (m == MATCH_NO) 843 { 844 m = MATCH_ERROR; 845 gfc_error ("Expected data constant after repeat spec at %C"); 846 } 847 if (m != MATCH_YES) 848 goto cleanup; 849 } 850 /* No repeat spec, we matched the data constant itself. */ 851 else 852 mpz_set_ui (repeat, 1); 853 854 if (!scalar) 855 { 856 /* Add the constant initializer as many times as repeated. */ 857 for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1)) 858 { 859 /* Make sure types of elements match */ 860 if(ts && !gfc_compare_types (&expr->ts, ts) 861 && !gfc_convert_type (expr, ts, 1)) 862 goto cleanup; 863 864 gfc_constructor_append_expr (&array_head, 865 gfc_copy_expr (expr), &gfc_current_locus); 866 } 867 868 gfc_free_expr (expr); 869 expr = NULL; 870 } 871 872 /* For scalar initializers quit after one element. */ 873 else 874 { 875 if(gfc_match_char ('/') != MATCH_YES) 876 { 877 gfc_error ("End of scalar initializer expected at %C"); 878 goto cleanup; 879 } 880 break; 881 } 882 883 if (gfc_match_char ('/') == MATCH_YES) 884 break; 885 if (gfc_match_char (',') == MATCH_NO) 886 goto syntax; 887 } 888 889 /* If we break early from here out, we encountered an error. */ 890 m = MATCH_ERROR; 891 892 /* Set up expr as an array constructor. */ 893 if (!scalar) 894 { 895 expr = gfc_get_array_expr (ts->type, ts->kind, &where); 896 expr->ts = *ts; 897 expr->value.constructor = array_head; 898 899 /* Validate sizes. We built expr ourselves, so cons_size will be 900 constant (we fail above for non-constant expressions). 901 We still need to verify that the sizes match. */ 902 gcc_assert (gfc_array_size (expr, &cons_size)); 903 cmp = mpz_cmp (cons_size, as_size); 904 if (cmp < 0) 905 gfc_error ("Not enough elements in array initializer at %C"); 906 else if (cmp > 0) 907 gfc_error ("Too many elements in array initializer at %C"); 908 mpz_clear (cons_size); 909 if (cmp) 910 goto cleanup; 911 912 /* Set the rank/shape to match the LHS as auto-reshape is implied. */ 913 expr->rank = as->rank; 914 expr->shape = gfc_get_shape (as->rank); 915 for (int i = 0; i < as->rank; ++i) 916 spec_dimen_size (as, i, &expr->shape[i]); 917 } 918 919 /* Make sure scalar types match. */ 920 else if (!gfc_compare_types (&expr->ts, ts) 921 && !gfc_convert_type (expr, ts, 1)) 922 goto cleanup; 923 924 if (expr->ts.u.cl) 925 expr->ts.u.cl->length_from_typespec = 1; 926 927 *result = expr; 928 m = MATCH_YES; 929 goto done; 930 931syntax: 932 m = MATCH_ERROR; 933 gfc_error ("Syntax error in old style initializer list at %C"); 934 935cleanup: 936 if (expr) 937 expr->value.constructor = NULL; 938 gfc_free_expr (expr); 939 gfc_constructor_free (array_head); 940 941done: 942 mpz_clear (repeat); 943 if (!scalar) 944 mpz_clear (as_size); 945 return m; 946} 947 948 949/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ 950 951static bool 952merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) 953{ 954 if ((from->type == AS_ASSUMED_RANK && to->corank) 955 || (to->type == AS_ASSUMED_RANK && from->corank)) 956 { 957 gfc_error ("The assumed-rank array at %C shall not have a codimension"); 958 return false; 959 } 960 961 if (to->rank == 0 && from->rank > 0) 962 { 963 to->rank = from->rank; 964 to->type = from->type; 965 to->cray_pointee = from->cray_pointee; 966 to->cp_was_assumed = from->cp_was_assumed; 967 968 for (int i = to->corank - 1; i >= 0; i--) 969 { 970 /* Do not exceed the limits on lower[] and upper[]. gfortran 971 cleans up elsewhere. */ 972 int j = from->rank + i; 973 if (j >= GFC_MAX_DIMENSIONS) 974 break; 975 976 to->lower[j] = to->lower[i]; 977 to->upper[j] = to->upper[i]; 978 } 979 for (int i = 0; i < from->rank; i++) 980 { 981 if (copy) 982 { 983 to->lower[i] = gfc_copy_expr (from->lower[i]); 984 to->upper[i] = gfc_copy_expr (from->upper[i]); 985 } 986 else 987 { 988 to->lower[i] = from->lower[i]; 989 to->upper[i] = from->upper[i]; 990 } 991 } 992 } 993 else if (to->corank == 0 && from->corank > 0) 994 { 995 to->corank = from->corank; 996 to->cotype = from->cotype; 997 998 for (int i = 0; i < from->corank; i++) 999 { 1000 /* Do not exceed the limits on lower[] and upper[]. gfortran 1001 cleans up elsewhere. */ 1002 int k = from->rank + i; 1003 int j = to->rank + i; 1004 if (j >= GFC_MAX_DIMENSIONS) 1005 break; 1006 1007 if (copy) 1008 { 1009 to->lower[j] = gfc_copy_expr (from->lower[k]); 1010 to->upper[j] = gfc_copy_expr (from->upper[k]); 1011 } 1012 else 1013 { 1014 to->lower[j] = from->lower[k]; 1015 to->upper[j] = from->upper[k]; 1016 } 1017 } 1018 } 1019 1020 if (to->rank + to->corank > GFC_MAX_DIMENSIONS) 1021 { 1022 gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum " 1023 "allowed dimensions of %d", 1024 to->rank, to->corank, GFC_MAX_DIMENSIONS); 1025 to->corank = GFC_MAX_DIMENSIONS - to->rank; 1026 return false; 1027 } 1028 return true; 1029} 1030 1031 1032/* Match an intent specification. Since this can only happen after an 1033 INTENT word, a legal intent-spec must follow. */ 1034 1035static sym_intent 1036match_intent_spec (void) 1037{ 1038 1039 if (gfc_match (" ( in out )") == MATCH_YES) 1040 return INTENT_INOUT; 1041 if (gfc_match (" ( in )") == MATCH_YES) 1042 return INTENT_IN; 1043 if (gfc_match (" ( out )") == MATCH_YES) 1044 return INTENT_OUT; 1045 1046 gfc_error ("Bad INTENT specification at %C"); 1047 return INTENT_UNKNOWN; 1048} 1049 1050 1051/* Matches a character length specification, which is either a 1052 specification expression, '*', or ':'. */ 1053 1054static match 1055char_len_param_value (gfc_expr **expr, bool *deferred) 1056{ 1057 match m; 1058 1059 *expr = NULL; 1060 *deferred = false; 1061 1062 if (gfc_match_char ('*') == MATCH_YES) 1063 return MATCH_YES; 1064 1065 if (gfc_match_char (':') == MATCH_YES) 1066 { 1067 if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C")) 1068 return MATCH_ERROR; 1069 1070 *deferred = true; 1071 1072 return MATCH_YES; 1073 } 1074 1075 m = gfc_match_expr (expr); 1076 1077 if (m == MATCH_NO || m == MATCH_ERROR) 1078 return m; 1079 1080 if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) 1081 return MATCH_ERROR; 1082 1083 /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things 1084 like CHARACTER(([1])). */ 1085 if ((*expr)->expr_type == EXPR_OP) 1086 gfc_simplify_expr (*expr, 1); 1087 1088 if ((*expr)->expr_type == EXPR_FUNCTION) 1089 { 1090 if ((*expr)->ts.type == BT_INTEGER 1091 || ((*expr)->ts.type == BT_UNKNOWN 1092 && strcmp((*expr)->symtree->name, "null") != 0)) 1093 return MATCH_YES; 1094 1095 goto syntax; 1096 } 1097 else if ((*expr)->expr_type == EXPR_CONSTANT) 1098 { 1099 /* F2008, 4.4.3.1: The length is a type parameter; its kind is 1100 processor dependent and its value is greater than or equal to zero. 1101 F2008, 4.4.3.2: If the character length parameter value evaluates 1102 to a negative value, the length of character entities declared 1103 is zero. */ 1104 1105 if ((*expr)->ts.type == BT_INTEGER) 1106 { 1107 if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) 1108 mpz_set_si ((*expr)->value.integer, 0); 1109 } 1110 else 1111 goto syntax; 1112 } 1113 else if ((*expr)->expr_type == EXPR_ARRAY) 1114 goto syntax; 1115 else if ((*expr)->expr_type == EXPR_VARIABLE) 1116 { 1117 bool t; 1118 gfc_expr *e; 1119 1120 e = gfc_copy_expr (*expr); 1121 1122 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", 1123 which causes an ICE if gfc_reduce_init_expr() is called. */ 1124 if (e->ref && e->ref->type == REF_ARRAY 1125 && e->ref->u.ar.type == AR_UNKNOWN 1126 && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) 1127 goto syntax; 1128 1129 t = gfc_reduce_init_expr (e); 1130 1131 if (!t && e->ts.type == BT_UNKNOWN 1132 && e->symtree->n.sym->attr.untyped == 1 1133 && (flag_implicit_none 1134 || e->symtree->n.sym->ns->seen_implicit_none == 1 1135 || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) 1136 { 1137 gfc_free_expr (e); 1138 goto syntax; 1139 } 1140 1141 if ((e->ref && e->ref->type == REF_ARRAY 1142 && e->ref->u.ar.type != AR_ELEMENT) 1143 || (!e->ref && e->expr_type == EXPR_ARRAY)) 1144 { 1145 gfc_free_expr (e); 1146 goto syntax; 1147 } 1148 1149 gfc_free_expr (e); 1150 } 1151 1152 if (gfc_seen_div0) 1153 m = MATCH_ERROR; 1154 1155 return m; 1156 1157syntax: 1158 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); 1159 return MATCH_ERROR; 1160} 1161 1162 1163/* A character length is a '*' followed by a literal integer or a 1164 char_len_param_value in parenthesis. */ 1165 1166static match 1167match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) 1168{ 1169 int length; 1170 match m; 1171 1172 *deferred = false; 1173 m = gfc_match_char ('*'); 1174 if (m != MATCH_YES) 1175 return m; 1176 1177 m = gfc_match_small_literal_int (&length, NULL); 1178 if (m == MATCH_ERROR) 1179 return m; 1180 1181 if (m == MATCH_YES) 1182 { 1183 if (obsolescent_check 1184 && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) 1185 return MATCH_ERROR; 1186 *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length); 1187 return m; 1188 } 1189 1190 if (gfc_match_char ('(') == MATCH_NO) 1191 goto syntax; 1192 1193 m = char_len_param_value (expr, deferred); 1194 if (m != MATCH_YES && gfc_matching_function) 1195 { 1196 gfc_undo_symbols (); 1197 m = MATCH_YES; 1198 } 1199 1200 if (m == MATCH_ERROR) 1201 return m; 1202 if (m == MATCH_NO) 1203 goto syntax; 1204 1205 if (gfc_match_char (')') == MATCH_NO) 1206 { 1207 gfc_free_expr (*expr); 1208 *expr = NULL; 1209 goto syntax; 1210 } 1211 1212 return MATCH_YES; 1213 1214syntax: 1215 gfc_error ("Syntax error in character length specification at %C"); 1216 return MATCH_ERROR; 1217} 1218 1219 1220/* Special subroutine for finding a symbol. Check if the name is found 1221 in the current name space. If not, and we're compiling a function or 1222 subroutine and the parent compilation unit is an interface, then check 1223 to see if the name we've been given is the name of the interface 1224 (located in another namespace). */ 1225 1226static int 1227find_special (const char *name, gfc_symbol **result, bool allow_subroutine) 1228{ 1229 gfc_state_data *s; 1230 gfc_symtree *st; 1231 int i; 1232 1233 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine); 1234 if (i == 0) 1235 { 1236 *result = st ? st->n.sym : NULL; 1237 goto end; 1238 } 1239 1240 if (gfc_current_state () != COMP_SUBROUTINE 1241 && gfc_current_state () != COMP_FUNCTION) 1242 goto end; 1243 1244 s = gfc_state_stack->previous; 1245 if (s == NULL) 1246 goto end; 1247 1248 if (s->state != COMP_INTERFACE) 1249 goto end; 1250 if (s->sym == NULL) 1251 goto end; /* Nameless interface. */ 1252 1253 if (strcmp (name, s->sym->name) == 0) 1254 { 1255 *result = s->sym; 1256 return 0; 1257 } 1258 1259end: 1260 return i; 1261} 1262 1263 1264/* Special subroutine for getting a symbol node associated with a 1265 procedure name, used in SUBROUTINE and FUNCTION statements. The 1266 symbol is created in the parent using with symtree node in the 1267 child unit pointing to the symbol. If the current namespace has no 1268 parent, then the symbol is just created in the current unit. */ 1269 1270static int 1271get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) 1272{ 1273 gfc_symtree *st; 1274 gfc_symbol *sym; 1275 int rc = 0; 1276 1277 /* Module functions have to be left in their own namespace because 1278 they have potentially (almost certainly!) already been referenced. 1279 In this sense, they are rather like external functions. This is 1280 fixed up in resolve.cc(resolve_entries), where the symbol name- 1281 space is set to point to the master function, so that the fake 1282 result mechanism can work. */ 1283 if (module_fcn_entry) 1284 { 1285 /* Present if entry is declared to be a module procedure. */ 1286 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result); 1287 1288 if (*result == NULL) 1289 rc = gfc_get_symbol (name, NULL, result); 1290 else if (!gfc_get_symbol (name, NULL, &sym) && sym 1291 && (*result)->ts.type == BT_UNKNOWN 1292 && sym->attr.flavor == FL_UNKNOWN) 1293 /* Pick up the typespec for the entry, if declared in the function 1294 body. Note that this symbol is FL_UNKNOWN because it will 1295 only have appeared in a type declaration. The local symtree 1296 is set to point to the module symbol and a unique symtree 1297 to the local version. This latter ensures a correct clearing 1298 of the symbols. */ 1299 { 1300 /* If the ENTRY proceeds its specification, we need to ensure 1301 that this does not raise a "has no IMPLICIT type" error. */ 1302 if (sym->ts.type == BT_UNKNOWN) 1303 sym->attr.untyped = 1; 1304 1305 (*result)->ts = sym->ts; 1306 1307 /* Put the symbol in the procedure namespace so that, should 1308 the ENTRY precede its specification, the specification 1309 can be applied. */ 1310 (*result)->ns = gfc_current_ns; 1311 1312 gfc_find_sym_tree (name, gfc_current_ns, 0, &st); 1313 st->n.sym = *result; 1314 st = gfc_get_unique_symtree (gfc_current_ns); 1315 sym->refs++; 1316 st->n.sym = sym; 1317 } 1318 } 1319 else 1320 rc = gfc_get_symbol (name, gfc_current_ns->parent, result); 1321 1322 if (rc) 1323 return rc; 1324 1325 sym = *result; 1326 if (sym->attr.proc == PROC_ST_FUNCTION) 1327 return rc; 1328 1329 if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) 1330 { 1331 /* Create a partially populated interface symbol to carry the 1332 characteristics of the procedure and the result. */ 1333 sym->tlink = gfc_new_symbol (name, sym->ns); 1334 gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); 1335 gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL); 1336 if (sym->attr.dimension) 1337 sym->tlink->as = gfc_copy_array_spec (sym->as); 1338 1339 /* Ideally, at this point, a copy would be made of the formal 1340 arguments and their namespace. However, this does not appear 1341 to be necessary, albeit at the expense of not being able to 1342 use gfc_compare_interfaces directly. */ 1343 1344 if (sym->result && sym->result != sym) 1345 { 1346 sym->tlink->result = sym->result; 1347 sym->result = NULL; 1348 } 1349 else if (sym->result) 1350 { 1351 sym->tlink->result = sym->tlink; 1352 } 1353 } 1354 else if (sym && !sym->gfc_new 1355 && gfc_current_state () != COMP_INTERFACE) 1356 { 1357 /* Trap another encompassed procedure with the same name. All 1358 these conditions are necessary to avoid picking up an entry 1359 whose name clashes with that of the encompassing procedure; 1360 this is handled using gsymbols to register unique, globally 1361 accessible names. */ 1362 if (sym->attr.flavor != 0 1363 && sym->attr.proc != 0 1364 && (sym->attr.subroutine || sym->attr.function || sym->attr.entry) 1365 && sym->attr.if_source != IFSRC_UNKNOWN) 1366 { 1367 gfc_error_now ("Procedure %qs at %C is already defined at %L", 1368 name, &sym->declared_at); 1369 return true; 1370 } 1371 if (sym->attr.flavor != 0 1372 && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN) 1373 { 1374 gfc_error_now ("Procedure %qs at %C is already defined at %L", 1375 name, &sym->declared_at); 1376 return true; 1377 } 1378 1379 if (sym->attr.external && sym->attr.procedure 1380 && gfc_current_state () == COMP_CONTAINS) 1381 { 1382 gfc_error_now ("Contained procedure %qs at %C clashes with " 1383 "procedure defined at %L", 1384 name, &sym->declared_at); 1385 return true; 1386 } 1387 1388 /* Trap a procedure with a name the same as interface in the 1389 encompassing scope. */ 1390 if (sym->attr.generic != 0 1391 && (sym->attr.subroutine || sym->attr.function) 1392 && !sym->attr.mod_proc) 1393 { 1394 gfc_error_now ("Name %qs at %C is already defined" 1395 " as a generic interface at %L", 1396 name, &sym->declared_at); 1397 return true; 1398 } 1399 1400 /* Trap declarations of attributes in encompassing scope. The 1401 signature for this is that ts.kind is nonzero for no-CLASS 1402 entity. For a CLASS entity, ts.kind is zero. */ 1403 if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS) 1404 && !sym->attr.implicit_type 1405 && sym->attr.proc == 0 1406 && gfc_current_ns->parent != NULL 1407 && sym->attr.access == 0 1408 && !module_fcn_entry) 1409 { 1410 gfc_error_now ("Procedure %qs at %C has an explicit interface " 1411 "from a previous declaration", name); 1412 return true; 1413 } 1414 } 1415 1416 /* C1246 (R1225) MODULE shall appear only in the function-stmt or 1417 subroutine-stmt of a module subprogram or of a nonabstract interface 1418 body that is declared in the scoping unit of a module or submodule. */ 1419 if (sym->attr.external 1420 && (sym->attr.subroutine || sym->attr.function) 1421 && sym->attr.if_source == IFSRC_IFBODY 1422 && !current_attr.module_procedure 1423 && sym->attr.proc == PROC_MODULE 1424 && gfc_state_stack->state == COMP_CONTAINS) 1425 { 1426 gfc_error_now ("Procedure %qs defined in interface body at %L " 1427 "clashes with internal procedure defined at %C", 1428 name, &sym->declared_at); 1429 return true; 1430 } 1431 1432 if (sym && !sym->gfc_new 1433 && sym->attr.flavor != FL_UNKNOWN 1434 && sym->attr.referenced == 0 && sym->attr.subroutine == 1 1435 && gfc_state_stack->state == COMP_CONTAINS 1436 && gfc_state_stack->previous->state == COMP_SUBROUTINE) 1437 { 1438 gfc_error_now ("Procedure %qs at %C is already defined at %L", 1439 name, &sym->declared_at); 1440 return true; 1441 } 1442 1443 if (gfc_current_ns->parent == NULL || *result == NULL) 1444 return rc; 1445 1446 /* Module function entries will already have a symtree in 1447 the current namespace but will need one at module level. */ 1448 if (module_fcn_entry) 1449 { 1450 /* Present if entry is declared to be a module procedure. */ 1451 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st); 1452 if (st == NULL) 1453 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); 1454 } 1455 else 1456 st = gfc_new_symtree (&gfc_current_ns->sym_root, name); 1457 1458 st->n.sym = sym; 1459 sym->refs++; 1460 1461 /* See if the procedure should be a module procedure. */ 1462 1463 if (((sym->ns->proc_name != NULL 1464 && sym->ns->proc_name->attr.flavor == FL_MODULE 1465 && sym->attr.proc != PROC_MODULE) 1466 || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) 1467 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 1468 rc = 2; 1469 1470 return rc; 1471} 1472 1473 1474/* Verify that the given symbol representing a parameter is C 1475 interoperable, by checking to see if it was marked as such after 1476 its declaration. If the given symbol is not interoperable, a 1477 warning is reported, thus removing the need to return the status to 1478 the calling function. The standard does not require the user use 1479 one of the iso_c_binding named constants to declare an 1480 interoperable parameter, but we can't be sure if the param is C 1481 interop or not if the user doesn't. For example, integer(4) may be 1482 legal Fortran, but doesn't have meaning in C. It may interop with 1483 a number of the C types, which causes a problem because the 1484 compiler can't know which one. This code is almost certainly not 1485 portable, and the user will get what they deserve if the C type 1486 across platforms isn't always interoperable with integer(4). If 1487 the user had used something like integer(c_int) or integer(c_long), 1488 the compiler could have automatically handled the varying sizes 1489 across platforms. */ 1490 1491bool 1492gfc_verify_c_interop_param (gfc_symbol *sym) 1493{ 1494 int is_c_interop = 0; 1495 bool retval = true; 1496 1497 /* We check implicitly typed variables in symbol.cc:gfc_set_default_type(). 1498 Don't repeat the checks here. */ 1499 if (sym->attr.implicit_type) 1500 return true; 1501 1502 /* For subroutines or functions that are passed to a BIND(C) procedure, 1503 they're interoperable if they're BIND(C) and their params are all 1504 interoperable. */ 1505 if (sym->attr.flavor == FL_PROCEDURE) 1506 { 1507 if (sym->attr.is_bind_c == 0) 1508 { 1509 gfc_error_now ("Procedure %qs at %L must have the BIND(C) " 1510 "attribute to be C interoperable", sym->name, 1511 &(sym->declared_at)); 1512 return false; 1513 } 1514 else 1515 { 1516 if (sym->attr.is_c_interop == 1) 1517 /* We've already checked this procedure; don't check it again. */ 1518 return true; 1519 else 1520 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 1521 sym->common_block); 1522 } 1523 } 1524 1525 /* See if we've stored a reference to a procedure that owns sym. */ 1526 if (sym->ns != NULL && sym->ns->proc_name != NULL) 1527 { 1528 if (sym->ns->proc_name->attr.is_bind_c == 1) 1529 { 1530 is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); 1531 1532 if (is_c_interop != 1) 1533 { 1534 /* Make personalized messages to give better feedback. */ 1535 if (sym->ts.type == BT_DERIVED) 1536 gfc_error ("Variable %qs at %L is a dummy argument to the " 1537 "BIND(C) procedure %qs but is not C interoperable " 1538 "because derived type %qs is not C interoperable", 1539 sym->name, &(sym->declared_at), 1540 sym->ns->proc_name->name, 1541 sym->ts.u.derived->name); 1542 else if (sym->ts.type == BT_CLASS) 1543 gfc_error ("Variable %qs at %L is a dummy argument to the " 1544 "BIND(C) procedure %qs but is not C interoperable " 1545 "because it is polymorphic", 1546 sym->name, &(sym->declared_at), 1547 sym->ns->proc_name->name); 1548 else if (warn_c_binding_type) 1549 gfc_warning (OPT_Wc_binding_type, 1550 "Variable %qs at %L is a dummy argument of the " 1551 "BIND(C) procedure %qs but may not be C " 1552 "interoperable", 1553 sym->name, &(sym->declared_at), 1554 sym->ns->proc_name->name); 1555 } 1556 1557 /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */ 1558 if (sym->attr.pointer && sym->attr.contiguous) 1559 gfc_error ("Dummy argument %qs at %L may not be a pointer with " 1560 "CONTIGUOUS attribute as procedure %qs is BIND(C)", 1561 sym->name, &sym->declared_at, sym->ns->proc_name->name); 1562 1563 /* Per F2018, C1557, pointer/allocatable dummies to a bind(c) 1564 procedure that are default-initialized are not permitted. */ 1565 if ((sym->attr.pointer || sym->attr.allocatable) 1566 && sym->ts.type == BT_DERIVED 1567 && gfc_has_default_initializer (sym->ts.u.derived)) 1568 { 1569 gfc_error ("Default-initialized %s dummy argument %qs " 1570 "at %L is not permitted in BIND(C) procedure %qs", 1571 (sym->attr.pointer ? "pointer" : "allocatable"), 1572 sym->name, &sym->declared_at, 1573 sym->ns->proc_name->name); 1574 retval = false; 1575 } 1576 1577 /* Character strings are only C interoperable if they have a 1578 length of 1. However, as an argument they are also iteroperable 1579 when passed as descriptor (which requires len=: or len=*). */ 1580 if (sym->ts.type == BT_CHARACTER) 1581 { 1582 gfc_charlen *cl = sym->ts.u.cl; 1583 1584 if (sym->attr.allocatable || sym->attr.pointer) 1585 { 1586 /* F2018, 18.3.6 (6). */ 1587 if (!sym->ts.deferred) 1588 { 1589 if (sym->attr.allocatable) 1590 gfc_error ("Allocatable character dummy argument %qs " 1591 "at %L must have deferred length as " 1592 "procedure %qs is BIND(C)", sym->name, 1593 &sym->declared_at, sym->ns->proc_name->name); 1594 else 1595 gfc_error ("Pointer character dummy argument %qs at %L " 1596 "must have deferred length as procedure %qs " 1597 "is BIND(C)", sym->name, &sym->declared_at, 1598 sym->ns->proc_name->name); 1599 retval = false; 1600 } 1601 else if (!gfc_notify_std (GFC_STD_F2018, 1602 "Deferred-length character dummy " 1603 "argument %qs at %L of procedure " 1604 "%qs with BIND(C) attribute", 1605 sym->name, &sym->declared_at, 1606 sym->ns->proc_name->name)) 1607 retval = false; 1608 } 1609 else if (sym->attr.value 1610 && (!cl || !cl->length 1611 || cl->length->expr_type != EXPR_CONSTANT 1612 || mpz_cmp_si (cl->length->value.integer, 1) != 0)) 1613 { 1614 gfc_error ("Character dummy argument %qs at %L must be " 1615 "of length 1 as it has the VALUE attribute", 1616 sym->name, &sym->declared_at); 1617 retval = false; 1618 } 1619 else if (!cl || !cl->length) 1620 { 1621 /* Assumed length; F2018, 18.3.6 (5)(2). 1622 Uses the CFI array descriptor - also for scalars and 1623 explicit-size/assumed-size arrays. */ 1624 if (!gfc_notify_std (GFC_STD_F2018, 1625 "Assumed-length character dummy argument " 1626 "%qs at %L of procedure %qs with BIND(C) " 1627 "attribute", sym->name, &sym->declared_at, 1628 sym->ns->proc_name->name)) 1629 retval = false; 1630 } 1631 else if (cl->length->expr_type != EXPR_CONSTANT 1632 || mpz_cmp_si (cl->length->value.integer, 1) != 0) 1633 { 1634 /* F2018, 18.3.6, (5), item 4. */ 1635 if (!sym->attr.dimension 1636 || sym->as->type == AS_ASSUMED_SIZE 1637 || sym->as->type == AS_EXPLICIT) 1638 { 1639 gfc_error ("Character dummy argument %qs at %L must be " 1640 "of constant length of one or assumed length, " 1641 "unless it has assumed shape or assumed rank, " 1642 "as procedure %qs has the BIND(C) attribute", 1643 sym->name, &sym->declared_at, 1644 sym->ns->proc_name->name); 1645 retval = false; 1646 } 1647 /* else: valid only since F2018 - and an assumed-shape/rank 1648 array; however, gfc_notify_std is already called when 1649 those array types are used. Thus, silently accept F200x. */ 1650 } 1651 } 1652 1653 /* We have to make sure that any param to a bind(c) routine does 1654 not have the allocatable, pointer, or optional attributes, 1655 according to J3/04-007, section 5.1. */ 1656 if (sym->attr.allocatable == 1 1657 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " 1658 "ALLOCATABLE attribute in procedure %qs " 1659 "with BIND(C)", sym->name, 1660 &(sym->declared_at), 1661 sym->ns->proc_name->name)) 1662 retval = false; 1663 1664 if (sym->attr.pointer == 1 1665 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with " 1666 "POINTER attribute in procedure %qs " 1667 "with BIND(C)", sym->name, 1668 &(sym->declared_at), 1669 sym->ns->proc_name->name)) 1670 retval = false; 1671 1672 if (sym->attr.optional == 1 && sym->attr.value) 1673 { 1674 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " 1675 "and the VALUE attribute because procedure %qs " 1676 "is BIND(C)", sym->name, &(sym->declared_at), 1677 sym->ns->proc_name->name); 1678 retval = false; 1679 } 1680 else if (sym->attr.optional == 1 1681 && !gfc_notify_std (GFC_STD_F2018, "Variable %qs " 1682 "at %L with OPTIONAL attribute in " 1683 "procedure %qs which is BIND(C)", 1684 sym->name, &(sym->declared_at), 1685 sym->ns->proc_name->name)) 1686 retval = false; 1687 1688 /* Make sure that if it has the dimension attribute, that it is 1689 either assumed size or explicit shape. Deferred shape is already 1690 covered by the pointer/allocatable attribute. */ 1691 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE 1692 && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs " 1693 "at %L as dummy argument to the BIND(C) " 1694 "procedure %qs at %L", sym->name, 1695 &(sym->declared_at), 1696 sym->ns->proc_name->name, 1697 &(sym->ns->proc_name->declared_at))) 1698 retval = false; 1699 } 1700 } 1701 1702 return retval; 1703} 1704 1705 1706 1707/* Function called by variable_decl() that adds a name to the symbol table. */ 1708 1709static bool 1710build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, 1711 gfc_array_spec **as, locus *var_locus) 1712{ 1713 symbol_attribute attr; 1714 gfc_symbol *sym; 1715 int upper; 1716 gfc_symtree *st; 1717 1718 /* Symbols in a submodule are host associated from the parent module or 1719 submodules. Therefore, they can be overridden by declarations in the 1720 submodule scope. Deal with this by attaching the existing symbol to 1721 a new symtree and recycling the old symtree with a new symbol... */ 1722 st = gfc_find_symtree (gfc_current_ns->sym_root, name); 1723 if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE 1724 && st->n.sym != NULL 1725 && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) 1726 { 1727 gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); 1728 s->n.sym = st->n.sym; 1729 sym = gfc_new_symbol (name, gfc_current_ns); 1730 1731 1732 st->n.sym = sym; 1733 sym->refs++; 1734 gfc_set_sym_referenced (sym); 1735 } 1736 /* ...Otherwise generate a new symtree and new symbol. */ 1737 else if (gfc_get_symbol (name, NULL, &sym)) 1738 return false; 1739 1740 /* Check if the name has already been defined as a type. The 1741 first letter of the symtree will be in upper case then. Of 1742 course, this is only necessary if the upper case letter is 1743 actually different. */ 1744 1745 upper = TOUPPER(name[0]); 1746 if (upper != name[0]) 1747 { 1748 char u_name[GFC_MAX_SYMBOL_LEN + 1]; 1749 gfc_symtree *st; 1750 1751 gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN); 1752 strcpy (u_name, name); 1753 u_name[0] = upper; 1754 1755 st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); 1756 1757 /* STRUCTURE types can alias symbol names */ 1758 if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT) 1759 { 1760 gfc_error ("Symbol %qs at %C also declared as a type at %L", name, 1761 &st->n.sym->declared_at); 1762 return false; 1763 } 1764 } 1765 1766 /* Start updating the symbol table. Add basic type attribute if present. */ 1767 if (current_ts.type != BT_UNKNOWN 1768 && (sym->attr.implicit_type == 0 1769 || !gfc_compare_types (&sym->ts, ¤t_ts)) 1770 && !gfc_add_type (sym, ¤t_ts, var_locus)) 1771 return false; 1772 1773 if (sym->ts.type == BT_CHARACTER) 1774 { 1775 sym->ts.u.cl = cl; 1776 sym->ts.deferred = cl_deferred; 1777 } 1778 1779 /* Add dimension attribute if present. */ 1780 if (!gfc_set_array_spec (sym, *as, var_locus)) 1781 return false; 1782 *as = NULL; 1783 1784 /* Add attribute to symbol. The copy is so that we can reset the 1785 dimension attribute. */ 1786 attr = current_attr; 1787 attr.dimension = 0; 1788 attr.codimension = 0; 1789 1790 if (!gfc_copy_attr (&sym->attr, &attr, var_locus)) 1791 return false; 1792 1793 /* Finish any work that may need to be done for the binding label, 1794 if it's a bind(c). The bind(c) attr is found before the symbol 1795 is made, and before the symbol name (for data decls), so the 1796 current_ts is holding the binding label, or nothing if the 1797 name= attr wasn't given. Therefore, test here if we're dealing 1798 with a bind(c) and make sure the binding label is set correctly. */ 1799 if (sym->attr.is_bind_c == 1) 1800 { 1801 if (!sym->binding_label) 1802 { 1803 /* Set the binding label and verify that if a NAME= was specified 1804 then only one identifier was in the entity-decl-list. */ 1805 if (!set_binding_label (&sym->binding_label, sym->name, 1806 num_idents_on_line)) 1807 return false; 1808 } 1809 } 1810 1811 /* See if we know we're in a common block, and if it's a bind(c) 1812 common then we need to make sure we're an interoperable type. */ 1813 if (sym->attr.in_common == 1) 1814 { 1815 /* Test the common block object. */ 1816 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1 1817 && sym->ts.is_c_interop != 1) 1818 { 1819 gfc_error_now ("Variable %qs in common block %qs at %C " 1820 "must be declared with a C interoperable " 1821 "kind since common block %qs is BIND(C)", 1822 sym->name, sym->common_block->name, 1823 sym->common_block->name); 1824 gfc_clear_error (); 1825 } 1826 } 1827 1828 sym->attr.implied_index = 0; 1829 1830 /* Use the parameter expressions for a parameterized derived type. */ 1831 if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) 1832 && sym->ts.u.derived->attr.pdt_type && type_param_spec_list) 1833 sym->param_list = gfc_copy_actual_arglist (type_param_spec_list); 1834 1835 if (sym->ts.type == BT_CLASS) 1836 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); 1837 1838 return true; 1839} 1840 1841 1842/* Set character constant to the given length. The constant will be padded or 1843 truncated. If we're inside an array constructor without a typespec, we 1844 additionally check that all elements have the same length; check_len -1 1845 means no checking. */ 1846 1847void 1848gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr, 1849 gfc_charlen_t check_len) 1850{ 1851 gfc_char_t *s; 1852 gfc_charlen_t slen; 1853 1854 if (expr->ts.type != BT_CHARACTER) 1855 return; 1856 1857 if (expr->expr_type != EXPR_CONSTANT) 1858 { 1859 gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where); 1860 return; 1861 } 1862 1863 slen = expr->value.character.length; 1864 if (len != slen) 1865 { 1866 s = gfc_get_wide_string (len + 1); 1867 memcpy (s, expr->value.character.string, 1868 MIN (len, slen) * sizeof (gfc_char_t)); 1869 if (len > slen) 1870 gfc_wide_memset (&s[slen], ' ', len - slen); 1871 1872 if (warn_character_truncation && slen > len) 1873 gfc_warning_now (OPT_Wcharacter_truncation, 1874 "CHARACTER expression at %L is being truncated " 1875 "(%ld/%ld)", &expr->where, 1876 (long) slen, (long) len); 1877 1878 /* Apply the standard by 'hand' otherwise it gets cleared for 1879 initializers. */ 1880 if (check_len != -1 && slen != check_len 1881 && !(gfc_option.allow_std & GFC_STD_GNU)) 1882 gfc_error_now ("The CHARACTER elements of the array constructor " 1883 "at %L must have the same length (%ld/%ld)", 1884 &expr->where, (long) slen, 1885 (long) check_len); 1886 1887 s[len] = '\0'; 1888 free (expr->value.character.string); 1889 expr->value.character.string = s; 1890 expr->value.character.length = len; 1891 /* If explicit representation was given, clear it 1892 as it is no longer needed after padding. */ 1893 if (expr->representation.length) 1894 { 1895 expr->representation.length = 0; 1896 free (expr->representation.string); 1897 expr->representation.string = NULL; 1898 } 1899 } 1900} 1901 1902 1903/* Function to create and update the enumerator history 1904 using the information passed as arguments. 1905 Pointer "max_enum" is also updated, to point to 1906 enum history node containing largest initializer. 1907 1908 SYM points to the symbol node of enumerator. 1909 INIT points to its enumerator value. */ 1910 1911static void 1912create_enum_history (gfc_symbol *sym, gfc_expr *init) 1913{ 1914 enumerator_history *new_enum_history; 1915 gcc_assert (sym != NULL && init != NULL); 1916 1917 new_enum_history = XCNEW (enumerator_history); 1918 1919 new_enum_history->sym = sym; 1920 new_enum_history->initializer = init; 1921 new_enum_history->next = NULL; 1922 1923 if (enum_history == NULL) 1924 { 1925 enum_history = new_enum_history; 1926 max_enum = enum_history; 1927 } 1928 else 1929 { 1930 new_enum_history->next = enum_history; 1931 enum_history = new_enum_history; 1932 1933 if (mpz_cmp (max_enum->initializer->value.integer, 1934 new_enum_history->initializer->value.integer) < 0) 1935 max_enum = new_enum_history; 1936 } 1937} 1938 1939 1940/* Function to free enum kind history. */ 1941 1942void 1943gfc_free_enum_history (void) 1944{ 1945 enumerator_history *current = enum_history; 1946 enumerator_history *next; 1947 1948 while (current != NULL) 1949 { 1950 next = current->next; 1951 free (current); 1952 current = next; 1953 } 1954 max_enum = NULL; 1955 enum_history = NULL; 1956} 1957 1958 1959/* Function called by variable_decl() that adds an initialization 1960 expression to a symbol. */ 1961 1962static bool 1963add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) 1964{ 1965 symbol_attribute attr; 1966 gfc_symbol *sym; 1967 gfc_expr *init; 1968 1969 init = *initp; 1970 if (find_special (name, &sym, false)) 1971 return false; 1972 1973 attr = sym->attr; 1974 1975 /* If this symbol is confirming an implicit parameter type, 1976 then an initialization expression is not allowed. */ 1977 if (attr.flavor == FL_PARAMETER && sym->value != NULL) 1978 { 1979 if (*initp != NULL) 1980 { 1981 gfc_error ("Initializer not allowed for PARAMETER %qs at %C", 1982 sym->name); 1983 return false; 1984 } 1985 else 1986 return true; 1987 } 1988 1989 if (init == NULL) 1990 { 1991 /* An initializer is required for PARAMETER declarations. */ 1992 if (attr.flavor == FL_PARAMETER) 1993 { 1994 gfc_error ("PARAMETER at %L is missing an initializer", var_locus); 1995 return false; 1996 } 1997 } 1998 else 1999 { 2000 /* If a variable appears in a DATA block, it cannot have an 2001 initializer. */ 2002 if (sym->attr.data) 2003 { 2004 gfc_error ("Variable %qs at %C with an initializer already " 2005 "appears in a DATA statement", sym->name); 2006 return false; 2007 } 2008 2009 /* Check if the assignment can happen. This has to be put off 2010 until later for derived type variables and procedure pointers. */ 2011 if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type) 2012 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS 2013 && !sym->attr.proc_pointer 2014 && !gfc_check_assign_symbol (sym, NULL, init)) 2015 return false; 2016 2017 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl 2018 && init->ts.type == BT_CHARACTER) 2019 { 2020 /* Update symbol character length according initializer. */ 2021 if (!gfc_check_assign_symbol (sym, NULL, init)) 2022 return false; 2023 2024 if (sym->ts.u.cl->length == NULL) 2025 { 2026 gfc_charlen_t clen; 2027 /* If there are multiple CHARACTER variables declared on the 2028 same line, we don't want them to share the same length. */ 2029 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 2030 2031 if (sym->attr.flavor == FL_PARAMETER) 2032 { 2033 if (init->expr_type == EXPR_CONSTANT) 2034 { 2035 clen = init->value.character.length; 2036 sym->ts.u.cl->length 2037 = gfc_get_int_expr (gfc_charlen_int_kind, 2038 NULL, clen); 2039 } 2040 else if (init->expr_type == EXPR_ARRAY) 2041 { 2042 if (init->ts.u.cl && init->ts.u.cl->length) 2043 { 2044 const gfc_expr *length = init->ts.u.cl->length; 2045 if (length->expr_type != EXPR_CONSTANT) 2046 { 2047 gfc_error ("Cannot initialize parameter array " 2048 "at %L " 2049 "with variable length elements", 2050 &sym->declared_at); 2051 return false; 2052 } 2053 clen = mpz_get_si (length->value.integer); 2054 } 2055 else if (init->value.constructor) 2056 { 2057 gfc_constructor *c; 2058 c = gfc_constructor_first (init->value.constructor); 2059 clen = c->expr->value.character.length; 2060 } 2061 else 2062 gcc_unreachable (); 2063 sym->ts.u.cl->length 2064 = gfc_get_int_expr (gfc_charlen_int_kind, 2065 NULL, clen); 2066 } 2067 else if (init->ts.u.cl && init->ts.u.cl->length) 2068 sym->ts.u.cl->length = 2069 gfc_copy_expr (init->ts.u.cl->length); 2070 } 2071 } 2072 /* Update initializer character length according symbol. */ 2073 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 2074 { 2075 if (!gfc_specification_expr (sym->ts.u.cl->length)) 2076 return false; 2077 2078 int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, 2079 false); 2080 /* resolve_charlen will complain later on if the length 2081 is too large. Just skeep the initialization in that case. */ 2082 if (mpz_cmp (sym->ts.u.cl->length->value.integer, 2083 gfc_integer_kinds[k].huge) <= 0) 2084 { 2085 HOST_WIDE_INT len 2086 = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer); 2087 2088 if (init->expr_type == EXPR_CONSTANT) 2089 gfc_set_constant_character_len (len, init, -1); 2090 else if (init->expr_type == EXPR_ARRAY) 2091 { 2092 gfc_constructor *c; 2093 2094 /* Build a new charlen to prevent simplification from 2095 deleting the length before it is resolved. */ 2096 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 2097 init->ts.u.cl->length 2098 = gfc_copy_expr (sym->ts.u.cl->length); 2099 2100 for (c = gfc_constructor_first (init->value.constructor); 2101 c; c = gfc_constructor_next (c)) 2102 gfc_set_constant_character_len (len, c->expr, -1); 2103 } 2104 } 2105 } 2106 } 2107 2108 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as 2109 && sym->as->rank && init->rank && init->rank != sym->as->rank) 2110 { 2111 gfc_error ("Rank mismatch of array at %L and its initializer " 2112 "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank); 2113 return false; 2114 } 2115 2116 /* If sym is implied-shape, set its upper bounds from init. */ 2117 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension 2118 && sym->as->type == AS_IMPLIED_SHAPE) 2119 { 2120 int dim; 2121 2122 if (init->rank == 0) 2123 { 2124 gfc_error ("Cannot initialize implied-shape array at %L" 2125 " with scalar", &sym->declared_at); 2126 return false; 2127 } 2128 2129 /* The shape may be NULL for EXPR_ARRAY, set it. */ 2130 if (init->shape == NULL) 2131 { 2132 if (init->expr_type != EXPR_ARRAY) 2133 { 2134 gfc_error ("Bad shape of initializer at %L", &init->where); 2135 return false; 2136 } 2137 2138 init->shape = gfc_get_shape (1); 2139 if (!gfc_array_size (init, &init->shape[0])) 2140 { 2141 gfc_error ("Cannot determine shape of initializer at %L", 2142 &init->where); 2143 free (init->shape); 2144 init->shape = NULL; 2145 return false; 2146 } 2147 } 2148 2149 for (dim = 0; dim < sym->as->rank; ++dim) 2150 { 2151 int k; 2152 gfc_expr *e, *lower; 2153 2154 lower = sym->as->lower[dim]; 2155 2156 /* If the lower bound is an array element from another 2157 parameterized array, then it is marked with EXPR_VARIABLE and 2158 is an initialization expression. Try to reduce it. */ 2159 if (lower->expr_type == EXPR_VARIABLE) 2160 gfc_reduce_init_expr (lower); 2161 2162 if (lower->expr_type == EXPR_CONSTANT) 2163 { 2164 /* All dimensions must be without upper bound. */ 2165 gcc_assert (!sym->as->upper[dim]); 2166 2167 k = lower->ts.kind; 2168 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); 2169 mpz_add (e->value.integer, lower->value.integer, 2170 init->shape[dim]); 2171 mpz_sub_ui (e->value.integer, e->value.integer, 1); 2172 sym->as->upper[dim] = e; 2173 } 2174 else 2175 { 2176 gfc_error ("Non-constant lower bound in implied-shape" 2177 " declaration at %L", &lower->where); 2178 return false; 2179 } 2180 } 2181 2182 sym->as->type = AS_EXPLICIT; 2183 } 2184 2185 /* Ensure that explicit bounds are simplified. */ 2186 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension 2187 && sym->as->type == AS_EXPLICIT) 2188 { 2189 for (int dim = 0; dim < sym->as->rank; ++dim) 2190 { 2191 gfc_expr *e; 2192 2193 e = sym->as->lower[dim]; 2194 if (e->expr_type != EXPR_CONSTANT) 2195 gfc_reduce_init_expr (e); 2196 2197 e = sym->as->upper[dim]; 2198 if (e->expr_type != EXPR_CONSTANT) 2199 gfc_reduce_init_expr (e); 2200 } 2201 } 2202 2203 /* Need to check if the expression we initialized this 2204 to was one of the iso_c_binding named constants. If so, 2205 and we're a parameter (constant), let it be iso_c. 2206 For example: 2207 integer(c_int), parameter :: my_int = c_int 2208 integer(my_int) :: my_int_2 2209 If we mark my_int as iso_c (since we can see it's value 2210 is equal to one of the named constants), then my_int_2 2211 will be considered C interoperable. */ 2212 if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)) 2213 { 2214 sym->ts.is_iso_c |= init->ts.is_iso_c; 2215 sym->ts.is_c_interop |= init->ts.is_c_interop; 2216 /* attr bits needed for module files. */ 2217 sym->attr.is_iso_c |= init->ts.is_iso_c; 2218 sym->attr.is_c_interop |= init->ts.is_c_interop; 2219 if (init->ts.is_iso_c) 2220 sym->ts.f90_type = init->ts.f90_type; 2221 } 2222 2223 /* Add initializer. Make sure we keep the ranks sane. */ 2224 if (sym->attr.dimension && init->rank == 0) 2225 { 2226 mpz_t size; 2227 gfc_expr *array; 2228 int n; 2229 if (sym->attr.flavor == FL_PARAMETER 2230 && gfc_is_constant_expr (init) 2231 && (init->expr_type == EXPR_CONSTANT 2232 || init->expr_type == EXPR_STRUCTURE) 2233 && spec_size (sym->as, &size) 2234 && mpz_cmp_si (size, 0) > 0) 2235 { 2236 array = gfc_get_array_expr (init->ts.type, init->ts.kind, 2237 &init->where); 2238 if (init->ts.type == BT_DERIVED) 2239 array->ts.u.derived = init->ts.u.derived; 2240 for (n = 0; n < (int)mpz_get_si (size); n++) 2241 gfc_constructor_append_expr (&array->value.constructor, 2242 n == 0 2243 ? init 2244 : gfc_copy_expr (init), 2245 &init->where); 2246 2247 array->shape = gfc_get_shape (sym->as->rank); 2248 for (n = 0; n < sym->as->rank; n++) 2249 spec_dimen_size (sym->as, n, &array->shape[n]); 2250 2251 init = array; 2252 mpz_clear (size); 2253 } 2254 init->rank = sym->as->rank; 2255 } 2256 2257 sym->value = init; 2258 if (sym->attr.save == SAVE_NONE) 2259 sym->attr.save = SAVE_IMPLICIT; 2260 *initp = NULL; 2261 } 2262 2263 return true; 2264} 2265 2266 2267/* Function called by variable_decl() that adds a name to a structure 2268 being built. */ 2269 2270static bool 2271build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, 2272 gfc_array_spec **as) 2273{ 2274 gfc_state_data *s; 2275 gfc_component *c; 2276 2277 /* F03:C438/C439. If the current symbol is of the same derived type that we're 2278 constructing, it must have the pointer attribute. */ 2279 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 2280 && current_ts.u.derived == gfc_current_block () 2281 && current_attr.pointer == 0) 2282 { 2283 if (current_attr.allocatable 2284 && !gfc_notify_std(GFC_STD_F2008, "Component at %C " 2285 "must have the POINTER attribute")) 2286 { 2287 return false; 2288 } 2289 else if (current_attr.allocatable == 0) 2290 { 2291 gfc_error ("Component at %C must have the POINTER attribute"); 2292 return false; 2293 } 2294 } 2295 2296 /* F03:C437. */ 2297 if (current_ts.type == BT_CLASS 2298 && !(current_attr.pointer || current_attr.allocatable)) 2299 { 2300 gfc_error ("Component %qs with CLASS at %C must be allocatable " 2301 "or pointer", name); 2302 return false; 2303 } 2304 2305 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0) 2306 { 2307 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) 2308 { 2309 gfc_error ("Array component of structure at %C must have explicit " 2310 "or deferred shape"); 2311 return false; 2312 } 2313 } 2314 2315 /* If we are in a nested union/map definition, gfc_add_component will not 2316 properly find repeated components because: 2317 (i) gfc_add_component does a flat search, where components of unions 2318 and maps are implicity chained so nested components may conflict. 2319 (ii) Unions and maps are not linked as components of their parent 2320 structures until after they are parsed. 2321 For (i) we use gfc_find_component which searches recursively, and for (ii) 2322 we search each block directly from the parse stack until we find the top 2323 level structure. */ 2324 2325 s = gfc_state_stack; 2326 if (s->state == COMP_UNION || s->state == COMP_MAP) 2327 { 2328 while (s->state == COMP_UNION || gfc_comp_struct (s->state)) 2329 { 2330 c = gfc_find_component (s->sym, name, true, true, NULL); 2331 if (c != NULL) 2332 { 2333 gfc_error_now ("Component %qs at %C already declared at %L", 2334 name, &c->loc); 2335 return false; 2336 } 2337 /* Break after we've searched the entire chain. */ 2338 if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE) 2339 break; 2340 s = s->previous; 2341 } 2342 } 2343 2344 if (!gfc_add_component (gfc_current_block(), name, &c)) 2345 return false; 2346 2347 c->ts = current_ts; 2348 if (c->ts.type == BT_CHARACTER) 2349 c->ts.u.cl = cl; 2350 2351 if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED 2352 && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER) 2353 && saved_kind_expr != NULL) 2354 c->kind_expr = gfc_copy_expr (saved_kind_expr); 2355 2356 c->attr = current_attr; 2357 2358 c->initializer = *init; 2359 *init = NULL; 2360 2361 c->as = *as; 2362 if (c->as != NULL) 2363 { 2364 if (c->as->corank) 2365 c->attr.codimension = 1; 2366 if (c->as->rank) 2367 c->attr.dimension = 1; 2368 } 2369 *as = NULL; 2370 2371 gfc_apply_init (&c->ts, &c->attr, c->initializer); 2372 2373 /* Check array components. */ 2374 if (!c->attr.dimension) 2375 goto scalar; 2376 2377 if (c->attr.pointer) 2378 { 2379 if (c->as->type != AS_DEFERRED) 2380 { 2381 gfc_error ("Pointer array component of structure at %C must have a " 2382 "deferred shape"); 2383 return false; 2384 } 2385 } 2386 else if (c->attr.allocatable) 2387 { 2388 if (c->as->type != AS_DEFERRED) 2389 { 2390 gfc_error ("Allocatable component of structure at %C must have a " 2391 "deferred shape"); 2392 return false; 2393 } 2394 } 2395 else 2396 { 2397 if (c->as->type != AS_EXPLICIT) 2398 { 2399 gfc_error ("Array component of structure at %C must have an " 2400 "explicit shape"); 2401 return false; 2402 } 2403 } 2404 2405scalar: 2406 if (c->ts.type == BT_CLASS) 2407 return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); 2408 2409 if (c->attr.pdt_kind || c->attr.pdt_len) 2410 { 2411 gfc_symbol *sym; 2412 gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived, 2413 0, &sym); 2414 if (sym == NULL) 2415 { 2416 gfc_error ("Type parameter %qs at %C has no corresponding entry " 2417 "in the type parameter name list at %L", 2418 c->name, &gfc_current_block ()->declared_at); 2419 return false; 2420 } 2421 sym->ts = c->ts; 2422 sym->attr.pdt_kind = c->attr.pdt_kind; 2423 sym->attr.pdt_len = c->attr.pdt_len; 2424 if (c->initializer) 2425 sym->value = gfc_copy_expr (c->initializer); 2426 sym->attr.flavor = FL_VARIABLE; 2427 } 2428 2429 if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) 2430 && c->ts.u.derived && c->ts.u.derived->attr.pdt_template 2431 && decl_type_param_list) 2432 c->param_list = gfc_copy_actual_arglist (decl_type_param_list); 2433 2434 return true; 2435} 2436 2437 2438/* Match a 'NULL()', and possibly take care of some side effects. */ 2439 2440match 2441gfc_match_null (gfc_expr **result) 2442{ 2443 gfc_symbol *sym; 2444 match m, m2 = MATCH_NO; 2445 2446 if ((m = gfc_match (" null ( )")) == MATCH_ERROR) 2447 return MATCH_ERROR; 2448 2449 if (m == MATCH_NO) 2450 { 2451 locus old_loc; 2452 char name[GFC_MAX_SYMBOL_LEN + 1]; 2453 2454 if ((m2 = gfc_match (" null (")) != MATCH_YES) 2455 return m2; 2456 2457 old_loc = gfc_current_locus; 2458 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR) 2459 return MATCH_ERROR; 2460 if (m2 != MATCH_YES 2461 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR)) 2462 return MATCH_ERROR; 2463 if (m2 == MATCH_NO) 2464 { 2465 gfc_current_locus = old_loc; 2466 return MATCH_NO; 2467 } 2468 } 2469 2470 /* The NULL symbol now has to be/become an intrinsic function. */ 2471 if (gfc_get_symbol ("null", NULL, &sym)) 2472 { 2473 gfc_error ("NULL() initialization at %C is ambiguous"); 2474 return MATCH_ERROR; 2475 } 2476 2477 gfc_intrinsic_symbol (sym); 2478 2479 if (sym->attr.proc != PROC_INTRINSIC 2480 && !(sym->attr.use_assoc && sym->attr.intrinsic) 2481 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL) 2482 || !gfc_add_function (&sym->attr, sym->name, NULL))) 2483 return MATCH_ERROR; 2484 2485 *result = gfc_get_null_expr (&gfc_current_locus); 2486 2487 /* Invalid per F2008, C512. */ 2488 if (m2 == MATCH_YES) 2489 { 2490 gfc_error ("NULL() initialization at %C may not have MOLD"); 2491 return MATCH_ERROR; 2492 } 2493 2494 return MATCH_YES; 2495} 2496 2497 2498/* Match the initialization expr for a data pointer or procedure pointer. */ 2499 2500static match 2501match_pointer_init (gfc_expr **init, int procptr) 2502{ 2503 match m; 2504 2505 if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state)) 2506 { 2507 gfc_error ("Initialization of pointer at %C is not allowed in " 2508 "a PURE procedure"); 2509 return MATCH_ERROR; 2510 } 2511 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 2512 2513 /* Match NULL() initialization. */ 2514 m = gfc_match_null (init); 2515 if (m != MATCH_NO) 2516 return m; 2517 2518 /* Match non-NULL initialization. */ 2519 gfc_matching_ptr_assignment = !procptr; 2520 gfc_matching_procptr_assignment = procptr; 2521 m = gfc_match_rvalue (init); 2522 gfc_matching_ptr_assignment = 0; 2523 gfc_matching_procptr_assignment = 0; 2524 if (m == MATCH_ERROR) 2525 return MATCH_ERROR; 2526 else if (m == MATCH_NO) 2527 { 2528 gfc_error ("Error in pointer initialization at %C"); 2529 return MATCH_ERROR; 2530 } 2531 2532 if (!procptr && !gfc_resolve_expr (*init)) 2533 return MATCH_ERROR; 2534 2535 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " 2536 "initialization at %C")) 2537 return MATCH_ERROR; 2538 2539 return MATCH_YES; 2540} 2541 2542 2543static bool 2544check_function_name (char *name) 2545{ 2546 /* In functions that have a RESULT variable defined, the function name always 2547 refers to function calls. Therefore, the name is not allowed to appear in 2548 specification statements. When checking this, be careful about 2549 'hidden' procedure pointer results ('ppr@'). */ 2550 2551 if (gfc_current_state () == COMP_FUNCTION) 2552 { 2553 gfc_symbol *block = gfc_current_block (); 2554 if (block && block->result && block->result != block 2555 && strcmp (block->result->name, "ppr@") != 0 2556 && strcmp (block->name, name) == 0) 2557 { 2558 gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C " 2559 "from appearing in a specification statement", 2560 block->result->name, &block->result->declared_at, name); 2561 return false; 2562 } 2563 } 2564 2565 return true; 2566} 2567 2568 2569/* Match a variable name with an optional initializer. When this 2570 subroutine is called, a variable is expected to be parsed next. 2571 Depending on what is happening at the moment, updates either the 2572 symbol table or the current interface. */ 2573 2574static match 2575variable_decl (int elem) 2576{ 2577 char name[GFC_MAX_SYMBOL_LEN + 1]; 2578 static unsigned int fill_id = 0; 2579 gfc_expr *initializer, *char_len; 2580 gfc_array_spec *as; 2581 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ 2582 gfc_charlen *cl; 2583 bool cl_deferred; 2584 locus var_locus; 2585 match m; 2586 bool t; 2587 gfc_symbol *sym; 2588 char c; 2589 2590 initializer = NULL; 2591 as = NULL; 2592 cp_as = NULL; 2593 2594 /* When we get here, we've just matched a list of attributes and 2595 maybe a type and a double colon. The next thing we expect to see 2596 is the name of the symbol. */ 2597 2598 /* If we are parsing a structure with legacy support, we allow the symbol 2599 name to be '%FILL' which gives it an anonymous (inaccessible) name. */ 2600 m = MATCH_NO; 2601 gfc_gobble_whitespace (); 2602 c = gfc_peek_ascii_char (); 2603 if (c == '%') 2604 { 2605 gfc_next_ascii_char (); /* Burn % character. */ 2606 m = gfc_match ("fill"); 2607 if (m == MATCH_YES) 2608 { 2609 if (gfc_current_state () != COMP_STRUCTURE) 2610 { 2611 if (flag_dec_structure) 2612 gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL"); 2613 else 2614 gfc_error ("%qs at %C is a DEC extension, enable with " 2615 "%<-fdec-structure%>", "%FILL"); 2616 m = MATCH_ERROR; 2617 goto cleanup; 2618 } 2619 2620 if (attr_seen) 2621 { 2622 gfc_error ("%qs entity cannot have attributes at %C", "%FILL"); 2623 m = MATCH_ERROR; 2624 goto cleanup; 2625 } 2626 2627 /* %FILL components are given invalid fortran names. */ 2628 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++); 2629 } 2630 else 2631 { 2632 gfc_error ("Invalid character %qc in variable name at %C", c); 2633 return MATCH_ERROR; 2634 } 2635 } 2636 else 2637 { 2638 m = gfc_match_name (name); 2639 if (m != MATCH_YES) 2640 goto cleanup; 2641 } 2642 2643 var_locus = gfc_current_locus; 2644 2645 /* Now we could see the optional array spec. or character length. */ 2646 m = gfc_match_array_spec (&as, true, true); 2647 if (m == MATCH_ERROR) 2648 goto cleanup; 2649 2650 if (m == MATCH_NO) 2651 as = gfc_copy_array_spec (current_as); 2652 else if (current_as 2653 && !merge_array_spec (current_as, as, true)) 2654 { 2655 m = MATCH_ERROR; 2656 goto cleanup; 2657 } 2658 2659 if (flag_cray_pointer) 2660 cp_as = gfc_copy_array_spec (as); 2661 2662 /* At this point, we know for sure if the symbol is PARAMETER and can thus 2663 determine (and check) whether it can be implied-shape. If it 2664 was parsed as assumed-size, change it because PARAMETERs cannot 2665 be assumed-size. 2666 2667 An explicit-shape-array cannot appear under several conditions. 2668 That check is done here as well. */ 2669 if (as) 2670 { 2671 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) 2672 { 2673 m = MATCH_ERROR; 2674 gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape", 2675 name, &var_locus); 2676 goto cleanup; 2677 } 2678 2679 if (as->type == AS_ASSUMED_SIZE && as->rank == 1 2680 && current_attr.flavor == FL_PARAMETER) 2681 as->type = AS_IMPLIED_SHAPE; 2682 2683 if (as->type == AS_IMPLIED_SHAPE 2684 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", 2685 &var_locus)) 2686 { 2687 m = MATCH_ERROR; 2688 goto cleanup; 2689 } 2690 2691 gfc_seen_div0 = false; 2692 2693 /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not 2694 constant expressions shall appear only in a subprogram, derived 2695 type definition, BLOCK construct, or interface body. */ 2696 if (as->type == AS_EXPLICIT 2697 && gfc_current_state () != COMP_BLOCK 2698 && gfc_current_state () != COMP_DERIVED 2699 && gfc_current_state () != COMP_FUNCTION 2700 && gfc_current_state () != COMP_INTERFACE 2701 && gfc_current_state () != COMP_SUBROUTINE) 2702 { 2703 gfc_expr *e; 2704 bool not_constant = false; 2705 2706 for (int i = 0; i < as->rank; i++) 2707 { 2708 e = gfc_copy_expr (as->lower[i]); 2709 if (!gfc_resolve_expr (e) && gfc_seen_div0) 2710 { 2711 m = MATCH_ERROR; 2712 goto cleanup; 2713 } 2714 2715 gfc_simplify_expr (e, 0); 2716 if (e && (e->expr_type != EXPR_CONSTANT)) 2717 { 2718 not_constant = true; 2719 break; 2720 } 2721 gfc_free_expr (e); 2722 2723 e = gfc_copy_expr (as->upper[i]); 2724 if (!gfc_resolve_expr (e) && gfc_seen_div0) 2725 { 2726 m = MATCH_ERROR; 2727 goto cleanup; 2728 } 2729 2730 gfc_simplify_expr (e, 0); 2731 if (e && (e->expr_type != EXPR_CONSTANT)) 2732 { 2733 not_constant = true; 2734 break; 2735 } 2736 gfc_free_expr (e); 2737 } 2738 2739 if (not_constant && e->ts.type != BT_INTEGER) 2740 { 2741 gfc_error ("Explicit array shape at %C must be constant of " 2742 "INTEGER type and not %s type", 2743 gfc_basic_typename (e->ts.type)); 2744 m = MATCH_ERROR; 2745 goto cleanup; 2746 } 2747 if (not_constant) 2748 { 2749 gfc_error ("Explicit shaped array with nonconstant bounds at %C"); 2750 m = MATCH_ERROR; 2751 goto cleanup; 2752 } 2753 } 2754 if (as->type == AS_EXPLICIT) 2755 { 2756 for (int i = 0; i < as->rank; i++) 2757 { 2758 gfc_expr *e, *n; 2759 e = as->lower[i]; 2760 if (e->expr_type != EXPR_CONSTANT) 2761 { 2762 n = gfc_copy_expr (e); 2763 if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) 2764 { 2765 m = MATCH_ERROR; 2766 goto cleanup; 2767 } 2768 2769 if (n->expr_type == EXPR_CONSTANT) 2770 gfc_replace_expr (e, n); 2771 else 2772 gfc_free_expr (n); 2773 } 2774 e = as->upper[i]; 2775 if (e->expr_type != EXPR_CONSTANT) 2776 { 2777 n = gfc_copy_expr (e); 2778 if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) 2779 { 2780 m = MATCH_ERROR; 2781 goto cleanup; 2782 } 2783 2784 if (n->expr_type == EXPR_CONSTANT) 2785 gfc_replace_expr (e, n); 2786 else 2787 gfc_free_expr (n); 2788 } 2789 /* For an explicit-shape spec with constant bounds, ensure 2790 that the effective upper bound is not lower than the 2791 respective lower bound minus one. Otherwise adjust it so 2792 that the extent is trivially derived to be zero. */ 2793 if (as->lower[i]->expr_type == EXPR_CONSTANT 2794 && as->upper[i]->expr_type == EXPR_CONSTANT 2795 && as->lower[i]->ts.type == BT_INTEGER 2796 && as->upper[i]->ts.type == BT_INTEGER 2797 && mpz_cmp (as->upper[i]->value.integer, 2798 as->lower[i]->value.integer) < 0) 2799 mpz_sub_ui (as->upper[i]->value.integer, 2800 as->lower[i]->value.integer, 1); 2801 } 2802 } 2803 } 2804 2805 char_len = NULL; 2806 cl = NULL; 2807 cl_deferred = false; 2808 2809 if (current_ts.type == BT_CHARACTER) 2810 { 2811 switch (match_char_length (&char_len, &cl_deferred, false)) 2812 { 2813 case MATCH_YES: 2814 cl = gfc_new_charlen (gfc_current_ns, NULL); 2815 2816 cl->length = char_len; 2817 break; 2818 2819 /* Non-constant lengths need to be copied after the first 2820 element. Also copy assumed lengths. */ 2821 case MATCH_NO: 2822 if (elem > 1 2823 && (current_ts.u.cl->length == NULL 2824 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) 2825 { 2826 cl = gfc_new_charlen (gfc_current_ns, NULL); 2827 cl->length = gfc_copy_expr (current_ts.u.cl->length); 2828 } 2829 else 2830 cl = current_ts.u.cl; 2831 2832 cl_deferred = current_ts.deferred; 2833 2834 break; 2835 2836 case MATCH_ERROR: 2837 goto cleanup; 2838 } 2839 } 2840 2841 /* The dummy arguments and result of the abreviated form of MODULE 2842 PROCEDUREs, used in SUBMODULES should not be redefined. */ 2843 if (gfc_current_ns->proc_name 2844 && gfc_current_ns->proc_name->abr_modproc_decl) 2845 { 2846 gfc_find_symbol (name, gfc_current_ns, 1, &sym); 2847 if (sym != NULL && (sym->attr.dummy || sym->attr.result)) 2848 { 2849 m = MATCH_ERROR; 2850 gfc_error ("%qs at %C is a redefinition of the declaration " 2851 "in the corresponding interface for MODULE " 2852 "PROCEDURE %qs", sym->name, 2853 gfc_current_ns->proc_name->name); 2854 goto cleanup; 2855 } 2856 } 2857 2858 /* %FILL components may not have initializers. */ 2859 if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) 2860 { 2861 gfc_error ("%qs entity cannot have an initializer at %C", "%FILL"); 2862 m = MATCH_ERROR; 2863 goto cleanup; 2864 } 2865 2866 /* If this symbol has already shown up in a Cray Pointer declaration, 2867 and this is not a component declaration, 2868 then we want to set the type & bail out. */ 2869 if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())) 2870 { 2871 gfc_find_symbol (name, gfc_current_ns, 0, &sym); 2872 if (sym != NULL && sym->attr.cray_pointee) 2873 { 2874 m = MATCH_YES; 2875 if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) 2876 { 2877 m = MATCH_ERROR; 2878 goto cleanup; 2879 } 2880 2881 /* Check to see if we have an array specification. */ 2882 if (cp_as != NULL) 2883 { 2884 if (sym->as != NULL) 2885 { 2886 gfc_error ("Duplicate array spec for Cray pointee at %C"); 2887 gfc_free_array_spec (cp_as); 2888 m = MATCH_ERROR; 2889 goto cleanup; 2890 } 2891 else 2892 { 2893 if (!gfc_set_array_spec (sym, cp_as, &var_locus)) 2894 gfc_internal_error ("Cannot set pointee array spec."); 2895 2896 /* Fix the array spec. */ 2897 m = gfc_mod_pointee_as (sym->as); 2898 if (m == MATCH_ERROR) 2899 goto cleanup; 2900 } 2901 } 2902 goto cleanup; 2903 } 2904 else 2905 { 2906 gfc_free_array_spec (cp_as); 2907 } 2908 } 2909 2910 /* Procedure pointer as function result. */ 2911 if (gfc_current_state () == COMP_FUNCTION 2912 && strcmp ("ppr@", gfc_current_block ()->name) == 0 2913 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) 2914 strcpy (name, "ppr@"); 2915 2916 if (gfc_current_state () == COMP_FUNCTION 2917 && strcmp (name, gfc_current_block ()->name) == 0 2918 && gfc_current_block ()->result 2919 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) 2920 strcpy (name, "ppr@"); 2921 2922 /* OK, we've successfully matched the declaration. Now put the 2923 symbol in the current namespace, because it might be used in the 2924 optional initialization expression for this symbol, e.g. this is 2925 perfectly legal: 2926 2927 integer, parameter :: i = huge(i) 2928 2929 This is only true for parameters or variables of a basic type. 2930 For components of derived types, it is not true, so we don't 2931 create a symbol for those yet. If we fail to create the symbol, 2932 bail out. */ 2933 if (!gfc_comp_struct (gfc_current_state ()) 2934 && !build_sym (name, cl, cl_deferred, &as, &var_locus)) 2935 { 2936 m = MATCH_ERROR; 2937 goto cleanup; 2938 } 2939 2940 if (!check_function_name (name)) 2941 { 2942 m = MATCH_ERROR; 2943 goto cleanup; 2944 } 2945 2946 /* We allow old-style initializations of the form 2947 integer i /2/, j(4) /3*3, 1/ 2948 (if no colon has been seen). These are different from data 2949 statements in that initializers are only allowed to apply to the 2950 variable immediately preceding, i.e. 2951 integer i, j /1, 2/ 2952 is not allowed. Therefore we have to do some work manually, that 2953 could otherwise be left to the matchers for DATA statements. */ 2954 2955 if (!colon_seen && gfc_match (" /") == MATCH_YES) 2956 { 2957 if (!gfc_notify_std (GFC_STD_GNU, "Old-style " 2958 "initialization at %C")) 2959 return MATCH_ERROR; 2960 2961 /* Allow old style initializations for components of STRUCTUREs and MAPs 2962 but not components of derived types. */ 2963 else if (gfc_current_state () == COMP_DERIVED) 2964 { 2965 gfc_error ("Invalid old style initialization for derived type " 2966 "component at %C"); 2967 m = MATCH_ERROR; 2968 goto cleanup; 2969 } 2970 2971 /* For structure components, read the initializer as a special 2972 expression and let the rest of this function apply the initializer 2973 as usual. */ 2974 else if (gfc_comp_struct (gfc_current_state ())) 2975 { 2976 m = match_clist_expr (&initializer, ¤t_ts, as); 2977 if (m == MATCH_NO) 2978 gfc_error ("Syntax error in old style initialization of %s at %C", 2979 name); 2980 if (m != MATCH_YES) 2981 goto cleanup; 2982 } 2983 2984 /* Otherwise we treat the old style initialization just like a 2985 DATA declaration for the current variable. */ 2986 else 2987 return match_old_style_init (name); 2988 } 2989 2990 /* The double colon must be present in order to have initializers. 2991 Otherwise the statement is ambiguous with an assignment statement. */ 2992 if (colon_seen) 2993 { 2994 if (gfc_match (" =>") == MATCH_YES) 2995 { 2996 if (!current_attr.pointer) 2997 { 2998 gfc_error ("Initialization at %C isn't for a pointer variable"); 2999 m = MATCH_ERROR; 3000 goto cleanup; 3001 } 3002 3003 m = match_pointer_init (&initializer, 0); 3004 if (m != MATCH_YES) 3005 goto cleanup; 3006 3007 /* The target of a pointer initialization must have the SAVE 3008 attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope 3009 is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */ 3010 if (initializer->expr_type == EXPR_VARIABLE 3011 && initializer->symtree->n.sym->attr.save == SAVE_NONE 3012 && (gfc_current_state () == COMP_PROGRAM 3013 || gfc_current_state () == COMP_MODULE 3014 || gfc_current_state () == COMP_SUBMODULE)) 3015 initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT; 3016 } 3017 else if (gfc_match_char ('=') == MATCH_YES) 3018 { 3019 if (current_attr.pointer) 3020 { 3021 gfc_error ("Pointer initialization at %C requires %<=>%>, " 3022 "not %<=%>"); 3023 m = MATCH_ERROR; 3024 goto cleanup; 3025 } 3026 3027 m = gfc_match_init_expr (&initializer); 3028 if (m == MATCH_NO) 3029 { 3030 gfc_error ("Expected an initialization expression at %C"); 3031 m = MATCH_ERROR; 3032 } 3033 3034 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL) 3035 && !gfc_comp_struct (gfc_state_stack->state)) 3036 { 3037 gfc_error ("Initialization of variable at %C is not allowed in " 3038 "a PURE procedure"); 3039 m = MATCH_ERROR; 3040 } 3041 3042 if (current_attr.flavor != FL_PARAMETER 3043 && !gfc_comp_struct (gfc_state_stack->state)) 3044 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 3045 3046 if (m != MATCH_YES) 3047 goto cleanup; 3048 } 3049 } 3050 3051 if (initializer != NULL && current_attr.allocatable 3052 && gfc_comp_struct (gfc_current_state ())) 3053 { 3054 gfc_error ("Initialization of allocatable component at %C is not " 3055 "allowed"); 3056 m = MATCH_ERROR; 3057 goto cleanup; 3058 } 3059 3060 if (gfc_current_state () == COMP_DERIVED 3061 && initializer && initializer->ts.type == BT_HOLLERITH) 3062 { 3063 gfc_error ("Initialization of structure component with a HOLLERITH " 3064 "constant at %L is not allowed", &initializer->where); 3065 m = MATCH_ERROR; 3066 goto cleanup; 3067 } 3068 3069 if (gfc_current_state () == COMP_DERIVED 3070 && gfc_current_block ()->attr.pdt_template) 3071 { 3072 gfc_symbol *param; 3073 gfc_find_symbol (name, gfc_current_block ()->f2k_derived, 3074 0, ¶m); 3075 if (!param && (current_attr.pdt_kind || current_attr.pdt_len)) 3076 { 3077 gfc_error ("The component with KIND or LEN attribute at %C does not " 3078 "not appear in the type parameter list at %L", 3079 &gfc_current_block ()->declared_at); 3080 m = MATCH_ERROR; 3081 goto cleanup; 3082 } 3083 else if (param && !(current_attr.pdt_kind || current_attr.pdt_len)) 3084 { 3085 gfc_error ("The component at %C that appears in the type parameter " 3086 "list at %L has neither the KIND nor LEN attribute", 3087 &gfc_current_block ()->declared_at); 3088 m = MATCH_ERROR; 3089 goto cleanup; 3090 } 3091 else if (as && (current_attr.pdt_kind || current_attr.pdt_len)) 3092 { 3093 gfc_error ("The component at %C which is a type parameter must be " 3094 "a scalar"); 3095 m = MATCH_ERROR; 3096 goto cleanup; 3097 } 3098 else if (param && initializer) 3099 { 3100 if (initializer->ts.type == BT_BOZ) 3101 { 3102 gfc_error ("BOZ literal constant at %L cannot appear as an " 3103 "initializer", &initializer->where); 3104 m = MATCH_ERROR; 3105 goto cleanup; 3106 } 3107 param->value = gfc_copy_expr (initializer); 3108 } 3109 } 3110 3111 /* Before adding a possible initilizer, do a simple check for compatibility 3112 of lhs and rhs types. Assigning a REAL value to a derived type is not a 3113 good thing. */ 3114 if (current_ts.type == BT_DERIVED && initializer 3115 && (gfc_numeric_ts (&initializer->ts) 3116 || initializer->ts.type == BT_LOGICAL 3117 || initializer->ts.type == BT_CHARACTER)) 3118 { 3119 gfc_error ("Incompatible initialization between a derived type " 3120 "entity and an entity with %qs type at %C", 3121 gfc_typename (initializer)); 3122 m = MATCH_ERROR; 3123 goto cleanup; 3124 } 3125 3126 3127 /* Add the initializer. Note that it is fine if initializer is 3128 NULL here, because we sometimes also need to check if a 3129 declaration *must* have an initialization expression. */ 3130 if (!gfc_comp_struct (gfc_current_state ())) 3131 t = add_init_expr_to_sym (name, &initializer, &var_locus); 3132 else 3133 { 3134 if (current_ts.type == BT_DERIVED 3135 && !current_attr.pointer && !initializer) 3136 initializer = gfc_default_initializer (¤t_ts); 3137 t = build_struct (name, cl, &initializer, &as); 3138 3139 /* If we match a nested structure definition we expect to see the 3140 * body even if the variable declarations blow up, so we need to keep 3141 * the structure declaration around. */ 3142 if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT) 3143 gfc_commit_symbol (gfc_new_block); 3144 } 3145 3146 m = (t) ? MATCH_YES : MATCH_ERROR; 3147 3148cleanup: 3149 /* Free stuff up and return. */ 3150 gfc_seen_div0 = false; 3151 gfc_free_expr (initializer); 3152 gfc_free_array_spec (as); 3153 3154 return m; 3155} 3156 3157 3158/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification. 3159 This assumes that the byte size is equal to the kind number for 3160 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */ 3161 3162static match 3163gfc_match_old_kind_spec (gfc_typespec *ts) 3164{ 3165 match m; 3166 int original_kind; 3167 3168 if (gfc_match_char ('*') != MATCH_YES) 3169 return MATCH_NO; 3170 3171 m = gfc_match_small_literal_int (&ts->kind, NULL); 3172 if (m != MATCH_YES) 3173 return MATCH_ERROR; 3174 3175 original_kind = ts->kind; 3176 3177 /* Massage the kind numbers for complex types. */ 3178 if (ts->type == BT_COMPLEX) 3179 { 3180 if (ts->kind % 2) 3181 { 3182 gfc_error ("Old-style type declaration %s*%d not supported at %C", 3183 gfc_basic_typename (ts->type), original_kind); 3184 return MATCH_ERROR; 3185 } 3186 ts->kind /= 2; 3187 3188 } 3189 3190 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) 3191 ts->kind = 8; 3192 3193 if (ts->type == BT_REAL || ts->type == BT_COMPLEX) 3194 { 3195 if (ts->kind == 4) 3196 { 3197 if (flag_real4_kind == 8) 3198 ts->kind = 8; 3199 if (flag_real4_kind == 10) 3200 ts->kind = 10; 3201 if (flag_real4_kind == 16) 3202 ts->kind = 16; 3203 } 3204 else if (ts->kind == 8) 3205 { 3206 if (flag_real8_kind == 4) 3207 ts->kind = 4; 3208 if (flag_real8_kind == 10) 3209 ts->kind = 10; 3210 if (flag_real8_kind == 16) 3211 ts->kind = 16; 3212 } 3213 } 3214 3215 if (gfc_validate_kind (ts->type, ts->kind, true) < 0) 3216 { 3217 gfc_error ("Old-style type declaration %s*%d not supported at %C", 3218 gfc_basic_typename (ts->type), original_kind); 3219 return MATCH_ERROR; 3220 } 3221 3222 if (!gfc_notify_std (GFC_STD_GNU, 3223 "Nonstandard type declaration %s*%d at %C", 3224 gfc_basic_typename(ts->type), original_kind)) 3225 return MATCH_ERROR; 3226 3227 return MATCH_YES; 3228} 3229 3230 3231/* Match a kind specification. Since kinds are generally optional, we 3232 usually return MATCH_NO if something goes wrong. If a "kind=" 3233 string is found, then we know we have an error. */ 3234 3235match 3236gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) 3237{ 3238 locus where, loc; 3239 gfc_expr *e; 3240 match m, n; 3241 char c; 3242 3243 m = MATCH_NO; 3244 n = MATCH_YES; 3245 e = NULL; 3246 saved_kind_expr = NULL; 3247 3248 where = loc = gfc_current_locus; 3249 3250 if (kind_expr_only) 3251 goto kind_expr; 3252 3253 if (gfc_match_char ('(') == MATCH_NO) 3254 return MATCH_NO; 3255 3256 /* Also gobbles optional text. */ 3257 if (gfc_match (" kind = ") == MATCH_YES) 3258 m = MATCH_ERROR; 3259 3260 loc = gfc_current_locus; 3261 3262kind_expr: 3263 3264 n = gfc_match_init_expr (&e); 3265 3266 if (gfc_derived_parameter_expr (e)) 3267 { 3268 ts->kind = 0; 3269 saved_kind_expr = gfc_copy_expr (e); 3270 goto close_brackets; 3271 } 3272 3273 if (n != MATCH_YES) 3274 { 3275 if (gfc_matching_function) 3276 { 3277 /* The function kind expression might include use associated or 3278 imported parameters and try again after the specification 3279 expressions..... */ 3280 if (gfc_match_char (')') != MATCH_YES) 3281 { 3282 gfc_error ("Missing right parenthesis at %C"); 3283 m = MATCH_ERROR; 3284 goto no_match; 3285 } 3286 3287 gfc_free_expr (e); 3288 gfc_undo_symbols (); 3289 return MATCH_YES; 3290 } 3291 else 3292 { 3293 /* ....or else, the match is real. */ 3294 if (n == MATCH_NO) 3295 gfc_error ("Expected initialization expression at %C"); 3296 if (n != MATCH_YES) 3297 return MATCH_ERROR; 3298 } 3299 } 3300 3301 if (e->rank != 0) 3302 { 3303 gfc_error ("Expected scalar initialization expression at %C"); 3304 m = MATCH_ERROR; 3305 goto no_match; 3306 } 3307 3308 if (gfc_extract_int (e, &ts->kind, 1)) 3309 { 3310 m = MATCH_ERROR; 3311 goto no_match; 3312 } 3313 3314 /* Before throwing away the expression, let's see if we had a 3315 C interoperable kind (and store the fact). */ 3316 if (e->ts.is_c_interop == 1) 3317 { 3318 /* Mark this as C interoperable if being declared with one 3319 of the named constants from iso_c_binding. */ 3320 ts->is_c_interop = e->ts.is_iso_c; 3321 ts->f90_type = e->ts.f90_type; 3322 if (e->symtree) 3323 ts->interop_kind = e->symtree->n.sym; 3324 } 3325 3326 gfc_free_expr (e); 3327 e = NULL; 3328 3329 /* Ignore errors to this point, if we've gotten here. This means 3330 we ignore the m=MATCH_ERROR from above. */ 3331 if (gfc_validate_kind (ts->type, ts->kind, true) < 0) 3332 { 3333 gfc_error ("Kind %d not supported for type %s at %C", ts->kind, 3334 gfc_basic_typename (ts->type)); 3335 gfc_current_locus = where; 3336 return MATCH_ERROR; 3337 } 3338 3339 /* Warn if, e.g., c_int is used for a REAL variable, but not 3340 if, e.g., c_double is used for COMPLEX as the standard 3341 explicitly says that the kind type parameter for complex and real 3342 variable is the same, i.e. c_float == c_float_complex. */ 3343 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type 3344 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) 3345 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) 3346 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L " 3347 "is %s", gfc_basic_typename (ts->f90_type), &where, 3348 gfc_basic_typename (ts->type)); 3349 3350close_brackets: 3351 3352 gfc_gobble_whitespace (); 3353 if ((c = gfc_next_ascii_char ()) != ')' 3354 && (ts->type != BT_CHARACTER || c != ',')) 3355 { 3356 if (ts->type == BT_CHARACTER) 3357 gfc_error ("Missing right parenthesis or comma at %C"); 3358 else 3359 gfc_error ("Missing right parenthesis at %C"); 3360 m = MATCH_ERROR; 3361 } 3362 else 3363 /* All tests passed. */ 3364 m = MATCH_YES; 3365 3366 if(m == MATCH_ERROR) 3367 gfc_current_locus = where; 3368 3369 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) 3370 ts->kind = 8; 3371 3372 if (ts->type == BT_REAL || ts->type == BT_COMPLEX) 3373 { 3374 if (ts->kind == 4) 3375 { 3376 if (flag_real4_kind == 8) 3377 ts->kind = 8; 3378 if (flag_real4_kind == 10) 3379 ts->kind = 10; 3380 if (flag_real4_kind == 16) 3381 ts->kind = 16; 3382 } 3383 else if (ts->kind == 8) 3384 { 3385 if (flag_real8_kind == 4) 3386 ts->kind = 4; 3387 if (flag_real8_kind == 10) 3388 ts->kind = 10; 3389 if (flag_real8_kind == 16) 3390 ts->kind = 16; 3391 } 3392 } 3393 3394 /* Return what we know from the test(s). */ 3395 return m; 3396 3397no_match: 3398 gfc_free_expr (e); 3399 gfc_current_locus = where; 3400 return m; 3401} 3402 3403 3404static match 3405match_char_kind (int * kind, int * is_iso_c) 3406{ 3407 locus where; 3408 gfc_expr *e; 3409 match m, n; 3410 bool fail; 3411 3412 m = MATCH_NO; 3413 e = NULL; 3414 where = gfc_current_locus; 3415 3416 n = gfc_match_init_expr (&e); 3417 3418 if (n != MATCH_YES && gfc_matching_function) 3419 { 3420 /* The expression might include use-associated or imported 3421 parameters and try again after the specification 3422 expressions. */ 3423 gfc_free_expr (e); 3424 gfc_undo_symbols (); 3425 return MATCH_YES; 3426 } 3427 3428 if (n == MATCH_NO) 3429 gfc_error ("Expected initialization expression at %C"); 3430 if (n != MATCH_YES) 3431 return MATCH_ERROR; 3432 3433 if (e->rank != 0) 3434 { 3435 gfc_error ("Expected scalar initialization expression at %C"); 3436 m = MATCH_ERROR; 3437 goto no_match; 3438 } 3439 3440 if (gfc_derived_parameter_expr (e)) 3441 { 3442 saved_kind_expr = e; 3443 *kind = 0; 3444 return MATCH_YES; 3445 } 3446 3447 fail = gfc_extract_int (e, kind, 1); 3448 *is_iso_c = e->ts.is_iso_c; 3449 if (fail) 3450 { 3451 m = MATCH_ERROR; 3452 goto no_match; 3453 } 3454 3455 gfc_free_expr (e); 3456 3457 /* Ignore errors to this point, if we've gotten here. This means 3458 we ignore the m=MATCH_ERROR from above. */ 3459 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) 3460 { 3461 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); 3462 m = MATCH_ERROR; 3463 } 3464 else 3465 /* All tests passed. */ 3466 m = MATCH_YES; 3467 3468 if (m == MATCH_ERROR) 3469 gfc_current_locus = where; 3470 3471 /* Return what we know from the test(s). */ 3472 return m; 3473 3474no_match: 3475 gfc_free_expr (e); 3476 gfc_current_locus = where; 3477 return m; 3478} 3479 3480 3481/* Match the various kind/length specifications in a CHARACTER 3482 declaration. We don't return MATCH_NO. */ 3483 3484match 3485gfc_match_char_spec (gfc_typespec *ts) 3486{ 3487 int kind, seen_length, is_iso_c; 3488 gfc_charlen *cl; 3489 gfc_expr *len; 3490 match m; 3491 bool deferred; 3492 3493 len = NULL; 3494 seen_length = 0; 3495 kind = 0; 3496 is_iso_c = 0; 3497 deferred = false; 3498 3499 /* Try the old-style specification first. */ 3500 old_char_selector = 0; 3501 3502 m = match_char_length (&len, &deferred, true); 3503 if (m != MATCH_NO) 3504 { 3505 if (m == MATCH_YES) 3506 old_char_selector = 1; 3507 seen_length = 1; 3508 goto done; 3509 } 3510 3511 m = gfc_match_char ('('); 3512 if (m != MATCH_YES) 3513 { 3514 m = MATCH_YES; /* Character without length is a single char. */ 3515 goto done; 3516 } 3517 3518 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */ 3519 if (gfc_match (" kind =") == MATCH_YES) 3520 { 3521 m = match_char_kind (&kind, &is_iso_c); 3522 3523 if (m == MATCH_ERROR) 3524 goto done; 3525 if (m == MATCH_NO) 3526 goto syntax; 3527 3528 if (gfc_match (" , len =") == MATCH_NO) 3529 goto rparen; 3530 3531 m = char_len_param_value (&len, &deferred); 3532 if (m == MATCH_NO) 3533 goto syntax; 3534 if (m == MATCH_ERROR) 3535 goto done; 3536 seen_length = 1; 3537 3538 goto rparen; 3539 } 3540 3541 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */ 3542 if (gfc_match (" len =") == MATCH_YES) 3543 { 3544 m = char_len_param_value (&len, &deferred); 3545 if (m == MATCH_NO) 3546 goto syntax; 3547 if (m == MATCH_ERROR) 3548 goto done; 3549 seen_length = 1; 3550 3551 if (gfc_match_char (')') == MATCH_YES) 3552 goto done; 3553 3554 if (gfc_match (" , kind =") != MATCH_YES) 3555 goto syntax; 3556 3557 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) 3558 goto done; 3559 3560 goto rparen; 3561 } 3562 3563 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */ 3564 m = char_len_param_value (&len, &deferred); 3565 if (m == MATCH_NO) 3566 goto syntax; 3567 if (m == MATCH_ERROR) 3568 goto done; 3569 seen_length = 1; 3570 3571 m = gfc_match_char (')'); 3572 if (m == MATCH_YES) 3573 goto done; 3574 3575 if (gfc_match_char (',') != MATCH_YES) 3576 goto syntax; 3577 3578 gfc_match (" kind ="); /* Gobble optional text. */ 3579 3580 m = match_char_kind (&kind, &is_iso_c); 3581 if (m == MATCH_ERROR) 3582 goto done; 3583 if (m == MATCH_NO) 3584 goto syntax; 3585 3586rparen: 3587 /* Require a right-paren at this point. */ 3588 m = gfc_match_char (')'); 3589 if (m == MATCH_YES) 3590 goto done; 3591 3592syntax: 3593 gfc_error ("Syntax error in CHARACTER declaration at %C"); 3594 m = MATCH_ERROR; 3595 gfc_free_expr (len); 3596 return m; 3597 3598done: 3599 /* Deal with character functions after USE and IMPORT statements. */ 3600 if (gfc_matching_function) 3601 { 3602 gfc_free_expr (len); 3603 gfc_undo_symbols (); 3604 return MATCH_YES; 3605 } 3606 3607 if (m != MATCH_YES) 3608 { 3609 gfc_free_expr (len); 3610 return m; 3611 } 3612 3613 /* Do some final massaging of the length values. */ 3614 cl = gfc_new_charlen (gfc_current_ns, NULL); 3615 3616 if (seen_length == 0) 3617 cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1); 3618 else 3619 { 3620 /* If gfortran ends up here, then len may be reducible to a constant. 3621 Try to do that here. If it does not reduce, simply assign len to 3622 charlen. A complication occurs with user-defined generic functions, 3623 which are not resolved. Use a private namespace to deal with 3624 generic functions. */ 3625 3626 if (len && len->expr_type != EXPR_CONSTANT) 3627 { 3628 gfc_namespace *old_ns; 3629 gfc_expr *e; 3630 3631 old_ns = gfc_current_ns; 3632 gfc_current_ns = gfc_get_namespace (NULL, 0); 3633 3634 e = gfc_copy_expr (len); 3635 gfc_push_suppress_errors (); 3636 gfc_reduce_init_expr (e); 3637 gfc_pop_suppress_errors (); 3638 if (e->expr_type == EXPR_CONSTANT) 3639 { 3640 gfc_replace_expr (len, e); 3641 if (mpz_cmp_si (len->value.integer, 0) < 0) 3642 mpz_set_ui (len->value.integer, 0); 3643 } 3644 else 3645 gfc_free_expr (e); 3646 3647 gfc_free_namespace (gfc_current_ns); 3648 gfc_current_ns = old_ns; 3649 } 3650 3651 cl->length = len; 3652 } 3653 3654 ts->u.cl = cl; 3655 ts->kind = kind == 0 ? gfc_default_character_kind : kind; 3656 ts->deferred = deferred; 3657 3658 /* We have to know if it was a C interoperable kind so we can 3659 do accurate type checking of bind(c) procs, etc. */ 3660 if (kind != 0) 3661 /* Mark this as C interoperable if being declared with one 3662 of the named constants from iso_c_binding. */ 3663 ts->is_c_interop = is_iso_c; 3664 else if (len != NULL) 3665 /* Here, we might have parsed something such as: character(c_char) 3666 In this case, the parsing code above grabs the c_char when 3667 looking for the length (line 1690, roughly). it's the last 3668 testcase for parsing the kind params of a character variable. 3669 However, it's not actually the length. this seems like it 3670 could be an error. 3671 To see if the user used a C interop kind, test the expr 3672 of the so called length, and see if it's C interoperable. */ 3673 ts->is_c_interop = len->ts.is_iso_c; 3674 3675 return MATCH_YES; 3676} 3677 3678 3679/* Matches a RECORD declaration. */ 3680 3681static match 3682match_record_decl (char *name) 3683{ 3684 locus old_loc; 3685 old_loc = gfc_current_locus; 3686 match m; 3687 3688 m = gfc_match (" record /"); 3689 if (m == MATCH_YES) 3690 { 3691 if (!flag_dec_structure) 3692 { 3693 gfc_current_locus = old_loc; 3694 gfc_error ("RECORD at %C is an extension, enable it with " 3695 "%<-fdec-structure%>"); 3696 return MATCH_ERROR; 3697 } 3698 m = gfc_match (" %n/", name); 3699 if (m == MATCH_YES) 3700 return MATCH_YES; 3701 } 3702 3703 gfc_current_locus = old_loc; 3704 if (flag_dec_structure 3705 && (gfc_match (" record% ") == MATCH_YES 3706 || gfc_match (" record%t") == MATCH_YES)) 3707 gfc_error ("Structure name expected after RECORD at %C"); 3708 if (m == MATCH_NO) 3709 return MATCH_NO; 3710 3711 return MATCH_ERROR; 3712} 3713 3714 3715/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source 3716 of expressions to substitute into the possibly parameterized expression 3717 'e'. Using a list is inefficient but should not be too bad since the 3718 number of type parameters is not likely to be large. */ 3719static bool 3720insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED, 3721 int* f) 3722{ 3723 gfc_actual_arglist *param; 3724 gfc_expr *copy; 3725 3726 if (e->expr_type != EXPR_VARIABLE) 3727 return false; 3728 3729 gcc_assert (e->symtree); 3730 if (e->symtree->n.sym->attr.pdt_kind 3731 || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) 3732 { 3733 for (param = type_param_spec_list; param; param = param->next) 3734 if (strcmp (e->symtree->n.sym->name, param->name) == 0) 3735 break; 3736 3737 if (param) 3738 { 3739 copy = gfc_copy_expr (param->expr); 3740 *e = *copy; 3741 free (copy); 3742 } 3743 } 3744 3745 return false; 3746} 3747 3748 3749static bool 3750gfc_insert_kind_parameter_exprs (gfc_expr *e) 3751{ 3752 return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0); 3753} 3754 3755 3756bool 3757gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list) 3758{ 3759 gfc_actual_arglist *old_param_spec_list = type_param_spec_list; 3760 type_param_spec_list = param_list; 3761 bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1); 3762 type_param_spec_list = old_param_spec_list; 3763 return res; 3764} 3765 3766/* Determines the instance of a parameterized derived type to be used by 3767 matching determining the values of the kind parameters and using them 3768 in the name of the instance. If the instance exists, it is used, otherwise 3769 a new derived type is created. */ 3770match 3771gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, 3772 gfc_actual_arglist **ext_param_list) 3773{ 3774 /* The PDT template symbol. */ 3775 gfc_symbol *pdt = *sym; 3776 /* The symbol for the parameter in the template f2k_namespace. */ 3777 gfc_symbol *param; 3778 /* The hoped for instance of the PDT. */ 3779 gfc_symbol *instance; 3780 /* The list of parameters appearing in the PDT declaration. */ 3781 gfc_formal_arglist *type_param_name_list; 3782 /* Used to store the parameter specification list during recursive calls. */ 3783 gfc_actual_arglist *old_param_spec_list; 3784 /* Pointers to the parameter specification being used. */ 3785 gfc_actual_arglist *actual_param; 3786 gfc_actual_arglist *tail = NULL; 3787 /* Used to build up the name of the PDT instance. The prefix uses 4 3788 characters and each KIND parameter 2 more. Allow 8 of the latter. */ 3789 char name[GFC_MAX_SYMBOL_LEN + 21]; 3790 3791 bool name_seen = (param_list == NULL); 3792 bool assumed_seen = false; 3793 bool deferred_seen = false; 3794 bool spec_error = false; 3795 int kind_value, i; 3796 gfc_expr *kind_expr; 3797 gfc_component *c1, *c2; 3798 match m; 3799 3800 type_param_spec_list = NULL; 3801 3802 type_param_name_list = pdt->formal; 3803 actual_param = param_list; 3804 sprintf (name, "Pdt%s", pdt->name); 3805 3806 /* Run through the parameter name list and pick up the actual 3807 parameter values or use the default values in the PDT declaration. */ 3808 for (; type_param_name_list; 3809 type_param_name_list = type_param_name_list->next) 3810 { 3811 if (actual_param && actual_param->spec_type != SPEC_EXPLICIT) 3812 { 3813 if (actual_param->spec_type == SPEC_ASSUMED) 3814 spec_error = deferred_seen; 3815 else 3816 spec_error = assumed_seen; 3817 3818 if (spec_error) 3819 { 3820 gfc_error ("The type parameter spec list at %C cannot contain " 3821 "both ASSUMED and DEFERRED parameters"); 3822 goto error_return; 3823 } 3824 } 3825 3826 if (actual_param && actual_param->name) 3827 name_seen = true; 3828 param = type_param_name_list->sym; 3829 3830 if (!param || !param->name) 3831 continue; 3832 3833 c1 = gfc_find_component (pdt, param->name, false, true, NULL); 3834 /* An error should already have been thrown in resolve.cc 3835 (resolve_fl_derived0). */ 3836 if (!pdt->attr.use_assoc && !c1) 3837 goto error_return; 3838 3839 kind_expr = NULL; 3840 if (!name_seen) 3841 { 3842 if (!actual_param && !(c1 && c1->initializer)) 3843 { 3844 gfc_error ("The type parameter spec list at %C does not contain " 3845 "enough parameter expressions"); 3846 goto error_return; 3847 } 3848 else if (!actual_param && c1 && c1->initializer) 3849 kind_expr = gfc_copy_expr (c1->initializer); 3850 else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) 3851 kind_expr = gfc_copy_expr (actual_param->expr); 3852 } 3853 else 3854 { 3855 actual_param = param_list; 3856 for (;actual_param; actual_param = actual_param->next) 3857 if (actual_param->name 3858 && strcmp (actual_param->name, param->name) == 0) 3859 break; 3860 if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) 3861 kind_expr = gfc_copy_expr (actual_param->expr); 3862 else 3863 { 3864 if (c1->initializer) 3865 kind_expr = gfc_copy_expr (c1->initializer); 3866 else if (!(actual_param && param->attr.pdt_len)) 3867 { 3868 gfc_error ("The derived parameter %qs at %C does not " 3869 "have a default value", param->name); 3870 goto error_return; 3871 } 3872 } 3873 } 3874 3875 /* Store the current parameter expressions in a temporary actual 3876 arglist 'list' so that they can be substituted in the corresponding 3877 expressions in the PDT instance. */ 3878 if (type_param_spec_list == NULL) 3879 { 3880 type_param_spec_list = gfc_get_actual_arglist (); 3881 tail = type_param_spec_list; 3882 } 3883 else 3884 { 3885 tail->next = gfc_get_actual_arglist (); 3886 tail = tail->next; 3887 } 3888 tail->name = param->name; 3889 3890 if (kind_expr) 3891 { 3892 /* Try simplification even for LEN expressions. */ 3893 bool ok; 3894 gfc_resolve_expr (kind_expr); 3895 ok = gfc_simplify_expr (kind_expr, 1); 3896 /* Variable expressions seem to default to BT_PROCEDURE. 3897 TODO find out why this is and fix it. */ 3898 if (kind_expr->ts.type != BT_INTEGER 3899 && kind_expr->ts.type != BT_PROCEDURE) 3900 { 3901 gfc_error ("The parameter expression at %C must be of " 3902 "INTEGER type and not %s type", 3903 gfc_basic_typename (kind_expr->ts.type)); 3904 goto error_return; 3905 } 3906 if (kind_expr->ts.type == BT_INTEGER && !ok) 3907 { 3908 gfc_error ("The parameter expression at %C does not " 3909 "simplify to an INTEGER constant"); 3910 goto error_return; 3911 } 3912 3913 tail->expr = gfc_copy_expr (kind_expr); 3914 } 3915 3916 if (actual_param) 3917 tail->spec_type = actual_param->spec_type; 3918 3919 if (!param->attr.pdt_kind) 3920 { 3921 if (!name_seen && actual_param) 3922 actual_param = actual_param->next; 3923 if (kind_expr) 3924 { 3925 gfc_free_expr (kind_expr); 3926 kind_expr = NULL; 3927 } 3928 continue; 3929 } 3930 3931 if (actual_param 3932 && (actual_param->spec_type == SPEC_ASSUMED 3933 || actual_param->spec_type == SPEC_DEFERRED)) 3934 { 3935 gfc_error ("The KIND parameter %qs at %C cannot either be " 3936 "ASSUMED or DEFERRED", param->name); 3937 goto error_return; 3938 } 3939 3940 if (!kind_expr || !gfc_is_constant_expr (kind_expr)) 3941 { 3942 gfc_error ("The value for the KIND parameter %qs at %C does not " 3943 "reduce to a constant expression", param->name); 3944 goto error_return; 3945 } 3946 3947 gfc_extract_int (kind_expr, &kind_value); 3948 sprintf (name + strlen (name), "_%d", kind_value); 3949 3950 if (!name_seen && actual_param) 3951 actual_param = actual_param->next; 3952 gfc_free_expr (kind_expr); 3953 } 3954 3955 if (!name_seen && actual_param) 3956 { 3957 gfc_error ("The type parameter spec list at %C contains too many " 3958 "parameter expressions"); 3959 goto error_return; 3960 } 3961 3962 /* Now we search for the PDT instance 'name'. If it doesn't exist, we 3963 build it, using 'pdt' as a template. */ 3964 if (gfc_get_symbol (name, pdt->ns, &instance)) 3965 { 3966 gfc_error ("Parameterized derived type at %C is ambiguous"); 3967 goto error_return; 3968 } 3969 3970 m = MATCH_YES; 3971 3972 if (instance->attr.flavor == FL_DERIVED 3973 && instance->attr.pdt_type) 3974 { 3975 instance->refs++; 3976 if (ext_param_list) 3977 *ext_param_list = type_param_spec_list; 3978 *sym = instance; 3979 gfc_commit_symbols (); 3980 return m; 3981 } 3982 3983 /* Start building the new instance of the parameterized type. */ 3984 gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); 3985 instance->attr.pdt_template = 0; 3986 instance->attr.pdt_type = 1; 3987 instance->declared_at = gfc_current_locus; 3988 3989 /* Add the components, replacing the parameters in all expressions 3990 with the expressions for their values in 'type_param_spec_list'. */ 3991 c1 = pdt->components; 3992 tail = type_param_spec_list; 3993 for (; c1; c1 = c1->next) 3994 { 3995 gfc_add_component (instance, c1->name, &c2); 3996 3997 c2->ts = c1->ts; 3998 c2->attr = c1->attr; 3999 4000 /* The order of declaration of the type_specs might not be the 4001 same as that of the components. */ 4002 if (c1->attr.pdt_kind || c1->attr.pdt_len) 4003 { 4004 for (tail = type_param_spec_list; tail; tail = tail->next) 4005 if (strcmp (c1->name, tail->name) == 0) 4006 break; 4007 } 4008 4009 /* Deal with type extension by recursively calling this function 4010 to obtain the instance of the extended type. */ 4011 if (gfc_current_state () != COMP_DERIVED 4012 && c1 == pdt->components 4013 && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) 4014 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template 4015 && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) 4016 { 4017 gfc_formal_arglist *f; 4018 4019 old_param_spec_list = type_param_spec_list; 4020 4021 /* Obtain a spec list appropriate to the extended type..*/ 4022 actual_param = gfc_copy_actual_arglist (type_param_spec_list); 4023 type_param_spec_list = actual_param; 4024 for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) 4025 actual_param = actual_param->next; 4026 if (actual_param) 4027 { 4028 gfc_free_actual_arglist (actual_param->next); 4029 actual_param->next = NULL; 4030 } 4031 4032 /* Now obtain the PDT instance for the extended type. */ 4033 c2->param_list = type_param_spec_list; 4034 m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, 4035 NULL); 4036 type_param_spec_list = old_param_spec_list; 4037 4038 c2->ts.u.derived->refs++; 4039 gfc_set_sym_referenced (c2->ts.u.derived); 4040 4041 /* Set extension level. */ 4042 if (c2->ts.u.derived->attr.extension == 255) 4043 { 4044 /* Since the extension field is 8 bit wide, we can only have 4045 up to 255 extension levels. */ 4046 gfc_error ("Maximum extension level reached with type %qs at %L", 4047 c2->ts.u.derived->name, 4048 &c2->ts.u.derived->declared_at); 4049 goto error_return; 4050 } 4051 instance->attr.extension = c2->ts.u.derived->attr.extension + 1; 4052 4053 continue; 4054 } 4055 4056 /* Set the component kind using the parameterized expression. */ 4057 if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) 4058 && c1->kind_expr != NULL) 4059 { 4060 gfc_expr *e = gfc_copy_expr (c1->kind_expr); 4061 gfc_insert_kind_parameter_exprs (e); 4062 gfc_simplify_expr (e, 1); 4063 gfc_extract_int (e, &c2->ts.kind); 4064 gfc_free_expr (e); 4065 if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0) 4066 { 4067 gfc_error ("Kind %d not supported for type %s at %C", 4068 c2->ts.kind, gfc_basic_typename (c2->ts.type)); 4069 goto error_return; 4070 } 4071 } 4072 4073 /* Similarly, set the string length if parameterized. */ 4074 if (c1->ts.type == BT_CHARACTER 4075 && c1->ts.u.cl->length 4076 && gfc_derived_parameter_expr (c1->ts.u.cl->length)) 4077 { 4078 gfc_expr *e; 4079 e = gfc_copy_expr (c1->ts.u.cl->length); 4080 gfc_insert_kind_parameter_exprs (e); 4081 gfc_simplify_expr (e, 1); 4082 c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 4083 c2->ts.u.cl->length = e; 4084 c2->attr.pdt_string = 1; 4085 } 4086 4087 /* Set up either the KIND/LEN initializer, if constant, 4088 or the parameterized expression. Use the template 4089 initializer if one is not already set in this instance. */ 4090 if (c2->attr.pdt_kind || c2->attr.pdt_len) 4091 { 4092 if (tail && tail->expr && gfc_is_constant_expr (tail->expr)) 4093 c2->initializer = gfc_copy_expr (tail->expr); 4094 else if (tail && tail->expr) 4095 { 4096 c2->param_list = gfc_get_actual_arglist (); 4097 c2->param_list->name = tail->name; 4098 c2->param_list->expr = gfc_copy_expr (tail->expr); 4099 c2->param_list->next = NULL; 4100 } 4101 4102 if (!c2->initializer && c1->initializer) 4103 c2->initializer = gfc_copy_expr (c1->initializer); 4104 } 4105 4106 /* Copy the array spec. */ 4107 c2->as = gfc_copy_array_spec (c1->as); 4108 if (c1->ts.type == BT_CLASS) 4109 CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as); 4110 4111 /* Determine if an array spec is parameterized. If so, substitute 4112 in the parameter expressions for the bounds and set the pdt_array 4113 attribute. Notice that this attribute must be unconditionally set 4114 if this is an array of parameterized character length. */ 4115 if (c1->as && c1->as->type == AS_EXPLICIT) 4116 { 4117 bool pdt_array = false; 4118 4119 /* Are the bounds of the array parameterized? */ 4120 for (i = 0; i < c1->as->rank; i++) 4121 { 4122 if (gfc_derived_parameter_expr (c1->as->lower[i])) 4123 pdt_array = true; 4124 if (gfc_derived_parameter_expr (c1->as->upper[i])) 4125 pdt_array = true; 4126 } 4127 4128 /* If they are, free the expressions for the bounds and 4129 replace them with the template expressions with substitute 4130 values. */ 4131 for (i = 0; pdt_array && i < c1->as->rank; i++) 4132 { 4133 gfc_expr *e; 4134 e = gfc_copy_expr (c1->as->lower[i]); 4135 gfc_insert_kind_parameter_exprs (e); 4136 gfc_simplify_expr (e, 1); 4137 gfc_free_expr (c2->as->lower[i]); 4138 c2->as->lower[i] = e; 4139 e = gfc_copy_expr (c1->as->upper[i]); 4140 gfc_insert_kind_parameter_exprs (e); 4141 gfc_simplify_expr (e, 1); 4142 gfc_free_expr (c2->as->upper[i]); 4143 c2->as->upper[i] = e; 4144 } 4145 c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; 4146 if (c1->initializer) 4147 { 4148 c2->initializer = gfc_copy_expr (c1->initializer); 4149 gfc_insert_kind_parameter_exprs (c2->initializer); 4150 gfc_simplify_expr (c2->initializer, 1); 4151 } 4152 } 4153 4154 /* Recurse into this function for PDT components. */ 4155 if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) 4156 && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) 4157 { 4158 gfc_actual_arglist *params; 4159 /* The component in the template has a list of specification 4160 expressions derived from its declaration. */ 4161 params = gfc_copy_actual_arglist (c1->param_list); 4162 actual_param = params; 4163 /* Substitute the template parameters with the expressions 4164 from the specification list. */ 4165 for (;actual_param; actual_param = actual_param->next) 4166 gfc_insert_parameter_exprs (actual_param->expr, 4167 type_param_spec_list); 4168 4169 /* Now obtain the PDT instance for the component. */ 4170 old_param_spec_list = type_param_spec_list; 4171 m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL); 4172 type_param_spec_list = old_param_spec_list; 4173 4174 c2->param_list = params; 4175 if (!(c2->attr.pointer || c2->attr.allocatable)) 4176 c2->initializer = gfc_default_initializer (&c2->ts); 4177 4178 if (c2->attr.allocatable) 4179 instance->attr.alloc_comp = 1; 4180 } 4181 } 4182 4183 gfc_commit_symbol (instance); 4184 if (ext_param_list) 4185 *ext_param_list = type_param_spec_list; 4186 *sym = instance; 4187 return m; 4188 4189error_return: 4190 gfc_free_actual_arglist (type_param_spec_list); 4191 return MATCH_ERROR; 4192} 4193 4194 4195/* Match a legacy nonstandard BYTE type-spec. */ 4196 4197static match 4198match_byte_typespec (gfc_typespec *ts) 4199{ 4200 if (gfc_match (" byte") == MATCH_YES) 4201 { 4202 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C")) 4203 return MATCH_ERROR; 4204 4205 if (gfc_current_form == FORM_FREE) 4206 { 4207 char c = gfc_peek_ascii_char (); 4208 if (!gfc_is_whitespace (c) && c != ',') 4209 return MATCH_NO; 4210 } 4211 4212 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) 4213 { 4214 gfc_error ("BYTE type used at %C " 4215 "is not available on the target machine"); 4216 return MATCH_ERROR; 4217 } 4218 4219 ts->type = BT_INTEGER; 4220 ts->kind = 1; 4221 return MATCH_YES; 4222 } 4223 return MATCH_NO; 4224} 4225 4226 4227/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts 4228 structure to the matched specification. This is necessary for FUNCTION and 4229 IMPLICIT statements. 4230 4231 If implicit_flag is nonzero, then we don't check for the optional 4232 kind specification. Not doing so is needed for matching an IMPLICIT 4233 statement correctly. */ 4234 4235match 4236gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) 4237{ 4238 /* Provide sufficient space to hold "pdtsymbol". */ 4239 char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1); 4240 gfc_symbol *sym, *dt_sym; 4241 match m; 4242 char c; 4243 bool seen_deferred_kind, matched_type; 4244 const char *dt_name; 4245 4246 decl_type_param_list = NULL; 4247 4248 /* A belt and braces check that the typespec is correctly being treated 4249 as a deferred characteristic association. */ 4250 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) 4251 && (gfc_current_block ()->result->ts.kind == -1) 4252 && (ts->kind == -1); 4253 gfc_clear_ts (ts); 4254 if (seen_deferred_kind) 4255 ts->kind = -1; 4256 4257 /* Clear the current binding label, in case one is given. */ 4258 curr_binding_label = NULL; 4259 4260 /* Match BYTE type-spec. */ 4261 m = match_byte_typespec (ts); 4262 if (m != MATCH_NO) 4263 return m; 4264 4265 m = gfc_match (" type ("); 4266 matched_type = (m == MATCH_YES); 4267 if (matched_type) 4268 { 4269 gfc_gobble_whitespace (); 4270 if (gfc_peek_ascii_char () == '*') 4271 { 4272 if ((m = gfc_match ("* ) ")) != MATCH_YES) 4273 return m; 4274 if (gfc_comp_struct (gfc_current_state ())) 4275 { 4276 gfc_error ("Assumed type at %C is not allowed for components"); 4277 return MATCH_ERROR; 4278 } 4279 if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C")) 4280 return MATCH_ERROR; 4281 ts->type = BT_ASSUMED; 4282 return MATCH_YES; 4283 } 4284 4285 m = gfc_match ("%n", name); 4286 matched_type = (m == MATCH_YES); 4287 } 4288 4289 if ((matched_type && strcmp ("integer", name) == 0) 4290 || (!matched_type && gfc_match (" integer") == MATCH_YES)) 4291 { 4292 ts->type = BT_INTEGER; 4293 ts->kind = gfc_default_integer_kind; 4294 goto get_kind; 4295 } 4296 4297 if ((matched_type && strcmp ("character", name) == 0) 4298 || (!matched_type && gfc_match (" character") == MATCH_YES)) 4299 { 4300 if (matched_type 4301 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 4302 "intrinsic-type-spec at %C")) 4303 return MATCH_ERROR; 4304 4305 ts->type = BT_CHARACTER; 4306 if (implicit_flag == 0) 4307 m = gfc_match_char_spec (ts); 4308 else 4309 m = MATCH_YES; 4310 4311 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) 4312 { 4313 gfc_error ("Malformed type-spec at %C"); 4314 return MATCH_ERROR; 4315 } 4316 4317 return m; 4318 } 4319 4320 if ((matched_type && strcmp ("real", name) == 0) 4321 || (!matched_type && gfc_match (" real") == MATCH_YES)) 4322 { 4323 ts->type = BT_REAL; 4324 ts->kind = gfc_default_real_kind; 4325 goto get_kind; 4326 } 4327 4328 if ((matched_type 4329 && (strcmp ("doubleprecision", name) == 0 4330 || (strcmp ("double", name) == 0 4331 && gfc_match (" precision") == MATCH_YES))) 4332 || (!matched_type && gfc_match (" double precision") == MATCH_YES)) 4333 { 4334 if (matched_type 4335 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 4336 "intrinsic-type-spec at %C")) 4337 return MATCH_ERROR; 4338 4339 if (matched_type && gfc_match_char (')') != MATCH_YES) 4340 { 4341 gfc_error ("Malformed type-spec at %C"); 4342 return MATCH_ERROR; 4343 } 4344 4345 ts->type = BT_REAL; 4346 ts->kind = gfc_default_double_kind; 4347 return MATCH_YES; 4348 } 4349 4350 if ((matched_type && strcmp ("complex", name) == 0) 4351 || (!matched_type && gfc_match (" complex") == MATCH_YES)) 4352 { 4353 ts->type = BT_COMPLEX; 4354 ts->kind = gfc_default_complex_kind; 4355 goto get_kind; 4356 } 4357 4358 if ((matched_type 4359 && (strcmp ("doublecomplex", name) == 0 4360 || (strcmp ("double", name) == 0 4361 && gfc_match (" complex") == MATCH_YES))) 4362 || (!matched_type && gfc_match (" double complex") == MATCH_YES)) 4363 { 4364 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")) 4365 return MATCH_ERROR; 4366 4367 if (matched_type 4368 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 4369 "intrinsic-type-spec at %C")) 4370 return MATCH_ERROR; 4371 4372 if (matched_type && gfc_match_char (')') != MATCH_YES) 4373 { 4374 gfc_error ("Malformed type-spec at %C"); 4375 return MATCH_ERROR; 4376 } 4377 4378 ts->type = BT_COMPLEX; 4379 ts->kind = gfc_default_double_kind; 4380 return MATCH_YES; 4381 } 4382 4383 if ((matched_type && strcmp ("logical", name) == 0) 4384 || (!matched_type && gfc_match (" logical") == MATCH_YES)) 4385 { 4386 ts->type = BT_LOGICAL; 4387 ts->kind = gfc_default_logical_kind; 4388 goto get_kind; 4389 } 4390 4391 if (matched_type) 4392 { 4393 m = gfc_match_actual_arglist (1, &decl_type_param_list, true); 4394 if (m == MATCH_ERROR) 4395 return m; 4396 4397 gfc_gobble_whitespace (); 4398 if (gfc_peek_ascii_char () != ')') 4399 { 4400 gfc_error ("Malformed type-spec at %C"); 4401 return MATCH_ERROR; 4402 } 4403 m = gfc_match_char (')'); /* Burn closing ')'. */ 4404 } 4405 4406 if (m != MATCH_YES) 4407 m = match_record_decl (name); 4408 4409 if (matched_type || m == MATCH_YES) 4410 { 4411 ts->type = BT_DERIVED; 4412 /* We accept record/s/ or type(s) where s is a structure, but we 4413 * don't need all the extra derived-type stuff for structures. */ 4414 if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym)) 4415 { 4416 gfc_error ("Type name %qs at %C is ambiguous", name); 4417 return MATCH_ERROR; 4418 } 4419 4420 if (sym && sym->attr.flavor == FL_DERIVED 4421 && sym->attr.pdt_template 4422 && gfc_current_state () != COMP_DERIVED) 4423 { 4424 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); 4425 if (m != MATCH_YES) 4426 return m; 4427 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); 4428 ts->u.derived = sym; 4429 const char* lower = gfc_dt_lower_string (sym->name); 4430 size_t len = strlen (lower); 4431 /* Reallocate with sufficient size. */ 4432 if (len > GFC_MAX_SYMBOL_LEN) 4433 name = XALLOCAVEC (char, len + 1); 4434 memcpy (name, lower, len); 4435 name[len] = '\0'; 4436 } 4437 4438 if (sym && sym->attr.flavor == FL_STRUCT) 4439 { 4440 ts->u.derived = sym; 4441 return MATCH_YES; 4442 } 4443 /* Actually a derived type. */ 4444 } 4445 4446 else 4447 { 4448 /* Match nested STRUCTURE declarations; only valid within another 4449 structure declaration. */ 4450 if (flag_dec_structure 4451 && (gfc_current_state () == COMP_STRUCTURE 4452 || gfc_current_state () == COMP_MAP)) 4453 { 4454 m = gfc_match (" structure"); 4455 if (m == MATCH_YES) 4456 { 4457 m = gfc_match_structure_decl (); 4458 if (m == MATCH_YES) 4459 { 4460 /* gfc_new_block is updated by match_structure_decl. */ 4461 ts->type = BT_DERIVED; 4462 ts->u.derived = gfc_new_block; 4463 return MATCH_YES; 4464 } 4465 } 4466 if (m == MATCH_ERROR) 4467 return MATCH_ERROR; 4468 } 4469 4470 /* Match CLASS declarations. */ 4471 m = gfc_match (" class ( * )"); 4472 if (m == MATCH_ERROR) 4473 return MATCH_ERROR; 4474 else if (m == MATCH_YES) 4475 { 4476 gfc_symbol *upe; 4477 gfc_symtree *st; 4478 ts->type = BT_CLASS; 4479 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe); 4480 if (upe == NULL) 4481 { 4482 upe = gfc_new_symbol ("STAR", gfc_current_ns); 4483 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); 4484 st->n.sym = upe; 4485 gfc_set_sym_referenced (upe); 4486 upe->refs++; 4487 upe->ts.type = BT_VOID; 4488 upe->attr.unlimited_polymorphic = 1; 4489 /* This is essential to force the construction of 4490 unlimited polymorphic component class containers. */ 4491 upe->attr.zero_comp = 1; 4492 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, 4493 &gfc_current_locus)) 4494 return MATCH_ERROR; 4495 } 4496 else 4497 { 4498 st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR"); 4499 st->n.sym = upe; 4500 upe->refs++; 4501 } 4502 ts->u.derived = upe; 4503 return m; 4504 } 4505 4506 m = gfc_match (" class ("); 4507 4508 if (m == MATCH_YES) 4509 m = gfc_match ("%n", name); 4510 else 4511 return m; 4512 4513 if (m != MATCH_YES) 4514 return m; 4515 ts->type = BT_CLASS; 4516 4517 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")) 4518 return MATCH_ERROR; 4519 4520 m = gfc_match_actual_arglist (1, &decl_type_param_list, true); 4521 if (m == MATCH_ERROR) 4522 return m; 4523 4524 m = gfc_match_char (')'); 4525 if (m != MATCH_YES) 4526 return m; 4527 } 4528 4529 /* Defer association of the derived type until the end of the 4530 specification block. However, if the derived type can be 4531 found, add it to the typespec. */ 4532 if (gfc_matching_function) 4533 { 4534 ts->u.derived = NULL; 4535 if (gfc_current_state () != COMP_INTERFACE 4536 && !gfc_find_symbol (name, NULL, 1, &sym) && sym) 4537 { 4538 sym = gfc_find_dt_in_generic (sym); 4539 ts->u.derived = sym; 4540 } 4541 return MATCH_YES; 4542 } 4543 4544 /* Search for the name but allow the components to be defined later. If 4545 type = -1, this typespec has been seen in a function declaration but 4546 the type could not be accessed at that point. The actual derived type is 4547 stored in a symtree with the first letter of the name capitalized; the 4548 symtree with the all lower-case name contains the associated 4549 generic function. */ 4550 dt_name = gfc_dt_upper_string (name); 4551 sym = NULL; 4552 dt_sym = NULL; 4553 if (ts->kind != -1) 4554 { 4555 gfc_get_ha_symbol (name, &sym); 4556 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) 4557 { 4558 gfc_error ("Type name %qs at %C is ambiguous", name); 4559 return MATCH_ERROR; 4560 } 4561 if (sym->generic && !dt_sym) 4562 dt_sym = gfc_find_dt_in_generic (sym); 4563 4564 /* Host associated PDTs can get confused with their constructors 4565 because they ar instantiated in the template's namespace. */ 4566 if (!dt_sym) 4567 { 4568 if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) 4569 { 4570 gfc_error ("Type name %qs at %C is ambiguous", name); 4571 return MATCH_ERROR; 4572 } 4573 if (dt_sym && !dt_sym->attr.pdt_type) 4574 dt_sym = NULL; 4575 } 4576 } 4577 else if (ts->kind == -1) 4578 { 4579 int iface = gfc_state_stack->previous->state != COMP_INTERFACE 4580 || gfc_current_ns->has_import_set; 4581 gfc_find_symbol (name, NULL, iface, &sym); 4582 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) 4583 { 4584 gfc_error ("Type name %qs at %C is ambiguous", name); 4585 return MATCH_ERROR; 4586 } 4587 if (sym && sym->generic && !dt_sym) 4588 dt_sym = gfc_find_dt_in_generic (sym); 4589 4590 ts->kind = 0; 4591 if (sym == NULL) 4592 return MATCH_NO; 4593 } 4594 4595 if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT 4596 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) 4597 || sym->attr.subroutine) 4598 { 4599 gfc_error ("Type name %qs at %C conflicts with previously declared " 4600 "entity at %L, which has the same name", name, 4601 &sym->declared_at); 4602 return MATCH_ERROR; 4603 } 4604 4605 if (sym && sym->attr.flavor == FL_DERIVED 4606 && sym->attr.pdt_template 4607 && gfc_current_state () != COMP_DERIVED) 4608 { 4609 m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL); 4610 if (m != MATCH_YES) 4611 return m; 4612 gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type); 4613 ts->u.derived = sym; 4614 strcpy (name, gfc_dt_lower_string (sym->name)); 4615 } 4616 4617 gfc_save_symbol_data (sym); 4618 gfc_set_sym_referenced (sym); 4619 if (!sym->attr.generic 4620 && !gfc_add_generic (&sym->attr, sym->name, NULL)) 4621 return MATCH_ERROR; 4622 4623 if (!sym->attr.function 4624 && !gfc_add_function (&sym->attr, sym->name, NULL)) 4625 return MATCH_ERROR; 4626 4627 if (dt_sym && dt_sym->attr.flavor == FL_DERIVED 4628 && dt_sym->attr.pdt_template 4629 && gfc_current_state () != COMP_DERIVED) 4630 { 4631 m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL); 4632 if (m != MATCH_YES) 4633 return m; 4634 gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type); 4635 } 4636 4637 if (!dt_sym) 4638 { 4639 gfc_interface *intr, *head; 4640 4641 /* Use upper case to save the actual derived-type symbol. */ 4642 gfc_get_symbol (dt_name, NULL, &dt_sym); 4643 dt_sym->name = gfc_get_string ("%s", sym->name); 4644 head = sym->generic; 4645 intr = gfc_get_interface (); 4646 intr->sym = dt_sym; 4647 intr->where = gfc_current_locus; 4648 intr->next = head; 4649 sym->generic = intr; 4650 sym->attr.if_source = IFSRC_DECL; 4651 } 4652 else 4653 gfc_save_symbol_data (dt_sym); 4654 4655 gfc_set_sym_referenced (dt_sym); 4656 4657 if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT 4658 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)) 4659 return MATCH_ERROR; 4660 4661 ts->u.derived = dt_sym; 4662 4663 return MATCH_YES; 4664 4665get_kind: 4666 if (matched_type 4667 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 4668 "intrinsic-type-spec at %C")) 4669 return MATCH_ERROR; 4670 4671 /* For all types except double, derived and character, look for an 4672 optional kind specifier. MATCH_NO is actually OK at this point. */ 4673 if (implicit_flag == 1) 4674 { 4675 if (matched_type && gfc_match_char (')') != MATCH_YES) 4676 return MATCH_ERROR; 4677 4678 return MATCH_YES; 4679 } 4680 4681 if (gfc_current_form == FORM_FREE) 4682 { 4683 c = gfc_peek_ascii_char (); 4684 if (!gfc_is_whitespace (c) && c != '*' && c != '(' 4685 && c != ':' && c != ',') 4686 { 4687 if (matched_type && c == ')') 4688 { 4689 gfc_next_ascii_char (); 4690 return MATCH_YES; 4691 } 4692 gfc_error ("Malformed type-spec at %C"); 4693 return MATCH_NO; 4694 } 4695 } 4696 4697 m = gfc_match_kind_spec (ts, false); 4698 if (m == MATCH_NO && ts->type != BT_CHARACTER) 4699 { 4700 m = gfc_match_old_kind_spec (ts); 4701 if (gfc_validate_kind (ts->type, ts->kind, true) == -1) 4702 return MATCH_ERROR; 4703 } 4704 4705 if (matched_type && gfc_match_char (')') != MATCH_YES) 4706 { 4707 gfc_error ("Malformed type-spec at %C"); 4708 return MATCH_ERROR; 4709 } 4710 4711 /* Defer association of the KIND expression of function results 4712 until after USE and IMPORT statements. */ 4713 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) 4714 || gfc_matching_function) 4715 return MATCH_YES; 4716 4717 if (m == MATCH_NO) 4718 m = MATCH_YES; /* No kind specifier found. */ 4719 4720 return m; 4721} 4722 4723 4724/* Match an IMPLICIT NONE statement. Actually, this statement is 4725 already matched in parse.cc, or we would not end up here in the 4726 first place. So the only thing we need to check, is if there is 4727 trailing garbage. If not, the match is successful. */ 4728 4729match 4730gfc_match_implicit_none (void) 4731{ 4732 char c; 4733 match m; 4734 char name[GFC_MAX_SYMBOL_LEN + 1]; 4735 bool type = false; 4736 bool external = false; 4737 locus cur_loc = gfc_current_locus; 4738 4739 if (gfc_current_ns->seen_implicit_none 4740 || gfc_current_ns->has_implicit_none_export) 4741 { 4742 gfc_error ("Duplicate IMPLICIT NONE statement at %C"); 4743 return MATCH_ERROR; 4744 } 4745 4746 gfc_gobble_whitespace (); 4747 c = gfc_peek_ascii_char (); 4748 if (c == '(') 4749 { 4750 (void) gfc_next_ascii_char (); 4751 if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C")) 4752 return MATCH_ERROR; 4753 4754 gfc_gobble_whitespace (); 4755 if (gfc_peek_ascii_char () == ')') 4756 { 4757 (void) gfc_next_ascii_char (); 4758 type = true; 4759 } 4760 else 4761 for(;;) 4762 { 4763 m = gfc_match (" %n", name); 4764 if (m != MATCH_YES) 4765 return MATCH_ERROR; 4766 4767 if (strcmp (name, "type") == 0) 4768 type = true; 4769 else if (strcmp (name, "external") == 0) 4770 external = true; 4771 else 4772 return MATCH_ERROR; 4773 4774 gfc_gobble_whitespace (); 4775 c = gfc_next_ascii_char (); 4776 if (c == ',') 4777 continue; 4778 if (c == ')') 4779 break; 4780 return MATCH_ERROR; 4781 } 4782 } 4783 else 4784 type = true; 4785 4786 if (gfc_match_eos () != MATCH_YES) 4787 return MATCH_ERROR; 4788 4789 gfc_set_implicit_none (type, external, &cur_loc); 4790 4791 return MATCH_YES; 4792} 4793 4794 4795/* Match the letter range(s) of an IMPLICIT statement. */ 4796 4797static match 4798match_implicit_range (void) 4799{ 4800 char c, c1, c2; 4801 int inner; 4802 locus cur_loc; 4803 4804 cur_loc = gfc_current_locus; 4805 4806 gfc_gobble_whitespace (); 4807 c = gfc_next_ascii_char (); 4808 if (c != '(') 4809 { 4810 gfc_error ("Missing character range in IMPLICIT at %C"); 4811 goto bad; 4812 } 4813 4814 inner = 1; 4815 while (inner) 4816 { 4817 gfc_gobble_whitespace (); 4818 c1 = gfc_next_ascii_char (); 4819 if (!ISALPHA (c1)) 4820 goto bad; 4821 4822 gfc_gobble_whitespace (); 4823 c = gfc_next_ascii_char (); 4824 4825 switch (c) 4826 { 4827 case ')': 4828 inner = 0; /* Fall through. */ 4829 4830 case ',': 4831 c2 = c1; 4832 break; 4833 4834 case '-': 4835 gfc_gobble_whitespace (); 4836 c2 = gfc_next_ascii_char (); 4837 if (!ISALPHA (c2)) 4838 goto bad; 4839 4840 gfc_gobble_whitespace (); 4841 c = gfc_next_ascii_char (); 4842 4843 if ((c != ',') && (c != ')')) 4844 goto bad; 4845 if (c == ')') 4846 inner = 0; 4847 4848 break; 4849 4850 default: 4851 goto bad; 4852 } 4853 4854 if (c1 > c2) 4855 { 4856 gfc_error ("Letters must be in alphabetic order in " 4857 "IMPLICIT statement at %C"); 4858 goto bad; 4859 } 4860 4861 /* See if we can add the newly matched range to the pending 4862 implicits from this IMPLICIT statement. We do not check for 4863 conflicts with whatever earlier IMPLICIT statements may have 4864 set. This is done when we've successfully finished matching 4865 the current one. */ 4866 if (!gfc_add_new_implicit_range (c1, c2)) 4867 goto bad; 4868 } 4869 4870 return MATCH_YES; 4871 4872bad: 4873 gfc_syntax_error (ST_IMPLICIT); 4874 4875 gfc_current_locus = cur_loc; 4876 return MATCH_ERROR; 4877} 4878 4879 4880/* Match an IMPLICIT statement, storing the types for 4881 gfc_set_implicit() if the statement is accepted by the parser. 4882 There is a strange looking, but legal syntactic construction 4883 possible. It looks like: 4884 4885 IMPLICIT INTEGER (a-b) (c-d) 4886 4887 This is legal if "a-b" is a constant expression that happens to 4888 equal one of the legal kinds for integers. The real problem 4889 happens with an implicit specification that looks like: 4890 4891 IMPLICIT INTEGER (a-b) 4892 4893 In this case, a typespec matcher that is "greedy" (as most of the 4894 matchers are) gobbles the character range as a kindspec, leaving 4895 nothing left. We therefore have to go a bit more slowly in the 4896 matching process by inhibiting the kindspec checking during 4897 typespec matching and checking for a kind later. */ 4898 4899match 4900gfc_match_implicit (void) 4901{ 4902 gfc_typespec ts; 4903 locus cur_loc; 4904 char c; 4905 match m; 4906 4907 if (gfc_current_ns->seen_implicit_none) 4908 { 4909 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) " 4910 "statement"); 4911 return MATCH_ERROR; 4912 } 4913 4914 gfc_clear_ts (&ts); 4915 4916 /* We don't allow empty implicit statements. */ 4917 if (gfc_match_eos () == MATCH_YES) 4918 { 4919 gfc_error ("Empty IMPLICIT statement at %C"); 4920 return MATCH_ERROR; 4921 } 4922 4923 do 4924 { 4925 /* First cleanup. */ 4926 gfc_clear_new_implicit (); 4927 4928 /* A basic type is mandatory here. */ 4929 m = gfc_match_decl_type_spec (&ts, 1); 4930 if (m == MATCH_ERROR) 4931 goto error; 4932 if (m == MATCH_NO) 4933 goto syntax; 4934 4935 cur_loc = gfc_current_locus; 4936 m = match_implicit_range (); 4937 4938 if (m == MATCH_YES) 4939 { 4940 /* We may have <TYPE> (<RANGE>). */ 4941 gfc_gobble_whitespace (); 4942 c = gfc_peek_ascii_char (); 4943 if (c == ',' || c == '\n' || c == ';' || c == '!') 4944 { 4945 /* Check for CHARACTER with no length parameter. */ 4946 if (ts.type == BT_CHARACTER && !ts.u.cl) 4947 { 4948 ts.kind = gfc_default_character_kind; 4949 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 4950 ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, 4951 NULL, 1); 4952 } 4953 4954 /* Record the Successful match. */ 4955 if (!gfc_merge_new_implicit (&ts)) 4956 return MATCH_ERROR; 4957 if (c == ',') 4958 c = gfc_next_ascii_char (); 4959 else if (gfc_match_eos () == MATCH_ERROR) 4960 goto error; 4961 continue; 4962 } 4963 4964 gfc_current_locus = cur_loc; 4965 } 4966 4967 /* Discard the (incorrectly) matched range. */ 4968 gfc_clear_new_implicit (); 4969 4970 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */ 4971 if (ts.type == BT_CHARACTER) 4972 m = gfc_match_char_spec (&ts); 4973 else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL) 4974 { 4975 m = gfc_match_kind_spec (&ts, false); 4976 if (m == MATCH_NO) 4977 { 4978 m = gfc_match_old_kind_spec (&ts); 4979 if (m == MATCH_ERROR) 4980 goto error; 4981 if (m == MATCH_NO) 4982 goto syntax; 4983 } 4984 } 4985 if (m == MATCH_ERROR) 4986 goto error; 4987 4988 m = match_implicit_range (); 4989 if (m == MATCH_ERROR) 4990 goto error; 4991 if (m == MATCH_NO) 4992 goto syntax; 4993 4994 gfc_gobble_whitespace (); 4995 c = gfc_next_ascii_char (); 4996 if (c != ',' && gfc_match_eos () != MATCH_YES) 4997 goto syntax; 4998 4999 if (!gfc_merge_new_implicit (&ts)) 5000 return MATCH_ERROR; 5001 } 5002 while (c == ','); 5003 5004 return MATCH_YES; 5005 5006syntax: 5007 gfc_syntax_error (ST_IMPLICIT); 5008 5009error: 5010 return MATCH_ERROR; 5011} 5012 5013 5014match 5015gfc_match_import (void) 5016{ 5017 char name[GFC_MAX_SYMBOL_LEN + 1]; 5018 match m; 5019 gfc_symbol *sym; 5020 gfc_symtree *st; 5021 5022 if (gfc_current_ns->proc_name == NULL 5023 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) 5024 { 5025 gfc_error ("IMPORT statement at %C only permitted in " 5026 "an INTERFACE body"); 5027 return MATCH_ERROR; 5028 } 5029 5030 if (gfc_current_ns->proc_name->attr.module_procedure) 5031 { 5032 gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " 5033 "in a module procedure interface body"); 5034 return MATCH_ERROR; 5035 } 5036 5037 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) 5038 return MATCH_ERROR; 5039 5040 if (gfc_match_eos () == MATCH_YES) 5041 { 5042 /* All host variables should be imported. */ 5043 gfc_current_ns->has_import_set = 1; 5044 return MATCH_YES; 5045 } 5046 5047 if (gfc_match (" ::") == MATCH_YES) 5048 { 5049 if (gfc_match_eos () == MATCH_YES) 5050 { 5051 gfc_error ("Expecting list of named entities at %C"); 5052 return MATCH_ERROR; 5053 } 5054 } 5055 5056 for(;;) 5057 { 5058 sym = NULL; 5059 m = gfc_match (" %n", name); 5060 switch (m) 5061 { 5062 case MATCH_YES: 5063 if (gfc_current_ns->parent != NULL 5064 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) 5065 { 5066 gfc_error ("Type name %qs at %C is ambiguous", name); 5067 return MATCH_ERROR; 5068 } 5069 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL 5070 && gfc_find_symbol (name, 5071 gfc_current_ns->proc_name->ns->parent, 5072 1, &sym)) 5073 { 5074 gfc_error ("Type name %qs at %C is ambiguous", name); 5075 return MATCH_ERROR; 5076 } 5077 5078 if (sym == NULL) 5079 { 5080 gfc_error ("Cannot IMPORT %qs from host scoping unit " 5081 "at %C - does not exist.", name); 5082 return MATCH_ERROR; 5083 } 5084 5085 if (gfc_find_symtree (gfc_current_ns->sym_root, name)) 5086 { 5087 gfc_warning (0, "%qs is already IMPORTed from host scoping unit " 5088 "at %C", name); 5089 goto next_item; 5090 } 5091 5092 st = gfc_new_symtree (&gfc_current_ns->sym_root, name); 5093 st->n.sym = sym; 5094 sym->refs++; 5095 sym->attr.imported = 1; 5096 5097 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) 5098 { 5099 /* The actual derived type is stored in a symtree with the first 5100 letter of the name capitalized; the symtree with the all 5101 lower-case name contains the associated generic function. */ 5102 st = gfc_new_symtree (&gfc_current_ns->sym_root, 5103 gfc_dt_upper_string (name)); 5104 st->n.sym = sym; 5105 sym->refs++; 5106 sym->attr.imported = 1; 5107 } 5108 5109 goto next_item; 5110 5111 case MATCH_NO: 5112 break; 5113 5114 case MATCH_ERROR: 5115 return MATCH_ERROR; 5116 } 5117 5118 next_item: 5119 if (gfc_match_eos () == MATCH_YES) 5120 break; 5121 if (gfc_match_char (',') != MATCH_YES) 5122 goto syntax; 5123 } 5124 5125 return MATCH_YES; 5126 5127syntax: 5128 gfc_error ("Syntax error in IMPORT statement at %C"); 5129 return MATCH_ERROR; 5130} 5131 5132 5133/* A minimal implementation of gfc_match without whitespace, escape 5134 characters or variable arguments. Returns true if the next 5135 characters match the TARGET template exactly. */ 5136 5137static bool 5138match_string_p (const char *target) 5139{ 5140 const char *p; 5141 5142 for (p = target; *p; p++) 5143 if ((char) gfc_next_ascii_char () != *p) 5144 return false; 5145 return true; 5146} 5147 5148/* Matches an attribute specification including array specs. If 5149 successful, leaves the variables current_attr and current_as 5150 holding the specification. Also sets the colon_seen variable for 5151 later use by matchers associated with initializations. 5152 5153 This subroutine is a little tricky in the sense that we don't know 5154 if we really have an attr-spec until we hit the double colon. 5155 Until that time, we can only return MATCH_NO. This forces us to 5156 check for duplicate specification at this level. */ 5157 5158static match 5159match_attr_spec (void) 5160{ 5161 /* Modifiers that can exist in a type statement. */ 5162 enum 5163 { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN, 5164 DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT, 5165 DECL_DIMENSION, DECL_EXTERNAL, 5166 DECL_INTRINSIC, DECL_OPTIONAL, 5167 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, 5168 DECL_STATIC, DECL_AUTOMATIC, 5169 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, 5170 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, 5171 DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */ 5172 }; 5173 5174/* GFC_DECL_END is the sentinel, index starts at 0. */ 5175#define NUM_DECL GFC_DECL_END 5176 5177 /* Make sure that values from sym_intent are safe to be used here. */ 5178 gcc_assert (INTENT_IN > 0); 5179 5180 locus start, seen_at[NUM_DECL]; 5181 int seen[NUM_DECL]; 5182 unsigned int d; 5183 const char *attr; 5184 match m; 5185 bool t; 5186 5187 gfc_clear_attr (¤t_attr); 5188 start = gfc_current_locus; 5189 5190 current_as = NULL; 5191 colon_seen = 0; 5192 attr_seen = 0; 5193 5194 /* See if we get all of the keywords up to the final double colon. */ 5195 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 5196 seen[d] = 0; 5197 5198 for (;;) 5199 { 5200 char ch; 5201 5202 d = DECL_NONE; 5203 gfc_gobble_whitespace (); 5204 5205 ch = gfc_next_ascii_char (); 5206 if (ch == ':') 5207 { 5208 /* This is the successful exit condition for the loop. */ 5209 if (gfc_next_ascii_char () == ':') 5210 break; 5211 } 5212 else if (ch == ',') 5213 { 5214 gfc_gobble_whitespace (); 5215 switch (gfc_peek_ascii_char ()) 5216 { 5217 case 'a': 5218 gfc_next_ascii_char (); 5219 switch (gfc_next_ascii_char ()) 5220 { 5221 case 'l': 5222 if (match_string_p ("locatable")) 5223 { 5224 /* Matched "allocatable". */ 5225 d = DECL_ALLOCATABLE; 5226 } 5227 break; 5228 5229 case 's': 5230 if (match_string_p ("ynchronous")) 5231 { 5232 /* Matched "asynchronous". */ 5233 d = DECL_ASYNCHRONOUS; 5234 } 5235 break; 5236 5237 case 'u': 5238 if (match_string_p ("tomatic")) 5239 { 5240 /* Matched "automatic". */ 5241 d = DECL_AUTOMATIC; 5242 } 5243 break; 5244 } 5245 break; 5246 5247 case 'b': 5248 /* Try and match the bind(c). */ 5249 m = gfc_match_bind_c (NULL, true); 5250 if (m == MATCH_YES) 5251 d = DECL_IS_BIND_C; 5252 else if (m == MATCH_ERROR) 5253 goto cleanup; 5254 break; 5255 5256 case 'c': 5257 gfc_next_ascii_char (); 5258 if ('o' != gfc_next_ascii_char ()) 5259 break; 5260 switch (gfc_next_ascii_char ()) 5261 { 5262 case 'd': 5263 if (match_string_p ("imension")) 5264 { 5265 d = DECL_CODIMENSION; 5266 break; 5267 } 5268 /* FALLTHRU */ 5269 case 'n': 5270 if (match_string_p ("tiguous")) 5271 { 5272 d = DECL_CONTIGUOUS; 5273 break; 5274 } 5275 } 5276 break; 5277 5278 case 'd': 5279 if (match_string_p ("dimension")) 5280 d = DECL_DIMENSION; 5281 break; 5282 5283 case 'e': 5284 if (match_string_p ("external")) 5285 d = DECL_EXTERNAL; 5286 break; 5287 5288 case 'i': 5289 if (match_string_p ("int")) 5290 { 5291 ch = gfc_next_ascii_char (); 5292 if (ch == 'e') 5293 { 5294 if (match_string_p ("nt")) 5295 { 5296 /* Matched "intent". */ 5297 d = match_intent_spec (); 5298 if (d == INTENT_UNKNOWN) 5299 { 5300 m = MATCH_ERROR; 5301 goto cleanup; 5302 } 5303 } 5304 } 5305 else if (ch == 'r') 5306 { 5307 if (match_string_p ("insic")) 5308 { 5309 /* Matched "intrinsic". */ 5310 d = DECL_INTRINSIC; 5311 } 5312 } 5313 } 5314 break; 5315 5316 case 'k': 5317 if (match_string_p ("kind")) 5318 d = DECL_KIND; 5319 break; 5320 5321 case 'l': 5322 if (match_string_p ("len")) 5323 d = DECL_LEN; 5324 break; 5325 5326 case 'o': 5327 if (match_string_p ("optional")) 5328 d = DECL_OPTIONAL; 5329 break; 5330 5331 case 'p': 5332 gfc_next_ascii_char (); 5333 switch (gfc_next_ascii_char ()) 5334 { 5335 case 'a': 5336 if (match_string_p ("rameter")) 5337 { 5338 /* Matched "parameter". */ 5339 d = DECL_PARAMETER; 5340 } 5341 break; 5342 5343 case 'o': 5344 if (match_string_p ("inter")) 5345 { 5346 /* Matched "pointer". */ 5347 d = DECL_POINTER; 5348 } 5349 break; 5350 5351 case 'r': 5352 ch = gfc_next_ascii_char (); 5353 if (ch == 'i') 5354 { 5355 if (match_string_p ("vate")) 5356 { 5357 /* Matched "private". */ 5358 d = DECL_PRIVATE; 5359 } 5360 } 5361 else if (ch == 'o') 5362 { 5363 if (match_string_p ("tected")) 5364 { 5365 /* Matched "protected". */ 5366 d = DECL_PROTECTED; 5367 } 5368 } 5369 break; 5370 5371 case 'u': 5372 if (match_string_p ("blic")) 5373 { 5374 /* Matched "public". */ 5375 d = DECL_PUBLIC; 5376 } 5377 break; 5378 } 5379 break; 5380 5381 case 's': 5382 gfc_next_ascii_char (); 5383 switch (gfc_next_ascii_char ()) 5384 { 5385 case 'a': 5386 if (match_string_p ("ve")) 5387 { 5388 /* Matched "save". */ 5389 d = DECL_SAVE; 5390 } 5391 break; 5392 5393 case 't': 5394 if (match_string_p ("atic")) 5395 { 5396 /* Matched "static". */ 5397 d = DECL_STATIC; 5398 } 5399 break; 5400 } 5401 break; 5402 5403 case 't': 5404 if (match_string_p ("target")) 5405 d = DECL_TARGET; 5406 break; 5407 5408 case 'v': 5409 gfc_next_ascii_char (); 5410 ch = gfc_next_ascii_char (); 5411 if (ch == 'a') 5412 { 5413 if (match_string_p ("lue")) 5414 { 5415 /* Matched "value". */ 5416 d = DECL_VALUE; 5417 } 5418 } 5419 else if (ch == 'o') 5420 { 5421 if (match_string_p ("latile")) 5422 { 5423 /* Matched "volatile". */ 5424 d = DECL_VOLATILE; 5425 } 5426 } 5427 break; 5428 } 5429 } 5430 5431 /* No double colon and no recognizable decl_type, so assume that 5432 we've been looking at something else the whole time. */ 5433 if (d == DECL_NONE) 5434 { 5435 m = MATCH_NO; 5436 goto cleanup; 5437 } 5438 5439 /* Check to make sure any parens are paired up correctly. */ 5440 if (gfc_match_parens () == MATCH_ERROR) 5441 { 5442 m = MATCH_ERROR; 5443 goto cleanup; 5444 } 5445 5446 seen[d]++; 5447 seen_at[d] = gfc_current_locus; 5448 5449 if (d == DECL_DIMENSION || d == DECL_CODIMENSION) 5450 { 5451 gfc_array_spec *as = NULL; 5452 5453 m = gfc_match_array_spec (&as, d == DECL_DIMENSION, 5454 d == DECL_CODIMENSION); 5455 5456 if (current_as == NULL) 5457 current_as = as; 5458 else if (m == MATCH_YES) 5459 { 5460 if (!merge_array_spec (as, current_as, false)) 5461 m = MATCH_ERROR; 5462 free (as); 5463 } 5464 5465 if (m == MATCH_NO) 5466 { 5467 if (d == DECL_CODIMENSION) 5468 gfc_error ("Missing codimension specification at %C"); 5469 else 5470 gfc_error ("Missing dimension specification at %C"); 5471 m = MATCH_ERROR; 5472 } 5473 5474 if (m == MATCH_ERROR) 5475 goto cleanup; 5476 } 5477 } 5478 5479 /* Since we've seen a double colon, we have to be looking at an 5480 attr-spec. This means that we can now issue errors. */ 5481 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 5482 if (seen[d] > 1) 5483 { 5484 switch (d) 5485 { 5486 case DECL_ALLOCATABLE: 5487 attr = "ALLOCATABLE"; 5488 break; 5489 case DECL_ASYNCHRONOUS: 5490 attr = "ASYNCHRONOUS"; 5491 break; 5492 case DECL_CODIMENSION: 5493 attr = "CODIMENSION"; 5494 break; 5495 case DECL_CONTIGUOUS: 5496 attr = "CONTIGUOUS"; 5497 break; 5498 case DECL_DIMENSION: 5499 attr = "DIMENSION"; 5500 break; 5501 case DECL_EXTERNAL: 5502 attr = "EXTERNAL"; 5503 break; 5504 case DECL_IN: 5505 attr = "INTENT (IN)"; 5506 break; 5507 case DECL_OUT: 5508 attr = "INTENT (OUT)"; 5509 break; 5510 case DECL_INOUT: 5511 attr = "INTENT (IN OUT)"; 5512 break; 5513 case DECL_INTRINSIC: 5514 attr = "INTRINSIC"; 5515 break; 5516 case DECL_OPTIONAL: 5517 attr = "OPTIONAL"; 5518 break; 5519 case DECL_KIND: 5520 attr = "KIND"; 5521 break; 5522 case DECL_LEN: 5523 attr = "LEN"; 5524 break; 5525 case DECL_PARAMETER: 5526 attr = "PARAMETER"; 5527 break; 5528 case DECL_POINTER: 5529 attr = "POINTER"; 5530 break; 5531 case DECL_PROTECTED: 5532 attr = "PROTECTED"; 5533 break; 5534 case DECL_PRIVATE: 5535 attr = "PRIVATE"; 5536 break; 5537 case DECL_PUBLIC: 5538 attr = "PUBLIC"; 5539 break; 5540 case DECL_SAVE: 5541 attr = "SAVE"; 5542 break; 5543 case DECL_STATIC: 5544 attr = "STATIC"; 5545 break; 5546 case DECL_AUTOMATIC: 5547 attr = "AUTOMATIC"; 5548 break; 5549 case DECL_TARGET: 5550 attr = "TARGET"; 5551 break; 5552 case DECL_IS_BIND_C: 5553 attr = "IS_BIND_C"; 5554 break; 5555 case DECL_VALUE: 5556 attr = "VALUE"; 5557 break; 5558 case DECL_VOLATILE: 5559 attr = "VOLATILE"; 5560 break; 5561 default: 5562 attr = NULL; /* This shouldn't happen. */ 5563 } 5564 5565 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); 5566 m = MATCH_ERROR; 5567 goto cleanup; 5568 } 5569 5570 /* Now that we've dealt with duplicate attributes, add the attributes 5571 to the current attribute. */ 5572 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 5573 { 5574 if (seen[d] == 0) 5575 continue; 5576 else 5577 attr_seen = 1; 5578 5579 if ((d == DECL_STATIC || d == DECL_AUTOMATIC) 5580 && !flag_dec_static) 5581 { 5582 gfc_error ("%s at %L is a DEC extension, enable with " 5583 "%<-fdec-static%>", 5584 d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]); 5585 m = MATCH_ERROR; 5586 goto cleanup; 5587 } 5588 /* Allow SAVE with STATIC, but don't complain. */ 5589 if (d == DECL_STATIC && seen[DECL_SAVE]) 5590 continue; 5591 5592 if (gfc_comp_struct (gfc_current_state ()) 5593 && d != DECL_DIMENSION && d != DECL_CODIMENSION 5594 && d != DECL_POINTER && d != DECL_PRIVATE 5595 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) 5596 { 5597 bool is_derived = gfc_current_state () == COMP_DERIVED; 5598 if (d == DECL_ALLOCATABLE) 5599 { 5600 if (!gfc_notify_std (GFC_STD_F2003, is_derived 5601 ? G_("ALLOCATABLE attribute at %C in a " 5602 "TYPE definition") 5603 : G_("ALLOCATABLE attribute at %C in a " 5604 "STRUCTURE definition"))) 5605 { 5606 m = MATCH_ERROR; 5607 goto cleanup; 5608 } 5609 } 5610 else if (d == DECL_KIND) 5611 { 5612 if (!gfc_notify_std (GFC_STD_F2003, is_derived 5613 ? G_("KIND attribute at %C in a " 5614 "TYPE definition") 5615 : G_("KIND attribute at %C in a " 5616 "STRUCTURE definition"))) 5617 { 5618 m = MATCH_ERROR; 5619 goto cleanup; 5620 } 5621 if (current_ts.type != BT_INTEGER) 5622 { 5623 gfc_error ("Component with KIND attribute at %C must be " 5624 "INTEGER"); 5625 m = MATCH_ERROR; 5626 goto cleanup; 5627 } 5628 } 5629 else if (d == DECL_LEN) 5630 { 5631 if (!gfc_notify_std (GFC_STD_F2003, is_derived 5632 ? G_("LEN attribute at %C in a " 5633 "TYPE definition") 5634 : G_("LEN attribute at %C in a " 5635 "STRUCTURE definition"))) 5636 { 5637 m = MATCH_ERROR; 5638 goto cleanup; 5639 } 5640 if (current_ts.type != BT_INTEGER) 5641 { 5642 gfc_error ("Component with LEN attribute at %C must be " 5643 "INTEGER"); 5644 m = MATCH_ERROR; 5645 goto cleanup; 5646 } 5647 } 5648 else 5649 { 5650 gfc_error (is_derived ? G_("Attribute at %L is not allowed in a " 5651 "TYPE definition") 5652 : G_("Attribute at %L is not allowed in a " 5653 "STRUCTURE definition"), &seen_at[d]); 5654 m = MATCH_ERROR; 5655 goto cleanup; 5656 } 5657 } 5658 5659 if ((d == DECL_PRIVATE || d == DECL_PUBLIC) 5660 && gfc_current_state () != COMP_MODULE) 5661 { 5662 if (d == DECL_PRIVATE) 5663 attr = "PRIVATE"; 5664 else 5665 attr = "PUBLIC"; 5666 if (gfc_current_state () == COMP_DERIVED 5667 && gfc_state_stack->previous 5668 && gfc_state_stack->previous->state == COMP_MODULE) 5669 { 5670 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s " 5671 "at %L in a TYPE definition", attr, 5672 &seen_at[d])) 5673 { 5674 m = MATCH_ERROR; 5675 goto cleanup; 5676 } 5677 } 5678 else 5679 { 5680 gfc_error ("%s attribute at %L is not allowed outside of the " 5681 "specification part of a module", attr, &seen_at[d]); 5682 m = MATCH_ERROR; 5683 goto cleanup; 5684 } 5685 } 5686 5687 if (gfc_current_state () != COMP_DERIVED 5688 && (d == DECL_KIND || d == DECL_LEN)) 5689 { 5690 gfc_error ("Attribute at %L is not allowed outside a TYPE " 5691 "definition", &seen_at[d]); 5692 m = MATCH_ERROR; 5693 goto cleanup; 5694 } 5695 5696 switch (d) 5697 { 5698 case DECL_ALLOCATABLE: 5699 t = gfc_add_allocatable (¤t_attr, &seen_at[d]); 5700 break; 5701 5702 case DECL_ASYNCHRONOUS: 5703 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C")) 5704 t = false; 5705 else 5706 t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); 5707 break; 5708 5709 case DECL_CODIMENSION: 5710 t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); 5711 break; 5712 5713 case DECL_CONTIGUOUS: 5714 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C")) 5715 t = false; 5716 else 5717 t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); 5718 break; 5719 5720 case DECL_DIMENSION: 5721 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); 5722 break; 5723 5724 case DECL_EXTERNAL: 5725 t = gfc_add_external (¤t_attr, &seen_at[d]); 5726 break; 5727 5728 case DECL_IN: 5729 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); 5730 break; 5731 5732 case DECL_OUT: 5733 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); 5734 break; 5735 5736 case DECL_INOUT: 5737 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); 5738 break; 5739 5740 case DECL_INTRINSIC: 5741 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); 5742 break; 5743 5744 case DECL_OPTIONAL: 5745 t = gfc_add_optional (¤t_attr, &seen_at[d]); 5746 break; 5747 5748 case DECL_KIND: 5749 t = gfc_add_kind (¤t_attr, &seen_at[d]); 5750 break; 5751 5752 case DECL_LEN: 5753 t = gfc_add_len (¤t_attr, &seen_at[d]); 5754 break; 5755 5756 case DECL_PARAMETER: 5757 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); 5758 break; 5759 5760 case DECL_POINTER: 5761 t = gfc_add_pointer (¤t_attr, &seen_at[d]); 5762 break; 5763 5764 case DECL_PROTECTED: 5765 if (gfc_current_state () != COMP_MODULE 5766 || (gfc_current_ns->proc_name 5767 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) 5768 { 5769 gfc_error ("PROTECTED at %C only allowed in specification " 5770 "part of a module"); 5771 t = false; 5772 break; 5773 } 5774 5775 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C")) 5776 t = false; 5777 else 5778 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]); 5779 break; 5780 5781 case DECL_PRIVATE: 5782 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, 5783 &seen_at[d]); 5784 break; 5785 5786 case DECL_PUBLIC: 5787 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, 5788 &seen_at[d]); 5789 break; 5790 5791 case DECL_STATIC: 5792 case DECL_SAVE: 5793 t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); 5794 break; 5795 5796 case DECL_AUTOMATIC: 5797 t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]); 5798 break; 5799 5800 case DECL_TARGET: 5801 t = gfc_add_target (¤t_attr, &seen_at[d]); 5802 break; 5803 5804 case DECL_IS_BIND_C: 5805 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0); 5806 break; 5807 5808 case DECL_VALUE: 5809 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C")) 5810 t = false; 5811 else 5812 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]); 5813 break; 5814 5815 case DECL_VOLATILE: 5816 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C")) 5817 t = false; 5818 else 5819 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]); 5820 break; 5821 5822 default: 5823 gfc_internal_error ("match_attr_spec(): Bad attribute"); 5824 } 5825 5826 if (!t) 5827 { 5828 m = MATCH_ERROR; 5829 goto cleanup; 5830 } 5831 } 5832 5833 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ 5834 if ((gfc_current_state () == COMP_MODULE 5835 || gfc_current_state () == COMP_SUBMODULE) 5836 && !current_attr.save 5837 && (gfc_option.allow_std & GFC_STD_F2008) != 0) 5838 current_attr.save = SAVE_IMPLICIT; 5839 5840 colon_seen = 1; 5841 return MATCH_YES; 5842 5843cleanup: 5844 gfc_current_locus = start; 5845 gfc_free_array_spec (current_as); 5846 current_as = NULL; 5847 attr_seen = 0; 5848 return m; 5849} 5850 5851 5852/* Set the binding label, dest_label, either with the binding label 5853 stored in the given gfc_typespec, ts, or if none was provided, it 5854 will be the symbol name in all lower case, as required by the draft 5855 (J3/04-007, section 15.4.1). If a binding label was given and 5856 there is more than one argument (num_idents), it is an error. */ 5857 5858static bool 5859set_binding_label (const char **dest_label, const char *sym_name, 5860 int num_idents) 5861{ 5862 if (num_idents > 1 && has_name_equals) 5863 { 5864 gfc_error ("Multiple identifiers provided with " 5865 "single NAME= specifier at %C"); 5866 return false; 5867 } 5868 5869 if (curr_binding_label) 5870 /* Binding label given; store in temp holder till have sym. */ 5871 *dest_label = curr_binding_label; 5872 else 5873 { 5874 /* No binding label given, and the NAME= specifier did not exist, 5875 which means there was no NAME="". */ 5876 if (sym_name != NULL && has_name_equals == 0) 5877 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); 5878 } 5879 5880 return true; 5881} 5882 5883 5884/* Set the status of the given common block as being BIND(C) or not, 5885 depending on the given parameter, is_bind_c. */ 5886 5887static void 5888set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) 5889{ 5890 com_block->is_bind_c = is_bind_c; 5891 return; 5892} 5893 5894 5895/* Verify that the given gfc_typespec is for a C interoperable type. */ 5896 5897bool 5898gfc_verify_c_interop (gfc_typespec *ts) 5899{ 5900 if (ts->type == BT_DERIVED && ts->u.derived != NULL) 5901 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) 5902 ? true : false; 5903 else if (ts->type == BT_CLASS) 5904 return false; 5905 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) 5906 return false; 5907 5908 return true; 5909} 5910 5911 5912/* Verify that the variables of a given common block, which has been 5913 defined with the attribute specifier bind(c), to be of a C 5914 interoperable type. Errors will be reported here, if 5915 encountered. */ 5916 5917bool 5918verify_com_block_vars_c_interop (gfc_common_head *com_block) 5919{ 5920 gfc_symbol *curr_sym = NULL; 5921 bool retval = true; 5922 5923 curr_sym = com_block->head; 5924 5925 /* Make sure we have at least one symbol. */ 5926 if (curr_sym == NULL) 5927 return retval; 5928 5929 /* Here we know we have a symbol, so we'll execute this loop 5930 at least once. */ 5931 do 5932 { 5933 /* The second to last param, 1, says this is in a common block. */ 5934 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); 5935 curr_sym = curr_sym->common_next; 5936 } while (curr_sym != NULL); 5937 5938 return retval; 5939} 5940 5941 5942/* Verify that a given BIND(C) symbol is C interoperable. If it is not, 5943 an appropriate error message is reported. */ 5944 5945bool 5946verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, 5947 int is_in_common, gfc_common_head *com_block) 5948{ 5949 bool bind_c_function = false; 5950 bool retval = true; 5951 5952 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) 5953 bind_c_function = true; 5954 5955 if (tmp_sym->attr.function && tmp_sym->result != NULL) 5956 { 5957 tmp_sym = tmp_sym->result; 5958 /* Make sure it wasn't an implicitly typed result. */ 5959 if (tmp_sym->attr.implicit_type && warn_c_binding_type) 5960 { 5961 gfc_warning (OPT_Wc_binding_type, 5962 "Implicitly declared BIND(C) function %qs at " 5963 "%L may not be C interoperable", tmp_sym->name, 5964 &tmp_sym->declared_at); 5965 tmp_sym->ts.f90_type = tmp_sym->ts.type; 5966 /* Mark it as C interoperable to prevent duplicate warnings. */ 5967 tmp_sym->ts.is_c_interop = 1; 5968 tmp_sym->attr.is_c_interop = 1; 5969 } 5970 } 5971 5972 /* Here, we know we have the bind(c) attribute, so if we have 5973 enough type info, then verify that it's a C interop kind. 5974 The info could be in the symbol already, or possibly still in 5975 the given ts (current_ts), so look in both. */ 5976 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 5977 { 5978 if (!gfc_verify_c_interop (&(tmp_sym->ts))) 5979 { 5980 /* See if we're dealing with a sym in a common block or not. */ 5981 if (is_in_common == 1 && warn_c_binding_type) 5982 { 5983 gfc_warning (OPT_Wc_binding_type, 5984 "Variable %qs in common block %qs at %L " 5985 "may not be a C interoperable " 5986 "kind though common block %qs is BIND(C)", 5987 tmp_sym->name, com_block->name, 5988 &(tmp_sym->declared_at), com_block->name); 5989 } 5990 else 5991 { 5992 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) 5993 gfc_error ("Type declaration %qs at %L is not C " 5994 "interoperable but it is BIND(C)", 5995 tmp_sym->name, &(tmp_sym->declared_at)); 5996 else if (warn_c_binding_type) 5997 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " 5998 "may not be a C interoperable " 5999 "kind but it is BIND(C)", 6000 tmp_sym->name, &(tmp_sym->declared_at)); 6001 } 6002 } 6003 6004 /* Variables declared w/in a common block can't be bind(c) 6005 since there's no way for C to see these variables, so there's 6006 semantically no reason for the attribute. */ 6007 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) 6008 { 6009 gfc_error ("Variable %qs in common block %qs at " 6010 "%L cannot be declared with BIND(C) " 6011 "since it is not a global", 6012 tmp_sym->name, com_block->name, 6013 &(tmp_sym->declared_at)); 6014 retval = false; 6015 } 6016 6017 /* Scalar variables that are bind(c) cannot have the pointer 6018 or allocatable attributes. */ 6019 if (tmp_sym->attr.is_bind_c == 1) 6020 { 6021 if (tmp_sym->attr.pointer == 1) 6022 { 6023 gfc_error ("Variable %qs at %L cannot have both the " 6024 "POINTER and BIND(C) attributes", 6025 tmp_sym->name, &(tmp_sym->declared_at)); 6026 retval = false; 6027 } 6028 6029 if (tmp_sym->attr.allocatable == 1) 6030 { 6031 gfc_error ("Variable %qs at %L cannot have both the " 6032 "ALLOCATABLE and BIND(C) attributes", 6033 tmp_sym->name, &(tmp_sym->declared_at)); 6034 retval = false; 6035 } 6036 6037 } 6038 6039 /* If it is a BIND(C) function, make sure the return value is a 6040 scalar value. The previous tests in this function made sure 6041 the type is interoperable. */ 6042 if (bind_c_function && tmp_sym->as != NULL) 6043 gfc_error ("Return type of BIND(C) function %qs at %L cannot " 6044 "be an array", tmp_sym->name, &(tmp_sym->declared_at)); 6045 6046 /* BIND(C) functions cannot return a character string. */ 6047 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) 6048 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL 6049 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT 6050 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) 6051 gfc_error ("Return type of BIND(C) function %qs of character " 6052 "type at %L must have length 1", tmp_sym->name, 6053 &(tmp_sym->declared_at)); 6054 } 6055 6056 /* See if the symbol has been marked as private. If it has, make sure 6057 there is no binding label and warn the user if there is one. */ 6058 if (tmp_sym->attr.access == ACCESS_PRIVATE 6059 && tmp_sym->binding_label) 6060 /* Use gfc_warning_now because we won't say that the symbol fails 6061 just because of this. */ 6062 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " 6063 "given the binding label %qs", tmp_sym->name, 6064 &(tmp_sym->declared_at), tmp_sym->binding_label); 6065 6066 return retval; 6067} 6068 6069 6070/* Set the appropriate fields for a symbol that's been declared as 6071 BIND(C) (the is_bind_c flag and the binding label), and verify that 6072 the type is C interoperable. Errors are reported by the functions 6073 used to set/test these fields. */ 6074 6075static bool 6076set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) 6077{ 6078 bool retval = true; 6079 6080 /* TODO: Do we need to make sure the vars aren't marked private? */ 6081 6082 /* Set the is_bind_c bit in symbol_attribute. */ 6083 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); 6084 6085 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents)) 6086 return false; 6087 6088 return retval; 6089} 6090 6091 6092/* Set the fields marking the given common block as BIND(C), including 6093 a binding label, and report any errors encountered. */ 6094 6095static bool 6096set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) 6097{ 6098 bool retval = true; 6099 6100 /* destLabel, common name, typespec (which may have binding label). */ 6101 if (!set_binding_label (&com_block->binding_label, com_block->name, 6102 num_idents)) 6103 return false; 6104 6105 /* Set the given common block (com_block) to being bind(c) (1). */ 6106 set_com_block_bind_c (com_block, 1); 6107 6108 return retval; 6109} 6110 6111 6112/* Retrieve the list of one or more identifiers that the given bind(c) 6113 attribute applies to. */ 6114 6115static bool 6116get_bind_c_idents (void) 6117{ 6118 char name[GFC_MAX_SYMBOL_LEN + 1]; 6119 int num_idents = 0; 6120 gfc_symbol *tmp_sym = NULL; 6121 match found_id; 6122 gfc_common_head *com_block = NULL; 6123 6124 if (gfc_match_name (name) == MATCH_YES) 6125 { 6126 found_id = MATCH_YES; 6127 gfc_get_ha_symbol (name, &tmp_sym); 6128 } 6129 else if (gfc_match_common_name (name) == MATCH_YES) 6130 { 6131 found_id = MATCH_YES; 6132 com_block = gfc_get_common (name, 0); 6133 } 6134 else 6135 { 6136 gfc_error ("Need either entity or common block name for " 6137 "attribute specification statement at %C"); 6138 return false; 6139 } 6140 6141 /* Save the current identifier and look for more. */ 6142 do 6143 { 6144 /* Increment the number of identifiers found for this spec stmt. */ 6145 num_idents++; 6146 6147 /* Make sure we have a sym or com block, and verify that it can 6148 be bind(c). Set the appropriate field(s) and look for more 6149 identifiers. */ 6150 if (tmp_sym != NULL || com_block != NULL) 6151 { 6152 if (tmp_sym != NULL) 6153 { 6154 if (!set_verify_bind_c_sym (tmp_sym, num_idents)) 6155 return false; 6156 } 6157 else 6158 { 6159 if (!set_verify_bind_c_com_block (com_block, num_idents)) 6160 return false; 6161 } 6162 6163 /* Look to see if we have another identifier. */ 6164 tmp_sym = NULL; 6165 if (gfc_match_eos () == MATCH_YES) 6166 found_id = MATCH_NO; 6167 else if (gfc_match_char (',') != MATCH_YES) 6168 found_id = MATCH_NO; 6169 else if (gfc_match_name (name) == MATCH_YES) 6170 { 6171 found_id = MATCH_YES; 6172 gfc_get_ha_symbol (name, &tmp_sym); 6173 } 6174 else if (gfc_match_common_name (name) == MATCH_YES) 6175 { 6176 found_id = MATCH_YES; 6177 com_block = gfc_get_common (name, 0); 6178 } 6179 else 6180 { 6181 gfc_error ("Missing entity or common block name for " 6182 "attribute specification statement at %C"); 6183 return false; 6184 } 6185 } 6186 else 6187 { 6188 gfc_internal_error ("Missing symbol"); 6189 } 6190 } while (found_id == MATCH_YES); 6191 6192 /* if we get here we were successful */ 6193 return true; 6194} 6195 6196 6197/* Try and match a BIND(C) attribute specification statement. */ 6198 6199match 6200gfc_match_bind_c_stmt (void) 6201{ 6202 match found_match = MATCH_NO; 6203 gfc_typespec *ts; 6204 6205 ts = ¤t_ts; 6206 6207 /* This may not be necessary. */ 6208 gfc_clear_ts (ts); 6209 /* Clear the temporary binding label holder. */ 6210 curr_binding_label = NULL; 6211 6212 /* Look for the bind(c). */ 6213 found_match = gfc_match_bind_c (NULL, true); 6214 6215 if (found_match == MATCH_YES) 6216 { 6217 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C")) 6218 return MATCH_ERROR; 6219 6220 /* Look for the :: now, but it is not required. */ 6221 gfc_match (" :: "); 6222 6223 /* Get the identifier(s) that needs to be updated. This may need to 6224 change to hand the flag(s) for the attr specified so all identifiers 6225 found can have all appropriate parts updated (assuming that the same 6226 spec stmt can have multiple attrs, such as both bind(c) and 6227 allocatable...). */ 6228 if (!get_bind_c_idents ()) 6229 /* Error message should have printed already. */ 6230 return MATCH_ERROR; 6231 } 6232 6233 return found_match; 6234} 6235 6236 6237/* Match a data declaration statement. */ 6238 6239match 6240gfc_match_data_decl (void) 6241{ 6242 gfc_symbol *sym; 6243 match m; 6244 int elem; 6245 6246 type_param_spec_list = NULL; 6247 decl_type_param_list = NULL; 6248 6249 num_idents_on_line = 0; 6250 6251 m = gfc_match_decl_type_spec (¤t_ts, 0); 6252 if (m != MATCH_YES) 6253 return m; 6254 6255 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 6256 && !gfc_comp_struct (gfc_current_state ())) 6257 { 6258 sym = gfc_use_derived (current_ts.u.derived); 6259 6260 if (sym == NULL) 6261 { 6262 m = MATCH_ERROR; 6263 goto cleanup; 6264 } 6265 6266 current_ts.u.derived = sym; 6267 } 6268 6269 m = match_attr_spec (); 6270 if (m == MATCH_ERROR) 6271 { 6272 m = MATCH_NO; 6273 goto cleanup; 6274 } 6275 6276 /* F2018:C708. */ 6277 if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER) 6278 { 6279 gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute"); 6280 m = MATCH_ERROR; 6281 goto cleanup; 6282 } 6283 6284 if (current_ts.type == BT_CLASS 6285 && current_ts.u.derived->attr.unlimited_polymorphic) 6286 goto ok; 6287 6288 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 6289 && current_ts.u.derived->components == NULL 6290 && !current_ts.u.derived->attr.zero_comp) 6291 { 6292 6293 if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())) 6294 goto ok; 6295 6296 if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED) 6297 goto ok; 6298 6299 gfc_find_symbol (current_ts.u.derived->name, 6300 current_ts.u.derived->ns, 1, &sym); 6301 6302 /* Any symbol that we find had better be a type definition 6303 which has its components defined, or be a structure definition 6304 actively being parsed. */ 6305 if (sym != NULL && gfc_fl_struct (sym->attr.flavor) 6306 && (current_ts.u.derived->components != NULL 6307 || current_ts.u.derived->attr.zero_comp 6308 || current_ts.u.derived == gfc_new_block)) 6309 goto ok; 6310 6311 gfc_error ("Derived type at %C has not been previously defined " 6312 "and so cannot appear in a derived type definition"); 6313 m = MATCH_ERROR; 6314 goto cleanup; 6315 } 6316 6317ok: 6318 /* If we have an old-style character declaration, and no new-style 6319 attribute specifications, then there a comma is optional between 6320 the type specification and the variable list. */ 6321 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) 6322 gfc_match_char (','); 6323 6324 /* Give the types/attributes to symbols that follow. Give the element 6325 a number so that repeat character length expressions can be copied. */ 6326 elem = 1; 6327 for (;;) 6328 { 6329 num_idents_on_line++; 6330 m = variable_decl (elem++); 6331 if (m == MATCH_ERROR) 6332 goto cleanup; 6333 if (m == MATCH_NO) 6334 break; 6335 6336 if (gfc_match_eos () == MATCH_YES) 6337 goto cleanup; 6338 if (gfc_match_char (',') != MATCH_YES) 6339 break; 6340 } 6341 6342 if (!gfc_error_flag_test ()) 6343 { 6344 /* An anonymous structure declaration is unambiguous; if we matched one 6345 according to gfc_match_structure_decl, we need to return MATCH_YES 6346 here to avoid confusing the remaining matchers, even if there was an 6347 error during variable_decl. We must flush any such errors. Note this 6348 causes the parser to gracefully continue parsing the remaining input 6349 as a structure body, which likely follows. */ 6350 if (current_ts.type == BT_DERIVED && current_ts.u.derived 6351 && gfc_fl_struct (current_ts.u.derived->attr.flavor)) 6352 { 6353 gfc_error_now ("Syntax error in anonymous structure declaration" 6354 " at %C"); 6355 /* Skip the bad variable_decl and line up for the start of the 6356 structure body. */ 6357 gfc_error_recovery (); 6358 m = MATCH_YES; 6359 goto cleanup; 6360 } 6361 6362 gfc_error ("Syntax error in data declaration at %C"); 6363 } 6364 6365 m = MATCH_ERROR; 6366 6367 gfc_free_data_all (gfc_current_ns); 6368 6369cleanup: 6370 if (saved_kind_expr) 6371 gfc_free_expr (saved_kind_expr); 6372 if (type_param_spec_list) 6373 gfc_free_actual_arglist (type_param_spec_list); 6374 if (decl_type_param_list) 6375 gfc_free_actual_arglist (decl_type_param_list); 6376 saved_kind_expr = NULL; 6377 gfc_free_array_spec (current_as); 6378 current_as = NULL; 6379 return m; 6380} 6381 6382static bool 6383in_module_or_interface(void) 6384{ 6385 if (gfc_current_state () == COMP_MODULE 6386 || gfc_current_state () == COMP_SUBMODULE 6387 || gfc_current_state () == COMP_INTERFACE) 6388 return true; 6389 6390 if (gfc_state_stack->state == COMP_CONTAINS 6391 || gfc_state_stack->state == COMP_FUNCTION 6392 || gfc_state_stack->state == COMP_SUBROUTINE) 6393 { 6394 gfc_state_data *p; 6395 for (p = gfc_state_stack->previous; p ; p = p->previous) 6396 { 6397 if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE 6398 || p->state == COMP_INTERFACE) 6399 return true; 6400 } 6401 } 6402 return false; 6403} 6404 6405/* Match a prefix associated with a function or subroutine 6406 declaration. If the typespec pointer is nonnull, then a typespec 6407 can be matched. Note that if nothing matches, MATCH_YES is 6408 returned (the null string was matched). */ 6409 6410match 6411gfc_match_prefix (gfc_typespec *ts) 6412{ 6413 bool seen_type; 6414 bool seen_impure; 6415 bool found_prefix; 6416 6417 gfc_clear_attr (¤t_attr); 6418 seen_type = false; 6419 seen_impure = false; 6420 6421 gcc_assert (!gfc_matching_prefix); 6422 gfc_matching_prefix = true; 6423 6424 do 6425 { 6426 found_prefix = false; 6427 6428 /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a 6429 corresponding attribute seems natural and distinguishes these 6430 procedures from procedure types of PROC_MODULE, which these are 6431 as well. */ 6432 if (gfc_match ("module% ") == MATCH_YES) 6433 { 6434 if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C")) 6435 goto error; 6436 6437 if (!in_module_or_interface ()) 6438 { 6439 gfc_error ("MODULE prefix at %C found outside of a module, " 6440 "submodule, or interface"); 6441 goto error; 6442 } 6443 6444 current_attr.module_procedure = 1; 6445 found_prefix = true; 6446 } 6447 6448 if (!seen_type && ts != NULL) 6449 { 6450 match m; 6451 m = gfc_match_decl_type_spec (ts, 0); 6452 if (m == MATCH_ERROR) 6453 goto error; 6454 if (m == MATCH_YES && gfc_match_space () == MATCH_YES) 6455 { 6456 seen_type = true; 6457 found_prefix = true; 6458 } 6459 } 6460 6461 if (gfc_match ("elemental% ") == MATCH_YES) 6462 { 6463 if (!gfc_add_elemental (¤t_attr, NULL)) 6464 goto error; 6465 6466 found_prefix = true; 6467 } 6468 6469 if (gfc_match ("pure% ") == MATCH_YES) 6470 { 6471 if (!gfc_add_pure (¤t_attr, NULL)) 6472 goto error; 6473 6474 found_prefix = true; 6475 } 6476 6477 if (gfc_match ("recursive% ") == MATCH_YES) 6478 { 6479 if (!gfc_add_recursive (¤t_attr, NULL)) 6480 goto error; 6481 6482 found_prefix = true; 6483 } 6484 6485 /* IMPURE is a somewhat special case, as it needs not set an actual 6486 attribute but rather only prevents ELEMENTAL routines from being 6487 automatically PURE. */ 6488 if (gfc_match ("impure% ") == MATCH_YES) 6489 { 6490 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C")) 6491 goto error; 6492 6493 seen_impure = true; 6494 found_prefix = true; 6495 } 6496 } 6497 while (found_prefix); 6498 6499 /* IMPURE and PURE must not both appear, of course. */ 6500 if (seen_impure && current_attr.pure) 6501 { 6502 gfc_error ("PURE and IMPURE must not appear both at %C"); 6503 goto error; 6504 } 6505 6506 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ 6507 if (!seen_impure && current_attr.elemental && !current_attr.pure) 6508 { 6509 if (!gfc_add_pure (¤t_attr, NULL)) 6510 goto error; 6511 } 6512 6513 /* At this point, the next item is not a prefix. */ 6514 gcc_assert (gfc_matching_prefix); 6515 6516 gfc_matching_prefix = false; 6517 return MATCH_YES; 6518 6519error: 6520 gcc_assert (gfc_matching_prefix); 6521 gfc_matching_prefix = false; 6522 return MATCH_ERROR; 6523} 6524 6525 6526/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ 6527 6528static bool 6529copy_prefix (symbol_attribute *dest, locus *where) 6530{ 6531 if (dest->module_procedure) 6532 { 6533 if (current_attr.elemental) 6534 dest->elemental = 1; 6535 6536 if (current_attr.pure) 6537 dest->pure = 1; 6538 6539 if (current_attr.recursive) 6540 dest->recursive = 1; 6541 6542 /* Module procedures are unusual in that the 'dest' is copied from 6543 the interface declaration. However, this is an oportunity to 6544 check that the submodule declaration is compliant with the 6545 interface. */ 6546 if (dest->elemental && !current_attr.elemental) 6547 { 6548 gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is " 6549 "missing at %L", where); 6550 return false; 6551 } 6552 6553 if (dest->pure && !current_attr.pure) 6554 { 6555 gfc_error ("PURE prefix in MODULE PROCEDURE interface is " 6556 "missing at %L", where); 6557 return false; 6558 } 6559 6560 if (dest->recursive && !current_attr.recursive) 6561 { 6562 gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is " 6563 "missing at %L", where); 6564 return false; 6565 } 6566 6567 return true; 6568 } 6569 6570 if (current_attr.elemental && !gfc_add_elemental (dest, where)) 6571 return false; 6572 6573 if (current_attr.pure && !gfc_add_pure (dest, where)) 6574 return false; 6575 6576 if (current_attr.recursive && !gfc_add_recursive (dest, where)) 6577 return false; 6578 6579 return true; 6580} 6581 6582 6583/* Match a formal argument list or, if typeparam is true, a 6584 type_param_name_list. */ 6585 6586match 6587gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, 6588 int null_flag, bool typeparam) 6589{ 6590 gfc_formal_arglist *head, *tail, *p, *q; 6591 char name[GFC_MAX_SYMBOL_LEN + 1]; 6592 gfc_symbol *sym; 6593 match m; 6594 gfc_formal_arglist *formal = NULL; 6595 6596 head = tail = NULL; 6597 6598 /* Keep the interface formal argument list and null it so that the 6599 matching for the new declaration can be done. The numbers and 6600 names of the arguments are checked here. The interface formal 6601 arguments are retained in formal_arglist and the characteristics 6602 are compared in resolve.cc(resolve_fl_procedure). See the remark 6603 in get_proc_name about the eventual need to copy the formal_arglist 6604 and populate the formal namespace of the interface symbol. */ 6605 if (progname->attr.module_procedure 6606 && progname->attr.host_assoc) 6607 { 6608 formal = progname->formal; 6609 progname->formal = NULL; 6610 } 6611 6612 if (gfc_match_char ('(') != MATCH_YES) 6613 { 6614 if (null_flag) 6615 goto ok; 6616 return MATCH_NO; 6617 } 6618 6619 if (gfc_match_char (')') == MATCH_YES) 6620 { 6621 if (typeparam) 6622 { 6623 gfc_error_now ("A type parameter list is required at %C"); 6624 m = MATCH_ERROR; 6625 goto cleanup; 6626 } 6627 else 6628 goto ok; 6629 } 6630 6631 for (;;) 6632 { 6633 if (gfc_match_char ('*') == MATCH_YES) 6634 { 6635 sym = NULL; 6636 if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS, 6637 "Alternate-return argument at %C")) 6638 { 6639 m = MATCH_ERROR; 6640 goto cleanup; 6641 } 6642 else if (typeparam) 6643 gfc_error_now ("A parameter name is required at %C"); 6644 } 6645 else 6646 { 6647 m = gfc_match_name (name); 6648 if (m != MATCH_YES) 6649 { 6650 if(typeparam) 6651 gfc_error_now ("A parameter name is required at %C"); 6652 goto cleanup; 6653 } 6654 6655 if (!typeparam && gfc_get_symbol (name, NULL, &sym)) 6656 goto cleanup; 6657 else if (typeparam 6658 && gfc_get_symbol (name, progname->f2k_derived, &sym)) 6659 goto cleanup; 6660 } 6661 6662 p = gfc_get_formal_arglist (); 6663 6664 if (head == NULL) 6665 head = tail = p; 6666 else 6667 { 6668 tail->next = p; 6669 tail = p; 6670 } 6671 6672 tail->sym = sym; 6673 6674 /* We don't add the VARIABLE flavor because the name could be a 6675 dummy procedure. We don't apply these attributes to formal 6676 arguments of statement functions. */ 6677 if (sym != NULL && !st_flag 6678 && (!gfc_add_dummy(&sym->attr, sym->name, NULL) 6679 || !gfc_missing_attr (&sym->attr, NULL))) 6680 { 6681 m = MATCH_ERROR; 6682 goto cleanup; 6683 } 6684 6685 /* The name of a program unit can be in a different namespace, 6686 so check for it explicitly. After the statement is accepted, 6687 the name is checked for especially in gfc_get_symbol(). */ 6688 if (gfc_new_block != NULL && sym != NULL && !typeparam 6689 && strcmp (sym->name, gfc_new_block->name) == 0) 6690 { 6691 gfc_error ("Name %qs at %C is the name of the procedure", 6692 sym->name); 6693 m = MATCH_ERROR; 6694 goto cleanup; 6695 } 6696 6697 if (gfc_match_char (')') == MATCH_YES) 6698 goto ok; 6699 6700 m = gfc_match_char (','); 6701 if (m != MATCH_YES) 6702 { 6703 if (typeparam) 6704 gfc_error_now ("Expected parameter list in type declaration " 6705 "at %C"); 6706 else 6707 gfc_error ("Unexpected junk in formal argument list at %C"); 6708 goto cleanup; 6709 } 6710 } 6711 6712ok: 6713 /* Check for duplicate symbols in the formal argument list. */ 6714 if (head != NULL) 6715 { 6716 for (p = head; p->next; p = p->next) 6717 { 6718 if (p->sym == NULL) 6719 continue; 6720 6721 for (q = p->next; q; q = q->next) 6722 if (p->sym == q->sym) 6723 { 6724 if (typeparam) 6725 gfc_error_now ("Duplicate name %qs in parameter " 6726 "list at %C", p->sym->name); 6727 else 6728 gfc_error ("Duplicate symbol %qs in formal argument " 6729 "list at %C", p->sym->name); 6730 6731 m = MATCH_ERROR; 6732 goto cleanup; 6733 } 6734 } 6735 } 6736 6737 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)) 6738 { 6739 m = MATCH_ERROR; 6740 goto cleanup; 6741 } 6742 6743 /* gfc_error_now used in following and return with MATCH_YES because 6744 doing otherwise results in a cascade of extraneous errors and in 6745 some cases an ICE in symbol.cc(gfc_release_symbol). */ 6746 if (progname->attr.module_procedure && progname->attr.host_assoc) 6747 { 6748 bool arg_count_mismatch = false; 6749 6750 if (!formal && head) 6751 arg_count_mismatch = true; 6752 6753 /* Abbreviated module procedure declaration is not meant to have any 6754 formal arguments! */ 6755 if (!progname->abr_modproc_decl && formal && !head) 6756 arg_count_mismatch = true; 6757 6758 for (p = formal, q = head; p && q; p = p->next, q = q->next) 6759 { 6760 if ((p->next != NULL && q->next == NULL) 6761 || (p->next == NULL && q->next != NULL)) 6762 arg_count_mismatch = true; 6763 else if ((p->sym == NULL && q->sym == NULL) 6764 || strcmp (p->sym->name, q->sym->name) == 0) 6765 continue; 6766 else 6767 gfc_error_now ("Mismatch in MODULE PROCEDURE formal " 6768 "argument names (%s/%s) at %C", 6769 p->sym->name, q->sym->name); 6770 } 6771 6772 if (arg_count_mismatch) 6773 gfc_error_now ("Mismatch in number of MODULE PROCEDURE " 6774 "formal arguments at %C"); 6775 } 6776 6777 return MATCH_YES; 6778 6779cleanup: 6780 gfc_free_formal_arglist (head); 6781 return m; 6782} 6783 6784 6785/* Match a RESULT specification following a function declaration or 6786 ENTRY statement. Also matches the end-of-statement. */ 6787 6788static match 6789match_result (gfc_symbol *function, gfc_symbol **result) 6790{ 6791 char name[GFC_MAX_SYMBOL_LEN + 1]; 6792 gfc_symbol *r; 6793 match m; 6794 6795 if (gfc_match (" result (") != MATCH_YES) 6796 return MATCH_NO; 6797 6798 m = gfc_match_name (name); 6799 if (m != MATCH_YES) 6800 return m; 6801 6802 /* Get the right paren, and that's it because there could be the 6803 bind(c) attribute after the result clause. */ 6804 if (gfc_match_char (')') != MATCH_YES) 6805 { 6806 /* TODO: should report the missing right paren here. */ 6807 return MATCH_ERROR; 6808 } 6809 6810 if (strcmp (function->name, name) == 0) 6811 { 6812 gfc_error ("RESULT variable at %C must be different than function name"); 6813 return MATCH_ERROR; 6814 } 6815 6816 if (gfc_get_symbol (name, NULL, &r)) 6817 return MATCH_ERROR; 6818 6819 if (!gfc_add_result (&r->attr, r->name, NULL)) 6820 return MATCH_ERROR; 6821 6822 *result = r; 6823 6824 return MATCH_YES; 6825} 6826 6827 6828/* Match a function suffix, which could be a combination of a result 6829 clause and BIND(C), either one, or neither. The draft does not 6830 require them to come in a specific order. */ 6831 6832static match 6833gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) 6834{ 6835 match is_bind_c; /* Found bind(c). */ 6836 match is_result; /* Found result clause. */ 6837 match found_match; /* Status of whether we've found a good match. */ 6838 char peek_char; /* Character we're going to peek at. */ 6839 bool allow_binding_name; 6840 6841 /* Initialize to having found nothing. */ 6842 found_match = MATCH_NO; 6843 is_bind_c = MATCH_NO; 6844 is_result = MATCH_NO; 6845 6846 /* Get the next char to narrow between result and bind(c). */ 6847 gfc_gobble_whitespace (); 6848 peek_char = gfc_peek_ascii_char (); 6849 6850 /* C binding names are not allowed for internal procedures. */ 6851 if (gfc_current_state () == COMP_CONTAINS 6852 && sym->ns->proc_name->attr.flavor != FL_MODULE) 6853 allow_binding_name = false; 6854 else 6855 allow_binding_name = true; 6856 6857 switch (peek_char) 6858 { 6859 case 'r': 6860 /* Look for result clause. */ 6861 is_result = match_result (sym, result); 6862 if (is_result == MATCH_YES) 6863 { 6864 /* Now see if there is a bind(c) after it. */ 6865 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 6866 /* We've found the result clause and possibly bind(c). */ 6867 found_match = MATCH_YES; 6868 } 6869 else 6870 /* This should only be MATCH_ERROR. */ 6871 found_match = is_result; 6872 break; 6873 case 'b': 6874 /* Look for bind(c) first. */ 6875 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 6876 if (is_bind_c == MATCH_YES) 6877 { 6878 /* Now see if a result clause followed it. */ 6879 is_result = match_result (sym, result); 6880 found_match = MATCH_YES; 6881 } 6882 else 6883 { 6884 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */ 6885 found_match = MATCH_ERROR; 6886 } 6887 break; 6888 default: 6889 gfc_error ("Unexpected junk after function declaration at %C"); 6890 found_match = MATCH_ERROR; 6891 break; 6892 } 6893 6894 if (is_bind_c == MATCH_YES) 6895 { 6896 /* Fortran 2008 draft allows BIND(C) for internal procedures. */ 6897 if (gfc_current_state () == COMP_CONTAINS 6898 && sym->ns->proc_name->attr.flavor != FL_MODULE 6899 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " 6900 "at %L may not be specified for an internal " 6901 "procedure", &gfc_current_locus)) 6902 return MATCH_ERROR; 6903 6904 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)) 6905 return MATCH_ERROR; 6906 } 6907 6908 return found_match; 6909} 6910 6911 6912/* Procedure pointer return value without RESULT statement: 6913 Add "hidden" result variable named "ppr@". */ 6914 6915static bool 6916add_hidden_procptr_result (gfc_symbol *sym) 6917{ 6918 bool case1,case2; 6919 6920 if (gfc_notification_std (GFC_STD_F2003) == ERROR) 6921 return false; 6922 6923 /* First usage case: PROCEDURE and EXTERNAL statements. */ 6924 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () 6925 && strcmp (gfc_current_block ()->name, sym->name) == 0 6926 && sym->attr.external; 6927 /* Second usage case: INTERFACE statements. */ 6928 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous 6929 && gfc_state_stack->previous->state == COMP_FUNCTION 6930 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; 6931 6932 if (case1 || case2) 6933 { 6934 gfc_symtree *stree; 6935 if (case1) 6936 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false); 6937 else 6938 { 6939 gfc_symtree *st2; 6940 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false); 6941 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@"); 6942 st2->n.sym = stree->n.sym; 6943 stree->n.sym->refs++; 6944 } 6945 sym->result = stree->n.sym; 6946 6947 sym->result->attr.proc_pointer = sym->attr.proc_pointer; 6948 sym->result->attr.pointer = sym->attr.pointer; 6949 sym->result->attr.external = sym->attr.external; 6950 sym->result->attr.referenced = sym->attr.referenced; 6951 sym->result->ts = sym->ts; 6952 sym->attr.proc_pointer = 0; 6953 sym->attr.pointer = 0; 6954 sym->attr.external = 0; 6955 if (sym->result->attr.external && sym->result->attr.pointer) 6956 { 6957 sym->result->attr.pointer = 0; 6958 sym->result->attr.proc_pointer = 1; 6959 } 6960 6961 return gfc_add_result (&sym->result->attr, sym->result->name, NULL); 6962 } 6963 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ 6964 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer 6965 && sym->result && sym->result != sym && sym->result->attr.external 6966 && sym == gfc_current_ns->proc_name 6967 && sym == sym->result->ns->proc_name 6968 && strcmp ("ppr@", sym->result->name) == 0) 6969 { 6970 sym->result->attr.proc_pointer = 1; 6971 sym->attr.pointer = 0; 6972 return true; 6973 } 6974 else 6975 return false; 6976} 6977 6978 6979/* Match the interface for a PROCEDURE declaration, 6980 including brackets (R1212). */ 6981 6982static match 6983match_procedure_interface (gfc_symbol **proc_if) 6984{ 6985 match m; 6986 gfc_symtree *st; 6987 locus old_loc, entry_loc; 6988 gfc_namespace *old_ns = gfc_current_ns; 6989 char name[GFC_MAX_SYMBOL_LEN + 1]; 6990 6991 old_loc = entry_loc = gfc_current_locus; 6992 gfc_clear_ts (¤t_ts); 6993 6994 if (gfc_match (" (") != MATCH_YES) 6995 { 6996 gfc_current_locus = entry_loc; 6997 return MATCH_NO; 6998 } 6999 7000 /* Get the type spec. for the procedure interface. */ 7001 old_loc = gfc_current_locus; 7002 m = gfc_match_decl_type_spec (¤t_ts, 0); 7003 gfc_gobble_whitespace (); 7004 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) 7005 goto got_ts; 7006 7007 if (m == MATCH_ERROR) 7008 return m; 7009 7010 /* Procedure interface is itself a procedure. */ 7011 gfc_current_locus = old_loc; 7012 m = gfc_match_name (name); 7013 7014 /* First look to see if it is already accessible in the current 7015 namespace because it is use associated or contained. */ 7016 st = NULL; 7017 if (gfc_find_sym_tree (name, NULL, 0, &st)) 7018 return MATCH_ERROR; 7019 7020 /* If it is still not found, then try the parent namespace, if it 7021 exists and create the symbol there if it is still not found. */ 7022 if (gfc_current_ns->parent) 7023 gfc_current_ns = gfc_current_ns->parent; 7024 if (st == NULL && gfc_get_ha_sym_tree (name, &st)) 7025 return MATCH_ERROR; 7026 7027 gfc_current_ns = old_ns; 7028 *proc_if = st->n.sym; 7029 7030 if (*proc_if) 7031 { 7032 (*proc_if)->refs++; 7033 /* Resolve interface if possible. That way, attr.procedure is only set 7034 if it is declared by a later procedure-declaration-stmt, which is 7035 invalid per F08:C1216 (cf. resolve_procedure_interface). */ 7036 while ((*proc_if)->ts.interface 7037 && *proc_if != (*proc_if)->ts.interface) 7038 *proc_if = (*proc_if)->ts.interface; 7039 7040 if ((*proc_if)->attr.flavor == FL_UNKNOWN 7041 && (*proc_if)->ts.type == BT_UNKNOWN 7042 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, 7043 (*proc_if)->name, NULL)) 7044 return MATCH_ERROR; 7045 } 7046 7047got_ts: 7048 if (gfc_match (" )") != MATCH_YES) 7049 { 7050 gfc_current_locus = entry_loc; 7051 return MATCH_NO; 7052 } 7053 7054 return MATCH_YES; 7055} 7056 7057 7058/* Match a PROCEDURE declaration (R1211). */ 7059 7060static match 7061match_procedure_decl (void) 7062{ 7063 match m; 7064 gfc_symbol *sym, *proc_if = NULL; 7065 int num; 7066 gfc_expr *initializer = NULL; 7067 7068 /* Parse interface (with brackets). */ 7069 m = match_procedure_interface (&proc_if); 7070 if (m != MATCH_YES) 7071 return m; 7072 7073 /* Parse attributes (with colons). */ 7074 m = match_attr_spec(); 7075 if (m == MATCH_ERROR) 7076 return MATCH_ERROR; 7077 7078 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c) 7079 { 7080 current_attr.is_bind_c = 1; 7081 has_name_equals = 0; 7082 curr_binding_label = NULL; 7083 } 7084 7085 /* Get procedure symbols. */ 7086 for(num=1;;num++) 7087 { 7088 m = gfc_match_symbol (&sym, 0); 7089 if (m == MATCH_NO) 7090 goto syntax; 7091 else if (m == MATCH_ERROR) 7092 return m; 7093 7094 /* Add current_attr to the symbol attributes. */ 7095 if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL)) 7096 return MATCH_ERROR; 7097 7098 if (sym->attr.is_bind_c) 7099 { 7100 /* Check for C1218. */ 7101 if (!proc_if || !proc_if->attr.is_bind_c) 7102 { 7103 gfc_error ("BIND(C) attribute at %C requires " 7104 "an interface with BIND(C)"); 7105 return MATCH_ERROR; 7106 } 7107 /* Check for C1217. */ 7108 if (has_name_equals && sym->attr.pointer) 7109 { 7110 gfc_error ("BIND(C) procedure with NAME may not have " 7111 "POINTER attribute at %C"); 7112 return MATCH_ERROR; 7113 } 7114 if (has_name_equals && sym->attr.dummy) 7115 { 7116 gfc_error ("Dummy procedure at %C may not have " 7117 "BIND(C) attribute with NAME"); 7118 return MATCH_ERROR; 7119 } 7120 /* Set binding label for BIND(C). */ 7121 if (!set_binding_label (&sym->binding_label, sym->name, num)) 7122 return MATCH_ERROR; 7123 } 7124 7125 if (!gfc_add_external (&sym->attr, NULL)) 7126 return MATCH_ERROR; 7127 7128 if (add_hidden_procptr_result (sym)) 7129 sym = sym->result; 7130 7131 if (!gfc_add_proc (&sym->attr, sym->name, NULL)) 7132 return MATCH_ERROR; 7133 7134 /* Set interface. */ 7135 if (proc_if != NULL) 7136 { 7137 if (sym->ts.type != BT_UNKNOWN) 7138 { 7139 gfc_error ("Procedure %qs at %L already has basic type of %s", 7140 sym->name, &gfc_current_locus, 7141 gfc_basic_typename (sym->ts.type)); 7142 return MATCH_ERROR; 7143 } 7144 sym->ts.interface = proc_if; 7145 sym->attr.untyped = 1; 7146 sym->attr.if_source = IFSRC_IFBODY; 7147 } 7148 else if (current_ts.type != BT_UNKNOWN) 7149 { 7150 if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) 7151 return MATCH_ERROR; 7152 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); 7153 sym->ts.interface->ts = current_ts; 7154 sym->ts.interface->attr.flavor = FL_PROCEDURE; 7155 sym->ts.interface->attr.function = 1; 7156 sym->attr.function = 1; 7157 sym->attr.if_source = IFSRC_UNKNOWN; 7158 } 7159 7160 if (gfc_match (" =>") == MATCH_YES) 7161 { 7162 if (!current_attr.pointer) 7163 { 7164 gfc_error ("Initialization at %C isn't for a pointer variable"); 7165 m = MATCH_ERROR; 7166 goto cleanup; 7167 } 7168 7169 m = match_pointer_init (&initializer, 1); 7170 if (m != MATCH_YES) 7171 goto cleanup; 7172 7173 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)) 7174 goto cleanup; 7175 7176 } 7177 7178 if (gfc_match_eos () == MATCH_YES) 7179 return MATCH_YES; 7180 if (gfc_match_char (',') != MATCH_YES) 7181 goto syntax; 7182 } 7183 7184syntax: 7185 gfc_error ("Syntax error in PROCEDURE statement at %C"); 7186 return MATCH_ERROR; 7187 7188cleanup: 7189 /* Free stuff up and return. */ 7190 gfc_free_expr (initializer); 7191 return m; 7192} 7193 7194 7195static match 7196match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc); 7197 7198 7199/* Match a procedure pointer component declaration (R445). */ 7200 7201static match 7202match_ppc_decl (void) 7203{ 7204 match m; 7205 gfc_symbol *proc_if = NULL; 7206 gfc_typespec ts; 7207 int num; 7208 gfc_component *c; 7209 gfc_expr *initializer = NULL; 7210 gfc_typebound_proc* tb; 7211 char name[GFC_MAX_SYMBOL_LEN + 1]; 7212 7213 /* Parse interface (with brackets). */ 7214 m = match_procedure_interface (&proc_if); 7215 if (m != MATCH_YES) 7216 goto syntax; 7217 7218 /* Parse attributes. */ 7219 tb = XCNEW (gfc_typebound_proc); 7220 tb->where = gfc_current_locus; 7221 m = match_binding_attributes (tb, false, true); 7222 if (m == MATCH_ERROR) 7223 return m; 7224 7225 gfc_clear_attr (¤t_attr); 7226 current_attr.procedure = 1; 7227 current_attr.proc_pointer = 1; 7228 current_attr.access = tb->access; 7229 current_attr.flavor = FL_PROCEDURE; 7230 7231 /* Match the colons (required). */ 7232 if (gfc_match (" ::") != MATCH_YES) 7233 { 7234 gfc_error ("Expected %<::%> after binding-attributes at %C"); 7235 return MATCH_ERROR; 7236 } 7237 7238 /* Check for C450. */ 7239 if (!tb->nopass && proc_if == NULL) 7240 { 7241 gfc_error("NOPASS or explicit interface required at %C"); 7242 return MATCH_ERROR; 7243 } 7244 7245 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C")) 7246 return MATCH_ERROR; 7247 7248 /* Match PPC names. */ 7249 ts = current_ts; 7250 for(num=1;;num++) 7251 { 7252 m = gfc_match_name (name); 7253 if (m == MATCH_NO) 7254 goto syntax; 7255 else if (m == MATCH_ERROR) 7256 return m; 7257 7258 if (!gfc_add_component (gfc_current_block(), name, &c)) 7259 return MATCH_ERROR; 7260 7261 /* Add current_attr to the symbol attributes. */ 7262 if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL)) 7263 return MATCH_ERROR; 7264 7265 if (!gfc_add_external (&c->attr, NULL)) 7266 return MATCH_ERROR; 7267 7268 if (!gfc_add_proc (&c->attr, name, NULL)) 7269 return MATCH_ERROR; 7270 7271 if (num == 1) 7272 c->tb = tb; 7273 else 7274 { 7275 c->tb = XCNEW (gfc_typebound_proc); 7276 c->tb->where = gfc_current_locus; 7277 *c->tb = *tb; 7278 } 7279 7280 /* Set interface. */ 7281 if (proc_if != NULL) 7282 { 7283 c->ts.interface = proc_if; 7284 c->attr.untyped = 1; 7285 c->attr.if_source = IFSRC_IFBODY; 7286 } 7287 else if (ts.type != BT_UNKNOWN) 7288 { 7289 c->ts = ts; 7290 c->ts.interface = gfc_new_symbol ("", gfc_current_ns); 7291 c->ts.interface->result = c->ts.interface; 7292 c->ts.interface->ts = ts; 7293 c->ts.interface->attr.flavor = FL_PROCEDURE; 7294 c->ts.interface->attr.function = 1; 7295 c->attr.function = 1; 7296 c->attr.if_source = IFSRC_UNKNOWN; 7297 } 7298 7299 if (gfc_match (" =>") == MATCH_YES) 7300 { 7301 m = match_pointer_init (&initializer, 1); 7302 if (m != MATCH_YES) 7303 { 7304 gfc_free_expr (initializer); 7305 return m; 7306 } 7307 c->initializer = initializer; 7308 } 7309 7310 if (gfc_match_eos () == MATCH_YES) 7311 return MATCH_YES; 7312 if (gfc_match_char (',') != MATCH_YES) 7313 goto syntax; 7314 } 7315 7316syntax: 7317 gfc_error ("Syntax error in procedure pointer component at %C"); 7318 return MATCH_ERROR; 7319} 7320 7321 7322/* Match a PROCEDURE declaration inside an interface (R1206). */ 7323 7324static match 7325match_procedure_in_interface (void) 7326{ 7327 match m; 7328 gfc_symbol *sym; 7329 char name[GFC_MAX_SYMBOL_LEN + 1]; 7330 locus old_locus; 7331 7332 if (current_interface.type == INTERFACE_NAMELESS 7333 || current_interface.type == INTERFACE_ABSTRACT) 7334 { 7335 gfc_error ("PROCEDURE at %C must be in a generic interface"); 7336 return MATCH_ERROR; 7337 } 7338 7339 /* Check if the F2008 optional double colon appears. */ 7340 gfc_gobble_whitespace (); 7341 old_locus = gfc_current_locus; 7342 if (gfc_match ("::") == MATCH_YES) 7343 { 7344 if (!gfc_notify_std (GFC_STD_F2008, "double colon in " 7345 "MODULE PROCEDURE statement at %L", &old_locus)) 7346 return MATCH_ERROR; 7347 } 7348 else 7349 gfc_current_locus = old_locus; 7350 7351 for(;;) 7352 { 7353 m = gfc_match_name (name); 7354 if (m == MATCH_NO) 7355 goto syntax; 7356 else if (m == MATCH_ERROR) 7357 return m; 7358 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) 7359 return MATCH_ERROR; 7360 7361 if (!gfc_add_interface (sym)) 7362 return MATCH_ERROR; 7363 7364 if (gfc_match_eos () == MATCH_YES) 7365 break; 7366 if (gfc_match_char (',') != MATCH_YES) 7367 goto syntax; 7368 } 7369 7370 return MATCH_YES; 7371 7372syntax: 7373 gfc_error ("Syntax error in PROCEDURE statement at %C"); 7374 return MATCH_ERROR; 7375} 7376 7377 7378/* General matcher for PROCEDURE declarations. */ 7379 7380static match match_procedure_in_type (void); 7381 7382match 7383gfc_match_procedure (void) 7384{ 7385 match m; 7386 7387 switch (gfc_current_state ()) 7388 { 7389 case COMP_NONE: 7390 case COMP_PROGRAM: 7391 case COMP_MODULE: 7392 case COMP_SUBMODULE: 7393 case COMP_SUBROUTINE: 7394 case COMP_FUNCTION: 7395 case COMP_BLOCK: 7396 m = match_procedure_decl (); 7397 break; 7398 case COMP_INTERFACE: 7399 m = match_procedure_in_interface (); 7400 break; 7401 case COMP_DERIVED: 7402 m = match_ppc_decl (); 7403 break; 7404 case COMP_DERIVED_CONTAINS: 7405 m = match_procedure_in_type (); 7406 break; 7407 default: 7408 return MATCH_NO; 7409 } 7410 7411 if (m != MATCH_YES) 7412 return m; 7413 7414 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C")) 7415 return MATCH_ERROR; 7416 7417 return m; 7418} 7419 7420 7421/* Warn if a matched procedure has the same name as an intrinsic; this is 7422 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current 7423 parser-state-stack to find out whether we're in a module. */ 7424 7425static void 7426do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func) 7427{ 7428 bool in_module; 7429 7430 in_module = (gfc_state_stack->previous 7431 && (gfc_state_stack->previous->state == COMP_MODULE 7432 || gfc_state_stack->previous->state == COMP_SUBMODULE)); 7433 7434 gfc_warn_intrinsic_shadow (sym, in_module, func); 7435} 7436 7437 7438/* Match a function declaration. */ 7439 7440match 7441gfc_match_function_decl (void) 7442{ 7443 char name[GFC_MAX_SYMBOL_LEN + 1]; 7444 gfc_symbol *sym, *result; 7445 locus old_loc; 7446 match m; 7447 match suffix_match; 7448 match found_match; /* Status returned by match func. */ 7449 7450 if (gfc_current_state () != COMP_NONE 7451 && gfc_current_state () != COMP_INTERFACE 7452 && gfc_current_state () != COMP_CONTAINS) 7453 return MATCH_NO; 7454 7455 gfc_clear_ts (¤t_ts); 7456 7457 old_loc = gfc_current_locus; 7458 7459 m = gfc_match_prefix (¤t_ts); 7460 if (m != MATCH_YES) 7461 { 7462 gfc_current_locus = old_loc; 7463 return m; 7464 } 7465 7466 if (gfc_match ("function% %n", name) != MATCH_YES) 7467 { 7468 gfc_current_locus = old_loc; 7469 return MATCH_NO; 7470 } 7471 7472 if (get_proc_name (name, &sym, false)) 7473 return MATCH_ERROR; 7474 7475 if (add_hidden_procptr_result (sym)) 7476 sym = sym->result; 7477 7478 if (current_attr.module_procedure) 7479 sym->attr.module_procedure = 1; 7480 7481 gfc_new_block = sym; 7482 7483 m = gfc_match_formal_arglist (sym, 0, 0); 7484 if (m == MATCH_NO) 7485 { 7486 gfc_error ("Expected formal argument list in function " 7487 "definition at %C"); 7488 m = MATCH_ERROR; 7489 goto cleanup; 7490 } 7491 else if (m == MATCH_ERROR) 7492 goto cleanup; 7493 7494 result = NULL; 7495 7496 /* According to the draft, the bind(c) and result clause can 7497 come in either order after the formal_arg_list (i.e., either 7498 can be first, both can exist together or by themselves or neither 7499 one). Therefore, the match_result can't match the end of the 7500 string, and check for the bind(c) or result clause in either order. */ 7501 found_match = gfc_match_eos (); 7502 7503 /* Make sure that it isn't already declared as BIND(C). If it is, it 7504 must have been marked BIND(C) with a BIND(C) attribute and that is 7505 not allowed for procedures. */ 7506 if (sym->attr.is_bind_c == 1) 7507 { 7508 sym->attr.is_bind_c = 0; 7509 7510 if (gfc_state_stack->previous 7511 && gfc_state_stack->previous->state != COMP_SUBMODULE) 7512 { 7513 locus loc; 7514 loc = sym->old_symbol != NULL 7515 ? sym->old_symbol->declared_at : gfc_current_locus; 7516 gfc_error_now ("BIND(C) attribute at %L can only be used for " 7517 "variables or common blocks", &loc); 7518 } 7519 } 7520 7521 if (found_match != MATCH_YES) 7522 { 7523 /* If we haven't found the end-of-statement, look for a suffix. */ 7524 suffix_match = gfc_match_suffix (sym, &result); 7525 if (suffix_match == MATCH_YES) 7526 /* Need to get the eos now. */ 7527 found_match = gfc_match_eos (); 7528 else 7529 found_match = suffix_match; 7530 } 7531 7532 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module 7533 subprogram and a binding label is specified, it shall be the 7534 same as the binding label specified in the corresponding module 7535 procedure interface body. */ 7536 if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol 7537 && strcmp (sym->name, sym->old_symbol->name) == 0 7538 && sym->binding_label && sym->old_symbol->binding_label 7539 && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) 7540 { 7541 const char *null = "NULL", *s1, *s2; 7542 s1 = sym->binding_label; 7543 if (!s1) s1 = null; 7544 s2 = sym->old_symbol->binding_label; 7545 if (!s2) s2 = null; 7546 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); 7547 sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ 7548 return MATCH_ERROR; 7549 } 7550 7551 if(found_match != MATCH_YES) 7552 m = MATCH_ERROR; 7553 else 7554 { 7555 /* Make changes to the symbol. */ 7556 m = MATCH_ERROR; 7557 7558 if (!gfc_add_function (&sym->attr, sym->name, NULL)) 7559 goto cleanup; 7560 7561 if (!gfc_missing_attr (&sym->attr, NULL)) 7562 goto cleanup; 7563 7564 if (!copy_prefix (&sym->attr, &sym->declared_at)) 7565 { 7566 if(!sym->attr.module_procedure) 7567 goto cleanup; 7568 else 7569 gfc_error_check (); 7570 } 7571 7572 /* Delay matching the function characteristics until after the 7573 specification block by signalling kind=-1. */ 7574 sym->declared_at = old_loc; 7575 if (current_ts.type != BT_UNKNOWN) 7576 current_ts.kind = -1; 7577 else 7578 current_ts.kind = 0; 7579 7580 if (result == NULL) 7581 { 7582 if (current_ts.type != BT_UNKNOWN 7583 && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) 7584 goto cleanup; 7585 sym->result = sym; 7586 } 7587 else 7588 { 7589 if (current_ts.type != BT_UNKNOWN 7590 && !gfc_add_type (result, ¤t_ts, &gfc_current_locus)) 7591 goto cleanup; 7592 sym->result = result; 7593 } 7594 7595 /* Warn if this procedure has the same name as an intrinsic. */ 7596 do_warn_intrinsic_shadow (sym, true); 7597 7598 return MATCH_YES; 7599 } 7600 7601cleanup: 7602 gfc_current_locus = old_loc; 7603 return m; 7604} 7605 7606 7607/* This is mostly a copy of parse.cc(add_global_procedure) but modified to 7608 pass the name of the entry, rather than the gfc_current_block name, and 7609 to return false upon finding an existing global entry. */ 7610 7611static bool 7612add_global_entry (const char *name, const char *binding_label, bool sub, 7613 locus *where) 7614{ 7615 gfc_gsymbol *s; 7616 enum gfc_symbol_type type; 7617 7618 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; 7619 7620 /* Only in Fortran 2003: For procedures with a binding label also the Fortran 7621 name is a global identifier. */ 7622 if (!binding_label || gfc_notification_std (GFC_STD_F2008)) 7623 { 7624 s = gfc_get_gsymbol (name, false); 7625 7626 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) 7627 { 7628 gfc_global_used (s, where); 7629 return false; 7630 } 7631 else 7632 { 7633 s->type = type; 7634 s->sym_name = name; 7635 s->where = *where; 7636 s->defined = 1; 7637 s->ns = gfc_current_ns; 7638 } 7639 } 7640 7641 /* Don't add the symbol multiple times. */ 7642 if (binding_label 7643 && (!gfc_notification_std (GFC_STD_F2008) 7644 || strcmp (name, binding_label) != 0)) 7645 { 7646 s = gfc_get_gsymbol (binding_label, true); 7647 7648 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) 7649 { 7650 gfc_global_used (s, where); 7651 return false; 7652 } 7653 else 7654 { 7655 s->type = type; 7656 s->sym_name = name; 7657 s->binding_label = binding_label; 7658 s->where = *where; 7659 s->defined = 1; 7660 s->ns = gfc_current_ns; 7661 } 7662 } 7663 7664 return true; 7665} 7666 7667 7668/* Match an ENTRY statement. */ 7669 7670match 7671gfc_match_entry (void) 7672{ 7673 gfc_symbol *proc; 7674 gfc_symbol *result; 7675 gfc_symbol *entry; 7676 char name[GFC_MAX_SYMBOL_LEN + 1]; 7677 gfc_compile_state state; 7678 match m; 7679 gfc_entry_list *el; 7680 locus old_loc; 7681 bool module_procedure; 7682 char peek_char; 7683 match is_bind_c; 7684 7685 m = gfc_match_name (name); 7686 if (m != MATCH_YES) 7687 return m; 7688 7689 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C")) 7690 return MATCH_ERROR; 7691 7692 state = gfc_current_state (); 7693 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) 7694 { 7695 switch (state) 7696 { 7697 case COMP_PROGRAM: 7698 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM"); 7699 break; 7700 case COMP_MODULE: 7701 gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); 7702 break; 7703 case COMP_SUBMODULE: 7704 gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE"); 7705 break; 7706 case COMP_BLOCK_DATA: 7707 gfc_error ("ENTRY statement at %C cannot appear within " 7708 "a BLOCK DATA"); 7709 break; 7710 case COMP_INTERFACE: 7711 gfc_error ("ENTRY statement at %C cannot appear within " 7712 "an INTERFACE"); 7713 break; 7714 case COMP_STRUCTURE: 7715 gfc_error ("ENTRY statement at %C cannot appear within " 7716 "a STRUCTURE block"); 7717 break; 7718 case COMP_DERIVED: 7719 gfc_error ("ENTRY statement at %C cannot appear within " 7720 "a DERIVED TYPE block"); 7721 break; 7722 case COMP_IF: 7723 gfc_error ("ENTRY statement at %C cannot appear within " 7724 "an IF-THEN block"); 7725 break; 7726 case COMP_DO: 7727 case COMP_DO_CONCURRENT: 7728 gfc_error ("ENTRY statement at %C cannot appear within " 7729 "a DO block"); 7730 break; 7731 case COMP_SELECT: 7732 gfc_error ("ENTRY statement at %C cannot appear within " 7733 "a SELECT block"); 7734 break; 7735 case COMP_FORALL: 7736 gfc_error ("ENTRY statement at %C cannot appear within " 7737 "a FORALL block"); 7738 break; 7739 case COMP_WHERE: 7740 gfc_error ("ENTRY statement at %C cannot appear within " 7741 "a WHERE block"); 7742 break; 7743 case COMP_CONTAINS: 7744 gfc_error ("ENTRY statement at %C cannot appear within " 7745 "a contained subprogram"); 7746 break; 7747 default: 7748 gfc_error ("Unexpected ENTRY statement at %C"); 7749 } 7750 return MATCH_ERROR; 7751 } 7752 7753 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION) 7754 && gfc_state_stack->previous->state == COMP_INTERFACE) 7755 { 7756 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE"); 7757 return MATCH_ERROR; 7758 } 7759 7760 module_procedure = gfc_current_ns->parent != NULL 7761 && gfc_current_ns->parent->proc_name 7762 && gfc_current_ns->parent->proc_name->attr.flavor 7763 == FL_MODULE; 7764 7765 if (gfc_current_ns->parent != NULL 7766 && gfc_current_ns->parent->proc_name 7767 && !module_procedure) 7768 { 7769 gfc_error("ENTRY statement at %C cannot appear in a " 7770 "contained procedure"); 7771 return MATCH_ERROR; 7772 } 7773 7774 /* Module function entries need special care in get_proc_name 7775 because previous references within the function will have 7776 created symbols attached to the current namespace. */ 7777 if (get_proc_name (name, &entry, 7778 gfc_current_ns->parent != NULL 7779 && module_procedure)) 7780 return MATCH_ERROR; 7781 7782 proc = gfc_current_block (); 7783 7784 /* Make sure that it isn't already declared as BIND(C). If it is, it 7785 must have been marked BIND(C) with a BIND(C) attribute and that is 7786 not allowed for procedures. */ 7787 if (entry->attr.is_bind_c == 1) 7788 { 7789 locus loc; 7790 7791 entry->attr.is_bind_c = 0; 7792 7793 loc = entry->old_symbol != NULL 7794 ? entry->old_symbol->declared_at : gfc_current_locus; 7795 gfc_error_now ("BIND(C) attribute at %L can only be used for " 7796 "variables or common blocks", &loc); 7797 } 7798 7799 /* Check what next non-whitespace character is so we can tell if there 7800 is the required parens if we have a BIND(C). */ 7801 old_loc = gfc_current_locus; 7802 gfc_gobble_whitespace (); 7803 peek_char = gfc_peek_ascii_char (); 7804 7805 if (state == COMP_SUBROUTINE) 7806 { 7807 m = gfc_match_formal_arglist (entry, 0, 1); 7808 if (m != MATCH_YES) 7809 return MATCH_ERROR; 7810 7811 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can 7812 never be an internal procedure. */ 7813 is_bind_c = gfc_match_bind_c (entry, true); 7814 if (is_bind_c == MATCH_ERROR) 7815 return MATCH_ERROR; 7816 if (is_bind_c == MATCH_YES) 7817 { 7818 if (peek_char != '(') 7819 { 7820 gfc_error ("Missing required parentheses before BIND(C) at %C"); 7821 return MATCH_ERROR; 7822 } 7823 7824 if (!gfc_add_is_bind_c (&(entry->attr), entry->name, 7825 &(entry->declared_at), 1)) 7826 return MATCH_ERROR; 7827 7828 } 7829 7830 if (!gfc_current_ns->parent 7831 && !add_global_entry (name, entry->binding_label, true, 7832 &old_loc)) 7833 return MATCH_ERROR; 7834 7835 /* An entry in a subroutine. */ 7836 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 7837 || !gfc_add_subroutine (&entry->attr, entry->name, NULL)) 7838 return MATCH_ERROR; 7839 } 7840 else 7841 { 7842 /* An entry in a function. 7843 We need to take special care because writing 7844 ENTRY f() 7845 as 7846 ENTRY f 7847 is allowed, whereas 7848 ENTRY f() RESULT (r) 7849 can't be written as 7850 ENTRY f RESULT (r). */ 7851 if (gfc_match_eos () == MATCH_YES) 7852 { 7853 gfc_current_locus = old_loc; 7854 /* Match the empty argument list, and add the interface to 7855 the symbol. */ 7856 m = gfc_match_formal_arglist (entry, 0, 1); 7857 } 7858 else 7859 m = gfc_match_formal_arglist (entry, 0, 0); 7860 7861 if (m != MATCH_YES) 7862 return MATCH_ERROR; 7863 7864 result = NULL; 7865 7866 if (gfc_match_eos () == MATCH_YES) 7867 { 7868 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 7869 || !gfc_add_function (&entry->attr, entry->name, NULL)) 7870 return MATCH_ERROR; 7871 7872 entry->result = entry; 7873 } 7874 else 7875 { 7876 m = gfc_match_suffix (entry, &result); 7877 if (m == MATCH_NO) 7878 gfc_syntax_error (ST_ENTRY); 7879 if (m != MATCH_YES) 7880 return MATCH_ERROR; 7881 7882 if (result) 7883 { 7884 if (!gfc_add_result (&result->attr, result->name, NULL) 7885 || !gfc_add_entry (&entry->attr, result->name, NULL) 7886 || !gfc_add_function (&entry->attr, result->name, NULL)) 7887 return MATCH_ERROR; 7888 entry->result = result; 7889 } 7890 else 7891 { 7892 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 7893 || !gfc_add_function (&entry->attr, entry->name, NULL)) 7894 return MATCH_ERROR; 7895 entry->result = entry; 7896 } 7897 } 7898 7899 if (!gfc_current_ns->parent 7900 && !add_global_entry (name, entry->binding_label, false, 7901 &old_loc)) 7902 return MATCH_ERROR; 7903 } 7904 7905 if (gfc_match_eos () != MATCH_YES) 7906 { 7907 gfc_syntax_error (ST_ENTRY); 7908 return MATCH_ERROR; 7909 } 7910 7911 /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */ 7912 if (proc->attr.elemental && entry->attr.is_bind_c) 7913 { 7914 gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an " 7915 "elemental procedure", &entry->declared_at); 7916 return MATCH_ERROR; 7917 } 7918 7919 entry->attr.recursive = proc->attr.recursive; 7920 entry->attr.elemental = proc->attr.elemental; 7921 entry->attr.pure = proc->attr.pure; 7922 7923 el = gfc_get_entry_list (); 7924 el->sym = entry; 7925 el->next = gfc_current_ns->entries; 7926 gfc_current_ns->entries = el; 7927 if (el->next) 7928 el->id = el->next->id + 1; 7929 else 7930 el->id = 1; 7931 7932 new_st.op = EXEC_ENTRY; 7933 new_st.ext.entry = el; 7934 7935 return MATCH_YES; 7936} 7937 7938 7939/* Match a subroutine statement, including optional prefixes. */ 7940 7941match 7942gfc_match_subroutine (void) 7943{ 7944 char name[GFC_MAX_SYMBOL_LEN + 1]; 7945 gfc_symbol *sym; 7946 match m; 7947 match is_bind_c; 7948 char peek_char; 7949 bool allow_binding_name; 7950 locus loc; 7951 7952 if (gfc_current_state () != COMP_NONE 7953 && gfc_current_state () != COMP_INTERFACE 7954 && gfc_current_state () != COMP_CONTAINS) 7955 return MATCH_NO; 7956 7957 m = gfc_match_prefix (NULL); 7958 if (m != MATCH_YES) 7959 return m; 7960 7961 m = gfc_match ("subroutine% %n", name); 7962 if (m != MATCH_YES) 7963 return m; 7964 7965 if (get_proc_name (name, &sym, false)) 7966 return MATCH_ERROR; 7967 7968 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if 7969 the symbol existed before. */ 7970 sym->declared_at = gfc_current_locus; 7971 7972 if (current_attr.module_procedure) 7973 sym->attr.module_procedure = 1; 7974 7975 if (add_hidden_procptr_result (sym)) 7976 sym = sym->result; 7977 7978 gfc_new_block = sym; 7979 7980 /* Check what next non-whitespace character is so we can tell if there 7981 is the required parens if we have a BIND(C). */ 7982 gfc_gobble_whitespace (); 7983 peek_char = gfc_peek_ascii_char (); 7984 7985 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) 7986 return MATCH_ERROR; 7987 7988 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) 7989 return MATCH_ERROR; 7990 7991 /* Make sure that it isn't already declared as BIND(C). If it is, it 7992 must have been marked BIND(C) with a BIND(C) attribute and that is 7993 not allowed for procedures. */ 7994 if (sym->attr.is_bind_c == 1) 7995 { 7996 sym->attr.is_bind_c = 0; 7997 7998 if (gfc_state_stack->previous 7999 && gfc_state_stack->previous->state != COMP_SUBMODULE) 8000 { 8001 locus loc; 8002 loc = sym->old_symbol != NULL 8003 ? sym->old_symbol->declared_at : gfc_current_locus; 8004 gfc_error_now ("BIND(C) attribute at %L can only be used for " 8005 "variables or common blocks", &loc); 8006 } 8007 } 8008 8009 /* C binding names are not allowed for internal procedures. */ 8010 if (gfc_current_state () == COMP_CONTAINS 8011 && sym->ns->proc_name->attr.flavor != FL_MODULE) 8012 allow_binding_name = false; 8013 else 8014 allow_binding_name = true; 8015 8016 /* Here, we are just checking if it has the bind(c) attribute, and if 8017 so, then we need to make sure it's all correct. If it doesn't, 8018 we still need to continue matching the rest of the subroutine line. */ 8019 gfc_gobble_whitespace (); 8020 loc = gfc_current_locus; 8021 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 8022 if (is_bind_c == MATCH_ERROR) 8023 { 8024 /* There was an attempt at the bind(c), but it was wrong. An 8025 error message should have been printed w/in the gfc_match_bind_c 8026 so here we'll just return the MATCH_ERROR. */ 8027 return MATCH_ERROR; 8028 } 8029 8030 if (is_bind_c == MATCH_YES) 8031 { 8032 gfc_formal_arglist *arg; 8033 8034 /* The following is allowed in the Fortran 2008 draft. */ 8035 if (gfc_current_state () == COMP_CONTAINS 8036 && sym->ns->proc_name->attr.flavor != FL_MODULE 8037 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " 8038 "at %L may not be specified for an internal " 8039 "procedure", &gfc_current_locus)) 8040 return MATCH_ERROR; 8041 8042 if (peek_char != '(') 8043 { 8044 gfc_error ("Missing required parentheses before BIND(C) at %C"); 8045 return MATCH_ERROR; 8046 } 8047 8048 /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module 8049 subprogram and a binding label is specified, it shall be the 8050 same as the binding label specified in the corresponding module 8051 procedure interface body. */ 8052 if (sym->attr.module_procedure && sym->old_symbol 8053 && strcmp (sym->name, sym->old_symbol->name) == 0 8054 && sym->binding_label && sym->old_symbol->binding_label 8055 && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0) 8056 { 8057 const char *null = "NULL", *s1, *s2; 8058 s1 = sym->binding_label; 8059 if (!s1) s1 = null; 8060 s2 = sym->old_symbol->binding_label; 8061 if (!s2) s2 = null; 8062 gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2); 8063 sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */ 8064 return MATCH_ERROR; 8065 } 8066 8067 /* Scan the dummy arguments for an alternate return. */ 8068 for (arg = sym->formal; arg; arg = arg->next) 8069 if (!arg->sym) 8070 { 8071 gfc_error ("Alternate return dummy argument cannot appear in a " 8072 "SUBROUTINE with the BIND(C) attribute at %L", &loc); 8073 return MATCH_ERROR; 8074 } 8075 8076 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1)) 8077 return MATCH_ERROR; 8078 } 8079 8080 if (gfc_match_eos () != MATCH_YES) 8081 { 8082 gfc_syntax_error (ST_SUBROUTINE); 8083 return MATCH_ERROR; 8084 } 8085 8086 if (!copy_prefix (&sym->attr, &sym->declared_at)) 8087 { 8088 if(!sym->attr.module_procedure) 8089 return MATCH_ERROR; 8090 else 8091 gfc_error_check (); 8092 } 8093 8094 /* Warn if it has the same name as an intrinsic. */ 8095 do_warn_intrinsic_shadow (sym, false); 8096 8097 return MATCH_YES; 8098} 8099 8100 8101/* Check that the NAME identifier in a BIND attribute or statement 8102 is conform to C identifier rules. */ 8103 8104match 8105check_bind_name_identifier (char **name) 8106{ 8107 char *n = *name, *p; 8108 8109 /* Remove leading spaces. */ 8110 while (*n == ' ') 8111 n++; 8112 8113 /* On an empty string, free memory and set name to NULL. */ 8114 if (*n == '\0') 8115 { 8116 free (*name); 8117 *name = NULL; 8118 return MATCH_YES; 8119 } 8120 8121 /* Remove trailing spaces. */ 8122 p = n + strlen(n) - 1; 8123 while (*p == ' ') 8124 *(p--) = '\0'; 8125 8126 /* Insert the identifier into the symbol table. */ 8127 p = xstrdup (n); 8128 free (*name); 8129 *name = p; 8130 8131 /* Now check that identifier is valid under C rules. */ 8132 if (ISDIGIT (*p)) 8133 { 8134 gfc_error ("Invalid C identifier in NAME= specifier at %C"); 8135 return MATCH_ERROR; 8136 } 8137 8138 for (; *p; p++) 8139 if (!(ISALNUM (*p) || *p == '_' || *p == '$')) 8140 { 8141 gfc_error ("Invalid C identifier in NAME= specifier at %C"); 8142 return MATCH_ERROR; 8143 } 8144 8145 return MATCH_YES; 8146} 8147 8148 8149/* Match a BIND(C) specifier, with the optional 'name=' specifier if 8150 given, and set the binding label in either the given symbol (if not 8151 NULL), or in the current_ts. The symbol may be NULL because we may 8152 encounter the BIND(C) before the declaration itself. Return 8153 MATCH_NO if what we're looking at isn't a BIND(C) specifier, 8154 MATCH_ERROR if it is a BIND(C) clause but an error was encountered, 8155 or MATCH_YES if the specifier was correct and the binding label and 8156 bind(c) fields were set correctly for the given symbol or the 8157 current_ts. If allow_binding_name is false, no binding name may be 8158 given. */ 8159 8160match 8161gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) 8162{ 8163 char *binding_label = NULL; 8164 gfc_expr *e = NULL; 8165 8166 /* Initialize the flag that specifies whether we encountered a NAME= 8167 specifier or not. */ 8168 has_name_equals = 0; 8169 8170 /* This much we have to be able to match, in this order, if 8171 there is a bind(c) label. */ 8172 if (gfc_match (" bind ( c ") != MATCH_YES) 8173 return MATCH_NO; 8174 8175 /* Now see if there is a binding label, or if we've reached the 8176 end of the bind(c) attribute without one. */ 8177 if (gfc_match_char (',') == MATCH_YES) 8178 { 8179 if (gfc_match (" name = ") != MATCH_YES) 8180 { 8181 gfc_error ("Syntax error in NAME= specifier for binding label " 8182 "at %C"); 8183 /* should give an error message here */ 8184 return MATCH_ERROR; 8185 } 8186 8187 has_name_equals = 1; 8188 8189 if (gfc_match_init_expr (&e) != MATCH_YES) 8190 { 8191 gfc_free_expr (e); 8192 return MATCH_ERROR; 8193 } 8194 8195 if (!gfc_simplify_expr(e, 0)) 8196 { 8197 gfc_error ("NAME= specifier at %C should be a constant expression"); 8198 gfc_free_expr (e); 8199 return MATCH_ERROR; 8200 } 8201 8202 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER 8203 || e->ts.kind != gfc_default_character_kind || e->rank != 0) 8204 { 8205 gfc_error ("NAME= specifier at %C should be a scalar of " 8206 "default character kind"); 8207 gfc_free_expr(e); 8208 return MATCH_ERROR; 8209 } 8210 8211 // Get a C string from the Fortran string constant 8212 binding_label = gfc_widechar_to_char (e->value.character.string, 8213 e->value.character.length); 8214 gfc_free_expr(e); 8215 8216 // Check that it is valid (old gfc_match_name_C) 8217 if (check_bind_name_identifier (&binding_label) != MATCH_YES) 8218 return MATCH_ERROR; 8219 } 8220 8221 /* Get the required right paren. */ 8222 if (gfc_match_char (')') != MATCH_YES) 8223 { 8224 gfc_error ("Missing closing paren for binding label at %C"); 8225 return MATCH_ERROR; 8226 } 8227 8228 if (has_name_equals && !allow_binding_name) 8229 { 8230 gfc_error ("No binding name is allowed in BIND(C) at %C"); 8231 return MATCH_ERROR; 8232 } 8233 8234 if (has_name_equals && sym != NULL && sym->attr.dummy) 8235 { 8236 gfc_error ("For dummy procedure %s, no binding name is " 8237 "allowed in BIND(C) at %C", sym->name); 8238 return MATCH_ERROR; 8239 } 8240 8241 8242 /* Save the binding label to the symbol. If sym is null, we're 8243 probably matching the typespec attributes of a declaration and 8244 haven't gotten the name yet, and therefore, no symbol yet. */ 8245 if (binding_label) 8246 { 8247 if (sym != NULL) 8248 sym->binding_label = binding_label; 8249 else 8250 curr_binding_label = binding_label; 8251 } 8252 else if (allow_binding_name) 8253 { 8254 /* No binding label, but if symbol isn't null, we 8255 can set the label for it here. 8256 If name="" or allow_binding_name is false, no C binding name is 8257 created. */ 8258 if (sym != NULL && sym->name != NULL && has_name_equals == 0) 8259 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name)); 8260 } 8261 8262 if (has_name_equals && gfc_current_state () == COMP_INTERFACE 8263 && current_interface.type == INTERFACE_ABSTRACT) 8264 { 8265 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C"); 8266 return MATCH_ERROR; 8267 } 8268 8269 return MATCH_YES; 8270} 8271 8272 8273/* Return nonzero if we're currently compiling a contained procedure. */ 8274 8275static int 8276contained_procedure (void) 8277{ 8278 gfc_state_data *s = gfc_state_stack; 8279 8280 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION) 8281 && s->previous != NULL && s->previous->state == COMP_CONTAINS) 8282 return 1; 8283 8284 return 0; 8285} 8286 8287/* Set the kind of each enumerator. The kind is selected such that it is 8288 interoperable with the corresponding C enumeration type, making 8289 sure that -fshort-enums is honored. */ 8290 8291static void 8292set_enum_kind(void) 8293{ 8294 enumerator_history *current_history = NULL; 8295 int kind; 8296 int i; 8297 8298 if (max_enum == NULL || enum_history == NULL) 8299 return; 8300 8301 if (!flag_short_enums) 8302 return; 8303 8304 i = 0; 8305 do 8306 { 8307 kind = gfc_integer_kinds[i++].kind; 8308 } 8309 while (kind < gfc_c_int_kind 8310 && gfc_check_integer_range (max_enum->initializer->value.integer, 8311 kind) != ARITH_OK); 8312 8313 current_history = enum_history; 8314 while (current_history != NULL) 8315 { 8316 current_history->sym->ts.kind = kind; 8317 current_history = current_history->next; 8318 } 8319} 8320 8321 8322/* Match any of the various end-block statements. Returns the type of 8323 END to the caller. The END INTERFACE, END IF, END DO, END SELECT 8324 and END BLOCK statements cannot be replaced by a single END statement. */ 8325 8326match 8327gfc_match_end (gfc_statement *st) 8328{ 8329 char name[GFC_MAX_SYMBOL_LEN + 1]; 8330 gfc_compile_state state; 8331 locus old_loc; 8332 const char *block_name; 8333 const char *target; 8334 int eos_ok; 8335 match m; 8336 gfc_namespace *parent_ns, *ns, *prev_ns; 8337 gfc_namespace **nsp; 8338 bool abreviated_modproc_decl = false; 8339 bool got_matching_end = false; 8340 8341 old_loc = gfc_current_locus; 8342 if (gfc_match ("end") != MATCH_YES) 8343 return MATCH_NO; 8344 8345 state = gfc_current_state (); 8346 block_name = gfc_current_block () == NULL 8347 ? NULL : gfc_current_block ()->name; 8348 8349 switch (state) 8350 { 8351 case COMP_ASSOCIATE: 8352 case COMP_BLOCK: 8353 if (startswith (block_name, "block@")) 8354 block_name = NULL; 8355 break; 8356 8357 case COMP_CONTAINS: 8358 case COMP_DERIVED_CONTAINS: 8359 state = gfc_state_stack->previous->state; 8360 block_name = gfc_state_stack->previous->sym == NULL 8361 ? NULL : gfc_state_stack->previous->sym->name; 8362 abreviated_modproc_decl = gfc_state_stack->previous->sym 8363 && gfc_state_stack->previous->sym->abr_modproc_decl; 8364 break; 8365 8366 default: 8367 break; 8368 } 8369 8370 if (!abreviated_modproc_decl) 8371 abreviated_modproc_decl = gfc_current_block () 8372 && gfc_current_block ()->abr_modproc_decl; 8373 8374 switch (state) 8375 { 8376 case COMP_NONE: 8377 case COMP_PROGRAM: 8378 *st = ST_END_PROGRAM; 8379 target = " program"; 8380 eos_ok = 1; 8381 break; 8382 8383 case COMP_SUBROUTINE: 8384 *st = ST_END_SUBROUTINE; 8385 if (!abreviated_modproc_decl) 8386 target = " subroutine"; 8387 else 8388 target = " procedure"; 8389 eos_ok = !contained_procedure (); 8390 break; 8391 8392 case COMP_FUNCTION: 8393 *st = ST_END_FUNCTION; 8394 if (!abreviated_modproc_decl) 8395 target = " function"; 8396 else 8397 target = " procedure"; 8398 eos_ok = !contained_procedure (); 8399 break; 8400 8401 case COMP_BLOCK_DATA: 8402 *st = ST_END_BLOCK_DATA; 8403 target = " block data"; 8404 eos_ok = 1; 8405 break; 8406 8407 case COMP_MODULE: 8408 *st = ST_END_MODULE; 8409 target = " module"; 8410 eos_ok = 1; 8411 break; 8412 8413 case COMP_SUBMODULE: 8414 *st = ST_END_SUBMODULE; 8415 target = " submodule"; 8416 eos_ok = 1; 8417 break; 8418 8419 case COMP_INTERFACE: 8420 *st = ST_END_INTERFACE; 8421 target = " interface"; 8422 eos_ok = 0; 8423 break; 8424 8425 case COMP_MAP: 8426 *st = ST_END_MAP; 8427 target = " map"; 8428 eos_ok = 0; 8429 break; 8430 8431 case COMP_UNION: 8432 *st = ST_END_UNION; 8433 target = " union"; 8434 eos_ok = 0; 8435 break; 8436 8437 case COMP_STRUCTURE: 8438 *st = ST_END_STRUCTURE; 8439 target = " structure"; 8440 eos_ok = 0; 8441 break; 8442 8443 case COMP_DERIVED: 8444 case COMP_DERIVED_CONTAINS: 8445 *st = ST_END_TYPE; 8446 target = " type"; 8447 eos_ok = 0; 8448 break; 8449 8450 case COMP_ASSOCIATE: 8451 *st = ST_END_ASSOCIATE; 8452 target = " associate"; 8453 eos_ok = 0; 8454 break; 8455 8456 case COMP_BLOCK: 8457 case COMP_OMP_STRICTLY_STRUCTURED_BLOCK: 8458 *st = ST_END_BLOCK; 8459 target = " block"; 8460 eos_ok = 0; 8461 break; 8462 8463 case COMP_IF: 8464 *st = ST_ENDIF; 8465 target = " if"; 8466 eos_ok = 0; 8467 break; 8468 8469 case COMP_DO: 8470 case COMP_DO_CONCURRENT: 8471 *st = ST_ENDDO; 8472 target = " do"; 8473 eos_ok = 0; 8474 break; 8475 8476 case COMP_CRITICAL: 8477 *st = ST_END_CRITICAL; 8478 target = " critical"; 8479 eos_ok = 0; 8480 break; 8481 8482 case COMP_SELECT: 8483 case COMP_SELECT_TYPE: 8484 case COMP_SELECT_RANK: 8485 *st = ST_END_SELECT; 8486 target = " select"; 8487 eos_ok = 0; 8488 break; 8489 8490 case COMP_FORALL: 8491 *st = ST_END_FORALL; 8492 target = " forall"; 8493 eos_ok = 0; 8494 break; 8495 8496 case COMP_WHERE: 8497 *st = ST_END_WHERE; 8498 target = " where"; 8499 eos_ok = 0; 8500 break; 8501 8502 case COMP_ENUM: 8503 *st = ST_END_ENUM; 8504 target = " enum"; 8505 eos_ok = 0; 8506 last_initializer = NULL; 8507 set_enum_kind (); 8508 gfc_free_enum_history (); 8509 break; 8510 8511 default: 8512 gfc_error ("Unexpected END statement at %C"); 8513 goto cleanup; 8514 } 8515 8516 old_loc = gfc_current_locus; 8517 if (gfc_match_eos () == MATCH_YES) 8518 { 8519 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) 8520 { 8521 if (!gfc_notify_std (GFC_STD_F2008, "END statement " 8522 "instead of %s statement at %L", 8523 abreviated_modproc_decl ? "END PROCEDURE" 8524 : gfc_ascii_statement(*st), &old_loc)) 8525 goto cleanup; 8526 } 8527 else if (!eos_ok) 8528 { 8529 /* We would have required END [something]. */ 8530 gfc_error ("%s statement expected at %L", 8531 gfc_ascii_statement (*st), &old_loc); 8532 goto cleanup; 8533 } 8534 8535 return MATCH_YES; 8536 } 8537 8538 /* Verify that we've got the sort of end-block that we're expecting. */ 8539 if (gfc_match (target) != MATCH_YES) 8540 { 8541 gfc_error ("Expecting %s statement at %L", abreviated_modproc_decl 8542 ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc); 8543 goto cleanup; 8544 } 8545 else 8546 got_matching_end = true; 8547 8548 old_loc = gfc_current_locus; 8549 /* If we're at the end, make sure a block name wasn't required. */ 8550 if (gfc_match_eos () == MATCH_YES) 8551 { 8552 8553 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT 8554 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK 8555 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) 8556 return MATCH_YES; 8557 8558 if (!block_name) 8559 return MATCH_YES; 8560 8561 gfc_error ("Expected block name of %qs in %s statement at %L", 8562 block_name, gfc_ascii_statement (*st), &old_loc); 8563 8564 return MATCH_ERROR; 8565 } 8566 8567 /* END INTERFACE has a special handler for its several possible endings. */ 8568 if (*st == ST_END_INTERFACE) 8569 return gfc_match_end_interface (); 8570 8571 /* We haven't hit the end of statement, so what is left must be an 8572 end-name. */ 8573 m = gfc_match_space (); 8574 if (m == MATCH_YES) 8575 m = gfc_match_name (name); 8576 8577 if (m == MATCH_NO) 8578 gfc_error ("Expected terminating name at %C"); 8579 if (m != MATCH_YES) 8580 goto cleanup; 8581 8582 if (block_name == NULL) 8583 goto syntax; 8584 8585 /* We have to pick out the declared submodule name from the composite 8586 required by F2008:11.2.3 para 2, which ends in the declared name. */ 8587 if (state == COMP_SUBMODULE) 8588 block_name = strchr (block_name, '.') + 1; 8589 8590 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) 8591 { 8592 gfc_error ("Expected label %qs for %s statement at %C", block_name, 8593 gfc_ascii_statement (*st)); 8594 goto cleanup; 8595 } 8596 /* Procedure pointer as function result. */ 8597 else if (strcmp (block_name, "ppr@") == 0 8598 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) 8599 { 8600 gfc_error ("Expected label %qs for %s statement at %C", 8601 gfc_current_block ()->ns->proc_name->name, 8602 gfc_ascii_statement (*st)); 8603 goto cleanup; 8604 } 8605 8606 if (gfc_match_eos () == MATCH_YES) 8607 return MATCH_YES; 8608 8609syntax: 8610 gfc_syntax_error (*st); 8611 8612cleanup: 8613 gfc_current_locus = old_loc; 8614 8615 /* If we are missing an END BLOCK, we created a half-ready namespace. 8616 Remove it from the parent namespace's sibling list. */ 8617 8618 while (state == COMP_BLOCK && !got_matching_end) 8619 { 8620 parent_ns = gfc_current_ns->parent; 8621 8622 nsp = &(gfc_state_stack->previous->tail->ext.block.ns); 8623 8624 prev_ns = NULL; 8625 ns = *nsp; 8626 while (ns) 8627 { 8628 if (ns == gfc_current_ns) 8629 { 8630 if (prev_ns == NULL) 8631 *nsp = NULL; 8632 else 8633 prev_ns->sibling = ns->sibling; 8634 } 8635 prev_ns = ns; 8636 ns = ns->sibling; 8637 } 8638 8639 gfc_free_namespace (gfc_current_ns); 8640 gfc_current_ns = parent_ns; 8641 gfc_state_stack = gfc_state_stack->previous; 8642 state = gfc_current_state (); 8643 } 8644 8645 return MATCH_ERROR; 8646} 8647 8648 8649 8650/***************** Attribute declaration statements ****************/ 8651 8652/* Set the attribute of a single variable. */ 8653 8654static match 8655attr_decl1 (void) 8656{ 8657 char name[GFC_MAX_SYMBOL_LEN + 1]; 8658 gfc_array_spec *as; 8659 8660 /* Workaround -Wmaybe-uninitialized false positive during 8661 profiledbootstrap by initializing them. */ 8662 gfc_symbol *sym = NULL; 8663 locus var_locus; 8664 match m; 8665 8666 as = NULL; 8667 8668 m = gfc_match_name (name); 8669 if (m != MATCH_YES) 8670 goto cleanup; 8671 8672 if (find_special (name, &sym, false)) 8673 return MATCH_ERROR; 8674 8675 if (!check_function_name (name)) 8676 { 8677 m = MATCH_ERROR; 8678 goto cleanup; 8679 } 8680 8681 var_locus = gfc_current_locus; 8682 8683 /* Deal with possible array specification for certain attributes. */ 8684 if (current_attr.dimension 8685 || current_attr.codimension 8686 || current_attr.allocatable 8687 || current_attr.pointer 8688 || current_attr.target) 8689 { 8690 m = gfc_match_array_spec (&as, !current_attr.codimension, 8691 !current_attr.dimension 8692 && !current_attr.pointer 8693 && !current_attr.target); 8694 if (m == MATCH_ERROR) 8695 goto cleanup; 8696 8697 if (current_attr.dimension && m == MATCH_NO) 8698 { 8699 gfc_error ("Missing array specification at %L in DIMENSION " 8700 "statement", &var_locus); 8701 m = MATCH_ERROR; 8702 goto cleanup; 8703 } 8704 8705 if (current_attr.dimension && sym->value) 8706 { 8707 gfc_error ("Dimensions specified for %s at %L after its " 8708 "initialization", sym->name, &var_locus); 8709 m = MATCH_ERROR; 8710 goto cleanup; 8711 } 8712 8713 if (current_attr.codimension && m == MATCH_NO) 8714 { 8715 gfc_error ("Missing array specification at %L in CODIMENSION " 8716 "statement", &var_locus); 8717 m = MATCH_ERROR; 8718 goto cleanup; 8719 } 8720 8721 if ((current_attr.allocatable || current_attr.pointer) 8722 && (m == MATCH_YES) && (as->type != AS_DEFERRED)) 8723 { 8724 gfc_error ("Array specification must be deferred at %L", &var_locus); 8725 m = MATCH_ERROR; 8726 goto cleanup; 8727 } 8728 } 8729 8730 if (sym->ts.type == BT_CLASS 8731 && sym->ts.u.derived 8732 && sym->ts.u.derived->attr.is_class) 8733 { 8734 sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer; 8735 sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable; 8736 sym->attr.dimension = CLASS_DATA(sym)->attr.dimension; 8737 sym->attr.codimension = CLASS_DATA(sym)->attr.codimension; 8738 if (CLASS_DATA (sym)->as) 8739 sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as); 8740 } 8741 if (current_attr.dimension == 0 && current_attr.codimension == 0 8742 && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) 8743 { 8744 m = MATCH_ERROR; 8745 goto cleanup; 8746 } 8747 if (!gfc_set_array_spec (sym, as, &var_locus)) 8748 { 8749 m = MATCH_ERROR; 8750 goto cleanup; 8751 } 8752 8753 if (sym->attr.cray_pointee && sym->as != NULL) 8754 { 8755 /* Fix the array spec. */ 8756 m = gfc_mod_pointee_as (sym->as); 8757 if (m == MATCH_ERROR) 8758 goto cleanup; 8759 } 8760 8761 if (!gfc_add_attribute (&sym->attr, &var_locus)) 8762 { 8763 m = MATCH_ERROR; 8764 goto cleanup; 8765 } 8766 8767 if ((current_attr.external || current_attr.intrinsic) 8768 && sym->attr.flavor != FL_PROCEDURE 8769 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) 8770 { 8771 m = MATCH_ERROR; 8772 goto cleanup; 8773 } 8774 8775 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class 8776 && !as && !current_attr.pointer && !current_attr.allocatable 8777 && !current_attr.external) 8778 { 8779 sym->attr.pointer = 0; 8780 sym->attr.allocatable = 0; 8781 sym->attr.dimension = 0; 8782 sym->attr.codimension = 0; 8783 gfc_free_array_spec (sym->as); 8784 sym->as = NULL; 8785 } 8786 else if (sym->ts.type == BT_CLASS 8787 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) 8788 { 8789 m = MATCH_ERROR; 8790 goto cleanup; 8791 } 8792 8793 add_hidden_procptr_result (sym); 8794 8795 return MATCH_YES; 8796 8797cleanup: 8798 gfc_free_array_spec (as); 8799 return m; 8800} 8801 8802 8803/* Generic attribute declaration subroutine. Used for attributes that 8804 just have a list of names. */ 8805 8806static match 8807attr_decl (void) 8808{ 8809 match m; 8810 8811 /* Gobble the optional double colon, by simply ignoring the result 8812 of gfc_match(). */ 8813 gfc_match (" ::"); 8814 8815 for (;;) 8816 { 8817 m = attr_decl1 (); 8818 if (m != MATCH_YES) 8819 break; 8820 8821 if (gfc_match_eos () == MATCH_YES) 8822 { 8823 m = MATCH_YES; 8824 break; 8825 } 8826 8827 if (gfc_match_char (',') != MATCH_YES) 8828 { 8829 gfc_error ("Unexpected character in variable list at %C"); 8830 m = MATCH_ERROR; 8831 break; 8832 } 8833 } 8834 8835 return m; 8836} 8837 8838 8839/* This routine matches Cray Pointer declarations of the form: 8840 pointer ( <pointer>, <pointee> ) 8841 or 8842 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ... 8843 The pointer, if already declared, should be an integer. Otherwise, we 8844 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may 8845 be either a scalar, or an array declaration. No space is allocated for 8846 the pointee. For the statement 8847 pointer (ipt, ar(10)) 8848 any subsequent uses of ar will be translated (in C-notation) as 8849 ar(i) => ((<type> *) ipt)(i) 8850 After gimplification, pointee variable will disappear in the code. */ 8851 8852static match 8853cray_pointer_decl (void) 8854{ 8855 match m; 8856 gfc_array_spec *as = NULL; 8857 gfc_symbol *cptr; /* Pointer symbol. */ 8858 gfc_symbol *cpte; /* Pointee symbol. */ 8859 locus var_locus; 8860 bool done = false; 8861 8862 while (!done) 8863 { 8864 if (gfc_match_char ('(') != MATCH_YES) 8865 { 8866 gfc_error ("Expected %<(%> at %C"); 8867 return MATCH_ERROR; 8868 } 8869 8870 /* Match pointer. */ 8871 var_locus = gfc_current_locus; 8872 gfc_clear_attr (¤t_attr); 8873 gfc_add_cray_pointer (¤t_attr, &var_locus); 8874 current_ts.type = BT_INTEGER; 8875 current_ts.kind = gfc_index_integer_kind; 8876 8877 m = gfc_match_symbol (&cptr, 0); 8878 if (m != MATCH_YES) 8879 { 8880 gfc_error ("Expected variable name at %C"); 8881 return m; 8882 } 8883 8884 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus)) 8885 return MATCH_ERROR; 8886 8887 gfc_set_sym_referenced (cptr); 8888 8889 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */ 8890 { 8891 cptr->ts.type = BT_INTEGER; 8892 cptr->ts.kind = gfc_index_integer_kind; 8893 } 8894 else if (cptr->ts.type != BT_INTEGER) 8895 { 8896 gfc_error ("Cray pointer at %C must be an integer"); 8897 return MATCH_ERROR; 8898 } 8899 else if (cptr->ts.kind < gfc_index_integer_kind) 8900 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;" 8901 " memory addresses require %d bytes", 8902 cptr->ts.kind, gfc_index_integer_kind); 8903 8904 if (gfc_match_char (',') != MATCH_YES) 8905 { 8906 gfc_error ("Expected \",\" at %C"); 8907 return MATCH_ERROR; 8908 } 8909 8910 /* Match Pointee. */ 8911 var_locus = gfc_current_locus; 8912 gfc_clear_attr (¤t_attr); 8913 gfc_add_cray_pointee (¤t_attr, &var_locus); 8914 current_ts.type = BT_UNKNOWN; 8915 current_ts.kind = 0; 8916 8917 m = gfc_match_symbol (&cpte, 0); 8918 if (m != MATCH_YES) 8919 { 8920 gfc_error ("Expected variable name at %C"); 8921 return m; 8922 } 8923 8924 /* Check for an optional array spec. */ 8925 m = gfc_match_array_spec (&as, true, false); 8926 if (m == MATCH_ERROR) 8927 { 8928 gfc_free_array_spec (as); 8929 return m; 8930 } 8931 else if (m == MATCH_NO) 8932 { 8933 gfc_free_array_spec (as); 8934 as = NULL; 8935 } 8936 8937 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus)) 8938 return MATCH_ERROR; 8939 8940 gfc_set_sym_referenced (cpte); 8941 8942 if (cpte->as == NULL) 8943 { 8944 if (!gfc_set_array_spec (cpte, as, &var_locus)) 8945 gfc_internal_error ("Cannot set Cray pointee array spec."); 8946 } 8947 else if (as != NULL) 8948 { 8949 gfc_error ("Duplicate array spec for Cray pointee at %C"); 8950 gfc_free_array_spec (as); 8951 return MATCH_ERROR; 8952 } 8953 8954 as = NULL; 8955 8956 if (cpte->as != NULL) 8957 { 8958 /* Fix array spec. */ 8959 m = gfc_mod_pointee_as (cpte->as); 8960 if (m == MATCH_ERROR) 8961 return m; 8962 } 8963 8964 /* Point the Pointee at the Pointer. */ 8965 cpte->cp_pointer = cptr; 8966 8967 if (gfc_match_char (')') != MATCH_YES) 8968 { 8969 gfc_error ("Expected \")\" at %C"); 8970 return MATCH_ERROR; 8971 } 8972 m = gfc_match_char (','); 8973 if (m != MATCH_YES) 8974 done = true; /* Stop searching for more declarations. */ 8975 8976 } 8977 8978 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ 8979 || gfc_match_eos () != MATCH_YES) 8980 { 8981 gfc_error ("Expected %<,%> or end of statement at %C"); 8982 return MATCH_ERROR; 8983 } 8984 return MATCH_YES; 8985} 8986 8987 8988match 8989gfc_match_external (void) 8990{ 8991 8992 gfc_clear_attr (¤t_attr); 8993 current_attr.external = 1; 8994 8995 return attr_decl (); 8996} 8997 8998 8999match 9000gfc_match_intent (void) 9001{ 9002 sym_intent intent; 9003 9004 /* This is not allowed within a BLOCK construct! */ 9005 if (gfc_current_state () == COMP_BLOCK) 9006 { 9007 gfc_error ("INTENT is not allowed inside of BLOCK at %C"); 9008 return MATCH_ERROR; 9009 } 9010 9011 intent = match_intent_spec (); 9012 if (intent == INTENT_UNKNOWN) 9013 return MATCH_ERROR; 9014 9015 gfc_clear_attr (¤t_attr); 9016 current_attr.intent = intent; 9017 9018 return attr_decl (); 9019} 9020 9021 9022match 9023gfc_match_intrinsic (void) 9024{ 9025 9026 gfc_clear_attr (¤t_attr); 9027 current_attr.intrinsic = 1; 9028 9029 return attr_decl (); 9030} 9031 9032 9033match 9034gfc_match_optional (void) 9035{ 9036 /* This is not allowed within a BLOCK construct! */ 9037 if (gfc_current_state () == COMP_BLOCK) 9038 { 9039 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C"); 9040 return MATCH_ERROR; 9041 } 9042 9043 gfc_clear_attr (¤t_attr); 9044 current_attr.optional = 1; 9045 9046 return attr_decl (); 9047} 9048 9049 9050match 9051gfc_match_pointer (void) 9052{ 9053 gfc_gobble_whitespace (); 9054 if (gfc_peek_ascii_char () == '(') 9055 { 9056 if (!flag_cray_pointer) 9057 { 9058 gfc_error ("Cray pointer declaration at %C requires " 9059 "%<-fcray-pointer%> flag"); 9060 return MATCH_ERROR; 9061 } 9062 return cray_pointer_decl (); 9063 } 9064 else 9065 { 9066 gfc_clear_attr (¤t_attr); 9067 current_attr.pointer = 1; 9068 9069 return attr_decl (); 9070 } 9071} 9072 9073 9074match 9075gfc_match_allocatable (void) 9076{ 9077 gfc_clear_attr (¤t_attr); 9078 current_attr.allocatable = 1; 9079 9080 return attr_decl (); 9081} 9082 9083 9084match 9085gfc_match_codimension (void) 9086{ 9087 gfc_clear_attr (¤t_attr); 9088 current_attr.codimension = 1; 9089 9090 return attr_decl (); 9091} 9092 9093 9094match 9095gfc_match_contiguous (void) 9096{ 9097 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C")) 9098 return MATCH_ERROR; 9099 9100 gfc_clear_attr (¤t_attr); 9101 current_attr.contiguous = 1; 9102 9103 return attr_decl (); 9104} 9105 9106 9107match 9108gfc_match_dimension (void) 9109{ 9110 gfc_clear_attr (¤t_attr); 9111 current_attr.dimension = 1; 9112 9113 return attr_decl (); 9114} 9115 9116 9117match 9118gfc_match_target (void) 9119{ 9120 gfc_clear_attr (¤t_attr); 9121 current_attr.target = 1; 9122 9123 return attr_decl (); 9124} 9125 9126 9127/* Match the list of entities being specified in a PUBLIC or PRIVATE 9128 statement. */ 9129 9130static match 9131access_attr_decl (gfc_statement st) 9132{ 9133 char name[GFC_MAX_SYMBOL_LEN + 1]; 9134 interface_type type; 9135 gfc_user_op *uop; 9136 gfc_symbol *sym, *dt_sym; 9137 gfc_intrinsic_op op; 9138 match m; 9139 gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; 9140 9141 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 9142 goto done; 9143 9144 for (;;) 9145 { 9146 m = gfc_match_generic_spec (&type, name, &op); 9147 if (m == MATCH_NO) 9148 goto syntax; 9149 if (m == MATCH_ERROR) 9150 goto done; 9151 9152 switch (type) 9153 { 9154 case INTERFACE_NAMELESS: 9155 case INTERFACE_ABSTRACT: 9156 goto syntax; 9157 9158 case INTERFACE_GENERIC: 9159 case INTERFACE_DTIO: 9160 9161 if (gfc_get_symbol (name, NULL, &sym)) 9162 goto done; 9163 9164 if (type == INTERFACE_DTIO 9165 && gfc_current_ns->proc_name 9166 && gfc_current_ns->proc_name->attr.flavor == FL_MODULE 9167 && sym->attr.flavor == FL_UNKNOWN) 9168 sym->attr.flavor = FL_PROCEDURE; 9169 9170 if (!gfc_add_access (&sym->attr, access, sym->name, NULL)) 9171 goto done; 9172 9173 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) 9174 && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL)) 9175 goto done; 9176 9177 break; 9178 9179 case INTERFACE_INTRINSIC_OP: 9180 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) 9181 { 9182 gfc_intrinsic_op other_op; 9183 9184 gfc_current_ns->operator_access[op] = access; 9185 9186 /* Handle the case if there is another op with the same 9187 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ 9188 other_op = gfc_equivalent_op (op); 9189 9190 if (other_op != INTRINSIC_NONE) 9191 gfc_current_ns->operator_access[other_op] = access; 9192 } 9193 else 9194 { 9195 gfc_error ("Access specification of the %s operator at %C has " 9196 "already been specified", gfc_op2string (op)); 9197 goto done; 9198 } 9199 9200 break; 9201 9202 case INTERFACE_USER_OP: 9203 uop = gfc_get_uop (name); 9204 9205 if (uop->access == ACCESS_UNKNOWN) 9206 { 9207 uop->access = access; 9208 } 9209 else 9210 { 9211 gfc_error ("Access specification of the .%s. operator at %C " 9212 "has already been specified", uop->name); 9213 goto done; 9214 } 9215 9216 break; 9217 } 9218 9219 if (gfc_match_char (',') == MATCH_NO) 9220 break; 9221 } 9222 9223 if (gfc_match_eos () != MATCH_YES) 9224 goto syntax; 9225 return MATCH_YES; 9226 9227syntax: 9228 gfc_syntax_error (st); 9229 9230done: 9231 return MATCH_ERROR; 9232} 9233 9234 9235match 9236gfc_match_protected (void) 9237{ 9238 gfc_symbol *sym; 9239 match m; 9240 char c; 9241 9242 /* PROTECTED has already been seen, but must be followed by whitespace 9243 or ::. */ 9244 c = gfc_peek_ascii_char (); 9245 if (!gfc_is_whitespace (c) && c != ':') 9246 return MATCH_NO; 9247 9248 if (!gfc_current_ns->proc_name 9249 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) 9250 { 9251 gfc_error ("PROTECTED at %C only allowed in specification " 9252 "part of a module"); 9253 return MATCH_ERROR; 9254 9255 } 9256 9257 gfc_match (" ::"); 9258 9259 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C")) 9260 return MATCH_ERROR; 9261 9262 /* PROTECTED has an entity-list. */ 9263 if (gfc_match_eos () == MATCH_YES) 9264 goto syntax; 9265 9266 for(;;) 9267 { 9268 m = gfc_match_symbol (&sym, 0); 9269 switch (m) 9270 { 9271 case MATCH_YES: 9272 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)) 9273 return MATCH_ERROR; 9274 goto next_item; 9275 9276 case MATCH_NO: 9277 break; 9278 9279 case MATCH_ERROR: 9280 return MATCH_ERROR; 9281 } 9282 9283 next_item: 9284 if (gfc_match_eos () == MATCH_YES) 9285 break; 9286 if (gfc_match_char (',') != MATCH_YES) 9287 goto syntax; 9288 } 9289 9290 return MATCH_YES; 9291 9292syntax: 9293 gfc_error ("Syntax error in PROTECTED statement at %C"); 9294 return MATCH_ERROR; 9295} 9296 9297 9298/* The PRIVATE statement is a bit weird in that it can be an attribute 9299 declaration, but also works as a standalone statement inside of a 9300 type declaration or a module. */ 9301 9302match 9303gfc_match_private (gfc_statement *st) 9304{ 9305 gfc_state_data *prev; 9306 9307 if (gfc_match ("private") != MATCH_YES) 9308 return MATCH_NO; 9309 9310 /* Try matching PRIVATE without an access-list. */ 9311 if (gfc_match_eos () == MATCH_YES) 9312 { 9313 prev = gfc_state_stack->previous; 9314 if (gfc_current_state () != COMP_MODULE 9315 && !(gfc_current_state () == COMP_DERIVED 9316 && prev && prev->state == COMP_MODULE) 9317 && !(gfc_current_state () == COMP_DERIVED_CONTAINS 9318 && prev->previous && prev->previous->state == COMP_MODULE)) 9319 { 9320 gfc_error ("PRIVATE statement at %C is only allowed in the " 9321 "specification part of a module"); 9322 return MATCH_ERROR; 9323 } 9324 9325 *st = ST_PRIVATE; 9326 return MATCH_YES; 9327 } 9328 9329 /* At this point in free-form source code, PRIVATE must be followed 9330 by whitespace or ::. */ 9331 if (gfc_current_form == FORM_FREE) 9332 { 9333 char c = gfc_peek_ascii_char (); 9334 if (!gfc_is_whitespace (c) && c != ':') 9335 return MATCH_NO; 9336 } 9337 9338 prev = gfc_state_stack->previous; 9339 if (gfc_current_state () != COMP_MODULE 9340 && !(gfc_current_state () == COMP_DERIVED 9341 && prev && prev->state == COMP_MODULE) 9342 && !(gfc_current_state () == COMP_DERIVED_CONTAINS 9343 && prev->previous && prev->previous->state == COMP_MODULE)) 9344 { 9345 gfc_error ("PRIVATE statement at %C is only allowed in the " 9346 "specification part of a module"); 9347 return MATCH_ERROR; 9348 } 9349 9350 *st = ST_ATTR_DECL; 9351 return access_attr_decl (ST_PRIVATE); 9352} 9353 9354 9355match 9356gfc_match_public (gfc_statement *st) 9357{ 9358 if (gfc_match ("public") != MATCH_YES) 9359 return MATCH_NO; 9360 9361 /* Try matching PUBLIC without an access-list. */ 9362 if (gfc_match_eos () == MATCH_YES) 9363 { 9364 if (gfc_current_state () != COMP_MODULE) 9365 { 9366 gfc_error ("PUBLIC statement at %C is only allowed in the " 9367 "specification part of a module"); 9368 return MATCH_ERROR; 9369 } 9370 9371 *st = ST_PUBLIC; 9372 return MATCH_YES; 9373 } 9374 9375 /* At this point in free-form source code, PUBLIC must be followed 9376 by whitespace or ::. */ 9377 if (gfc_current_form == FORM_FREE) 9378 { 9379 char c = gfc_peek_ascii_char (); 9380 if (!gfc_is_whitespace (c) && c != ':') 9381 return MATCH_NO; 9382 } 9383 9384 if (gfc_current_state () != COMP_MODULE) 9385 { 9386 gfc_error ("PUBLIC statement at %C is only allowed in the " 9387 "specification part of a module"); 9388 return MATCH_ERROR; 9389 } 9390 9391 *st = ST_ATTR_DECL; 9392 return access_attr_decl (ST_PUBLIC); 9393} 9394 9395 9396/* Workhorse for gfc_match_parameter. */ 9397 9398static match 9399do_parm (void) 9400{ 9401 gfc_symbol *sym; 9402 gfc_expr *init; 9403 match m; 9404 bool t; 9405 9406 m = gfc_match_symbol (&sym, 0); 9407 if (m == MATCH_NO) 9408 gfc_error ("Expected variable name at %C in PARAMETER statement"); 9409 9410 if (m != MATCH_YES) 9411 return m; 9412 9413 if (gfc_match_char ('=') == MATCH_NO) 9414 { 9415 gfc_error ("Expected = sign in PARAMETER statement at %C"); 9416 return MATCH_ERROR; 9417 } 9418 9419 m = gfc_match_init_expr (&init); 9420 if (m == MATCH_NO) 9421 gfc_error ("Expected expression at %C in PARAMETER statement"); 9422 if (m != MATCH_YES) 9423 return m; 9424 9425 if (sym->ts.type == BT_UNKNOWN 9426 && !gfc_set_default_type (sym, 1, NULL)) 9427 { 9428 m = MATCH_ERROR; 9429 goto cleanup; 9430 } 9431 9432 if (!gfc_check_assign_symbol (sym, NULL, init) 9433 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL)) 9434 { 9435 m = MATCH_ERROR; 9436 goto cleanup; 9437 } 9438 9439 if (sym->value) 9440 { 9441 gfc_error ("Initializing already initialized variable at %C"); 9442 m = MATCH_ERROR; 9443 goto cleanup; 9444 } 9445 9446 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus); 9447 return (t) ? MATCH_YES : MATCH_ERROR; 9448 9449cleanup: 9450 gfc_free_expr (init); 9451 return m; 9452} 9453 9454 9455/* Match a parameter statement, with the weird syntax that these have. */ 9456 9457match 9458gfc_match_parameter (void) 9459{ 9460 const char *term = " )%t"; 9461 match m; 9462 9463 if (gfc_match_char ('(') == MATCH_NO) 9464 { 9465 /* With legacy PARAMETER statements, don't expect a terminating ')'. */ 9466 if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C")) 9467 return MATCH_NO; 9468 term = " %t"; 9469 } 9470 9471 for (;;) 9472 { 9473 m = do_parm (); 9474 if (m != MATCH_YES) 9475 break; 9476 9477 if (gfc_match (term) == MATCH_YES) 9478 break; 9479 9480 if (gfc_match_char (',') != MATCH_YES) 9481 { 9482 gfc_error ("Unexpected characters in PARAMETER statement at %C"); 9483 m = MATCH_ERROR; 9484 break; 9485 } 9486 } 9487 9488 return m; 9489} 9490 9491 9492match 9493gfc_match_automatic (void) 9494{ 9495 gfc_symbol *sym; 9496 match m; 9497 bool seen_symbol = false; 9498 9499 if (!flag_dec_static) 9500 { 9501 gfc_error ("%s at %C is a DEC extension, enable with " 9502 "%<-fdec-static%>", 9503 "AUTOMATIC" 9504 ); 9505 return MATCH_ERROR; 9506 } 9507 9508 gfc_match (" ::"); 9509 9510 for (;;) 9511 { 9512 m = gfc_match_symbol (&sym, 0); 9513 switch (m) 9514 { 9515 case MATCH_NO: 9516 break; 9517 9518 case MATCH_ERROR: 9519 return MATCH_ERROR; 9520 9521 case MATCH_YES: 9522 if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus)) 9523 return MATCH_ERROR; 9524 seen_symbol = true; 9525 break; 9526 } 9527 9528 if (gfc_match_eos () == MATCH_YES) 9529 break; 9530 if (gfc_match_char (',') != MATCH_YES) 9531 goto syntax; 9532 } 9533 9534 if (!seen_symbol) 9535 { 9536 gfc_error ("Expected entity-list in AUTOMATIC statement at %C"); 9537 return MATCH_ERROR; 9538 } 9539 9540 return MATCH_YES; 9541 9542syntax: 9543 gfc_error ("Syntax error in AUTOMATIC statement at %C"); 9544 return MATCH_ERROR; 9545} 9546 9547 9548match 9549gfc_match_static (void) 9550{ 9551 gfc_symbol *sym; 9552 match m; 9553 bool seen_symbol = false; 9554 9555 if (!flag_dec_static) 9556 { 9557 gfc_error ("%s at %C is a DEC extension, enable with " 9558 "%<-fdec-static%>", 9559 "STATIC"); 9560 return MATCH_ERROR; 9561 } 9562 9563 gfc_match (" ::"); 9564 9565 for (;;) 9566 { 9567 m = gfc_match_symbol (&sym, 0); 9568 switch (m) 9569 { 9570 case MATCH_NO: 9571 break; 9572 9573 case MATCH_ERROR: 9574 return MATCH_ERROR; 9575 9576 case MATCH_YES: 9577 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, 9578 &gfc_current_locus)) 9579 return MATCH_ERROR; 9580 seen_symbol = true; 9581 break; 9582 } 9583 9584 if (gfc_match_eos () == MATCH_YES) 9585 break; 9586 if (gfc_match_char (',') != MATCH_YES) 9587 goto syntax; 9588 } 9589 9590 if (!seen_symbol) 9591 { 9592 gfc_error ("Expected entity-list in STATIC statement at %C"); 9593 return MATCH_ERROR; 9594 } 9595 9596 return MATCH_YES; 9597 9598syntax: 9599 gfc_error ("Syntax error in STATIC statement at %C"); 9600 return MATCH_ERROR; 9601} 9602 9603 9604/* Save statements have a special syntax. */ 9605 9606match 9607gfc_match_save (void) 9608{ 9609 char n[GFC_MAX_SYMBOL_LEN+1]; 9610 gfc_common_head *c; 9611 gfc_symbol *sym; 9612 match m; 9613 9614 if (gfc_match_eos () == MATCH_YES) 9615 { 9616 if (gfc_current_ns->seen_save) 9617 { 9618 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C " 9619 "follows previous SAVE statement")) 9620 return MATCH_ERROR; 9621 } 9622 9623 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; 9624 return MATCH_YES; 9625 } 9626 9627 if (gfc_current_ns->save_all) 9628 { 9629 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows " 9630 "blanket SAVE statement")) 9631 return MATCH_ERROR; 9632 } 9633 9634 gfc_match (" ::"); 9635 9636 for (;;) 9637 { 9638 m = gfc_match_symbol (&sym, 0); 9639 switch (m) 9640 { 9641 case MATCH_YES: 9642 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, 9643 &gfc_current_locus)) 9644 return MATCH_ERROR; 9645 goto next_item; 9646 9647 case MATCH_NO: 9648 break; 9649 9650 case MATCH_ERROR: 9651 return MATCH_ERROR; 9652 } 9653 9654 m = gfc_match (" / %n /", &n); 9655 if (m == MATCH_ERROR) 9656 return MATCH_ERROR; 9657 if (m == MATCH_NO) 9658 goto syntax; 9659 9660 c = gfc_get_common (n, 0); 9661 c->saved = 1; 9662 9663 gfc_current_ns->seen_save = 1; 9664 9665 next_item: 9666 if (gfc_match_eos () == MATCH_YES) 9667 break; 9668 if (gfc_match_char (',') != MATCH_YES) 9669 goto syntax; 9670 } 9671 9672 return MATCH_YES; 9673 9674syntax: 9675 if (gfc_current_ns->seen_save) 9676 { 9677 gfc_error ("Syntax error in SAVE statement at %C"); 9678 return MATCH_ERROR; 9679 } 9680 else 9681 return MATCH_NO; 9682} 9683 9684 9685match 9686gfc_match_value (void) 9687{ 9688 gfc_symbol *sym; 9689 match m; 9690 9691 /* This is not allowed within a BLOCK construct! */ 9692 if (gfc_current_state () == COMP_BLOCK) 9693 { 9694 gfc_error ("VALUE is not allowed inside of BLOCK at %C"); 9695 return MATCH_ERROR; 9696 } 9697 9698 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C")) 9699 return MATCH_ERROR; 9700 9701 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 9702 { 9703 return MATCH_ERROR; 9704 } 9705 9706 if (gfc_match_eos () == MATCH_YES) 9707 goto syntax; 9708 9709 for(;;) 9710 { 9711 m = gfc_match_symbol (&sym, 0); 9712 switch (m) 9713 { 9714 case MATCH_YES: 9715 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)) 9716 return MATCH_ERROR; 9717 goto next_item; 9718 9719 case MATCH_NO: 9720 break; 9721 9722 case MATCH_ERROR: 9723 return MATCH_ERROR; 9724 } 9725 9726 next_item: 9727 if (gfc_match_eos () == MATCH_YES) 9728 break; 9729 if (gfc_match_char (',') != MATCH_YES) 9730 goto syntax; 9731 } 9732 9733 return MATCH_YES; 9734 9735syntax: 9736 gfc_error ("Syntax error in VALUE statement at %C"); 9737 return MATCH_ERROR; 9738} 9739 9740 9741match 9742gfc_match_volatile (void) 9743{ 9744 gfc_symbol *sym; 9745 char *name; 9746 match m; 9747 9748 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C")) 9749 return MATCH_ERROR; 9750 9751 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 9752 { 9753 return MATCH_ERROR; 9754 } 9755 9756 if (gfc_match_eos () == MATCH_YES) 9757 goto syntax; 9758 9759 for(;;) 9760 { 9761 /* VOLATILE is special because it can be added to host-associated 9762 symbols locally. Except for coarrays. */ 9763 m = gfc_match_symbol (&sym, 1); 9764 switch (m) 9765 { 9766 case MATCH_YES: 9767 name = XCNEWVAR (char, strlen (sym->name) + 1); 9768 strcpy (name, sym->name); 9769 if (!check_function_name (name)) 9770 return MATCH_ERROR; 9771 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or 9772 for variable in a BLOCK which is defined outside of the BLOCK. */ 9773 if (sym->ns != gfc_current_ns && sym->attr.codimension) 9774 { 9775 gfc_error ("Specifying VOLATILE for coarray variable %qs at " 9776 "%C, which is use-/host-associated", sym->name); 9777 return MATCH_ERROR; 9778 } 9779 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) 9780 return MATCH_ERROR; 9781 goto next_item; 9782 9783 case MATCH_NO: 9784 break; 9785 9786 case MATCH_ERROR: 9787 return MATCH_ERROR; 9788 } 9789 9790 next_item: 9791 if (gfc_match_eos () == MATCH_YES) 9792 break; 9793 if (gfc_match_char (',') != MATCH_YES) 9794 goto syntax; 9795 } 9796 9797 return MATCH_YES; 9798 9799syntax: 9800 gfc_error ("Syntax error in VOLATILE statement at %C"); 9801 return MATCH_ERROR; 9802} 9803 9804 9805match 9806gfc_match_asynchronous (void) 9807{ 9808 gfc_symbol *sym; 9809 char *name; 9810 match m; 9811 9812 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C")) 9813 return MATCH_ERROR; 9814 9815 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 9816 { 9817 return MATCH_ERROR; 9818 } 9819 9820 if (gfc_match_eos () == MATCH_YES) 9821 goto syntax; 9822 9823 for(;;) 9824 { 9825 /* ASYNCHRONOUS is special because it can be added to host-associated 9826 symbols locally. */ 9827 m = gfc_match_symbol (&sym, 1); 9828 switch (m) 9829 { 9830 case MATCH_YES: 9831 name = XCNEWVAR (char, strlen (sym->name) + 1); 9832 strcpy (name, sym->name); 9833 if (!check_function_name (name)) 9834 return MATCH_ERROR; 9835 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)) 9836 return MATCH_ERROR; 9837 goto next_item; 9838 9839 case MATCH_NO: 9840 break; 9841 9842 case MATCH_ERROR: 9843 return MATCH_ERROR; 9844 } 9845 9846 next_item: 9847 if (gfc_match_eos () == MATCH_YES) 9848 break; 9849 if (gfc_match_char (',') != MATCH_YES) 9850 goto syntax; 9851 } 9852 9853 return MATCH_YES; 9854 9855syntax: 9856 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C"); 9857 return MATCH_ERROR; 9858} 9859 9860 9861/* Match a module procedure statement in a submodule. */ 9862 9863match 9864gfc_match_submod_proc (void) 9865{ 9866 char name[GFC_MAX_SYMBOL_LEN + 1]; 9867 gfc_symbol *sym, *fsym; 9868 match m; 9869 gfc_formal_arglist *formal, *head, *tail; 9870 9871 if (gfc_current_state () != COMP_CONTAINS 9872 || !(gfc_state_stack->previous 9873 && (gfc_state_stack->previous->state == COMP_SUBMODULE 9874 || gfc_state_stack->previous->state == COMP_MODULE))) 9875 return MATCH_NO; 9876 9877 m = gfc_match (" module% procedure% %n", name); 9878 if (m != MATCH_YES) 9879 return m; 9880 9881 if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration " 9882 "at %C")) 9883 return MATCH_ERROR; 9884 9885 if (get_proc_name (name, &sym, false)) 9886 return MATCH_ERROR; 9887 9888 /* Make sure that the result field is appropriately filled. */ 9889 if (sym->tlink && sym->tlink->attr.function) 9890 { 9891 if (sym->tlink->result && sym->tlink->result != sym->tlink) 9892 { 9893 sym->result = sym->tlink->result; 9894 if (!sym->result->attr.use_assoc) 9895 { 9896 gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root, 9897 sym->result->name); 9898 st->n.sym = sym->result; 9899 sym->result->refs++; 9900 } 9901 } 9902 else 9903 sym->result = sym; 9904 } 9905 9906 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if 9907 the symbol existed before. */ 9908 sym->declared_at = gfc_current_locus; 9909 9910 if (!sym->attr.module_procedure) 9911 return MATCH_ERROR; 9912 9913 /* Signal match_end to expect "end procedure". */ 9914 sym->abr_modproc_decl = 1; 9915 9916 /* Change from IFSRC_IFBODY coming from the interface declaration. */ 9917 sym->attr.if_source = IFSRC_DECL; 9918 9919 gfc_new_block = sym; 9920 9921 /* Make a new formal arglist with the symbols in the procedure 9922 namespace. */ 9923 head = tail = NULL; 9924 for (formal = sym->formal; formal && formal->sym; formal = formal->next) 9925 { 9926 if (formal == sym->formal) 9927 head = tail = gfc_get_formal_arglist (); 9928 else 9929 { 9930 tail->next = gfc_get_formal_arglist (); 9931 tail = tail->next; 9932 } 9933 9934 if (gfc_copy_dummy_sym (&fsym, formal->sym, 0)) 9935 goto cleanup; 9936 9937 tail->sym = fsym; 9938 gfc_set_sym_referenced (fsym); 9939 } 9940 9941 /* The dummy symbols get cleaned up, when the formal_namespace of the 9942 interface declaration is cleared. This allows us to add the 9943 explicit interface as is done for other type of procedure. */ 9944 if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head, 9945 &gfc_current_locus)) 9946 return MATCH_ERROR; 9947 9948 if (gfc_match_eos () != MATCH_YES) 9949 { 9950 /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are 9951 undone, such that the st->n.sym->formal points to the original symbol; 9952 if now this namespace is finalized, the formal namespace is freed, 9953 but it might be still needed in the parent namespace. */ 9954 gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name); 9955 st->n.sym = NULL; 9956 gfc_free_symbol (sym->tlink); 9957 sym->tlink = NULL; 9958 sym->refs--; 9959 gfc_syntax_error (ST_MODULE_PROC); 9960 return MATCH_ERROR; 9961 } 9962 9963 return MATCH_YES; 9964 9965cleanup: 9966 gfc_free_formal_arglist (head); 9967 return MATCH_ERROR; 9968} 9969 9970 9971/* Match a module procedure statement. Note that we have to modify 9972 symbols in the parent's namespace because the current one was there 9973 to receive symbols that are in an interface's formal argument list. */ 9974 9975match 9976gfc_match_modproc (void) 9977{ 9978 char name[GFC_MAX_SYMBOL_LEN + 1]; 9979 gfc_symbol *sym; 9980 match m; 9981 locus old_locus; 9982 gfc_namespace *module_ns; 9983 gfc_interface *old_interface_head, *interface; 9984 9985 if (gfc_state_stack->previous == NULL 9986 || (gfc_state_stack->state != COMP_INTERFACE 9987 && (gfc_state_stack->state != COMP_CONTAINS 9988 || gfc_state_stack->previous->state != COMP_INTERFACE)) 9989 || current_interface.type == INTERFACE_NAMELESS 9990 || current_interface.type == INTERFACE_ABSTRACT) 9991 { 9992 gfc_error ("MODULE PROCEDURE at %C must be in a generic module " 9993 "interface"); 9994 return MATCH_ERROR; 9995 } 9996 9997 module_ns = gfc_current_ns->parent; 9998 for (; module_ns; module_ns = module_ns->parent) 9999 if (module_ns->proc_name->attr.flavor == FL_MODULE 10000 || module_ns->proc_name->attr.flavor == FL_PROGRAM 10001 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE 10002 && !module_ns->proc_name->attr.contained)) 10003 break; 10004 10005 if (module_ns == NULL) 10006 return MATCH_ERROR; 10007 10008 /* Store the current state of the interface. We will need it if we 10009 end up with a syntax error and need to recover. */ 10010 old_interface_head = gfc_current_interface_head (); 10011 10012 /* Check if the F2008 optional double colon appears. */ 10013 gfc_gobble_whitespace (); 10014 old_locus = gfc_current_locus; 10015 if (gfc_match ("::") == MATCH_YES) 10016 { 10017 if (!gfc_notify_std (GFC_STD_F2008, "double colon in " 10018 "MODULE PROCEDURE statement at %L", &old_locus)) 10019 return MATCH_ERROR; 10020 } 10021 else 10022 gfc_current_locus = old_locus; 10023 10024 for (;;) 10025 { 10026 bool last = false; 10027 old_locus = gfc_current_locus; 10028 10029 m = gfc_match_name (name); 10030 if (m == MATCH_NO) 10031 goto syntax; 10032 if (m != MATCH_YES) 10033 return MATCH_ERROR; 10034 10035 /* Check for syntax error before starting to add symbols to the 10036 current namespace. */ 10037 if (gfc_match_eos () == MATCH_YES) 10038 last = true; 10039 10040 if (!last && gfc_match_char (',') != MATCH_YES) 10041 goto syntax; 10042 10043 /* Now we're sure the syntax is valid, we process this item 10044 further. */ 10045 if (gfc_get_symbol (name, module_ns, &sym)) 10046 return MATCH_ERROR; 10047 10048 if (sym->attr.intrinsic) 10049 { 10050 gfc_error ("Intrinsic procedure at %L cannot be a MODULE " 10051 "PROCEDURE", &old_locus); 10052 return MATCH_ERROR; 10053 } 10054 10055 if (sym->attr.proc != PROC_MODULE 10056 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 10057 return MATCH_ERROR; 10058 10059 if (!gfc_add_interface (sym)) 10060 return MATCH_ERROR; 10061 10062 sym->attr.mod_proc = 1; 10063 sym->declared_at = old_locus; 10064 10065 if (last) 10066 break; 10067 } 10068 10069 return MATCH_YES; 10070 10071syntax: 10072 /* Restore the previous state of the interface. */ 10073 interface = gfc_current_interface_head (); 10074 gfc_set_current_interface_head (old_interface_head); 10075 10076 /* Free the new interfaces. */ 10077 while (interface != old_interface_head) 10078 { 10079 gfc_interface *i = interface->next; 10080 free (interface); 10081 interface = i; 10082 } 10083 10084 /* And issue a syntax error. */ 10085 gfc_syntax_error (ST_MODULE_PROC); 10086 return MATCH_ERROR; 10087} 10088 10089 10090/* Check a derived type that is being extended. */ 10091 10092static gfc_symbol* 10093check_extended_derived_type (char *name) 10094{ 10095 gfc_symbol *extended; 10096 10097 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended)) 10098 { 10099 gfc_error ("Ambiguous symbol in TYPE definition at %C"); 10100 return NULL; 10101 } 10102 10103 extended = gfc_find_dt_in_generic (extended); 10104 10105 /* F08:C428. */ 10106 if (!extended) 10107 { 10108 gfc_error ("Symbol %qs at %C has not been previously defined", name); 10109 return NULL; 10110 } 10111 10112 if (extended->attr.flavor != FL_DERIVED) 10113 { 10114 gfc_error ("%qs in EXTENDS expression at %C is not a " 10115 "derived type", name); 10116 return NULL; 10117 } 10118 10119 if (extended->attr.is_bind_c) 10120 { 10121 gfc_error ("%qs cannot be extended at %C because it " 10122 "is BIND(C)", extended->name); 10123 return NULL; 10124 } 10125 10126 if (extended->attr.sequence) 10127 { 10128 gfc_error ("%qs cannot be extended at %C because it " 10129 "is a SEQUENCE type", extended->name); 10130 return NULL; 10131 } 10132 10133 return extended; 10134} 10135 10136 10137/* Match the optional attribute specifiers for a type declaration. 10138 Return MATCH_ERROR if an error is encountered in one of the handled 10139 attributes (public, private, bind(c)), MATCH_NO if what's found is 10140 not a handled attribute, and MATCH_YES otherwise. TODO: More error 10141 checking on attribute conflicts needs to be done. */ 10142 10143static match 10144gfc_get_type_attr_spec (symbol_attribute *attr, char *name) 10145{ 10146 /* See if the derived type is marked as private. */ 10147 if (gfc_match (" , private") == MATCH_YES) 10148 { 10149 if (gfc_current_state () != COMP_MODULE) 10150 { 10151 gfc_error ("Derived type at %C can only be PRIVATE in the " 10152 "specification part of a module"); 10153 return MATCH_ERROR; 10154 } 10155 10156 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL)) 10157 return MATCH_ERROR; 10158 } 10159 else if (gfc_match (" , public") == MATCH_YES) 10160 { 10161 if (gfc_current_state () != COMP_MODULE) 10162 { 10163 gfc_error ("Derived type at %C can only be PUBLIC in the " 10164 "specification part of a module"); 10165 return MATCH_ERROR; 10166 } 10167 10168 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL)) 10169 return MATCH_ERROR; 10170 } 10171 else if (gfc_match (" , bind ( c )") == MATCH_YES) 10172 { 10173 /* If the type is defined to be bind(c) it then needs to make 10174 sure that all fields are interoperable. This will 10175 need to be a semantic check on the finished derived type. 10176 See 15.2.3 (lines 9-12) of F2003 draft. */ 10177 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0)) 10178 return MATCH_ERROR; 10179 10180 /* TODO: attr conflicts need to be checked, probably in symbol.cc. */ 10181 } 10182 else if (gfc_match (" , abstract") == MATCH_YES) 10183 { 10184 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C")) 10185 return MATCH_ERROR; 10186 10187 if (!gfc_add_abstract (attr, &gfc_current_locus)) 10188 return MATCH_ERROR; 10189 } 10190 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES) 10191 { 10192 if (!gfc_add_extension (attr, &gfc_current_locus)) 10193 return MATCH_ERROR; 10194 } 10195 else 10196 return MATCH_NO; 10197 10198 /* If we get here, something matched. */ 10199 return MATCH_YES; 10200} 10201 10202 10203/* Common function for type declaration blocks similar to derived types, such 10204 as STRUCTURES and MAPs. Unlike derived types, a structure type 10205 does NOT have a generic symbol matching the name given by the user. 10206 STRUCTUREs can share names with variables and PARAMETERs so we must allow 10207 for the creation of an independent symbol. 10208 Other parameters are a message to prefix errors with, the name of the new 10209 type to be created, and the flavor to add to the resulting symbol. */ 10210 10211static bool 10212get_struct_decl (const char *name, sym_flavor fl, locus *decl, 10213 gfc_symbol **result) 10214{ 10215 gfc_symbol *sym; 10216 locus where; 10217 10218 gcc_assert (name[0] == (char) TOUPPER (name[0])); 10219 10220 if (decl) 10221 where = *decl; 10222 else 10223 where = gfc_current_locus; 10224 10225 if (gfc_get_symbol (name, NULL, &sym)) 10226 return false; 10227 10228 if (!sym) 10229 { 10230 gfc_internal_error ("Failed to create structure type '%s' at %C", name); 10231 return false; 10232 } 10233 10234 if (sym->components != NULL || sym->attr.zero_comp) 10235 { 10236 gfc_error ("Type definition of %qs at %C was already defined at %L", 10237 sym->name, &sym->declared_at); 10238 return false; 10239 } 10240 10241 sym->declared_at = where; 10242 10243 if (sym->attr.flavor != fl 10244 && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL)) 10245 return false; 10246 10247 if (!sym->hash_value) 10248 /* Set the hash for the compound name for this type. */ 10249 sym->hash_value = gfc_hash_value (sym); 10250 10251 /* Normally the type is expected to have been completely parsed by the time 10252 a field declaration with this type is seen. For unions, maps, and nested 10253 structure declarations, we need to indicate that it is okay that we 10254 haven't seen any components yet. This will be updated after the structure 10255 is fully parsed. */ 10256 sym->attr.zero_comp = 0; 10257 10258 /* Structures always act like derived-types with the SEQUENCE attribute */ 10259 gfc_add_sequence (&sym->attr, sym->name, NULL); 10260 10261 if (result) *result = sym; 10262 10263 return true; 10264} 10265 10266 10267/* Match the opening of a MAP block. Like a struct within a union in C; 10268 behaves identical to STRUCTURE blocks. */ 10269 10270match 10271gfc_match_map (void) 10272{ 10273 /* Counter used to give unique internal names to map structures. */ 10274 static unsigned int gfc_map_id = 0; 10275 char name[GFC_MAX_SYMBOL_LEN + 1]; 10276 gfc_symbol *sym; 10277 locus old_loc; 10278 10279 old_loc = gfc_current_locus; 10280 10281 if (gfc_match_eos () != MATCH_YES) 10282 { 10283 gfc_error ("Junk after MAP statement at %C"); 10284 gfc_current_locus = old_loc; 10285 return MATCH_ERROR; 10286 } 10287 10288 /* Map blocks are anonymous so we make up unique names for the symbol table 10289 which are invalid Fortran identifiers. */ 10290 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++); 10291 10292 if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym)) 10293 return MATCH_ERROR; 10294 10295 gfc_new_block = sym; 10296 10297 return MATCH_YES; 10298} 10299 10300 10301/* Match the opening of a UNION block. */ 10302 10303match 10304gfc_match_union (void) 10305{ 10306 /* Counter used to give unique internal names to union types. */ 10307 static unsigned int gfc_union_id = 0; 10308 char name[GFC_MAX_SYMBOL_LEN + 1]; 10309 gfc_symbol *sym; 10310 locus old_loc; 10311 10312 old_loc = gfc_current_locus; 10313 10314 if (gfc_match_eos () != MATCH_YES) 10315 { 10316 gfc_error ("Junk after UNION statement at %C"); 10317 gfc_current_locus = old_loc; 10318 return MATCH_ERROR; 10319 } 10320 10321 /* Unions are anonymous so we make up unique names for the symbol table 10322 which are invalid Fortran identifiers. */ 10323 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++); 10324 10325 if (!get_struct_decl (name, FL_UNION, &old_loc, &sym)) 10326 return MATCH_ERROR; 10327 10328 gfc_new_block = sym; 10329 10330 return MATCH_YES; 10331} 10332 10333 10334/* Match the beginning of a STRUCTURE declaration. This is similar to 10335 matching the beginning of a derived type declaration with a few 10336 twists. The resulting type symbol has no access control or other 10337 interesting attributes. */ 10338 10339match 10340gfc_match_structure_decl (void) 10341{ 10342 /* Counter used to give unique internal names to anonymous structures. */ 10343 static unsigned int gfc_structure_id = 0; 10344 char name[GFC_MAX_SYMBOL_LEN + 1]; 10345 gfc_symbol *sym; 10346 match m; 10347 locus where; 10348 10349 if (!flag_dec_structure) 10350 { 10351 gfc_error ("%s at %C is a DEC extension, enable with " 10352 "%<-fdec-structure%>", 10353 "STRUCTURE"); 10354 return MATCH_ERROR; 10355 } 10356 10357 name[0] = '\0'; 10358 10359 m = gfc_match (" /%n/", name); 10360 if (m != MATCH_YES) 10361 { 10362 /* Non-nested structure declarations require a structure name. */ 10363 if (!gfc_comp_struct (gfc_current_state ())) 10364 { 10365 gfc_error ("Structure name expected in non-nested structure " 10366 "declaration at %C"); 10367 return MATCH_ERROR; 10368 } 10369 /* This is an anonymous structure; make up a unique name for it 10370 (upper-case letters never make it to symbol names from the source). 10371 The important thing is initializing the type variable 10372 and setting gfc_new_symbol, which is immediately used by 10373 parse_structure () and variable_decl () to add components of 10374 this type. */ 10375 snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++); 10376 } 10377 10378 where = gfc_current_locus; 10379 /* No field list allowed after non-nested structure declaration. */ 10380 if (!gfc_comp_struct (gfc_current_state ()) 10381 && gfc_match_eos () != MATCH_YES) 10382 { 10383 gfc_error ("Junk after non-nested STRUCTURE statement at %C"); 10384 return MATCH_ERROR; 10385 } 10386 10387 /* Make sure the name is not the name of an intrinsic type. */ 10388 if (gfc_is_intrinsic_typename (name)) 10389 { 10390 gfc_error ("Structure name %qs at %C cannot be the same as an" 10391 " intrinsic type", name); 10392 return MATCH_ERROR; 10393 } 10394 10395 /* Store the actual type symbol for the structure with an upper-case first 10396 letter (an invalid Fortran identifier). */ 10397 10398 if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym)) 10399 return MATCH_ERROR; 10400 10401 gfc_new_block = sym; 10402 return MATCH_YES; 10403} 10404 10405 10406/* This function does some work to determine which matcher should be used to 10407 * match a statement beginning with "TYPE". This is used to disambiguate TYPE 10408 * as an alias for PRINT from derived type declarations, TYPE IS statements, 10409 * and [parameterized] derived type declarations. */ 10410 10411match 10412gfc_match_type (gfc_statement *st) 10413{ 10414 char name[GFC_MAX_SYMBOL_LEN + 1]; 10415 match m; 10416 locus old_loc; 10417 10418 /* Requires -fdec. */ 10419 if (!flag_dec) 10420 return MATCH_NO; 10421 10422 m = gfc_match ("type"); 10423 if (m != MATCH_YES) 10424 return m; 10425 /* If we already have an error in the buffer, it is probably from failing to 10426 * match a derived type data declaration. Let it happen. */ 10427 else if (gfc_error_flag_test ()) 10428 return MATCH_NO; 10429 10430 old_loc = gfc_current_locus; 10431 *st = ST_NONE; 10432 10433 /* If we see an attribute list before anything else it's definitely a derived 10434 * type declaration. */ 10435 if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES) 10436 goto derived; 10437 10438 /* By now "TYPE" has already been matched. If we do not see a name, this may 10439 * be something like "TYPE *" or "TYPE <fmt>". */ 10440 m = gfc_match_name (name); 10441 if (m != MATCH_YES) 10442 { 10443 /* Let print match if it can, otherwise throw an error from 10444 * gfc_match_derived_decl. */ 10445 gfc_current_locus = old_loc; 10446 if (gfc_match_print () == MATCH_YES) 10447 { 10448 *st = ST_WRITE; 10449 return MATCH_YES; 10450 } 10451 goto derived; 10452 } 10453 10454 /* Check for EOS. */ 10455 if (gfc_match_eos () == MATCH_YES) 10456 { 10457 /* By now we have "TYPE <name> <EOS>". Check first if the name is an 10458 * intrinsic typename - if so let gfc_match_derived_decl dump an error. 10459 * Otherwise if gfc_match_derived_decl fails it's probably an existing 10460 * symbol which can be printed. */ 10461 gfc_current_locus = old_loc; 10462 m = gfc_match_derived_decl (); 10463 if (gfc_is_intrinsic_typename (name) || m == MATCH_YES) 10464 { 10465 *st = ST_DERIVED_DECL; 10466 return m; 10467 } 10468 } 10469 else 10470 { 10471 /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration 10472 like <type name(parameter)>. */ 10473 gfc_gobble_whitespace (); 10474 bool paren = gfc_peek_ascii_char () == '('; 10475 if (paren) 10476 { 10477 if (strcmp ("is", name) == 0) 10478 goto typeis; 10479 else 10480 goto derived; 10481 } 10482 } 10483 10484 /* Treat TYPE... like PRINT... */ 10485 gfc_current_locus = old_loc; 10486 *st = ST_WRITE; 10487 return gfc_match_print (); 10488 10489derived: 10490 gfc_current_locus = old_loc; 10491 *st = ST_DERIVED_DECL; 10492 return gfc_match_derived_decl (); 10493 10494typeis: 10495 gfc_current_locus = old_loc; 10496 *st = ST_TYPE_IS; 10497 return gfc_match_type_is (); 10498} 10499 10500 10501/* Match the beginning of a derived type declaration. If a type name 10502 was the result of a function, then it is possible to have a symbol 10503 already to be known as a derived type yet have no components. */ 10504 10505match 10506gfc_match_derived_decl (void) 10507{ 10508 char name[GFC_MAX_SYMBOL_LEN + 1]; 10509 char parent[GFC_MAX_SYMBOL_LEN + 1]; 10510 symbol_attribute attr; 10511 gfc_symbol *sym, *gensym; 10512 gfc_symbol *extended; 10513 match m; 10514 match is_type_attr_spec = MATCH_NO; 10515 bool seen_attr = false; 10516 gfc_interface *intr = NULL, *head; 10517 bool parameterized_type = false; 10518 bool seen_colons = false; 10519 10520 if (gfc_comp_struct (gfc_current_state ())) 10521 return MATCH_NO; 10522 10523 name[0] = '\0'; 10524 parent[0] = '\0'; 10525 gfc_clear_attr (&attr); 10526 extended = NULL; 10527 10528 do 10529 { 10530 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent); 10531 if (is_type_attr_spec == MATCH_ERROR) 10532 return MATCH_ERROR; 10533 if (is_type_attr_spec == MATCH_YES) 10534 seen_attr = true; 10535 } while (is_type_attr_spec == MATCH_YES); 10536 10537 /* Deal with derived type extensions. The extension attribute has 10538 been added to 'attr' but now the parent type must be found and 10539 checked. */ 10540 if (parent[0]) 10541 extended = check_extended_derived_type (parent); 10542 10543 if (parent[0] && !extended) 10544 return MATCH_ERROR; 10545 10546 m = gfc_match (" ::"); 10547 if (m == MATCH_YES) 10548 { 10549 seen_colons = true; 10550 } 10551 else if (seen_attr) 10552 { 10553 gfc_error ("Expected :: in TYPE definition at %C"); 10554 return MATCH_ERROR; 10555 } 10556 10557 /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX. 10558 But, we need to simply return for TYPE(. */ 10559 if (m == MATCH_NO && gfc_current_form == FORM_FREE) 10560 { 10561 char c = gfc_peek_ascii_char (); 10562 if (c == '(') 10563 return m; 10564 if (!gfc_is_whitespace (c)) 10565 { 10566 gfc_error ("Mangled derived type definition at %C"); 10567 return MATCH_NO; 10568 } 10569 } 10570 10571 m = gfc_match (" %n ", name); 10572 if (m != MATCH_YES) 10573 return m; 10574 10575 /* Make sure that we don't identify TYPE IS (...) as a parameterized 10576 derived type named 'is'. 10577 TODO Expand the check, when 'name' = "is" by matching " (tname) " 10578 and checking if this is a(n intrinsic) typename. This picks up 10579 misplaced TYPE IS statements such as in select_type_1.f03. */ 10580 if (gfc_peek_ascii_char () == '(') 10581 { 10582 if (gfc_current_state () == COMP_SELECT_TYPE 10583 || (!seen_colons && !strcmp (name, "is"))) 10584 return MATCH_NO; 10585 parameterized_type = true; 10586 } 10587 10588 m = gfc_match_eos (); 10589 if (m != MATCH_YES && !parameterized_type) 10590 return m; 10591 10592 /* Make sure the name is not the name of an intrinsic type. */ 10593 if (gfc_is_intrinsic_typename (name)) 10594 { 10595 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " 10596 "type", name); 10597 return MATCH_ERROR; 10598 } 10599 10600 if (gfc_get_symbol (name, NULL, &gensym)) 10601 return MATCH_ERROR; 10602 10603 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) 10604 { 10605 if (gensym->ts.u.derived) 10606 gfc_error ("Derived type name %qs at %C already has a basic type " 10607 "of %s", gensym->name, gfc_typename (&gensym->ts)); 10608 else 10609 gfc_error ("Derived type name %qs at %C already has a basic type", 10610 gensym->name); 10611 return MATCH_ERROR; 10612 } 10613 10614 if (!gensym->attr.generic 10615 && !gfc_add_generic (&gensym->attr, gensym->name, NULL)) 10616 return MATCH_ERROR; 10617 10618 if (!gensym->attr.function 10619 && !gfc_add_function (&gensym->attr, gensym->name, NULL)) 10620 return MATCH_ERROR; 10621 10622 if (gensym->attr.dummy) 10623 { 10624 gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C", 10625 name, &gensym->declared_at); 10626 return MATCH_ERROR; 10627 } 10628 10629 sym = gfc_find_dt_in_generic (gensym); 10630 10631 if (sym && (sym->components != NULL || sym->attr.zero_comp)) 10632 { 10633 gfc_error ("Derived type definition of %qs at %C has already been " 10634 "defined", sym->name); 10635 return MATCH_ERROR; 10636 } 10637 10638 if (!sym) 10639 { 10640 /* Use upper case to save the actual derived-type symbol. */ 10641 gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); 10642 sym->name = gfc_get_string ("%s", gensym->name); 10643 head = gensym->generic; 10644 intr = gfc_get_interface (); 10645 intr->sym = sym; 10646 intr->where = gfc_current_locus; 10647 intr->sym->declared_at = gfc_current_locus; 10648 intr->next = head; 10649 gensym->generic = intr; 10650 gensym->attr.if_source = IFSRC_DECL; 10651 } 10652 10653 /* The symbol may already have the derived attribute without the 10654 components. The ways this can happen is via a function 10655 definition, an INTRINSIC statement or a subtype in another 10656 derived type that is a pointer. The first part of the AND clause 10657 is true if the symbol is not the return value of a function. */ 10658 if (sym->attr.flavor != FL_DERIVED 10659 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL)) 10660 return MATCH_ERROR; 10661 10662 if (attr.access != ACCESS_UNKNOWN 10663 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL)) 10664 return MATCH_ERROR; 10665 else if (sym->attr.access == ACCESS_UNKNOWN 10666 && gensym->attr.access != ACCESS_UNKNOWN 10667 && !gfc_add_access (&sym->attr, gensym->attr.access, 10668 sym->name, NULL)) 10669 return MATCH_ERROR; 10670 10671 if (sym->attr.access != ACCESS_UNKNOWN 10672 && gensym->attr.access == ACCESS_UNKNOWN) 10673 gensym->attr.access = sym->attr.access; 10674 10675 /* See if the derived type was labeled as bind(c). */ 10676 if (attr.is_bind_c != 0) 10677 sym->attr.is_bind_c = attr.is_bind_c; 10678 10679 /* Construct the f2k_derived namespace if it is not yet there. */ 10680 if (!sym->f2k_derived) 10681 sym->f2k_derived = gfc_get_namespace (NULL, 0); 10682 10683 if (parameterized_type) 10684 { 10685 /* Ignore error or mismatches by going to the end of the statement 10686 in order to avoid the component declarations causing problems. */ 10687 m = gfc_match_formal_arglist (sym, 0, 0, true); 10688 if (m != MATCH_YES) 10689 gfc_error_recovery (); 10690 else 10691 sym->attr.pdt_template = 1; 10692 m = gfc_match_eos (); 10693 if (m != MATCH_YES) 10694 { 10695 gfc_error_recovery (); 10696 gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C"); 10697 } 10698 } 10699 10700 if (extended && !sym->components) 10701 { 10702 gfc_component *p; 10703 gfc_formal_arglist *f, *g, *h; 10704 10705 /* Add the extended derived type as the first component. */ 10706 gfc_add_component (sym, parent, &p); 10707 extended->refs++; 10708 gfc_set_sym_referenced (extended); 10709 10710 p->ts.type = BT_DERIVED; 10711 p->ts.u.derived = extended; 10712 p->initializer = gfc_default_initializer (&p->ts); 10713 10714 /* Set extension level. */ 10715 if (extended->attr.extension == 255) 10716 { 10717 /* Since the extension field is 8 bit wide, we can only have 10718 up to 255 extension levels. */ 10719 gfc_error ("Maximum extension level reached with type %qs at %L", 10720 extended->name, &extended->declared_at); 10721 return MATCH_ERROR; 10722 } 10723 sym->attr.extension = extended->attr.extension + 1; 10724 10725 /* Provide the links between the extended type and its extension. */ 10726 if (!extended->f2k_derived) 10727 extended->f2k_derived = gfc_get_namespace (NULL, 0); 10728 10729 /* Copy the extended type-param-name-list from the extended type, 10730 append those of the extension and add the whole lot to the 10731 extension. */ 10732 if (extended->attr.pdt_template) 10733 { 10734 g = h = NULL; 10735 sym->attr.pdt_template = 1; 10736 for (f = extended->formal; f; f = f->next) 10737 { 10738 if (f == extended->formal) 10739 { 10740 g = gfc_get_formal_arglist (); 10741 h = g; 10742 } 10743 else 10744 { 10745 g->next = gfc_get_formal_arglist (); 10746 g = g->next; 10747 } 10748 g->sym = f->sym; 10749 } 10750 g->next = sym->formal; 10751 sym->formal = h; 10752 } 10753 } 10754 10755 if (!sym->hash_value) 10756 /* Set the hash for the compound name for this type. */ 10757 sym->hash_value = gfc_hash_value (sym); 10758 10759 /* Take over the ABSTRACT attribute. */ 10760 sym->attr.abstract = attr.abstract; 10761 10762 gfc_new_block = sym; 10763 10764 return MATCH_YES; 10765} 10766 10767 10768/* Cray Pointees can be declared as: 10769 pointer (ipt, a (n,m,...,*)) */ 10770 10771match 10772gfc_mod_pointee_as (gfc_array_spec *as) 10773{ 10774 as->cray_pointee = true; /* This will be useful to know later. */ 10775 if (as->type == AS_ASSUMED_SIZE) 10776 as->cp_was_assumed = true; 10777 else if (as->type == AS_ASSUMED_SHAPE) 10778 { 10779 gfc_error ("Cray Pointee at %C cannot be assumed shape array"); 10780 return MATCH_ERROR; 10781 } 10782 return MATCH_YES; 10783} 10784 10785 10786/* Match the enum definition statement, here we are trying to match 10787 the first line of enum definition statement. 10788 Returns MATCH_YES if match is found. */ 10789 10790match 10791gfc_match_enum (void) 10792{ 10793 match m; 10794 10795 m = gfc_match_eos (); 10796 if (m != MATCH_YES) 10797 return m; 10798 10799 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C")) 10800 return MATCH_ERROR; 10801 10802 return MATCH_YES; 10803} 10804 10805 10806/* Returns an initializer whose value is one higher than the value of the 10807 LAST_INITIALIZER argument. If the argument is NULL, the 10808 initializers value will be set to zero. The initializer's kind 10809 will be set to gfc_c_int_kind. 10810 10811 If -fshort-enums is given, the appropriate kind will be selected 10812 later after all enumerators have been parsed. A warning is issued 10813 here if an initializer exceeds gfc_c_int_kind. */ 10814 10815static gfc_expr * 10816enum_initializer (gfc_expr *last_initializer, locus where) 10817{ 10818 gfc_expr *result; 10819 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where); 10820 10821 mpz_init (result->value.integer); 10822 10823 if (last_initializer != NULL) 10824 { 10825 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1); 10826 result->where = last_initializer->where; 10827 10828 if (gfc_check_integer_range (result->value.integer, 10829 gfc_c_int_kind) != ARITH_OK) 10830 { 10831 gfc_error ("Enumerator exceeds the C integer type at %C"); 10832 return NULL; 10833 } 10834 } 10835 else 10836 { 10837 /* Control comes here, if it's the very first enumerator and no 10838 initializer has been given. It will be initialized to zero. */ 10839 mpz_set_si (result->value.integer, 0); 10840 } 10841 10842 return result; 10843} 10844 10845 10846/* Match a variable name with an optional initializer. When this 10847 subroutine is called, a variable is expected to be parsed next. 10848 Depending on what is happening at the moment, updates either the 10849 symbol table or the current interface. */ 10850 10851static match 10852enumerator_decl (void) 10853{ 10854 char name[GFC_MAX_SYMBOL_LEN + 1]; 10855 gfc_expr *initializer; 10856 gfc_array_spec *as = NULL; 10857 gfc_symbol *sym; 10858 locus var_locus; 10859 match m; 10860 bool t; 10861 locus old_locus; 10862 10863 initializer = NULL; 10864 old_locus = gfc_current_locus; 10865 10866 /* When we get here, we've just matched a list of attributes and 10867 maybe a type and a double colon. The next thing we expect to see 10868 is the name of the symbol. */ 10869 m = gfc_match_name (name); 10870 if (m != MATCH_YES) 10871 goto cleanup; 10872 10873 var_locus = gfc_current_locus; 10874 10875 /* OK, we've successfully matched the declaration. Now put the 10876 symbol in the current namespace. If we fail to create the symbol, 10877 bail out. */ 10878 if (!build_sym (name, NULL, false, &as, &var_locus)) 10879 { 10880 m = MATCH_ERROR; 10881 goto cleanup; 10882 } 10883 10884 /* The double colon must be present in order to have initializers. 10885 Otherwise the statement is ambiguous with an assignment statement. */ 10886 if (colon_seen) 10887 { 10888 if (gfc_match_char ('=') == MATCH_YES) 10889 { 10890 m = gfc_match_init_expr (&initializer); 10891 if (m == MATCH_NO) 10892 { 10893 gfc_error ("Expected an initialization expression at %C"); 10894 m = MATCH_ERROR; 10895 } 10896 10897 if (m != MATCH_YES) 10898 goto cleanup; 10899 } 10900 } 10901 10902 /* If we do not have an initializer, the initialization value of the 10903 previous enumerator (stored in last_initializer) is incremented 10904 by 1 and is used to initialize the current enumerator. */ 10905 if (initializer == NULL) 10906 initializer = enum_initializer (last_initializer, old_locus); 10907 10908 if (initializer == NULL || initializer->ts.type != BT_INTEGER) 10909 { 10910 gfc_error ("ENUMERATOR %L not initialized with integer expression", 10911 &var_locus); 10912 m = MATCH_ERROR; 10913 goto cleanup; 10914 } 10915 10916 /* Store this current initializer, for the next enumerator variable 10917 to be parsed. add_init_expr_to_sym() zeros initializer, so we 10918 use last_initializer below. */ 10919 last_initializer = initializer; 10920 t = add_init_expr_to_sym (name, &initializer, &var_locus); 10921 10922 /* Maintain enumerator history. */ 10923 gfc_find_symbol (name, NULL, 0, &sym); 10924 create_enum_history (sym, last_initializer); 10925 10926 return (t) ? MATCH_YES : MATCH_ERROR; 10927 10928cleanup: 10929 /* Free stuff up and return. */ 10930 gfc_free_expr (initializer); 10931 10932 return m; 10933} 10934 10935 10936/* Match the enumerator definition statement. */ 10937 10938match 10939gfc_match_enumerator_def (void) 10940{ 10941 match m; 10942 bool t; 10943 10944 gfc_clear_ts (¤t_ts); 10945 10946 m = gfc_match (" enumerator"); 10947 if (m != MATCH_YES) 10948 return m; 10949 10950 m = gfc_match (" :: "); 10951 if (m == MATCH_ERROR) 10952 return m; 10953 10954 colon_seen = (m == MATCH_YES); 10955 10956 if (gfc_current_state () != COMP_ENUM) 10957 { 10958 gfc_error ("ENUM definition statement expected before %C"); 10959 gfc_free_enum_history (); 10960 return MATCH_ERROR; 10961 } 10962 10963 (¤t_ts)->type = BT_INTEGER; 10964 (¤t_ts)->kind = gfc_c_int_kind; 10965 10966 gfc_clear_attr (¤t_attr); 10967 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL); 10968 if (!t) 10969 { 10970 m = MATCH_ERROR; 10971 goto cleanup; 10972 } 10973 10974 for (;;) 10975 { 10976 m = enumerator_decl (); 10977 if (m == MATCH_ERROR) 10978 { 10979 gfc_free_enum_history (); 10980 goto cleanup; 10981 } 10982 if (m == MATCH_NO) 10983 break; 10984 10985 if (gfc_match_eos () == MATCH_YES) 10986 goto cleanup; 10987 if (gfc_match_char (',') != MATCH_YES) 10988 break; 10989 } 10990 10991 if (gfc_current_state () == COMP_ENUM) 10992 { 10993 gfc_free_enum_history (); 10994 gfc_error ("Syntax error in ENUMERATOR definition at %C"); 10995 m = MATCH_ERROR; 10996 } 10997 10998cleanup: 10999 gfc_free_array_spec (current_as); 11000 current_as = NULL; 11001 return m; 11002 11003} 11004 11005 11006/* Match binding attributes. */ 11007 11008static match 11009match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) 11010{ 11011 bool found_passing = false; 11012 bool seen_ptr = false; 11013 match m = MATCH_YES; 11014 11015 /* Initialize to defaults. Do so even before the MATCH_NO check so that in 11016 this case the defaults are in there. */ 11017 ba->access = ACCESS_UNKNOWN; 11018 ba->pass_arg = NULL; 11019 ba->pass_arg_num = 0; 11020 ba->nopass = 0; 11021 ba->non_overridable = 0; 11022 ba->deferred = 0; 11023 ba->ppc = ppc; 11024 11025 /* If we find a comma, we believe there are binding attributes. */ 11026 m = gfc_match_char (','); 11027 if (m == MATCH_NO) 11028 goto done; 11029 11030 do 11031 { 11032 /* Access specifier. */ 11033 11034 m = gfc_match (" public"); 11035 if (m == MATCH_ERROR) 11036 goto error; 11037 if (m == MATCH_YES) 11038 { 11039 if (ba->access != ACCESS_UNKNOWN) 11040 { 11041 gfc_error ("Duplicate access-specifier at %C"); 11042 goto error; 11043 } 11044 11045 ba->access = ACCESS_PUBLIC; 11046 continue; 11047 } 11048 11049 m = gfc_match (" private"); 11050 if (m == MATCH_ERROR) 11051 goto error; 11052 if (m == MATCH_YES) 11053 { 11054 if (ba->access != ACCESS_UNKNOWN) 11055 { 11056 gfc_error ("Duplicate access-specifier at %C"); 11057 goto error; 11058 } 11059 11060 ba->access = ACCESS_PRIVATE; 11061 continue; 11062 } 11063 11064 /* If inside GENERIC, the following is not allowed. */ 11065 if (!generic) 11066 { 11067 11068 /* NOPASS flag. */ 11069 m = gfc_match (" nopass"); 11070 if (m == MATCH_ERROR) 11071 goto error; 11072 if (m == MATCH_YES) 11073 { 11074 if (found_passing) 11075 { 11076 gfc_error ("Binding attributes already specify passing," 11077 " illegal NOPASS at %C"); 11078 goto error; 11079 } 11080 11081 found_passing = true; 11082 ba->nopass = 1; 11083 continue; 11084 } 11085 11086 /* PASS possibly including argument. */ 11087 m = gfc_match (" pass"); 11088 if (m == MATCH_ERROR) 11089 goto error; 11090 if (m == MATCH_YES) 11091 { 11092 char arg[GFC_MAX_SYMBOL_LEN + 1]; 11093 11094 if (found_passing) 11095 { 11096 gfc_error ("Binding attributes already specify passing," 11097 " illegal PASS at %C"); 11098 goto error; 11099 } 11100 11101 m = gfc_match (" ( %n )", arg); 11102 if (m == MATCH_ERROR) 11103 goto error; 11104 if (m == MATCH_YES) 11105 ba->pass_arg = gfc_get_string ("%s", arg); 11106 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); 11107 11108 found_passing = true; 11109 ba->nopass = 0; 11110 continue; 11111 } 11112 11113 if (ppc) 11114 { 11115 /* POINTER flag. */ 11116 m = gfc_match (" pointer"); 11117 if (m == MATCH_ERROR) 11118 goto error; 11119 if (m == MATCH_YES) 11120 { 11121 if (seen_ptr) 11122 { 11123 gfc_error ("Duplicate POINTER attribute at %C"); 11124 goto error; 11125 } 11126 11127 seen_ptr = true; 11128 continue; 11129 } 11130 } 11131 else 11132 { 11133 /* NON_OVERRIDABLE flag. */ 11134 m = gfc_match (" non_overridable"); 11135 if (m == MATCH_ERROR) 11136 goto error; 11137 if (m == MATCH_YES) 11138 { 11139 if (ba->non_overridable) 11140 { 11141 gfc_error ("Duplicate NON_OVERRIDABLE at %C"); 11142 goto error; 11143 } 11144 11145 ba->non_overridable = 1; 11146 continue; 11147 } 11148 11149 /* DEFERRED flag. */ 11150 m = gfc_match (" deferred"); 11151 if (m == MATCH_ERROR) 11152 goto error; 11153 if (m == MATCH_YES) 11154 { 11155 if (ba->deferred) 11156 { 11157 gfc_error ("Duplicate DEFERRED at %C"); 11158 goto error; 11159 } 11160 11161 ba->deferred = 1; 11162 continue; 11163 } 11164 } 11165 11166 } 11167 11168 /* Nothing matching found. */ 11169 if (generic) 11170 gfc_error ("Expected access-specifier at %C"); 11171 else 11172 gfc_error ("Expected binding attribute at %C"); 11173 goto error; 11174 } 11175 while (gfc_match_char (',') == MATCH_YES); 11176 11177 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */ 11178 if (ba->non_overridable && ba->deferred) 11179 { 11180 gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C"); 11181 goto error; 11182 } 11183 11184 m = MATCH_YES; 11185 11186done: 11187 if (ba->access == ACCESS_UNKNOWN) 11188 ba->access = ppc ? gfc_current_block()->component_access 11189 : gfc_typebound_default_access; 11190 11191 if (ppc && !seen_ptr) 11192 { 11193 gfc_error ("POINTER attribute is required for procedure pointer component" 11194 " at %C"); 11195 goto error; 11196 } 11197 11198 return m; 11199 11200error: 11201 return MATCH_ERROR; 11202} 11203 11204 11205/* Match a PROCEDURE specific binding inside a derived type. */ 11206 11207static match 11208match_procedure_in_type (void) 11209{ 11210 char name[GFC_MAX_SYMBOL_LEN + 1]; 11211 char target_buf[GFC_MAX_SYMBOL_LEN + 1]; 11212 char* target = NULL, *ifc = NULL; 11213 gfc_typebound_proc tb; 11214 bool seen_colons; 11215 bool seen_attrs; 11216 match m; 11217 gfc_symtree* stree; 11218 gfc_namespace* ns; 11219 gfc_symbol* block; 11220 int num; 11221 11222 /* Check current state. */ 11223 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); 11224 block = gfc_state_stack->previous->sym; 11225 gcc_assert (block); 11226 11227 /* Try to match PROCEDURE(interface). */ 11228 if (gfc_match (" (") == MATCH_YES) 11229 { 11230 m = gfc_match_name (target_buf); 11231 if (m == MATCH_ERROR) 11232 return m; 11233 if (m != MATCH_YES) 11234 { 11235 gfc_error ("Interface-name expected after %<(%> at %C"); 11236 return MATCH_ERROR; 11237 } 11238 11239 if (gfc_match (" )") != MATCH_YES) 11240 { 11241 gfc_error ("%<)%> expected at %C"); 11242 return MATCH_ERROR; 11243 } 11244 11245 ifc = target_buf; 11246 } 11247 11248 /* Construct the data structure. */ 11249 memset (&tb, 0, sizeof (tb)); 11250 tb.where = gfc_current_locus; 11251 11252 /* Match binding attributes. */ 11253 m = match_binding_attributes (&tb, false, false); 11254 if (m == MATCH_ERROR) 11255 return m; 11256 seen_attrs = (m == MATCH_YES); 11257 11258 /* Check that attribute DEFERRED is given if an interface is specified. */ 11259 if (tb.deferred && !ifc) 11260 { 11261 gfc_error ("Interface must be specified for DEFERRED binding at %C"); 11262 return MATCH_ERROR; 11263 } 11264 if (ifc && !tb.deferred) 11265 { 11266 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); 11267 return MATCH_ERROR; 11268 } 11269 11270 /* Match the colons. */ 11271 m = gfc_match (" ::"); 11272 if (m == MATCH_ERROR) 11273 return m; 11274 seen_colons = (m == MATCH_YES); 11275 if (seen_attrs && !seen_colons) 11276 { 11277 gfc_error ("Expected %<::%> after binding-attributes at %C"); 11278 return MATCH_ERROR; 11279 } 11280 11281 /* Match the binding names. */ 11282 for(num=1;;num++) 11283 { 11284 m = gfc_match_name (name); 11285 if (m == MATCH_ERROR) 11286 return m; 11287 if (m == MATCH_NO) 11288 { 11289 gfc_error ("Expected binding name at %C"); 11290 return MATCH_ERROR; 11291 } 11292 11293 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C")) 11294 return MATCH_ERROR; 11295 11296 /* Try to match the '=> target', if it's there. */ 11297 target = ifc; 11298 m = gfc_match (" =>"); 11299 if (m == MATCH_ERROR) 11300 return m; 11301 if (m == MATCH_YES) 11302 { 11303 if (tb.deferred) 11304 { 11305 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C"); 11306 return MATCH_ERROR; 11307 } 11308 11309 if (!seen_colons) 11310 { 11311 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target" 11312 " at %C"); 11313 return MATCH_ERROR; 11314 } 11315 11316 m = gfc_match_name (target_buf); 11317 if (m == MATCH_ERROR) 11318 return m; 11319 if (m == MATCH_NO) 11320 { 11321 gfc_error ("Expected binding target after %<=>%> at %C"); 11322 return MATCH_ERROR; 11323 } 11324 target = target_buf; 11325 } 11326 11327 /* If no target was found, it has the same name as the binding. */ 11328 if (!target) 11329 target = name; 11330 11331 /* Get the namespace to insert the symbols into. */ 11332 ns = block->f2k_derived; 11333 gcc_assert (ns); 11334 11335 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ 11336 if (tb.deferred && !block->attr.abstract) 11337 { 11338 gfc_error ("Type %qs containing DEFERRED binding at %C " 11339 "is not ABSTRACT", block->name); 11340 return MATCH_ERROR; 11341 } 11342 11343 /* See if we already have a binding with this name in the symtree which 11344 would be an error. If a GENERIC already targeted this binding, it may 11345 be already there but then typebound is still NULL. */ 11346 stree = gfc_find_symtree (ns->tb_sym_root, name); 11347 if (stree && stree->n.tb) 11348 { 11349 gfc_error ("There is already a procedure with binding name %qs for " 11350 "the derived type %qs at %C", name, block->name); 11351 return MATCH_ERROR; 11352 } 11353 11354 /* Insert it and set attributes. */ 11355 11356 if (!stree) 11357 { 11358 stree = gfc_new_symtree (&ns->tb_sym_root, name); 11359 gcc_assert (stree); 11360 } 11361 stree->n.tb = gfc_get_typebound_proc (&tb); 11362 11363 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, 11364 false)) 11365 return MATCH_ERROR; 11366 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); 11367 gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE, 11368 target, &stree->n.tb->u.specific->n.sym->declared_at); 11369 11370 if (gfc_match_eos () == MATCH_YES) 11371 return MATCH_YES; 11372 if (gfc_match_char (',') != MATCH_YES) 11373 goto syntax; 11374 } 11375 11376syntax: 11377 gfc_error ("Syntax error in PROCEDURE statement at %C"); 11378 return MATCH_ERROR; 11379} 11380 11381 11382/* Match a GENERIC procedure binding inside a derived type. */ 11383 11384match 11385gfc_match_generic (void) 11386{ 11387 char name[GFC_MAX_SYMBOL_LEN + 1]; 11388 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ 11389 gfc_symbol* block; 11390 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ 11391 gfc_typebound_proc* tb; 11392 gfc_namespace* ns; 11393 interface_type op_type; 11394 gfc_intrinsic_op op; 11395 match m; 11396 11397 /* Check current state. */ 11398 if (gfc_current_state () == COMP_DERIVED) 11399 { 11400 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS"); 11401 return MATCH_ERROR; 11402 } 11403 if (gfc_current_state () != COMP_DERIVED_CONTAINS) 11404 return MATCH_NO; 11405 block = gfc_state_stack->previous->sym; 11406 ns = block->f2k_derived; 11407 gcc_assert (block && ns); 11408 11409 memset (&tbattr, 0, sizeof (tbattr)); 11410 tbattr.where = gfc_current_locus; 11411 11412 /* See if we get an access-specifier. */ 11413 m = match_binding_attributes (&tbattr, true, false); 11414 if (m == MATCH_ERROR) 11415 goto error; 11416 11417 /* Now the colons, those are required. */ 11418 if (gfc_match (" ::") != MATCH_YES) 11419 { 11420 gfc_error ("Expected %<::%> at %C"); 11421 goto error; 11422 } 11423 11424 /* Match the binding name; depending on type (operator / generic) format 11425 it for future error messages into bind_name. */ 11426 11427 m = gfc_match_generic_spec (&op_type, name, &op); 11428 if (m == MATCH_ERROR) 11429 return MATCH_ERROR; 11430 if (m == MATCH_NO) 11431 { 11432 gfc_error ("Expected generic name or operator descriptor at %C"); 11433 goto error; 11434 } 11435 11436 switch (op_type) 11437 { 11438 case INTERFACE_GENERIC: 11439 case INTERFACE_DTIO: 11440 snprintf (bind_name, sizeof (bind_name), "%s", name); 11441 break; 11442 11443 case INTERFACE_USER_OP: 11444 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); 11445 break; 11446 11447 case INTERFACE_INTRINSIC_OP: 11448 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", 11449 gfc_op2string (op)); 11450 break; 11451 11452 case INTERFACE_NAMELESS: 11453 gfc_error ("Malformed GENERIC statement at %C"); 11454 goto error; 11455 break; 11456 11457 default: 11458 gcc_unreachable (); 11459 } 11460 11461 /* Match the required =>. */ 11462 if (gfc_match (" =>") != MATCH_YES) 11463 { 11464 gfc_error ("Expected %<=>%> at %C"); 11465 goto error; 11466 } 11467 11468 /* Try to find existing GENERIC binding with this name / for this operator; 11469 if there is something, check that it is another GENERIC and then extend 11470 it rather than building a new node. Otherwise, create it and put it 11471 at the right position. */ 11472 11473 switch (op_type) 11474 { 11475 case INTERFACE_DTIO: 11476 case INTERFACE_USER_OP: 11477 case INTERFACE_GENERIC: 11478 { 11479 const bool is_op = (op_type == INTERFACE_USER_OP); 11480 gfc_symtree* st; 11481 11482 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); 11483 tb = st ? st->n.tb : NULL; 11484 break; 11485 } 11486 11487 case INTERFACE_INTRINSIC_OP: 11488 tb = ns->tb_op[op]; 11489 break; 11490 11491 default: 11492 gcc_unreachable (); 11493 } 11494 11495 if (tb) 11496 { 11497 if (!tb->is_generic) 11498 { 11499 gcc_assert (op_type == INTERFACE_GENERIC); 11500 gfc_error ("There's already a non-generic procedure with binding name" 11501 " %qs for the derived type %qs at %C", 11502 bind_name, block->name); 11503 goto error; 11504 } 11505 11506 if (tb->access != tbattr.access) 11507 { 11508 gfc_error ("Binding at %C must have the same access as already" 11509 " defined binding %qs", bind_name); 11510 goto error; 11511 } 11512 } 11513 else 11514 { 11515 tb = gfc_get_typebound_proc (NULL); 11516 tb->where = gfc_current_locus; 11517 tb->access = tbattr.access; 11518 tb->is_generic = 1; 11519 tb->u.generic = NULL; 11520 11521 switch (op_type) 11522 { 11523 case INTERFACE_DTIO: 11524 case INTERFACE_GENERIC: 11525 case INTERFACE_USER_OP: 11526 { 11527 const bool is_op = (op_type == INTERFACE_USER_OP); 11528 gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root : 11529 &ns->tb_sym_root, name); 11530 gcc_assert (st); 11531 st->n.tb = tb; 11532 11533 break; 11534 } 11535 11536 case INTERFACE_INTRINSIC_OP: 11537 ns->tb_op[op] = tb; 11538 break; 11539 11540 default: 11541 gcc_unreachable (); 11542 } 11543 } 11544 11545 /* Now, match all following names as specific targets. */ 11546 do 11547 { 11548 gfc_symtree* target_st; 11549 gfc_tbp_generic* target; 11550 11551 m = gfc_match_name (name); 11552 if (m == MATCH_ERROR) 11553 goto error; 11554 if (m == MATCH_NO) 11555 { 11556 gfc_error ("Expected specific binding name at %C"); 11557 goto error; 11558 } 11559 11560 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name); 11561 11562 /* See if this is a duplicate specification. */ 11563 for (target = tb->u.generic; target; target = target->next) 11564 if (target_st == target->specific_st) 11565 { 11566 gfc_error ("%qs already defined as specific binding for the" 11567 " generic %qs at %C", name, bind_name); 11568 goto error; 11569 } 11570 11571 target = gfc_get_tbp_generic (); 11572 target->specific_st = target_st; 11573 target->specific = NULL; 11574 target->next = tb->u.generic; 11575 target->is_operator = ((op_type == INTERFACE_USER_OP) 11576 || (op_type == INTERFACE_INTRINSIC_OP)); 11577 tb->u.generic = target; 11578 } 11579 while (gfc_match (" ,") == MATCH_YES); 11580 11581 /* Here should be the end. */ 11582 if (gfc_match_eos () != MATCH_YES) 11583 { 11584 gfc_error ("Junk after GENERIC binding at %C"); 11585 goto error; 11586 } 11587 11588 return MATCH_YES; 11589 11590error: 11591 return MATCH_ERROR; 11592} 11593 11594 11595/* Match a FINAL declaration inside a derived type. */ 11596 11597match 11598gfc_match_final_decl (void) 11599{ 11600 char name[GFC_MAX_SYMBOL_LEN + 1]; 11601 gfc_symbol* sym; 11602 match m; 11603 gfc_namespace* module_ns; 11604 bool first, last; 11605 gfc_symbol* block; 11606 11607 if (gfc_current_form == FORM_FREE) 11608 { 11609 char c = gfc_peek_ascii_char (); 11610 if (!gfc_is_whitespace (c) && c != ':') 11611 return MATCH_NO; 11612 } 11613 11614 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) 11615 { 11616 if (gfc_current_form == FORM_FIXED) 11617 return MATCH_NO; 11618 11619 gfc_error ("FINAL declaration at %C must be inside a derived type " 11620 "CONTAINS section"); 11621 return MATCH_ERROR; 11622 } 11623 11624 block = gfc_state_stack->previous->sym; 11625 gcc_assert (block); 11626 11627 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous 11628 || gfc_state_stack->previous->previous->state != COMP_MODULE) 11629 { 11630 gfc_error ("Derived type declaration with FINAL at %C must be in the" 11631 " specification part of a MODULE"); 11632 return MATCH_ERROR; 11633 } 11634 11635 module_ns = gfc_current_ns; 11636 gcc_assert (module_ns); 11637 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); 11638 11639 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ 11640 if (gfc_match (" ::") == MATCH_ERROR) 11641 return MATCH_ERROR; 11642 11643 /* Match the sequence of procedure names. */ 11644 first = true; 11645 last = false; 11646 do 11647 { 11648 gfc_finalizer* f; 11649 11650 if (first && gfc_match_eos () == MATCH_YES) 11651 { 11652 gfc_error ("Empty FINAL at %C"); 11653 return MATCH_ERROR; 11654 } 11655 11656 m = gfc_match_name (name); 11657 if (m == MATCH_NO) 11658 { 11659 gfc_error ("Expected module procedure name at %C"); 11660 return MATCH_ERROR; 11661 } 11662 else if (m != MATCH_YES) 11663 return MATCH_ERROR; 11664 11665 if (gfc_match_eos () == MATCH_YES) 11666 last = true; 11667 if (!last && gfc_match_char (',') != MATCH_YES) 11668 { 11669 gfc_error ("Expected %<,%> at %C"); 11670 return MATCH_ERROR; 11671 } 11672 11673 if (gfc_get_symbol (name, module_ns, &sym)) 11674 { 11675 gfc_error ("Unknown procedure name %qs at %C", name); 11676 return MATCH_ERROR; 11677 } 11678 11679 /* Mark the symbol as module procedure. */ 11680 if (sym->attr.proc != PROC_MODULE 11681 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 11682 return MATCH_ERROR; 11683 11684 /* Check if we already have this symbol in the list, this is an error. */ 11685 for (f = block->f2k_derived->finalizers; f; f = f->next) 11686 if (f->proc_sym == sym) 11687 { 11688 gfc_error ("%qs at %C is already defined as FINAL procedure", 11689 name); 11690 return MATCH_ERROR; 11691 } 11692 11693 /* Add this symbol to the list of finalizers. */ 11694 gcc_assert (block->f2k_derived); 11695 sym->refs++; 11696 f = XCNEW (gfc_finalizer); 11697 f->proc_sym = sym; 11698 f->proc_tree = NULL; 11699 f->where = gfc_current_locus; 11700 f->next = block->f2k_derived->finalizers; 11701 block->f2k_derived->finalizers = f; 11702 11703 first = false; 11704 } 11705 while (!last); 11706 11707 return MATCH_YES; 11708} 11709 11710 11711const ext_attr_t ext_attr_list[] = { 11712 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, 11713 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, 11714 { "cdecl", EXT_ATTR_CDECL, "cdecl" }, 11715 { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, 11716 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, 11717 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL }, 11718 { "deprecated", EXT_ATTR_DEPRECATED, NULL }, 11719 { NULL, EXT_ATTR_LAST, NULL } 11720}; 11721 11722/* Match a !GCC$ ATTRIBUTES statement of the form: 11723 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ... 11724 When we come here, we have already matched the !GCC$ ATTRIBUTES string. 11725 11726 TODO: We should support all GCC attributes using the same syntax for 11727 the attribute list, i.e. the list in C 11728 __attributes(( attribute-list )) 11729 matches then 11730 !GCC$ ATTRIBUTES attribute-list :: 11731 Cf. c-parser.cc's c_parser_attributes; the data can then directly be 11732 saved into a TREE. 11733 11734 As there is absolutely no risk of confusion, we should never return 11735 MATCH_NO. */ 11736match 11737gfc_match_gcc_attributes (void) 11738{ 11739 symbol_attribute attr; 11740 char name[GFC_MAX_SYMBOL_LEN + 1]; 11741 unsigned id; 11742 gfc_symbol *sym; 11743 match m; 11744 11745 gfc_clear_attr (&attr); 11746 for(;;) 11747 { 11748 char ch; 11749 11750 if (gfc_match_name (name) != MATCH_YES) 11751 return MATCH_ERROR; 11752 11753 for (id = 0; id < EXT_ATTR_LAST; id++) 11754 if (strcmp (name, ext_attr_list[id].name) == 0) 11755 break; 11756 11757 if (id == EXT_ATTR_LAST) 11758 { 11759 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C"); 11760 return MATCH_ERROR; 11761 } 11762 11763 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus)) 11764 return MATCH_ERROR; 11765 11766 gfc_gobble_whitespace (); 11767 ch = gfc_next_ascii_char (); 11768 if (ch == ':') 11769 { 11770 /* This is the successful exit condition for the loop. */ 11771 if (gfc_next_ascii_char () == ':') 11772 break; 11773 } 11774 11775 if (ch == ',') 11776 continue; 11777 11778 goto syntax; 11779 } 11780 11781 if (gfc_match_eos () == MATCH_YES) 11782 goto syntax; 11783 11784 for(;;) 11785 { 11786 m = gfc_match_name (name); 11787 if (m != MATCH_YES) 11788 return m; 11789 11790 if (find_special (name, &sym, true)) 11791 return MATCH_ERROR; 11792 11793 sym->attr.ext_attr |= attr.ext_attr; 11794 11795 if (gfc_match_eos () == MATCH_YES) 11796 break; 11797 11798 if (gfc_match_char (',') != MATCH_YES) 11799 goto syntax; 11800 } 11801 11802 return MATCH_YES; 11803 11804syntax: 11805 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C"); 11806 return MATCH_ERROR; 11807} 11808 11809 11810/* Match a !GCC$ UNROLL statement of the form: 11811 !GCC$ UNROLL n 11812 11813 The parameter n is the number of times we are supposed to unroll. 11814 11815 When we come here, we have already matched the !GCC$ UNROLL string. */ 11816match 11817gfc_match_gcc_unroll (void) 11818{ 11819 int value; 11820 11821 /* FIXME: use gfc_match_small_literal_int instead, delete small_int */ 11822 if (gfc_match_small_int (&value) == MATCH_YES) 11823 { 11824 if (value < 0 || value > USHRT_MAX) 11825 { 11826 gfc_error ("%<GCC unroll%> directive requires a" 11827 " non-negative integral constant" 11828 " less than or equal to %u at %C", 11829 USHRT_MAX 11830 ); 11831 return MATCH_ERROR; 11832 } 11833 if (gfc_match_eos () == MATCH_YES) 11834 { 11835 directive_unroll = value == 0 ? 1 : value; 11836 return MATCH_YES; 11837 } 11838 } 11839 11840 gfc_error ("Syntax error in !GCC$ UNROLL directive at %C"); 11841 return MATCH_ERROR; 11842} 11843 11844/* Match a !GCC$ builtin (b) attributes simd flags if('target') form: 11845 11846 The parameter b is name of a middle-end built-in. 11847 FLAGS is optional and must be one of: 11848 - (inbranch) 11849 - (notinbranch) 11850 11851 IF('target') is optional and TARGET is a name of a multilib ABI. 11852 11853 When we come here, we have already matched the !GCC$ builtin string. */ 11854 11855match 11856gfc_match_gcc_builtin (void) 11857{ 11858 char builtin[GFC_MAX_SYMBOL_LEN + 1]; 11859 char target[GFC_MAX_SYMBOL_LEN + 1]; 11860 11861 if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES) 11862 return MATCH_ERROR; 11863 11864 gfc_simd_clause clause = SIMD_NONE; 11865 if (gfc_match (" ( notinbranch ) ") == MATCH_YES) 11866 clause = SIMD_NOTINBRANCH; 11867 else if (gfc_match (" ( inbranch ) ") == MATCH_YES) 11868 clause = SIMD_INBRANCH; 11869 11870 if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES) 11871 { 11872 const char *abi = targetm.get_multilib_abi_name (); 11873 if (abi == NULL || strcmp (abi, target) != 0) 11874 return MATCH_YES; 11875 } 11876 11877 if (gfc_vectorized_builtins == NULL) 11878 gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> (); 11879 11880 char *r = XNEWVEC (char, strlen (builtin) + 32); 11881 sprintf (r, "__builtin_%s", builtin); 11882 11883 bool existed; 11884 int &value = gfc_vectorized_builtins->get_or_insert (r, &existed); 11885 value |= clause; 11886 if (existed) 11887 free (r); 11888 11889 return MATCH_YES; 11890} 11891 11892/* Match an !GCC$ IVDEP statement. 11893 When we come here, we have already matched the !GCC$ IVDEP string. */ 11894 11895match 11896gfc_match_gcc_ivdep (void) 11897{ 11898 if (gfc_match_eos () == MATCH_YES) 11899 { 11900 directive_ivdep = true; 11901 return MATCH_YES; 11902 } 11903 11904 gfc_error ("Syntax error in !GCC$ IVDEP directive at %C"); 11905 return MATCH_ERROR; 11906} 11907 11908/* Match an !GCC$ VECTOR statement. 11909 When we come here, we have already matched the !GCC$ VECTOR string. */ 11910 11911match 11912gfc_match_gcc_vector (void) 11913{ 11914 if (gfc_match_eos () == MATCH_YES) 11915 { 11916 directive_vector = true; 11917 directive_novector = false; 11918 return MATCH_YES; 11919 } 11920 11921 gfc_error ("Syntax error in !GCC$ VECTOR directive at %C"); 11922 return MATCH_ERROR; 11923} 11924 11925/* Match an !GCC$ NOVECTOR statement. 11926 When we come here, we have already matched the !GCC$ NOVECTOR string. */ 11927 11928match 11929gfc_match_gcc_novector (void) 11930{ 11931 if (gfc_match_eos () == MATCH_YES) 11932 { 11933 directive_novector = true; 11934 directive_vector = false; 11935 return MATCH_YES; 11936 } 11937 11938 gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C"); 11939 return MATCH_ERROR; 11940} 11941