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