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