1/* Declaration statement matcher 2 Copyright (C) 2002-2015 Free Software Foundation, Inc. 3 Contributed by Andy Vaught 4 5This file is part of GCC. 6 7GCC is free software; you can redistribute it and/or modify it under 8the terms of the GNU General Public License as published by the Free 9Software Foundation; either version 3, or (at your option) any later 10version. 11 12GCC is distributed in the hope that it will be useful, but WITHOUT ANY 13WARRANTY; without even the implied warranty of MERCHANTABILITY or 14FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 15for more details. 16 17You should have received a copy of the GNU General Public License 18along with GCC; see the file COPYING3. If not see 19<http://www.gnu.org/licenses/>. */ 20 21#include "config.h" 22#include "system.h" 23#include "coretypes.h" 24#include "gfortran.h" 25#include "match.h" 26#include "parse.h" 27#include "flags.h" 28#include "constructor.h" 29#include "hash-set.h" 30#include "machmode.h" 31#include "vec.h" 32#include "double-int.h" 33#include "input.h" 34#include "alias.h" 35#include "symtab.h" 36#include "wide-int.h" 37#include "inchash.h" 38#include "tree.h" 39#include "stringpool.h" 40 41/* Macros to access allocate memory for gfc_data_variable, 42 gfc_data_value and gfc_data. */ 43#define gfc_get_data_variable() XCNEW (gfc_data_variable) 44#define gfc_get_data_value() XCNEW (gfc_data_value) 45#define gfc_get_data() XCNEW (gfc_data) 46 47 48static bool set_binding_label (const char **, const char *, int); 49 50 51/* This flag is set if an old-style length selector is matched 52 during a type-declaration statement. */ 53 54static int old_char_selector; 55 56/* When variables acquire types and attributes from a declaration 57 statement, they get them from the following static variables. The 58 first part of a declaration sets these variables and the second 59 part copies these into symbol structures. */ 60 61static gfc_typespec current_ts; 62 63static symbol_attribute current_attr; 64static gfc_array_spec *current_as; 65static int colon_seen; 66 67/* The current binding label (if any). */ 68static const char* curr_binding_label; 69/* Need to know how many identifiers are on the current data declaration 70 line in case we're given the BIND(C) attribute with a NAME= specifier. */ 71static int num_idents_on_line; 72/* Need to know if a NAME= specifier was found during gfc_match_bind_c so we 73 can supply a name if the curr_binding_label is nil and NAME= was not. */ 74static int has_name_equals = 0; 75 76/* Initializer of the previous enumerator. */ 77 78static gfc_expr *last_initializer; 79 80/* History of all the enumerators is maintained, so that 81 kind values of all the enumerators could be updated depending 82 upon the maximum initialized value. */ 83 84typedef struct enumerator_history 85{ 86 gfc_symbol *sym; 87 gfc_expr *initializer; 88 struct enumerator_history *next; 89} 90enumerator_history; 91 92/* Header of enum history chain. */ 93 94static enumerator_history *enum_history = NULL; 95 96/* Pointer of enum history node containing largest initializer. */ 97 98static enumerator_history *max_enum = NULL; 99 100/* gfc_new_block points to the symbol of a newly matched block. */ 101 102gfc_symbol *gfc_new_block; 103 104bool gfc_matching_function; 105 106 107/********************* DATA statement subroutines *********************/ 108 109static bool in_match_data = false; 110 111bool 112gfc_in_match_data (void) 113{ 114 return in_match_data; 115} 116 117static void 118set_in_match_data (bool set_value) 119{ 120 in_match_data = set_value; 121} 122 123/* Free a gfc_data_variable structure and everything beneath it. */ 124 125static void 126free_variable (gfc_data_variable *p) 127{ 128 gfc_data_variable *q; 129 130 for (; p; p = q) 131 { 132 q = p->next; 133 gfc_free_expr (p->expr); 134 gfc_free_iterator (&p->iter, 0); 135 free_variable (p->list); 136 free (p); 137 } 138} 139 140 141/* Free a gfc_data_value structure and everything beneath it. */ 142 143static void 144free_value (gfc_data_value *p) 145{ 146 gfc_data_value *q; 147 148 for (; p; p = q) 149 { 150 q = p->next; 151 mpz_clear (p->repeat); 152 gfc_free_expr (p->expr); 153 free (p); 154 } 155} 156 157 158/* Free a list of gfc_data structures. */ 159 160void 161gfc_free_data (gfc_data *p) 162{ 163 gfc_data *q; 164 165 for (; p; p = q) 166 { 167 q = p->next; 168 free_variable (p->var); 169 free_value (p->value); 170 free (p); 171 } 172} 173 174 175/* Free all data in a namespace. */ 176 177static void 178gfc_free_data_all (gfc_namespace *ns) 179{ 180 gfc_data *d; 181 182 for (;ns->data;) 183 { 184 d = ns->data->next; 185 free (ns->data); 186 ns->data = d; 187 } 188} 189 190/* Reject data parsed since the last restore point was marked. */ 191 192void 193gfc_reject_data (gfc_namespace *ns) 194{ 195 gfc_data *d; 196 197 while (ns->data && ns->data != ns->old_data) 198 { 199 d = ns->data->next; 200 free (ns->data); 201 ns->data = d; 202 } 203} 204 205static match var_element (gfc_data_variable *); 206 207/* Match a list of variables terminated by an iterator and a right 208 parenthesis. */ 209 210static match 211var_list (gfc_data_variable *parent) 212{ 213 gfc_data_variable *tail, var; 214 match m; 215 216 m = var_element (&var); 217 if (m == MATCH_ERROR) 218 return MATCH_ERROR; 219 if (m == MATCH_NO) 220 goto syntax; 221 222 tail = gfc_get_data_variable (); 223 *tail = var; 224 225 parent->list = tail; 226 227 for (;;) 228 { 229 if (gfc_match_char (',') != MATCH_YES) 230 goto syntax; 231 232 m = gfc_match_iterator (&parent->iter, 1); 233 if (m == MATCH_YES) 234 break; 235 if (m == MATCH_ERROR) 236 return MATCH_ERROR; 237 238 m = var_element (&var); 239 if (m == MATCH_ERROR) 240 return MATCH_ERROR; 241 if (m == MATCH_NO) 242 goto syntax; 243 244 tail->next = gfc_get_data_variable (); 245 tail = tail->next; 246 247 *tail = var; 248 } 249 250 if (gfc_match_char (')') != MATCH_YES) 251 goto syntax; 252 return MATCH_YES; 253 254syntax: 255 gfc_syntax_error (ST_DATA); 256 return MATCH_ERROR; 257} 258 259 260/* Match a single element in a data variable list, which can be a 261 variable-iterator list. */ 262 263static match 264var_element (gfc_data_variable *new_var) 265{ 266 match m; 267 gfc_symbol *sym; 268 269 memset (new_var, 0, sizeof (gfc_data_variable)); 270 271 if (gfc_match_char ('(') == MATCH_YES) 272 return var_list (new_var); 273 274 m = gfc_match_variable (&new_var->expr, 0); 275 if (m != MATCH_YES) 276 return m; 277 278 sym = new_var->expr->symtree->n.sym; 279 280 /* Symbol should already have an associated type. */ 281 if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus)) 282 return MATCH_ERROR; 283 284 if (!sym->attr.function && gfc_current_ns->parent 285 && gfc_current_ns->parent == sym->ns) 286 { 287 gfc_error ("Host associated variable %qs may not be in the DATA " 288 "statement at %C", sym->name); 289 return MATCH_ERROR; 290 } 291 292 if (gfc_current_state () != COMP_BLOCK_DATA 293 && sym->attr.in_common 294 && !gfc_notify_std (GFC_STD_GNU, "initialization of " 295 "common block variable %qs in DATA statement at %C", 296 sym->name)) 297 return MATCH_ERROR; 298 299 if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where)) 300 return MATCH_ERROR; 301 302 return MATCH_YES; 303} 304 305 306/* Match the top-level list of data variables. */ 307 308static match 309top_var_list (gfc_data *d) 310{ 311 gfc_data_variable var, *tail, *new_var; 312 match m; 313 314 tail = NULL; 315 316 for (;;) 317 { 318 m = var_element (&var); 319 if (m == MATCH_NO) 320 goto syntax; 321 if (m == MATCH_ERROR) 322 return MATCH_ERROR; 323 324 new_var = gfc_get_data_variable (); 325 *new_var = var; 326 327 if (tail == NULL) 328 d->var = new_var; 329 else 330 tail->next = new_var; 331 332 tail = new_var; 333 334 if (gfc_match_char ('/') == MATCH_YES) 335 break; 336 if (gfc_match_char (',') != MATCH_YES) 337 goto syntax; 338 } 339 340 return MATCH_YES; 341 342syntax: 343 gfc_syntax_error (ST_DATA); 344 gfc_free_data_all (gfc_current_ns); 345 return MATCH_ERROR; 346} 347 348 349static match 350match_data_constant (gfc_expr **result) 351{ 352 char name[GFC_MAX_SYMBOL_LEN + 1]; 353 gfc_symbol *sym, *dt_sym = NULL; 354 gfc_expr *expr; 355 match m; 356 locus old_loc; 357 358 m = gfc_match_literal_constant (&expr, 1); 359 if (m == MATCH_YES) 360 { 361 *result = expr; 362 return MATCH_YES; 363 } 364 365 if (m == MATCH_ERROR) 366 return MATCH_ERROR; 367 368 m = gfc_match_null (result); 369 if (m != MATCH_NO) 370 return m; 371 372 old_loc = gfc_current_locus; 373 374 /* Should this be a structure component, try to match it 375 before matching a name. */ 376 m = gfc_match_rvalue (result); 377 if (m == MATCH_ERROR) 378 return m; 379 380 if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE) 381 { 382 if (!gfc_simplify_expr (*result, 0)) 383 m = MATCH_ERROR; 384 return m; 385 } 386 else if (m == MATCH_YES) 387 gfc_free_expr (*result); 388 389 gfc_current_locus = old_loc; 390 391 m = gfc_match_name (name); 392 if (m != MATCH_YES) 393 return m; 394 395 if (gfc_find_symbol (name, NULL, 1, &sym)) 396 return MATCH_ERROR; 397 398 if (sym && sym->attr.generic) 399 dt_sym = gfc_find_dt_in_generic (sym); 400 401 if (sym == NULL 402 || (sym->attr.flavor != FL_PARAMETER 403 && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED))) 404 { 405 gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", 406 name); 407 return MATCH_ERROR; 408 } 409 else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED) 410 return gfc_match_structure_constructor (dt_sym, result); 411 412 /* Check to see if the value is an initialization array expression. */ 413 if (sym->value->expr_type == EXPR_ARRAY) 414 { 415 gfc_current_locus = old_loc; 416 417 m = gfc_match_init_expr (result); 418 if (m == MATCH_ERROR) 419 return m; 420 421 if (m == MATCH_YES) 422 { 423 if (!gfc_simplify_expr (*result, 0)) 424 m = MATCH_ERROR; 425 426 if ((*result)->expr_type == EXPR_CONSTANT) 427 return m; 428 else 429 { 430 gfc_error ("Invalid initializer %s in Data statement at %C", name); 431 return MATCH_ERROR; 432 } 433 } 434 } 435 436 *result = gfc_copy_expr (sym->value); 437 return MATCH_YES; 438} 439 440 441/* Match a list of values in a DATA statement. The leading '/' has 442 already been seen at this point. */ 443 444static match 445top_val_list (gfc_data *data) 446{ 447 gfc_data_value *new_val, *tail; 448 gfc_expr *expr; 449 match m; 450 451 tail = NULL; 452 453 for (;;) 454 { 455 m = match_data_constant (&expr); 456 if (m == MATCH_NO) 457 goto syntax; 458 if (m == MATCH_ERROR) 459 return MATCH_ERROR; 460 461 new_val = gfc_get_data_value (); 462 mpz_init (new_val->repeat); 463 464 if (tail == NULL) 465 data->value = new_val; 466 else 467 tail->next = new_val; 468 469 tail = new_val; 470 471 if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) 472 { 473 tail->expr = expr; 474 mpz_set_ui (tail->repeat, 1); 475 } 476 else 477 { 478 mpz_set (tail->repeat, expr->value.integer); 479 gfc_free_expr (expr); 480 481 m = match_data_constant (&tail->expr); 482 if (m == MATCH_NO) 483 goto syntax; 484 if (m == MATCH_ERROR) 485 return MATCH_ERROR; 486 } 487 488 if (gfc_match_char ('/') == MATCH_YES) 489 break; 490 if (gfc_match_char (',') == MATCH_NO) 491 goto syntax; 492 } 493 494 return MATCH_YES; 495 496syntax: 497 gfc_syntax_error (ST_DATA); 498 gfc_free_data_all (gfc_current_ns); 499 return MATCH_ERROR; 500} 501 502 503/* Matches an old style initialization. */ 504 505static match 506match_old_style_init (const char *name) 507{ 508 match m; 509 gfc_symtree *st; 510 gfc_symbol *sym; 511 gfc_data *newdata; 512 513 /* Set up data structure to hold initializers. */ 514 gfc_find_sym_tree (name, NULL, 0, &st); 515 sym = st->n.sym; 516 517 newdata = gfc_get_data (); 518 newdata->var = gfc_get_data_variable (); 519 newdata->var->expr = gfc_get_variable_expr (st); 520 newdata->where = gfc_current_locus; 521 522 /* Match initial value list. This also eats the terminal '/'. */ 523 m = top_val_list (newdata); 524 if (m != MATCH_YES) 525 { 526 free (newdata); 527 return m; 528 } 529 530 if (gfc_pure (NULL)) 531 { 532 gfc_error ("Initialization at %C is not allowed in a PURE procedure"); 533 free (newdata); 534 return MATCH_ERROR; 535 } 536 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 537 538 /* Mark the variable as having appeared in a data statement. */ 539 if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at)) 540 { 541 free (newdata); 542 return MATCH_ERROR; 543 } 544 545 /* Chain in namespace list of DATA initializers. */ 546 newdata->next = gfc_current_ns->data; 547 gfc_current_ns->data = newdata; 548 549 return m; 550} 551 552 553/* Match the stuff following a DATA statement. If ERROR_FLAG is set, 554 we are matching a DATA statement and are therefore issuing an error 555 if we encounter something unexpected, if not, we're trying to match 556 an old-style initialization expression of the form INTEGER I /2/. */ 557 558match 559gfc_match_data (void) 560{ 561 gfc_data *new_data; 562 match m; 563 564 /* Before parsing the rest of a DATA statement, check F2008:c1206. */ 565 if ((gfc_current_state () == COMP_FUNCTION 566 || gfc_current_state () == COMP_SUBROUTINE) 567 && gfc_state_stack->previous->state == COMP_INTERFACE) 568 { 569 gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); 570 return MATCH_ERROR; 571 } 572 573 set_in_match_data (true); 574 575 for (;;) 576 { 577 new_data = gfc_get_data (); 578 new_data->where = gfc_current_locus; 579 580 m = top_var_list (new_data); 581 if (m != MATCH_YES) 582 goto cleanup; 583 584 m = top_val_list (new_data); 585 if (m != MATCH_YES) 586 goto cleanup; 587 588 new_data->next = gfc_current_ns->data; 589 gfc_current_ns->data = new_data; 590 591 if (gfc_match_eos () == MATCH_YES) 592 break; 593 594 gfc_match_char (','); /* Optional comma */ 595 } 596 597 set_in_match_data (false); 598 599 if (gfc_pure (NULL)) 600 { 601 gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); 602 return MATCH_ERROR; 603 } 604 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 605 606 return MATCH_YES; 607 608cleanup: 609 set_in_match_data (false); 610 gfc_free_data (new_data); 611 return MATCH_ERROR; 612} 613 614 615/************************ Declaration statements *********************/ 616 617 618/* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ 619 620static bool 621merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) 622{ 623 int i; 624 625 if ((from->type == AS_ASSUMED_RANK && to->corank) 626 || (to->type == AS_ASSUMED_RANK && from->corank)) 627 { 628 gfc_error ("The assumed-rank array at %C shall not have a codimension"); 629 return false; 630 } 631 632 if (to->rank == 0 && from->rank > 0) 633 { 634 to->rank = from->rank; 635 to->type = from->type; 636 to->cray_pointee = from->cray_pointee; 637 to->cp_was_assumed = from->cp_was_assumed; 638 639 for (i = 0; i < to->corank; i++) 640 { 641 to->lower[from->rank + i] = to->lower[i]; 642 to->upper[from->rank + i] = to->upper[i]; 643 } 644 for (i = 0; i < from->rank; i++) 645 { 646 if (copy) 647 { 648 to->lower[i] = gfc_copy_expr (from->lower[i]); 649 to->upper[i] = gfc_copy_expr (from->upper[i]); 650 } 651 else 652 { 653 to->lower[i] = from->lower[i]; 654 to->upper[i] = from->upper[i]; 655 } 656 } 657 } 658 else if (to->corank == 0 && from->corank > 0) 659 { 660 to->corank = from->corank; 661 to->cotype = from->cotype; 662 663 for (i = 0; i < from->corank; i++) 664 { 665 if (copy) 666 { 667 to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]); 668 to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]); 669 } 670 else 671 { 672 to->lower[to->rank + i] = from->lower[i]; 673 to->upper[to->rank + i] = from->upper[i]; 674 } 675 } 676 } 677 678 return true; 679} 680 681 682/* Match an intent specification. Since this can only happen after an 683 INTENT word, a legal intent-spec must follow. */ 684 685static sym_intent 686match_intent_spec (void) 687{ 688 689 if (gfc_match (" ( in out )") == MATCH_YES) 690 return INTENT_INOUT; 691 if (gfc_match (" ( in )") == MATCH_YES) 692 return INTENT_IN; 693 if (gfc_match (" ( out )") == MATCH_YES) 694 return INTENT_OUT; 695 696 gfc_error ("Bad INTENT specification at %C"); 697 return INTENT_UNKNOWN; 698} 699 700 701/* Matches a character length specification, which is either a 702 specification expression, '*', or ':'. */ 703 704static match 705char_len_param_value (gfc_expr **expr, bool *deferred) 706{ 707 match m; 708 709 *expr = NULL; 710 *deferred = false; 711 712 if (gfc_match_char ('*') == MATCH_YES) 713 return MATCH_YES; 714 715 if (gfc_match_char (':') == MATCH_YES) 716 { 717 if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C")) 718 return MATCH_ERROR; 719 720 *deferred = true; 721 722 return MATCH_YES; 723 } 724 725 m = gfc_match_expr (expr); 726 727 if (m == MATCH_NO || m == MATCH_ERROR) 728 return m; 729 730 if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) 731 return MATCH_ERROR; 732 733 if ((*expr)->expr_type == EXPR_FUNCTION) 734 { 735 if ((*expr)->ts.type == BT_INTEGER 736 || ((*expr)->ts.type == BT_UNKNOWN 737 && strcmp((*expr)->symtree->name, "null") != 0)) 738 return MATCH_YES; 739 740 goto syntax; 741 } 742 else if ((*expr)->expr_type == EXPR_CONSTANT) 743 { 744 /* F2008, 4.4.3.1: The length is a type parameter; its kind is 745 processor dependent and its value is greater than or equal to zero. 746 F2008, 4.4.3.2: If the character length parameter value evaluates 747 to a negative value, the length of character entities declared 748 is zero. */ 749 750 if ((*expr)->ts.type == BT_INTEGER) 751 { 752 if (mpz_cmp_si ((*expr)->value.integer, 0) < 0) 753 mpz_set_si ((*expr)->value.integer, 0); 754 } 755 else 756 goto syntax; 757 } 758 else if ((*expr)->expr_type == EXPR_ARRAY) 759 goto syntax; 760 else if ((*expr)->expr_type == EXPR_VARIABLE) 761 { 762 gfc_expr *e; 763 764 e = gfc_copy_expr (*expr); 765 766 /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", 767 which causes an ICE if gfc_reduce_init_expr() is called. */ 768 if (e->ref && e->ref->type == REF_ARRAY 769 && e->ref->u.ar.type == AR_UNKNOWN 770 && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) 771 goto syntax; 772 773 gfc_reduce_init_expr (e); 774 775 if ((e->ref && e->ref->type == REF_ARRAY 776 && e->ref->u.ar.type != AR_ELEMENT) 777 || (!e->ref && e->expr_type == EXPR_ARRAY)) 778 { 779 gfc_free_expr (e); 780 goto syntax; 781 } 782 783 gfc_free_expr (e); 784 } 785 786 return m; 787 788syntax: 789 gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); 790 return MATCH_ERROR; 791} 792 793 794/* A character length is a '*' followed by a literal integer or a 795 char_len_param_value in parenthesis. */ 796 797static match 798match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) 799{ 800 int length; 801 match m; 802 803 *deferred = false; 804 m = gfc_match_char ('*'); 805 if (m != MATCH_YES) 806 return m; 807 808 m = gfc_match_small_literal_int (&length, NULL); 809 if (m == MATCH_ERROR) 810 return m; 811 812 if (m == MATCH_YES) 813 { 814 if (obsolescent_check 815 && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C")) 816 return MATCH_ERROR; 817 *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length); 818 return m; 819 } 820 821 if (gfc_match_char ('(') == MATCH_NO) 822 goto syntax; 823 824 m = char_len_param_value (expr, deferred); 825 if (m != MATCH_YES && gfc_matching_function) 826 { 827 gfc_undo_symbols (); 828 m = MATCH_YES; 829 } 830 831 if (m == MATCH_ERROR) 832 return m; 833 if (m == MATCH_NO) 834 goto syntax; 835 836 if (gfc_match_char (')') == MATCH_NO) 837 { 838 gfc_free_expr (*expr); 839 *expr = NULL; 840 goto syntax; 841 } 842 843 return MATCH_YES; 844 845syntax: 846 gfc_error ("Syntax error in character length specification at %C"); 847 return MATCH_ERROR; 848} 849 850 851/* Special subroutine for finding a symbol. Check if the name is found 852 in the current name space. If not, and we're compiling a function or 853 subroutine and the parent compilation unit is an interface, then check 854 to see if the name we've been given is the name of the interface 855 (located in another namespace). */ 856 857static int 858find_special (const char *name, gfc_symbol **result, bool allow_subroutine) 859{ 860 gfc_state_data *s; 861 gfc_symtree *st; 862 int i; 863 864 i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine); 865 if (i == 0) 866 { 867 *result = st ? st->n.sym : NULL; 868 goto end; 869 } 870 871 if (gfc_current_state () != COMP_SUBROUTINE 872 && gfc_current_state () != COMP_FUNCTION) 873 goto end; 874 875 s = gfc_state_stack->previous; 876 if (s == NULL) 877 goto end; 878 879 if (s->state != COMP_INTERFACE) 880 goto end; 881 if (s->sym == NULL) 882 goto end; /* Nameless interface. */ 883 884 if (strcmp (name, s->sym->name) == 0) 885 { 886 *result = s->sym; 887 return 0; 888 } 889 890end: 891 return i; 892} 893 894 895/* Special subroutine for getting a symbol node associated with a 896 procedure name, used in SUBROUTINE and FUNCTION statements. The 897 symbol is created in the parent using with symtree node in the 898 child unit pointing to the symbol. If the current namespace has no 899 parent, then the symbol is just created in the current unit. */ 900 901static int 902get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) 903{ 904 gfc_symtree *st; 905 gfc_symbol *sym; 906 int rc = 0; 907 908 /* Module functions have to be left in their own namespace because 909 they have potentially (almost certainly!) already been referenced. 910 In this sense, they are rather like external functions. This is 911 fixed up in resolve.c(resolve_entries), where the symbol name- 912 space is set to point to the master function, so that the fake 913 result mechanism can work. */ 914 if (module_fcn_entry) 915 { 916 /* Present if entry is declared to be a module procedure. */ 917 rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result); 918 919 if (*result == NULL) 920 rc = gfc_get_symbol (name, NULL, result); 921 else if (!gfc_get_symbol (name, NULL, &sym) && sym 922 && (*result)->ts.type == BT_UNKNOWN 923 && sym->attr.flavor == FL_UNKNOWN) 924 /* Pick up the typespec for the entry, if declared in the function 925 body. Note that this symbol is FL_UNKNOWN because it will 926 only have appeared in a type declaration. The local symtree 927 is set to point to the module symbol and a unique symtree 928 to the local version. This latter ensures a correct clearing 929 of the symbols. */ 930 { 931 /* If the ENTRY proceeds its specification, we need to ensure 932 that this does not raise a "has no IMPLICIT type" error. */ 933 if (sym->ts.type == BT_UNKNOWN) 934 sym->attr.untyped = 1; 935 936 (*result)->ts = sym->ts; 937 938 /* Put the symbol in the procedure namespace so that, should 939 the ENTRY precede its specification, the specification 940 can be applied. */ 941 (*result)->ns = gfc_current_ns; 942 943 gfc_find_sym_tree (name, gfc_current_ns, 0, &st); 944 st->n.sym = *result; 945 st = gfc_get_unique_symtree (gfc_current_ns); 946 sym->refs++; 947 st->n.sym = sym; 948 } 949 } 950 else 951 rc = gfc_get_symbol (name, gfc_current_ns->parent, result); 952 953 if (rc) 954 return rc; 955 956 sym = *result; 957 958 if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE) 959 { 960 /* Trap another encompassed procedure with the same name. All 961 these conditions are necessary to avoid picking up an entry 962 whose name clashes with that of the encompassing procedure; 963 this is handled using gsymbols to register unique, globally 964 accessible names. */ 965 if (sym->attr.flavor != 0 966 && sym->attr.proc != 0 967 && (sym->attr.subroutine || sym->attr.function) 968 && sym->attr.if_source != IFSRC_UNKNOWN) 969 gfc_error_now_1 ("Procedure '%s' at %C is already defined at %L", 970 name, &sym->declared_at); 971 972 /* Trap a procedure with a name the same as interface in the 973 encompassing scope. */ 974 if (sym->attr.generic != 0 975 && (sym->attr.subroutine || sym->attr.function) 976 && !sym->attr.mod_proc) 977 gfc_error_now_1 ("Name '%s' at %C is already defined" 978 " as a generic interface at %L", 979 name, &sym->declared_at); 980 981 /* Trap declarations of attributes in encompassing scope. The 982 signature for this is that ts.kind is set. Legitimate 983 references only set ts.type. */ 984 if (sym->ts.kind != 0 985 && !sym->attr.implicit_type 986 && sym->attr.proc == 0 987 && gfc_current_ns->parent != NULL 988 && sym->attr.access == 0 989 && !module_fcn_entry) 990 gfc_error_now_1 ("Procedure '%s' at %C has an explicit interface " 991 "and must not have attributes declared at %L", 992 name, &sym->declared_at); 993 } 994 995 if (gfc_current_ns->parent == NULL || *result == NULL) 996 return rc; 997 998 /* Module function entries will already have a symtree in 999 the current namespace but will need one at module level. */ 1000 if (module_fcn_entry) 1001 { 1002 /* Present if entry is declared to be a module procedure. */ 1003 rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st); 1004 if (st == NULL) 1005 st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); 1006 } 1007 else 1008 st = gfc_new_symtree (&gfc_current_ns->sym_root, name); 1009 1010 st->n.sym = sym; 1011 sym->refs++; 1012 1013 /* See if the procedure should be a module procedure. */ 1014 1015 if (((sym->ns->proc_name != NULL 1016 && sym->ns->proc_name->attr.flavor == FL_MODULE 1017 && sym->attr.proc != PROC_MODULE) 1018 || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) 1019 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 1020 rc = 2; 1021 1022 return rc; 1023} 1024 1025 1026/* Verify that the given symbol representing a parameter is C 1027 interoperable, by checking to see if it was marked as such after 1028 its declaration. If the given symbol is not interoperable, a 1029 warning is reported, thus removing the need to return the status to 1030 the calling function. The standard does not require the user use 1031 one of the iso_c_binding named constants to declare an 1032 interoperable parameter, but we can't be sure if the param is C 1033 interop or not if the user doesn't. For example, integer(4) may be 1034 legal Fortran, but doesn't have meaning in C. It may interop with 1035 a number of the C types, which causes a problem because the 1036 compiler can't know which one. This code is almost certainly not 1037 portable, and the user will get what they deserve if the C type 1038 across platforms isn't always interoperable with integer(4). If 1039 the user had used something like integer(c_int) or integer(c_long), 1040 the compiler could have automatically handled the varying sizes 1041 across platforms. */ 1042 1043bool 1044gfc_verify_c_interop_param (gfc_symbol *sym) 1045{ 1046 int is_c_interop = 0; 1047 bool retval = true; 1048 1049 /* We check implicitly typed variables in symbol.c:gfc_set_default_type(). 1050 Don't repeat the checks here. */ 1051 if (sym->attr.implicit_type) 1052 return true; 1053 1054 /* For subroutines or functions that are passed to a BIND(C) procedure, 1055 they're interoperable if they're BIND(C) and their params are all 1056 interoperable. */ 1057 if (sym->attr.flavor == FL_PROCEDURE) 1058 { 1059 if (sym->attr.is_bind_c == 0) 1060 { 1061 gfc_error_now ("Procedure %qs at %L must have the BIND(C) " 1062 "attribute to be C interoperable", sym->name, 1063 &(sym->declared_at)); 1064 return false; 1065 } 1066 else 1067 { 1068 if (sym->attr.is_c_interop == 1) 1069 /* We've already checked this procedure; don't check it again. */ 1070 return true; 1071 else 1072 return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, 1073 sym->common_block); 1074 } 1075 } 1076 1077 /* See if we've stored a reference to a procedure that owns sym. */ 1078 if (sym->ns != NULL && sym->ns->proc_name != NULL) 1079 { 1080 if (sym->ns->proc_name->attr.is_bind_c == 1) 1081 { 1082 is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); 1083 1084 if (is_c_interop != 1) 1085 { 1086 /* Make personalized messages to give better feedback. */ 1087 if (sym->ts.type == BT_DERIVED) 1088 gfc_error ("Variable %qs at %L is a dummy argument to the " 1089 "BIND(C) procedure %qs but is not C interoperable " 1090 "because derived type %qs is not C interoperable", 1091 sym->name, &(sym->declared_at), 1092 sym->ns->proc_name->name, 1093 sym->ts.u.derived->name); 1094 else if (sym->ts.type == BT_CLASS) 1095 gfc_error ("Variable %qs at %L is a dummy argument to the " 1096 "BIND(C) procedure %qs but is not C interoperable " 1097 "because it is polymorphic", 1098 sym->name, &(sym->declared_at), 1099 sym->ns->proc_name->name); 1100 else if (warn_c_binding_type) 1101 gfc_warning (OPT_Wc_binding_type, 1102 "Variable %qs at %L is a dummy argument of the " 1103 "BIND(C) procedure %qs but may not be C " 1104 "interoperable", 1105 sym->name, &(sym->declared_at), 1106 sym->ns->proc_name->name); 1107 } 1108 1109 /* Character strings are only C interoperable if they have a 1110 length of 1. */ 1111 if (sym->ts.type == BT_CHARACTER) 1112 { 1113 gfc_charlen *cl = sym->ts.u.cl; 1114 if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT 1115 || mpz_cmp_si (cl->length->value.integer, 1) != 0) 1116 { 1117 gfc_error ("Character argument %qs at %L " 1118 "must be length 1 because " 1119 "procedure %qs is BIND(C)", 1120 sym->name, &sym->declared_at, 1121 sym->ns->proc_name->name); 1122 retval = false; 1123 } 1124 } 1125 1126 /* We have to make sure that any param to a bind(c) routine does 1127 not have the allocatable, pointer, or optional attributes, 1128 according to J3/04-007, section 5.1. */ 1129 if (sym->attr.allocatable == 1 1130 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with " 1131 "ALLOCATABLE attribute in procedure %qs " 1132 "with BIND(C)", sym->name, 1133 &(sym->declared_at), 1134 sym->ns->proc_name->name)) 1135 retval = false; 1136 1137 if (sym->attr.pointer == 1 1138 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs at %L with " 1139 "POINTER attribute in procedure %qs " 1140 "with BIND(C)", sym->name, 1141 &(sym->declared_at), 1142 sym->ns->proc_name->name)) 1143 retval = false; 1144 1145 if ((sym->attr.allocatable || sym->attr.pointer) && !sym->as) 1146 { 1147 gfc_error ("Scalar variable %qs at %L with POINTER or " 1148 "ALLOCATABLE in procedure %qs with BIND(C) is not yet" 1149 " supported", sym->name, &(sym->declared_at), 1150 sym->ns->proc_name->name); 1151 retval = false; 1152 } 1153 1154 if (sym->attr.optional == 1 && sym->attr.value) 1155 { 1156 gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " 1157 "and the VALUE attribute because procedure %qs " 1158 "is BIND(C)", sym->name, &(sym->declared_at), 1159 sym->ns->proc_name->name); 1160 retval = false; 1161 } 1162 else if (sym->attr.optional == 1 1163 && !gfc_notify_std (GFC_STD_F2008_TS, "Variable %qs " 1164 "at %L with OPTIONAL attribute in " 1165 "procedure %qs which is BIND(C)", 1166 sym->name, &(sym->declared_at), 1167 sym->ns->proc_name->name)) 1168 retval = false; 1169 1170 /* Make sure that if it has the dimension attribute, that it is 1171 either assumed size or explicit shape. Deferred shape is already 1172 covered by the pointer/allocatable attribute. */ 1173 if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE 1174 && !gfc_notify_std_1 (GFC_STD_F2008_TS, "Assumed-shape array '%s' " 1175 "at %L as dummy argument to the BIND(C) " 1176 "procedure '%s' at %L", sym->name, 1177 &(sym->declared_at), 1178 sym->ns->proc_name->name, 1179 &(sym->ns->proc_name->declared_at))) 1180 retval = false; 1181 } 1182 } 1183 1184 return retval; 1185} 1186 1187 1188 1189/* Function called by variable_decl() that adds a name to the symbol table. */ 1190 1191static bool 1192build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, 1193 gfc_array_spec **as, locus *var_locus) 1194{ 1195 symbol_attribute attr; 1196 gfc_symbol *sym; 1197 1198 if (gfc_get_symbol (name, NULL, &sym)) 1199 return false; 1200 1201 /* Start updating the symbol table. Add basic type attribute if present. */ 1202 if (current_ts.type != BT_UNKNOWN 1203 && (sym->attr.implicit_type == 0 1204 || !gfc_compare_types (&sym->ts, ¤t_ts)) 1205 && !gfc_add_type (sym, ¤t_ts, var_locus)) 1206 return false; 1207 1208 if (sym->ts.type == BT_CHARACTER) 1209 { 1210 sym->ts.u.cl = cl; 1211 sym->ts.deferred = cl_deferred; 1212 } 1213 1214 /* Add dimension attribute if present. */ 1215 if (!gfc_set_array_spec (sym, *as, var_locus)) 1216 return false; 1217 *as = NULL; 1218 1219 /* Add attribute to symbol. The copy is so that we can reset the 1220 dimension attribute. */ 1221 attr = current_attr; 1222 attr.dimension = 0; 1223 attr.codimension = 0; 1224 1225 if (!gfc_copy_attr (&sym->attr, &attr, var_locus)) 1226 return false; 1227 1228 /* Finish any work that may need to be done for the binding label, 1229 if it's a bind(c). The bind(c) attr is found before the symbol 1230 is made, and before the symbol name (for data decls), so the 1231 current_ts is holding the binding label, or nothing if the 1232 name= attr wasn't given. Therefore, test here if we're dealing 1233 with a bind(c) and make sure the binding label is set correctly. */ 1234 if (sym->attr.is_bind_c == 1) 1235 { 1236 if (!sym->binding_label) 1237 { 1238 /* Set the binding label and verify that if a NAME= was specified 1239 then only one identifier was in the entity-decl-list. */ 1240 if (!set_binding_label (&sym->binding_label, sym->name, 1241 num_idents_on_line)) 1242 return false; 1243 } 1244 } 1245 1246 /* See if we know we're in a common block, and if it's a bind(c) 1247 common then we need to make sure we're an interoperable type. */ 1248 if (sym->attr.in_common == 1) 1249 { 1250 /* Test the common block object. */ 1251 if (sym->common_block != NULL && sym->common_block->is_bind_c == 1 1252 && sym->ts.is_c_interop != 1) 1253 { 1254 gfc_error_now ("Variable %qs in common block %qs at %C " 1255 "must be declared with a C interoperable " 1256 "kind since common block %qs is BIND(C)", 1257 sym->name, sym->common_block->name, 1258 sym->common_block->name); 1259 gfc_clear_error (); 1260 } 1261 } 1262 1263 sym->attr.implied_index = 0; 1264 1265 if (sym->ts.type == BT_CLASS) 1266 return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); 1267 1268 return true; 1269} 1270 1271 1272/* Set character constant to the given length. The constant will be padded or 1273 truncated. If we're inside an array constructor without a typespec, we 1274 additionally check that all elements have the same length; check_len -1 1275 means no checking. */ 1276 1277void 1278gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len) 1279{ 1280 gfc_char_t *s; 1281 int slen; 1282 1283 gcc_assert (expr->expr_type == EXPR_CONSTANT); 1284 1285 if (expr->ts.type != BT_CHARACTER) 1286 return; 1287 1288 slen = expr->value.character.length; 1289 if (len != slen) 1290 { 1291 s = gfc_get_wide_string (len + 1); 1292 memcpy (s, expr->value.character.string, 1293 MIN (len, slen) * sizeof (gfc_char_t)); 1294 if (len > slen) 1295 gfc_wide_memset (&s[slen], ' ', len - slen); 1296 1297 if (warn_character_truncation && slen > len) 1298 gfc_warning_now (OPT_Wcharacter_truncation, 1299 "CHARACTER expression at %L is being truncated " 1300 "(%d/%d)", &expr->where, slen, len); 1301 1302 /* Apply the standard by 'hand' otherwise it gets cleared for 1303 initializers. */ 1304 if (check_len != -1 && slen != check_len 1305 && !(gfc_option.allow_std & GFC_STD_GNU)) 1306 gfc_error_now ("The CHARACTER elements of the array constructor " 1307 "at %L must have the same length (%d/%d)", 1308 &expr->where, slen, check_len); 1309 1310 s[len] = '\0'; 1311 free (expr->value.character.string); 1312 expr->value.character.string = s; 1313 expr->value.character.length = len; 1314 } 1315} 1316 1317 1318/* Function to create and update the enumerator history 1319 using the information passed as arguments. 1320 Pointer "max_enum" is also updated, to point to 1321 enum history node containing largest initializer. 1322 1323 SYM points to the symbol node of enumerator. 1324 INIT points to its enumerator value. */ 1325 1326static void 1327create_enum_history (gfc_symbol *sym, gfc_expr *init) 1328{ 1329 enumerator_history *new_enum_history; 1330 gcc_assert (sym != NULL && init != NULL); 1331 1332 new_enum_history = XCNEW (enumerator_history); 1333 1334 new_enum_history->sym = sym; 1335 new_enum_history->initializer = init; 1336 new_enum_history->next = NULL; 1337 1338 if (enum_history == NULL) 1339 { 1340 enum_history = new_enum_history; 1341 max_enum = enum_history; 1342 } 1343 else 1344 { 1345 new_enum_history->next = enum_history; 1346 enum_history = new_enum_history; 1347 1348 if (mpz_cmp (max_enum->initializer->value.integer, 1349 new_enum_history->initializer->value.integer) < 0) 1350 max_enum = new_enum_history; 1351 } 1352} 1353 1354 1355/* Function to free enum kind history. */ 1356 1357void 1358gfc_free_enum_history (void) 1359{ 1360 enumerator_history *current = enum_history; 1361 enumerator_history *next; 1362 1363 while (current != NULL) 1364 { 1365 next = current->next; 1366 free (current); 1367 current = next; 1368 } 1369 max_enum = NULL; 1370 enum_history = NULL; 1371} 1372 1373 1374/* Function called by variable_decl() that adds an initialization 1375 expression to a symbol. */ 1376 1377static bool 1378add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) 1379{ 1380 symbol_attribute attr; 1381 gfc_symbol *sym; 1382 gfc_expr *init; 1383 1384 init = *initp; 1385 if (find_special (name, &sym, false)) 1386 return false; 1387 1388 attr = sym->attr; 1389 1390 /* If this symbol is confirming an implicit parameter type, 1391 then an initialization expression is not allowed. */ 1392 if (attr.flavor == FL_PARAMETER 1393 && sym->value != NULL 1394 && *initp != NULL) 1395 { 1396 gfc_error ("Initializer not allowed for PARAMETER %qs at %C", 1397 sym->name); 1398 return false; 1399 } 1400 1401 if (init == NULL) 1402 { 1403 /* An initializer is required for PARAMETER declarations. */ 1404 if (attr.flavor == FL_PARAMETER) 1405 { 1406 gfc_error ("PARAMETER at %L is missing an initializer", var_locus); 1407 return false; 1408 } 1409 } 1410 else 1411 { 1412 /* If a variable appears in a DATA block, it cannot have an 1413 initializer. */ 1414 if (sym->attr.data) 1415 { 1416 gfc_error ("Variable %qs at %C with an initializer already " 1417 "appears in a DATA statement", sym->name); 1418 return false; 1419 } 1420 1421 /* Check if the assignment can happen. This has to be put off 1422 until later for derived type variables and procedure pointers. */ 1423 if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED 1424 && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS 1425 && !sym->attr.proc_pointer 1426 && !gfc_check_assign_symbol (sym, NULL, init)) 1427 return false; 1428 1429 if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl 1430 && init->ts.type == BT_CHARACTER) 1431 { 1432 /* Update symbol character length according initializer. */ 1433 if (!gfc_check_assign_symbol (sym, NULL, init)) 1434 return false; 1435 1436 if (sym->ts.u.cl->length == NULL) 1437 { 1438 int clen; 1439 /* If there are multiple CHARACTER variables declared on the 1440 same line, we don't want them to share the same length. */ 1441 sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 1442 1443 if (sym->attr.flavor == FL_PARAMETER) 1444 { 1445 if (init->expr_type == EXPR_CONSTANT) 1446 { 1447 clen = init->value.character.length; 1448 sym->ts.u.cl->length 1449 = gfc_get_int_expr (gfc_default_integer_kind, 1450 NULL, clen); 1451 } 1452 else if (init->expr_type == EXPR_ARRAY) 1453 { 1454 if (init->ts.u.cl) 1455 clen = mpz_get_si (init->ts.u.cl->length->value.integer); 1456 else if (init->value.constructor) 1457 { 1458 gfc_constructor *c; 1459 c = gfc_constructor_first (init->value.constructor); 1460 clen = c->expr->value.character.length; 1461 } 1462 else 1463 gcc_unreachable (); 1464 sym->ts.u.cl->length 1465 = gfc_get_int_expr (gfc_default_integer_kind, 1466 NULL, clen); 1467 } 1468 else if (init->ts.u.cl && init->ts.u.cl->length) 1469 sym->ts.u.cl->length = 1470 gfc_copy_expr (sym->value->ts.u.cl->length); 1471 } 1472 } 1473 /* Update initializer character length according symbol. */ 1474 else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) 1475 { 1476 int len; 1477 1478 if (!gfc_specification_expr (sym->ts.u.cl->length)) 1479 return false; 1480 1481 len = mpz_get_si (sym->ts.u.cl->length->value.integer); 1482 1483 if (init->expr_type == EXPR_CONSTANT) 1484 gfc_set_constant_character_len (len, init, -1); 1485 else if (init->expr_type == EXPR_ARRAY) 1486 { 1487 gfc_constructor *c; 1488 1489 /* Build a new charlen to prevent simplification from 1490 deleting the length before it is resolved. */ 1491 init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 1492 init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length); 1493 1494 for (c = gfc_constructor_first (init->value.constructor); 1495 c; c = gfc_constructor_next (c)) 1496 gfc_set_constant_character_len (len, c->expr, -1); 1497 } 1498 } 1499 } 1500 1501 /* If sym is implied-shape, set its upper bounds from init. */ 1502 if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension 1503 && sym->as->type == AS_IMPLIED_SHAPE) 1504 { 1505 int dim; 1506 1507 if (init->rank == 0) 1508 { 1509 gfc_error ("Can't initialize implied-shape array at %L" 1510 " with scalar", &sym->declared_at); 1511 return false; 1512 } 1513 1514 /* Shape should be present, we get an initialization expression. */ 1515 gcc_assert (init->shape); 1516 1517 for (dim = 0; dim < sym->as->rank; ++dim) 1518 { 1519 int k; 1520 gfc_expr *e, *lower; 1521 1522 lower = sym->as->lower[dim]; 1523 1524 /* If the lower bound is an array element from another 1525 parameterized array, then it is marked with EXPR_VARIABLE and 1526 is an initialization expression. Try to reduce it. */ 1527 if (lower->expr_type == EXPR_VARIABLE) 1528 gfc_reduce_init_expr (lower); 1529 1530 if (lower->expr_type == EXPR_CONSTANT) 1531 { 1532 /* All dimensions must be without upper bound. */ 1533 gcc_assert (!sym->as->upper[dim]); 1534 1535 k = lower->ts.kind; 1536 e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); 1537 mpz_add (e->value.integer, lower->value.integer, 1538 init->shape[dim]); 1539 mpz_sub_ui (e->value.integer, e->value.integer, 1); 1540 sym->as->upper[dim] = e; 1541 } 1542 else 1543 { 1544 gfc_error ("Non-constant lower bound in implied-shape" 1545 " declaration at %L", &lower->where); 1546 return false; 1547 } 1548 } 1549 1550 sym->as->type = AS_EXPLICIT; 1551 } 1552 1553 /* Need to check if the expression we initialized this 1554 to was one of the iso_c_binding named constants. If so, 1555 and we're a parameter (constant), let it be iso_c. 1556 For example: 1557 integer(c_int), parameter :: my_int = c_int 1558 integer(my_int) :: my_int_2 1559 If we mark my_int as iso_c (since we can see it's value 1560 is equal to one of the named constants), then my_int_2 1561 will be considered C interoperable. */ 1562 if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED) 1563 { 1564 sym->ts.is_iso_c |= init->ts.is_iso_c; 1565 sym->ts.is_c_interop |= init->ts.is_c_interop; 1566 /* attr bits needed for module files. */ 1567 sym->attr.is_iso_c |= init->ts.is_iso_c; 1568 sym->attr.is_c_interop |= init->ts.is_c_interop; 1569 if (init->ts.is_iso_c) 1570 sym->ts.f90_type = init->ts.f90_type; 1571 } 1572 1573 /* Add initializer. Make sure we keep the ranks sane. */ 1574 if (sym->attr.dimension && init->rank == 0) 1575 { 1576 mpz_t size; 1577 gfc_expr *array; 1578 int n; 1579 if (sym->attr.flavor == FL_PARAMETER 1580 && init->expr_type == EXPR_CONSTANT 1581 && spec_size (sym->as, &size) 1582 && mpz_cmp_si (size, 0) > 0) 1583 { 1584 array = gfc_get_array_expr (init->ts.type, init->ts.kind, 1585 &init->where); 1586 for (n = 0; n < (int)mpz_get_si (size); n++) 1587 gfc_constructor_append_expr (&array->value.constructor, 1588 n == 0 1589 ? init 1590 : gfc_copy_expr (init), 1591 &init->where); 1592 1593 array->shape = gfc_get_shape (sym->as->rank); 1594 for (n = 0; n < sym->as->rank; n++) 1595 spec_dimen_size (sym->as, n, &array->shape[n]); 1596 1597 init = array; 1598 mpz_clear (size); 1599 } 1600 init->rank = sym->as->rank; 1601 } 1602 1603 sym->value = init; 1604 if (sym->attr.save == SAVE_NONE) 1605 sym->attr.save = SAVE_IMPLICIT; 1606 *initp = NULL; 1607 } 1608 1609 return true; 1610} 1611 1612 1613/* Function called by variable_decl() that adds a name to a structure 1614 being built. */ 1615 1616static bool 1617build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, 1618 gfc_array_spec **as) 1619{ 1620 gfc_component *c; 1621 bool t = true; 1622 1623 /* F03:C438/C439. If the current symbol is of the same derived type that we're 1624 constructing, it must have the pointer attribute. */ 1625 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 1626 && current_ts.u.derived == gfc_current_block () 1627 && current_attr.pointer == 0) 1628 { 1629 gfc_error ("Component at %C must have the POINTER attribute"); 1630 return false; 1631 } 1632 1633 if (gfc_current_block ()->attr.pointer && (*as)->rank != 0) 1634 { 1635 if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) 1636 { 1637 gfc_error ("Array component of structure at %C must have explicit " 1638 "or deferred shape"); 1639 return false; 1640 } 1641 } 1642 1643 if (!gfc_add_component (gfc_current_block(), name, &c)) 1644 return false; 1645 1646 c->ts = current_ts; 1647 if (c->ts.type == BT_CHARACTER) 1648 c->ts.u.cl = cl; 1649 c->attr = current_attr; 1650 1651 c->initializer = *init; 1652 *init = NULL; 1653 1654 c->as = *as; 1655 if (c->as != NULL) 1656 { 1657 if (c->as->corank) 1658 c->attr.codimension = 1; 1659 if (c->as->rank) 1660 c->attr.dimension = 1; 1661 } 1662 *as = NULL; 1663 1664 /* Should this ever get more complicated, combine with similar section 1665 in add_init_expr_to_sym into a separate function. */ 1666 if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer 1667 && c->ts.u.cl 1668 && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT) 1669 { 1670 int len; 1671 1672 gcc_assert (c->ts.u.cl && c->ts.u.cl->length); 1673 gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT); 1674 gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER); 1675 1676 len = mpz_get_si (c->ts.u.cl->length->value.integer); 1677 1678 if (c->initializer->expr_type == EXPR_CONSTANT) 1679 gfc_set_constant_character_len (len, c->initializer, -1); 1680 else if (mpz_cmp (c->ts.u.cl->length->value.integer, 1681 c->initializer->ts.u.cl->length->value.integer)) 1682 { 1683 gfc_constructor *ctor; 1684 ctor = gfc_constructor_first (c->initializer->value.constructor); 1685 1686 if (ctor) 1687 { 1688 int first_len; 1689 bool has_ts = (c->initializer->ts.u.cl 1690 && c->initializer->ts.u.cl->length_from_typespec); 1691 1692 /* Remember the length of the first element for checking 1693 that all elements *in the constructor* have the same 1694 length. This need not be the length of the LHS! */ 1695 gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT); 1696 gcc_assert (ctor->expr->ts.type == BT_CHARACTER); 1697 first_len = ctor->expr->value.character.length; 1698 1699 for ( ; ctor; ctor = gfc_constructor_next (ctor)) 1700 if (ctor->expr->expr_type == EXPR_CONSTANT) 1701 { 1702 gfc_set_constant_character_len (len, ctor->expr, 1703 has_ts ? -1 : first_len); 1704 ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length); 1705 } 1706 } 1707 } 1708 } 1709 1710 /* Check array components. */ 1711 if (!c->attr.dimension) 1712 goto scalar; 1713 1714 if (c->attr.pointer) 1715 { 1716 if (c->as->type != AS_DEFERRED) 1717 { 1718 gfc_error ("Pointer array component of structure at %C must have a " 1719 "deferred shape"); 1720 t = false; 1721 } 1722 } 1723 else if (c->attr.allocatable) 1724 { 1725 if (c->as->type != AS_DEFERRED) 1726 { 1727 gfc_error ("Allocatable component of structure at %C must have a " 1728 "deferred shape"); 1729 t = false; 1730 } 1731 } 1732 else 1733 { 1734 if (c->as->type != AS_EXPLICIT) 1735 { 1736 gfc_error ("Array component of structure at %C must have an " 1737 "explicit shape"); 1738 t = false; 1739 } 1740 } 1741 1742scalar: 1743 if (c->ts.type == BT_CLASS) 1744 { 1745 bool t2 = gfc_build_class_symbol (&c->ts, &c->attr, &c->as); 1746 1747 if (t) 1748 t = t2; 1749 } 1750 1751 return t; 1752} 1753 1754 1755/* Match a 'NULL()', and possibly take care of some side effects. */ 1756 1757match 1758gfc_match_null (gfc_expr **result) 1759{ 1760 gfc_symbol *sym; 1761 match m, m2 = MATCH_NO; 1762 1763 if ((m = gfc_match (" null ( )")) == MATCH_ERROR) 1764 return MATCH_ERROR; 1765 1766 if (m == MATCH_NO) 1767 { 1768 locus old_loc; 1769 char name[GFC_MAX_SYMBOL_LEN + 1]; 1770 1771 if ((m2 = gfc_match (" null (")) != MATCH_YES) 1772 return m2; 1773 1774 old_loc = gfc_current_locus; 1775 if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR) 1776 return MATCH_ERROR; 1777 if (m2 != MATCH_YES 1778 && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR)) 1779 return MATCH_ERROR; 1780 if (m2 == MATCH_NO) 1781 { 1782 gfc_current_locus = old_loc; 1783 return MATCH_NO; 1784 } 1785 } 1786 1787 /* The NULL symbol now has to be/become an intrinsic function. */ 1788 if (gfc_get_symbol ("null", NULL, &sym)) 1789 { 1790 gfc_error ("NULL() initialization at %C is ambiguous"); 1791 return MATCH_ERROR; 1792 } 1793 1794 gfc_intrinsic_symbol (sym); 1795 1796 if (sym->attr.proc != PROC_INTRINSIC 1797 && !(sym->attr.use_assoc && sym->attr.intrinsic) 1798 && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL) 1799 || !gfc_add_function (&sym->attr, sym->name, NULL))) 1800 return MATCH_ERROR; 1801 1802 *result = gfc_get_null_expr (&gfc_current_locus); 1803 1804 /* Invalid per F2008, C512. */ 1805 if (m2 == MATCH_YES) 1806 { 1807 gfc_error ("NULL() initialization at %C may not have MOLD"); 1808 return MATCH_ERROR; 1809 } 1810 1811 return MATCH_YES; 1812} 1813 1814 1815/* Match the initialization expr for a data pointer or procedure pointer. */ 1816 1817static match 1818match_pointer_init (gfc_expr **init, int procptr) 1819{ 1820 match m; 1821 1822 if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED) 1823 { 1824 gfc_error ("Initialization of pointer at %C is not allowed in " 1825 "a PURE procedure"); 1826 return MATCH_ERROR; 1827 } 1828 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 1829 1830 /* Match NULL() initialization. */ 1831 m = gfc_match_null (init); 1832 if (m != MATCH_NO) 1833 return m; 1834 1835 /* Match non-NULL initialization. */ 1836 gfc_matching_ptr_assignment = !procptr; 1837 gfc_matching_procptr_assignment = procptr; 1838 m = gfc_match_rvalue (init); 1839 gfc_matching_ptr_assignment = 0; 1840 gfc_matching_procptr_assignment = 0; 1841 if (m == MATCH_ERROR) 1842 return MATCH_ERROR; 1843 else if (m == MATCH_NO) 1844 { 1845 gfc_error ("Error in pointer initialization at %C"); 1846 return MATCH_ERROR; 1847 } 1848 1849 if (!procptr && !gfc_resolve_expr (*init)) 1850 return MATCH_ERROR; 1851 1852 if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer " 1853 "initialization at %C")) 1854 return MATCH_ERROR; 1855 1856 return MATCH_YES; 1857} 1858 1859 1860static bool 1861check_function_name (char *name) 1862{ 1863 /* In functions that have a RESULT variable defined, the function name always 1864 refers to function calls. Therefore, the name is not allowed to appear in 1865 specification statements. When checking this, be careful about 1866 'hidden' procedure pointer results ('ppr@'). */ 1867 1868 if (gfc_current_state () == COMP_FUNCTION) 1869 { 1870 gfc_symbol *block = gfc_current_block (); 1871 if (block && block->result && block->result != block 1872 && strcmp (block->result->name, "ppr@") != 0 1873 && strcmp (block->name, name) == 0) 1874 { 1875 gfc_error ("Function name %qs not allowed at %C", name); 1876 return false; 1877 } 1878 } 1879 1880 return true; 1881} 1882 1883 1884/* Match a variable name with an optional initializer. When this 1885 subroutine is called, a variable is expected to be parsed next. 1886 Depending on what is happening at the moment, updates either the 1887 symbol table or the current interface. */ 1888 1889static match 1890variable_decl (int elem) 1891{ 1892 char name[GFC_MAX_SYMBOL_LEN + 1]; 1893 gfc_expr *initializer, *char_len; 1894 gfc_array_spec *as; 1895 gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ 1896 gfc_charlen *cl; 1897 bool cl_deferred; 1898 locus var_locus; 1899 match m; 1900 bool t; 1901 gfc_symbol *sym; 1902 1903 initializer = NULL; 1904 as = NULL; 1905 cp_as = NULL; 1906 1907 /* When we get here, we've just matched a list of attributes and 1908 maybe a type and a double colon. The next thing we expect to see 1909 is the name of the symbol. */ 1910 m = gfc_match_name (name); 1911 if (m != MATCH_YES) 1912 goto cleanup; 1913 1914 var_locus = gfc_current_locus; 1915 1916 /* Now we could see the optional array spec. or character length. */ 1917 m = gfc_match_array_spec (&as, true, true); 1918 if (m == MATCH_ERROR) 1919 goto cleanup; 1920 1921 if (m == MATCH_NO) 1922 as = gfc_copy_array_spec (current_as); 1923 else if (current_as 1924 && !merge_array_spec (current_as, as, true)) 1925 { 1926 m = MATCH_ERROR; 1927 goto cleanup; 1928 } 1929 1930 if (flag_cray_pointer) 1931 cp_as = gfc_copy_array_spec (as); 1932 1933 /* At this point, we know for sure if the symbol is PARAMETER and can thus 1934 determine (and check) whether it can be implied-shape. If it 1935 was parsed as assumed-size, change it because PARAMETERs can not 1936 be assumed-size. */ 1937 if (as) 1938 { 1939 if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) 1940 { 1941 m = MATCH_ERROR; 1942 gfc_error ("Non-PARAMETER symbol %qs at %L can't be implied-shape", 1943 name, &var_locus); 1944 goto cleanup; 1945 } 1946 1947 if (as->type == AS_ASSUMED_SIZE && as->rank == 1 1948 && current_attr.flavor == FL_PARAMETER) 1949 as->type = AS_IMPLIED_SHAPE; 1950 1951 if (as->type == AS_IMPLIED_SHAPE 1952 && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L", 1953 &var_locus)) 1954 { 1955 m = MATCH_ERROR; 1956 goto cleanup; 1957 } 1958 } 1959 1960 char_len = NULL; 1961 cl = NULL; 1962 cl_deferred = false; 1963 1964 if (current_ts.type == BT_CHARACTER) 1965 { 1966 switch (match_char_length (&char_len, &cl_deferred, false)) 1967 { 1968 case MATCH_YES: 1969 cl = gfc_new_charlen (gfc_current_ns, NULL); 1970 1971 cl->length = char_len; 1972 break; 1973 1974 /* Non-constant lengths need to be copied after the first 1975 element. Also copy assumed lengths. */ 1976 case MATCH_NO: 1977 if (elem > 1 1978 && (current_ts.u.cl->length == NULL 1979 || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) 1980 { 1981 cl = gfc_new_charlen (gfc_current_ns, NULL); 1982 cl->length = gfc_copy_expr (current_ts.u.cl->length); 1983 } 1984 else 1985 cl = current_ts.u.cl; 1986 1987 cl_deferred = current_ts.deferred; 1988 1989 break; 1990 1991 case MATCH_ERROR: 1992 goto cleanup; 1993 } 1994 } 1995 1996 /* If this symbol has already shown up in a Cray Pointer declaration, 1997 and this is not a component declaration, 1998 then we want to set the type & bail out. */ 1999 if (flag_cray_pointer && gfc_current_state () != COMP_DERIVED) 2000 { 2001 gfc_find_symbol (name, gfc_current_ns, 1, &sym); 2002 if (sym != NULL && sym->attr.cray_pointee) 2003 { 2004 sym->ts.type = current_ts.type; 2005 sym->ts.kind = current_ts.kind; 2006 sym->ts.u.cl = cl; 2007 sym->ts.u.derived = current_ts.u.derived; 2008 sym->ts.is_c_interop = current_ts.is_c_interop; 2009 sym->ts.is_iso_c = current_ts.is_iso_c; 2010 m = MATCH_YES; 2011 2012 /* Check to see if we have an array specification. */ 2013 if (cp_as != NULL) 2014 { 2015 if (sym->as != NULL) 2016 { 2017 gfc_error ("Duplicate array spec for Cray pointee at %C"); 2018 gfc_free_array_spec (cp_as); 2019 m = MATCH_ERROR; 2020 goto cleanup; 2021 } 2022 else 2023 { 2024 if (!gfc_set_array_spec (sym, cp_as, &var_locus)) 2025 gfc_internal_error ("Couldn't set pointee array spec."); 2026 2027 /* Fix the array spec. */ 2028 m = gfc_mod_pointee_as (sym->as); 2029 if (m == MATCH_ERROR) 2030 goto cleanup; 2031 } 2032 } 2033 goto cleanup; 2034 } 2035 else 2036 { 2037 gfc_free_array_spec (cp_as); 2038 } 2039 } 2040 2041 /* Procedure pointer as function result. */ 2042 if (gfc_current_state () == COMP_FUNCTION 2043 && strcmp ("ppr@", gfc_current_block ()->name) == 0 2044 && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0) 2045 strcpy (name, "ppr@"); 2046 2047 if (gfc_current_state () == COMP_FUNCTION 2048 && strcmp (name, gfc_current_block ()->name) == 0 2049 && gfc_current_block ()->result 2050 && strcmp ("ppr@", gfc_current_block ()->result->name) == 0) 2051 strcpy (name, "ppr@"); 2052 2053 /* OK, we've successfully matched the declaration. Now put the 2054 symbol in the current namespace, because it might be used in the 2055 optional initialization expression for this symbol, e.g. this is 2056 perfectly legal: 2057 2058 integer, parameter :: i = huge(i) 2059 2060 This is only true for parameters or variables of a basic type. 2061 For components of derived types, it is not true, so we don't 2062 create a symbol for those yet. If we fail to create the symbol, 2063 bail out. */ 2064 if (gfc_current_state () != COMP_DERIVED 2065 && !build_sym (name, cl, cl_deferred, &as, &var_locus)) 2066 { 2067 m = MATCH_ERROR; 2068 goto cleanup; 2069 } 2070 2071 if (!check_function_name (name)) 2072 { 2073 m = MATCH_ERROR; 2074 goto cleanup; 2075 } 2076 2077 /* We allow old-style initializations of the form 2078 integer i /2/, j(4) /3*3, 1/ 2079 (if no colon has been seen). These are different from data 2080 statements in that initializers are only allowed to apply to the 2081 variable immediately preceding, i.e. 2082 integer i, j /1, 2/ 2083 is not allowed. Therefore we have to do some work manually, that 2084 could otherwise be left to the matchers for DATA statements. */ 2085 2086 if (!colon_seen && gfc_match (" /") == MATCH_YES) 2087 { 2088 if (!gfc_notify_std (GFC_STD_GNU, "Old-style " 2089 "initialization at %C")) 2090 return MATCH_ERROR; 2091 else if (gfc_current_state () == COMP_DERIVED) 2092 { 2093 gfc_error ("Invalid old style initialization for derived type " 2094 "component at %C"); 2095 m = MATCH_ERROR; 2096 goto cleanup; 2097 } 2098 2099 return match_old_style_init (name); 2100 } 2101 2102 /* The double colon must be present in order to have initializers. 2103 Otherwise the statement is ambiguous with an assignment statement. */ 2104 if (colon_seen) 2105 { 2106 if (gfc_match (" =>") == MATCH_YES) 2107 { 2108 if (!current_attr.pointer) 2109 { 2110 gfc_error ("Initialization at %C isn't for a pointer variable"); 2111 m = MATCH_ERROR; 2112 goto cleanup; 2113 } 2114 2115 m = match_pointer_init (&initializer, 0); 2116 if (m != MATCH_YES) 2117 goto cleanup; 2118 } 2119 else if (gfc_match_char ('=') == MATCH_YES) 2120 { 2121 if (current_attr.pointer) 2122 { 2123 gfc_error ("Pointer initialization at %C requires %<=>%>, " 2124 "not %<=%>"); 2125 m = MATCH_ERROR; 2126 goto cleanup; 2127 } 2128 2129 m = gfc_match_init_expr (&initializer); 2130 if (m == MATCH_NO) 2131 { 2132 gfc_error ("Expected an initialization expression at %C"); 2133 m = MATCH_ERROR; 2134 } 2135 2136 if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL) 2137 && gfc_state_stack->state != COMP_DERIVED) 2138 { 2139 gfc_error ("Initialization of variable at %C is not allowed in " 2140 "a PURE procedure"); 2141 m = MATCH_ERROR; 2142 } 2143 2144 if (current_attr.flavor != FL_PARAMETER 2145 && gfc_state_stack->state != COMP_DERIVED) 2146 gfc_unset_implicit_pure (gfc_current_ns->proc_name); 2147 2148 if (m != MATCH_YES) 2149 goto cleanup; 2150 } 2151 } 2152 2153 if (initializer != NULL && current_attr.allocatable 2154 && gfc_current_state () == COMP_DERIVED) 2155 { 2156 gfc_error ("Initialization of allocatable component at %C is not " 2157 "allowed"); 2158 m = MATCH_ERROR; 2159 goto cleanup; 2160 } 2161 2162 /* Add the initializer. Note that it is fine if initializer is 2163 NULL here, because we sometimes also need to check if a 2164 declaration *must* have an initialization expression. */ 2165 if (gfc_current_state () != COMP_DERIVED) 2166 t = add_init_expr_to_sym (name, &initializer, &var_locus); 2167 else 2168 { 2169 if (current_ts.type == BT_DERIVED 2170 && !current_attr.pointer && !initializer) 2171 initializer = gfc_default_initializer (¤t_ts); 2172 t = build_struct (name, cl, &initializer, &as); 2173 } 2174 2175 m = (t) ? MATCH_YES : MATCH_ERROR; 2176 2177cleanup: 2178 /* Free stuff up and return. */ 2179 gfc_free_expr (initializer); 2180 gfc_free_array_spec (as); 2181 2182 return m; 2183} 2184 2185 2186/* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification. 2187 This assumes that the byte size is equal to the kind number for 2188 non-COMPLEX types, and equal to twice the kind number for COMPLEX. */ 2189 2190match 2191gfc_match_old_kind_spec (gfc_typespec *ts) 2192{ 2193 match m; 2194 int original_kind; 2195 2196 if (gfc_match_char ('*') != MATCH_YES) 2197 return MATCH_NO; 2198 2199 m = gfc_match_small_literal_int (&ts->kind, NULL); 2200 if (m != MATCH_YES) 2201 return MATCH_ERROR; 2202 2203 original_kind = ts->kind; 2204 2205 /* Massage the kind numbers for complex types. */ 2206 if (ts->type == BT_COMPLEX) 2207 { 2208 if (ts->kind % 2) 2209 { 2210 gfc_error ("Old-style type declaration %s*%d not supported at %C", 2211 gfc_basic_typename (ts->type), original_kind); 2212 return MATCH_ERROR; 2213 } 2214 ts->kind /= 2; 2215 2216 } 2217 2218 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) 2219 ts->kind = 8; 2220 2221 if (ts->type == BT_REAL || ts->type == BT_COMPLEX) 2222 { 2223 if (ts->kind == 4) 2224 { 2225 if (flag_real4_kind == 8) 2226 ts->kind = 8; 2227 if (flag_real4_kind == 10) 2228 ts->kind = 10; 2229 if (flag_real4_kind == 16) 2230 ts->kind = 16; 2231 } 2232 2233 if (ts->kind == 8) 2234 { 2235 if (flag_real8_kind == 4) 2236 ts->kind = 4; 2237 if (flag_real8_kind == 10) 2238 ts->kind = 10; 2239 if (flag_real8_kind == 16) 2240 ts->kind = 16; 2241 } 2242 } 2243 2244 if (gfc_validate_kind (ts->type, ts->kind, true) < 0) 2245 { 2246 gfc_error ("Old-style type declaration %s*%d not supported at %C", 2247 gfc_basic_typename (ts->type), original_kind); 2248 return MATCH_ERROR; 2249 } 2250 2251 if (!gfc_notify_std (GFC_STD_GNU, 2252 "Nonstandard type declaration %s*%d at %C", 2253 gfc_basic_typename(ts->type), original_kind)) 2254 return MATCH_ERROR; 2255 2256 return MATCH_YES; 2257} 2258 2259 2260/* Match a kind specification. Since kinds are generally optional, we 2261 usually return MATCH_NO if something goes wrong. If a "kind=" 2262 string is found, then we know we have an error. */ 2263 2264match 2265gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) 2266{ 2267 locus where, loc; 2268 gfc_expr *e; 2269 match m, n; 2270 char c; 2271 const char *msg; 2272 2273 m = MATCH_NO; 2274 n = MATCH_YES; 2275 e = NULL; 2276 2277 where = loc = gfc_current_locus; 2278 2279 if (kind_expr_only) 2280 goto kind_expr; 2281 2282 if (gfc_match_char ('(') == MATCH_NO) 2283 return MATCH_NO; 2284 2285 /* Also gobbles optional text. */ 2286 if (gfc_match (" kind = ") == MATCH_YES) 2287 m = MATCH_ERROR; 2288 2289 loc = gfc_current_locus; 2290 2291kind_expr: 2292 n = gfc_match_init_expr (&e); 2293 2294 if (n != MATCH_YES) 2295 { 2296 if (gfc_matching_function) 2297 { 2298 /* The function kind expression might include use associated or 2299 imported parameters and try again after the specification 2300 expressions..... */ 2301 if (gfc_match_char (')') != MATCH_YES) 2302 { 2303 gfc_error ("Missing right parenthesis at %C"); 2304 m = MATCH_ERROR; 2305 goto no_match; 2306 } 2307 2308 gfc_free_expr (e); 2309 gfc_undo_symbols (); 2310 return MATCH_YES; 2311 } 2312 else 2313 { 2314 /* ....or else, the match is real. */ 2315 if (n == MATCH_NO) 2316 gfc_error ("Expected initialization expression at %C"); 2317 if (n != MATCH_YES) 2318 return MATCH_ERROR; 2319 } 2320 } 2321 2322 if (e->rank != 0) 2323 { 2324 gfc_error ("Expected scalar initialization expression at %C"); 2325 m = MATCH_ERROR; 2326 goto no_match; 2327 } 2328 2329 msg = gfc_extract_int (e, &ts->kind); 2330 2331 if (msg != NULL) 2332 { 2333 gfc_error (msg); 2334 m = MATCH_ERROR; 2335 goto no_match; 2336 } 2337 2338 /* Before throwing away the expression, let's see if we had a 2339 C interoperable kind (and store the fact). */ 2340 if (e->ts.is_c_interop == 1) 2341 { 2342 /* Mark this as C interoperable if being declared with one 2343 of the named constants from iso_c_binding. */ 2344 ts->is_c_interop = e->ts.is_iso_c; 2345 ts->f90_type = e->ts.f90_type; 2346 } 2347 2348 gfc_free_expr (e); 2349 e = NULL; 2350 2351 /* Ignore errors to this point, if we've gotten here. This means 2352 we ignore the m=MATCH_ERROR from above. */ 2353 if (gfc_validate_kind (ts->type, ts->kind, true) < 0) 2354 { 2355 gfc_error ("Kind %d not supported for type %s at %C", ts->kind, 2356 gfc_basic_typename (ts->type)); 2357 gfc_current_locus = where; 2358 return MATCH_ERROR; 2359 } 2360 2361 /* Warn if, e.g., c_int is used for a REAL variable, but not 2362 if, e.g., c_double is used for COMPLEX as the standard 2363 explicitly says that the kind type parameter for complex and real 2364 variable is the same, i.e. c_float == c_float_complex. */ 2365 if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type 2366 && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) 2367 || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) 2368 gfc_warning_now (0, "C kind type parameter is for type %s but type at %L " 2369 "is %s", gfc_basic_typename (ts->f90_type), &where, 2370 gfc_basic_typename (ts->type)); 2371 2372 gfc_gobble_whitespace (); 2373 if ((c = gfc_next_ascii_char ()) != ')' 2374 && (ts->type != BT_CHARACTER || c != ',')) 2375 { 2376 if (ts->type == BT_CHARACTER) 2377 gfc_error ("Missing right parenthesis or comma at %C"); 2378 else 2379 gfc_error ("Missing right parenthesis at %C"); 2380 m = MATCH_ERROR; 2381 } 2382 else 2383 /* All tests passed. */ 2384 m = MATCH_YES; 2385 2386 if(m == MATCH_ERROR) 2387 gfc_current_locus = where; 2388 2389 if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8) 2390 ts->kind = 8; 2391 2392 if (ts->type == BT_REAL || ts->type == BT_COMPLEX) 2393 { 2394 if (ts->kind == 4) 2395 { 2396 if (flag_real4_kind == 8) 2397 ts->kind = 8; 2398 if (flag_real4_kind == 10) 2399 ts->kind = 10; 2400 if (flag_real4_kind == 16) 2401 ts->kind = 16; 2402 } 2403 2404 if (ts->kind == 8) 2405 { 2406 if (flag_real8_kind == 4) 2407 ts->kind = 4; 2408 if (flag_real8_kind == 10) 2409 ts->kind = 10; 2410 if (flag_real8_kind == 16) 2411 ts->kind = 16; 2412 } 2413 } 2414 2415 /* Return what we know from the test(s). */ 2416 return m; 2417 2418no_match: 2419 gfc_free_expr (e); 2420 gfc_current_locus = where; 2421 return m; 2422} 2423 2424 2425static match 2426match_char_kind (int * kind, int * is_iso_c) 2427{ 2428 locus where; 2429 gfc_expr *e; 2430 match m, n; 2431 const char *msg; 2432 2433 m = MATCH_NO; 2434 e = NULL; 2435 where = gfc_current_locus; 2436 2437 n = gfc_match_init_expr (&e); 2438 2439 if (n != MATCH_YES && gfc_matching_function) 2440 { 2441 /* The expression might include use-associated or imported 2442 parameters and try again after the specification 2443 expressions. */ 2444 gfc_free_expr (e); 2445 gfc_undo_symbols (); 2446 return MATCH_YES; 2447 } 2448 2449 if (n == MATCH_NO) 2450 gfc_error ("Expected initialization expression at %C"); 2451 if (n != MATCH_YES) 2452 return MATCH_ERROR; 2453 2454 if (e->rank != 0) 2455 { 2456 gfc_error ("Expected scalar initialization expression at %C"); 2457 m = MATCH_ERROR; 2458 goto no_match; 2459 } 2460 2461 msg = gfc_extract_int (e, kind); 2462 *is_iso_c = e->ts.is_iso_c; 2463 if (msg != NULL) 2464 { 2465 gfc_error (msg); 2466 m = MATCH_ERROR; 2467 goto no_match; 2468 } 2469 2470 gfc_free_expr (e); 2471 2472 /* Ignore errors to this point, if we've gotten here. This means 2473 we ignore the m=MATCH_ERROR from above. */ 2474 if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) 2475 { 2476 gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); 2477 m = MATCH_ERROR; 2478 } 2479 else 2480 /* All tests passed. */ 2481 m = MATCH_YES; 2482 2483 if (m == MATCH_ERROR) 2484 gfc_current_locus = where; 2485 2486 /* Return what we know from the test(s). */ 2487 return m; 2488 2489no_match: 2490 gfc_free_expr (e); 2491 gfc_current_locus = where; 2492 return m; 2493} 2494 2495 2496/* Match the various kind/length specifications in a CHARACTER 2497 declaration. We don't return MATCH_NO. */ 2498 2499match 2500gfc_match_char_spec (gfc_typespec *ts) 2501{ 2502 int kind, seen_length, is_iso_c; 2503 gfc_charlen *cl; 2504 gfc_expr *len; 2505 match m; 2506 bool deferred; 2507 2508 len = NULL; 2509 seen_length = 0; 2510 kind = 0; 2511 is_iso_c = 0; 2512 deferred = false; 2513 2514 /* Try the old-style specification first. */ 2515 old_char_selector = 0; 2516 2517 m = match_char_length (&len, &deferred, true); 2518 if (m != MATCH_NO) 2519 { 2520 if (m == MATCH_YES) 2521 old_char_selector = 1; 2522 seen_length = 1; 2523 goto done; 2524 } 2525 2526 m = gfc_match_char ('('); 2527 if (m != MATCH_YES) 2528 { 2529 m = MATCH_YES; /* Character without length is a single char. */ 2530 goto done; 2531 } 2532 2533 /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */ 2534 if (gfc_match (" kind =") == MATCH_YES) 2535 { 2536 m = match_char_kind (&kind, &is_iso_c); 2537 2538 if (m == MATCH_ERROR) 2539 goto done; 2540 if (m == MATCH_NO) 2541 goto syntax; 2542 2543 if (gfc_match (" , len =") == MATCH_NO) 2544 goto rparen; 2545 2546 m = char_len_param_value (&len, &deferred); 2547 if (m == MATCH_NO) 2548 goto syntax; 2549 if (m == MATCH_ERROR) 2550 goto done; 2551 seen_length = 1; 2552 2553 goto rparen; 2554 } 2555 2556 /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */ 2557 if (gfc_match (" len =") == MATCH_YES) 2558 { 2559 m = char_len_param_value (&len, &deferred); 2560 if (m == MATCH_NO) 2561 goto syntax; 2562 if (m == MATCH_ERROR) 2563 goto done; 2564 seen_length = 1; 2565 2566 if (gfc_match_char (')') == MATCH_YES) 2567 goto done; 2568 2569 if (gfc_match (" , kind =") != MATCH_YES) 2570 goto syntax; 2571 2572 if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) 2573 goto done; 2574 2575 goto rparen; 2576 } 2577 2578 /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */ 2579 m = char_len_param_value (&len, &deferred); 2580 if (m == MATCH_NO) 2581 goto syntax; 2582 if (m == MATCH_ERROR) 2583 goto done; 2584 seen_length = 1; 2585 2586 m = gfc_match_char (')'); 2587 if (m == MATCH_YES) 2588 goto done; 2589 2590 if (gfc_match_char (',') != MATCH_YES) 2591 goto syntax; 2592 2593 gfc_match (" kind ="); /* Gobble optional text. */ 2594 2595 m = match_char_kind (&kind, &is_iso_c); 2596 if (m == MATCH_ERROR) 2597 goto done; 2598 if (m == MATCH_NO) 2599 goto syntax; 2600 2601rparen: 2602 /* Require a right-paren at this point. */ 2603 m = gfc_match_char (')'); 2604 if (m == MATCH_YES) 2605 goto done; 2606 2607syntax: 2608 gfc_error ("Syntax error in CHARACTER declaration at %C"); 2609 m = MATCH_ERROR; 2610 gfc_free_expr (len); 2611 return m; 2612 2613done: 2614 /* Deal with character functions after USE and IMPORT statements. */ 2615 if (gfc_matching_function) 2616 { 2617 gfc_free_expr (len); 2618 gfc_undo_symbols (); 2619 return MATCH_YES; 2620 } 2621 2622 if (m != MATCH_YES) 2623 { 2624 gfc_free_expr (len); 2625 return m; 2626 } 2627 2628 /* Do some final massaging of the length values. */ 2629 cl = gfc_new_charlen (gfc_current_ns, NULL); 2630 2631 if (seen_length == 0) 2632 cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); 2633 else 2634 cl->length = len; 2635 2636 ts->u.cl = cl; 2637 ts->kind = kind == 0 ? gfc_default_character_kind : kind; 2638 ts->deferred = deferred; 2639 2640 /* We have to know if it was a C interoperable kind so we can 2641 do accurate type checking of bind(c) procs, etc. */ 2642 if (kind != 0) 2643 /* Mark this as C interoperable if being declared with one 2644 of the named constants from iso_c_binding. */ 2645 ts->is_c_interop = is_iso_c; 2646 else if (len != NULL) 2647 /* Here, we might have parsed something such as: character(c_char) 2648 In this case, the parsing code above grabs the c_char when 2649 looking for the length (line 1690, roughly). it's the last 2650 testcase for parsing the kind params of a character variable. 2651 However, it's not actually the length. this seems like it 2652 could be an error. 2653 To see if the user used a C interop kind, test the expr 2654 of the so called length, and see if it's C interoperable. */ 2655 ts->is_c_interop = len->ts.is_iso_c; 2656 2657 return MATCH_YES; 2658} 2659 2660 2661/* Matches a declaration-type-spec (F03:R502). If successful, sets the ts 2662 structure to the matched specification. This is necessary for FUNCTION and 2663 IMPLICIT statements. 2664 2665 If implicit_flag is nonzero, then we don't check for the optional 2666 kind specification. Not doing so is needed for matching an IMPLICIT 2667 statement correctly. */ 2668 2669match 2670gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) 2671{ 2672 char name[GFC_MAX_SYMBOL_LEN + 1]; 2673 gfc_symbol *sym, *dt_sym; 2674 match m; 2675 char c; 2676 bool seen_deferred_kind, matched_type; 2677 const char *dt_name; 2678 2679 /* A belt and braces check that the typespec is correctly being treated 2680 as a deferred characteristic association. */ 2681 seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION) 2682 && (gfc_current_block ()->result->ts.kind == -1) 2683 && (ts->kind == -1); 2684 gfc_clear_ts (ts); 2685 if (seen_deferred_kind) 2686 ts->kind = -1; 2687 2688 /* Clear the current binding label, in case one is given. */ 2689 curr_binding_label = NULL; 2690 2691 if (gfc_match (" byte") == MATCH_YES) 2692 { 2693 if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C")) 2694 return MATCH_ERROR; 2695 2696 if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) 2697 { 2698 gfc_error ("BYTE type used at %C " 2699 "is not available on the target machine"); 2700 return MATCH_ERROR; 2701 } 2702 2703 ts->type = BT_INTEGER; 2704 ts->kind = 1; 2705 return MATCH_YES; 2706 } 2707 2708 2709 m = gfc_match (" type ("); 2710 matched_type = (m == MATCH_YES); 2711 if (matched_type) 2712 { 2713 gfc_gobble_whitespace (); 2714 if (gfc_peek_ascii_char () == '*') 2715 { 2716 if ((m = gfc_match ("*)")) != MATCH_YES) 2717 return m; 2718 if (gfc_current_state () == COMP_DERIVED) 2719 { 2720 gfc_error ("Assumed type at %C is not allowed for components"); 2721 return MATCH_ERROR; 2722 } 2723 if (!gfc_notify_std (GFC_STD_F2008_TS, "Assumed type " 2724 "at %C")) 2725 return MATCH_ERROR; 2726 ts->type = BT_ASSUMED; 2727 return MATCH_YES; 2728 } 2729 2730 m = gfc_match ("%n", name); 2731 matched_type = (m == MATCH_YES); 2732 } 2733 2734 if ((matched_type && strcmp ("integer", name) == 0) 2735 || (!matched_type && gfc_match (" integer") == MATCH_YES)) 2736 { 2737 ts->type = BT_INTEGER; 2738 ts->kind = gfc_default_integer_kind; 2739 goto get_kind; 2740 } 2741 2742 if ((matched_type && strcmp ("character", name) == 0) 2743 || (!matched_type && gfc_match (" character") == MATCH_YES)) 2744 { 2745 if (matched_type 2746 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 2747 "intrinsic-type-spec at %C")) 2748 return MATCH_ERROR; 2749 2750 ts->type = BT_CHARACTER; 2751 if (implicit_flag == 0) 2752 m = gfc_match_char_spec (ts); 2753 else 2754 m = MATCH_YES; 2755 2756 if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) 2757 m = MATCH_ERROR; 2758 2759 return m; 2760 } 2761 2762 if ((matched_type && strcmp ("real", name) == 0) 2763 || (!matched_type && gfc_match (" real") == MATCH_YES)) 2764 { 2765 ts->type = BT_REAL; 2766 ts->kind = gfc_default_real_kind; 2767 goto get_kind; 2768 } 2769 2770 if ((matched_type 2771 && (strcmp ("doubleprecision", name) == 0 2772 || (strcmp ("double", name) == 0 2773 && gfc_match (" precision") == MATCH_YES))) 2774 || (!matched_type && gfc_match (" double precision") == MATCH_YES)) 2775 { 2776 if (matched_type 2777 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 2778 "intrinsic-type-spec at %C")) 2779 return MATCH_ERROR; 2780 if (matched_type && gfc_match_char (')') != MATCH_YES) 2781 return MATCH_ERROR; 2782 2783 ts->type = BT_REAL; 2784 ts->kind = gfc_default_double_kind; 2785 return MATCH_YES; 2786 } 2787 2788 if ((matched_type && strcmp ("complex", name) == 0) 2789 || (!matched_type && gfc_match (" complex") == MATCH_YES)) 2790 { 2791 ts->type = BT_COMPLEX; 2792 ts->kind = gfc_default_complex_kind; 2793 goto get_kind; 2794 } 2795 2796 if ((matched_type 2797 && (strcmp ("doublecomplex", name) == 0 2798 || (strcmp ("double", name) == 0 2799 && gfc_match (" complex") == MATCH_YES))) 2800 || (!matched_type && gfc_match (" double complex") == MATCH_YES)) 2801 { 2802 if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C")) 2803 return MATCH_ERROR; 2804 2805 if (matched_type 2806 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 2807 "intrinsic-type-spec at %C")) 2808 return MATCH_ERROR; 2809 2810 if (matched_type && gfc_match_char (')') != MATCH_YES) 2811 return MATCH_ERROR; 2812 2813 ts->type = BT_COMPLEX; 2814 ts->kind = gfc_default_double_kind; 2815 return MATCH_YES; 2816 } 2817 2818 if ((matched_type && strcmp ("logical", name) == 0) 2819 || (!matched_type && gfc_match (" logical") == MATCH_YES)) 2820 { 2821 ts->type = BT_LOGICAL; 2822 ts->kind = gfc_default_logical_kind; 2823 goto get_kind; 2824 } 2825 2826 if (matched_type) 2827 m = gfc_match_char (')'); 2828 2829 if (m == MATCH_YES) 2830 ts->type = BT_DERIVED; 2831 else 2832 { 2833 /* Match CLASS declarations. */ 2834 m = gfc_match (" class ( * )"); 2835 if (m == MATCH_ERROR) 2836 return MATCH_ERROR; 2837 else if (m == MATCH_YES) 2838 { 2839 gfc_symbol *upe; 2840 gfc_symtree *st; 2841 ts->type = BT_CLASS; 2842 gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe); 2843 if (upe == NULL) 2844 { 2845 upe = gfc_new_symbol ("STAR", gfc_current_ns); 2846 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); 2847 st->n.sym = upe; 2848 gfc_set_sym_referenced (upe); 2849 upe->refs++; 2850 upe->ts.type = BT_VOID; 2851 upe->attr.unlimited_polymorphic = 1; 2852 /* This is essential to force the construction of 2853 unlimited polymorphic component class containers. */ 2854 upe->attr.zero_comp = 1; 2855 if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, 2856 &gfc_current_locus)) 2857 return MATCH_ERROR; 2858 } 2859 else 2860 { 2861 st = gfc_find_symtree (gfc_current_ns->sym_root, "STAR"); 2862 if (st == NULL) 2863 st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); 2864 st->n.sym = upe; 2865 upe->refs++; 2866 } 2867 ts->u.derived = upe; 2868 return m; 2869 } 2870 2871 m = gfc_match (" class ( %n )", name); 2872 if (m != MATCH_YES) 2873 return m; 2874 ts->type = BT_CLASS; 2875 2876 if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C")) 2877 return MATCH_ERROR; 2878 } 2879 2880 /* Defer association of the derived type until the end of the 2881 specification block. However, if the derived type can be 2882 found, add it to the typespec. */ 2883 if (gfc_matching_function) 2884 { 2885 ts->u.derived = NULL; 2886 if (gfc_current_state () != COMP_INTERFACE 2887 && !gfc_find_symbol (name, NULL, 1, &sym) && sym) 2888 { 2889 sym = gfc_find_dt_in_generic (sym); 2890 ts->u.derived = sym; 2891 } 2892 return MATCH_YES; 2893 } 2894 2895 /* Search for the name but allow the components to be defined later. If 2896 type = -1, this typespec has been seen in a function declaration but 2897 the type could not be accessed at that point. The actual derived type is 2898 stored in a symtree with the first letter of the name capitalized; the 2899 symtree with the all lower-case name contains the associated 2900 generic function. */ 2901 dt_name = gfc_get_string ("%c%s", 2902 (char) TOUPPER ((unsigned char) name[0]), 2903 (const char*)&name[1]); 2904 sym = NULL; 2905 dt_sym = NULL; 2906 if (ts->kind != -1) 2907 { 2908 gfc_get_ha_symbol (name, &sym); 2909 if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym)) 2910 { 2911 gfc_error ("Type name %qs at %C is ambiguous", name); 2912 return MATCH_ERROR; 2913 } 2914 if (sym->generic && !dt_sym) 2915 dt_sym = gfc_find_dt_in_generic (sym); 2916 } 2917 else if (ts->kind == -1) 2918 { 2919 int iface = gfc_state_stack->previous->state != COMP_INTERFACE 2920 || gfc_current_ns->has_import_set; 2921 gfc_find_symbol (name, NULL, iface, &sym); 2922 if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym)) 2923 { 2924 gfc_error ("Type name %qs at %C is ambiguous", name); 2925 return MATCH_ERROR; 2926 } 2927 if (sym && sym->generic && !dt_sym) 2928 dt_sym = gfc_find_dt_in_generic (sym); 2929 2930 ts->kind = 0; 2931 if (sym == NULL) 2932 return MATCH_NO; 2933 } 2934 2935 if ((sym->attr.flavor != FL_UNKNOWN 2936 && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) 2937 || sym->attr.subroutine) 2938 { 2939 gfc_error_1 ("Type name '%s' at %C conflicts with previously declared " 2940 "entity at %L, which has the same name", name, 2941 &sym->declared_at); 2942 return MATCH_ERROR; 2943 } 2944 2945 gfc_save_symbol_data (sym); 2946 gfc_set_sym_referenced (sym); 2947 if (!sym->attr.generic 2948 && !gfc_add_generic (&sym->attr, sym->name, NULL)) 2949 return MATCH_ERROR; 2950 2951 if (!sym->attr.function 2952 && !gfc_add_function (&sym->attr, sym->name, NULL)) 2953 return MATCH_ERROR; 2954 2955 if (!dt_sym) 2956 { 2957 gfc_interface *intr, *head; 2958 2959 /* Use upper case to save the actual derived-type symbol. */ 2960 gfc_get_symbol (dt_name, NULL, &dt_sym); 2961 dt_sym->name = gfc_get_string (sym->name); 2962 head = sym->generic; 2963 intr = gfc_get_interface (); 2964 intr->sym = dt_sym; 2965 intr->where = gfc_current_locus; 2966 intr->next = head; 2967 sym->generic = intr; 2968 sym->attr.if_source = IFSRC_DECL; 2969 } 2970 else 2971 gfc_save_symbol_data (dt_sym); 2972 2973 gfc_set_sym_referenced (dt_sym); 2974 2975 if (dt_sym->attr.flavor != FL_DERIVED 2976 && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)) 2977 return MATCH_ERROR; 2978 2979 ts->u.derived = dt_sym; 2980 2981 return MATCH_YES; 2982 2983get_kind: 2984 if (matched_type 2985 && !gfc_notify_std (GFC_STD_F2008, "TYPE with " 2986 "intrinsic-type-spec at %C")) 2987 return MATCH_ERROR; 2988 2989 /* For all types except double, derived and character, look for an 2990 optional kind specifier. MATCH_NO is actually OK at this point. */ 2991 if (implicit_flag == 1) 2992 { 2993 if (matched_type && gfc_match_char (')') != MATCH_YES) 2994 return MATCH_ERROR; 2995 2996 return MATCH_YES; 2997 } 2998 2999 if (gfc_current_form == FORM_FREE) 3000 { 3001 c = gfc_peek_ascii_char (); 3002 if (!gfc_is_whitespace (c) && c != '*' && c != '(' 3003 && c != ':' && c != ',') 3004 { 3005 if (matched_type && c == ')') 3006 { 3007 gfc_next_ascii_char (); 3008 return MATCH_YES; 3009 } 3010 return MATCH_NO; 3011 } 3012 } 3013 3014 m = gfc_match_kind_spec (ts, false); 3015 if (m == MATCH_NO && ts->type != BT_CHARACTER) 3016 { 3017 m = gfc_match_old_kind_spec (ts); 3018 if (gfc_validate_kind (ts->type, ts->kind, true) == -1) 3019 return MATCH_ERROR; 3020 } 3021 3022 if (matched_type && gfc_match_char (')') != MATCH_YES) 3023 return MATCH_ERROR; 3024 3025 /* Defer association of the KIND expression of function results 3026 until after USE and IMPORT statements. */ 3027 if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ()) 3028 || gfc_matching_function) 3029 return MATCH_YES; 3030 3031 if (m == MATCH_NO) 3032 m = MATCH_YES; /* No kind specifier found. */ 3033 3034 return m; 3035} 3036 3037 3038/* Match an IMPLICIT NONE statement. Actually, this statement is 3039 already matched in parse.c, or we would not end up here in the 3040 first place. So the only thing we need to check, is if there is 3041 trailing garbage. If not, the match is successful. */ 3042 3043match 3044gfc_match_implicit_none (void) 3045{ 3046 char c; 3047 match m; 3048 char name[GFC_MAX_SYMBOL_LEN + 1]; 3049 bool type = false; 3050 bool external = false; 3051 locus cur_loc = gfc_current_locus; 3052 3053 if (gfc_current_ns->seen_implicit_none 3054 || gfc_current_ns->has_implicit_none_export) 3055 { 3056 gfc_error ("Duplicate IMPLICIT NONE statement at %C"); 3057 return MATCH_ERROR; 3058 } 3059 3060 gfc_gobble_whitespace (); 3061 c = gfc_peek_ascii_char (); 3062 if (c == '(') 3063 { 3064 (void) gfc_next_ascii_char (); 3065 if (!gfc_notify_std (GFC_STD_F2015, "IMPORT NONE with spec list at %C")) 3066 return MATCH_ERROR; 3067 3068 gfc_gobble_whitespace (); 3069 if (gfc_peek_ascii_char () == ')') 3070 { 3071 (void) gfc_next_ascii_char (); 3072 type = true; 3073 } 3074 else 3075 for(;;) 3076 { 3077 m = gfc_match (" %n", name); 3078 if (m != MATCH_YES) 3079 return MATCH_ERROR; 3080 3081 if (strcmp (name, "type") == 0) 3082 type = true; 3083 else if (strcmp (name, "external") == 0) 3084 external = true; 3085 else 3086 return MATCH_ERROR; 3087 3088 gfc_gobble_whitespace (); 3089 c = gfc_next_ascii_char (); 3090 if (c == ',') 3091 continue; 3092 if (c == ')') 3093 break; 3094 return MATCH_ERROR; 3095 } 3096 } 3097 else 3098 type = true; 3099 3100 if (gfc_match_eos () != MATCH_YES) 3101 return MATCH_ERROR; 3102 3103 gfc_set_implicit_none (type, external, &cur_loc); 3104 3105 return MATCH_YES; 3106} 3107 3108 3109/* Match the letter range(s) of an IMPLICIT statement. */ 3110 3111static match 3112match_implicit_range (void) 3113{ 3114 char c, c1, c2; 3115 int inner; 3116 locus cur_loc; 3117 3118 cur_loc = gfc_current_locus; 3119 3120 gfc_gobble_whitespace (); 3121 c = gfc_next_ascii_char (); 3122 if (c != '(') 3123 { 3124 gfc_error ("Missing character range in IMPLICIT at %C"); 3125 goto bad; 3126 } 3127 3128 inner = 1; 3129 while (inner) 3130 { 3131 gfc_gobble_whitespace (); 3132 c1 = gfc_next_ascii_char (); 3133 if (!ISALPHA (c1)) 3134 goto bad; 3135 3136 gfc_gobble_whitespace (); 3137 c = gfc_next_ascii_char (); 3138 3139 switch (c) 3140 { 3141 case ')': 3142 inner = 0; /* Fall through. */ 3143 3144 case ',': 3145 c2 = c1; 3146 break; 3147 3148 case '-': 3149 gfc_gobble_whitespace (); 3150 c2 = gfc_next_ascii_char (); 3151 if (!ISALPHA (c2)) 3152 goto bad; 3153 3154 gfc_gobble_whitespace (); 3155 c = gfc_next_ascii_char (); 3156 3157 if ((c != ',') && (c != ')')) 3158 goto bad; 3159 if (c == ')') 3160 inner = 0; 3161 3162 break; 3163 3164 default: 3165 goto bad; 3166 } 3167 3168 if (c1 > c2) 3169 { 3170 gfc_error ("Letters must be in alphabetic order in " 3171 "IMPLICIT statement at %C"); 3172 goto bad; 3173 } 3174 3175 /* See if we can add the newly matched range to the pending 3176 implicits from this IMPLICIT statement. We do not check for 3177 conflicts with whatever earlier IMPLICIT statements may have 3178 set. This is done when we've successfully finished matching 3179 the current one. */ 3180 if (!gfc_add_new_implicit_range (c1, c2)) 3181 goto bad; 3182 } 3183 3184 return MATCH_YES; 3185 3186bad: 3187 gfc_syntax_error (ST_IMPLICIT); 3188 3189 gfc_current_locus = cur_loc; 3190 return MATCH_ERROR; 3191} 3192 3193 3194/* Match an IMPLICIT statement, storing the types for 3195 gfc_set_implicit() if the statement is accepted by the parser. 3196 There is a strange looking, but legal syntactic construction 3197 possible. It looks like: 3198 3199 IMPLICIT INTEGER (a-b) (c-d) 3200 3201 This is legal if "a-b" is a constant expression that happens to 3202 equal one of the legal kinds for integers. The real problem 3203 happens with an implicit specification that looks like: 3204 3205 IMPLICIT INTEGER (a-b) 3206 3207 In this case, a typespec matcher that is "greedy" (as most of the 3208 matchers are) gobbles the character range as a kindspec, leaving 3209 nothing left. We therefore have to go a bit more slowly in the 3210 matching process by inhibiting the kindspec checking during 3211 typespec matching and checking for a kind later. */ 3212 3213match 3214gfc_match_implicit (void) 3215{ 3216 gfc_typespec ts; 3217 locus cur_loc; 3218 char c; 3219 match m; 3220 3221 if (gfc_current_ns->seen_implicit_none) 3222 { 3223 gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) " 3224 "statement"); 3225 return MATCH_ERROR; 3226 } 3227 3228 gfc_clear_ts (&ts); 3229 3230 /* We don't allow empty implicit statements. */ 3231 if (gfc_match_eos () == MATCH_YES) 3232 { 3233 gfc_error ("Empty IMPLICIT statement at %C"); 3234 return MATCH_ERROR; 3235 } 3236 3237 do 3238 { 3239 /* First cleanup. */ 3240 gfc_clear_new_implicit (); 3241 3242 /* A basic type is mandatory here. */ 3243 m = gfc_match_decl_type_spec (&ts, 1); 3244 if (m == MATCH_ERROR) 3245 goto error; 3246 if (m == MATCH_NO) 3247 goto syntax; 3248 3249 cur_loc = gfc_current_locus; 3250 m = match_implicit_range (); 3251 3252 if (m == MATCH_YES) 3253 { 3254 /* We may have <TYPE> (<RANGE>). */ 3255 gfc_gobble_whitespace (); 3256 c = gfc_peek_ascii_char (); 3257 if (c == ',' || c == '\n' || c == ';' || c == '!') 3258 { 3259 /* Check for CHARACTER with no length parameter. */ 3260 if (ts.type == BT_CHARACTER && !ts.u.cl) 3261 { 3262 ts.kind = gfc_default_character_kind; 3263 ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); 3264 ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, 3265 NULL, 1); 3266 } 3267 3268 /* Record the Successful match. */ 3269 if (!gfc_merge_new_implicit (&ts)) 3270 return MATCH_ERROR; 3271 if (c == ',') 3272 c = gfc_next_ascii_char (); 3273 else if (gfc_match_eos () == MATCH_ERROR) 3274 goto error; 3275 continue; 3276 } 3277 3278 gfc_current_locus = cur_loc; 3279 } 3280 3281 /* Discard the (incorrectly) matched range. */ 3282 gfc_clear_new_implicit (); 3283 3284 /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */ 3285 if (ts.type == BT_CHARACTER) 3286 m = gfc_match_char_spec (&ts); 3287 else 3288 { 3289 m = gfc_match_kind_spec (&ts, false); 3290 if (m == MATCH_NO) 3291 { 3292 m = gfc_match_old_kind_spec (&ts); 3293 if (m == MATCH_ERROR) 3294 goto error; 3295 if (m == MATCH_NO) 3296 goto syntax; 3297 } 3298 } 3299 if (m == MATCH_ERROR) 3300 goto error; 3301 3302 m = match_implicit_range (); 3303 if (m == MATCH_ERROR) 3304 goto error; 3305 if (m == MATCH_NO) 3306 goto syntax; 3307 3308 gfc_gobble_whitespace (); 3309 c = gfc_next_ascii_char (); 3310 if (c != ',' && gfc_match_eos () != MATCH_YES) 3311 goto syntax; 3312 3313 if (!gfc_merge_new_implicit (&ts)) 3314 return MATCH_ERROR; 3315 } 3316 while (c == ','); 3317 3318 return MATCH_YES; 3319 3320syntax: 3321 gfc_syntax_error (ST_IMPLICIT); 3322 3323error: 3324 return MATCH_ERROR; 3325} 3326 3327 3328match 3329gfc_match_import (void) 3330{ 3331 char name[GFC_MAX_SYMBOL_LEN + 1]; 3332 match m; 3333 gfc_symbol *sym; 3334 gfc_symtree *st; 3335 3336 if (gfc_current_ns->proc_name == NULL 3337 || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) 3338 { 3339 gfc_error ("IMPORT statement at %C only permitted in " 3340 "an INTERFACE body"); 3341 return MATCH_ERROR; 3342 } 3343 3344 if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C")) 3345 return MATCH_ERROR; 3346 3347 if (gfc_match_eos () == MATCH_YES) 3348 { 3349 /* All host variables should be imported. */ 3350 gfc_current_ns->has_import_set = 1; 3351 return MATCH_YES; 3352 } 3353 3354 if (gfc_match (" ::") == MATCH_YES) 3355 { 3356 if (gfc_match_eos () == MATCH_YES) 3357 { 3358 gfc_error ("Expecting list of named entities at %C"); 3359 return MATCH_ERROR; 3360 } 3361 } 3362 3363 for(;;) 3364 { 3365 sym = NULL; 3366 m = gfc_match (" %n", name); 3367 switch (m) 3368 { 3369 case MATCH_YES: 3370 if (gfc_current_ns->parent != NULL 3371 && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) 3372 { 3373 gfc_error ("Type name %qs at %C is ambiguous", name); 3374 return MATCH_ERROR; 3375 } 3376 else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL 3377 && gfc_find_symbol (name, 3378 gfc_current_ns->proc_name->ns->parent, 3379 1, &sym)) 3380 { 3381 gfc_error ("Type name %qs at %C is ambiguous", name); 3382 return MATCH_ERROR; 3383 } 3384 3385 if (sym == NULL) 3386 { 3387 gfc_error ("Cannot IMPORT %qs from host scoping unit " 3388 "at %C - does not exist.", name); 3389 return MATCH_ERROR; 3390 } 3391 3392 if (gfc_find_symtree (gfc_current_ns->sym_root, name)) 3393 { 3394 gfc_warning (0, "%qs is already IMPORTed from host scoping unit " 3395 "at %C", name); 3396 goto next_item; 3397 } 3398 3399 st = gfc_new_symtree (&gfc_current_ns->sym_root, name); 3400 st->n.sym = sym; 3401 sym->refs++; 3402 sym->attr.imported = 1; 3403 3404 if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) 3405 { 3406 /* The actual derived type is stored in a symtree with the first 3407 letter of the name capitalized; the symtree with the all 3408 lower-case name contains the associated generic function. */ 3409 st = gfc_new_symtree (&gfc_current_ns->sym_root, 3410 gfc_get_string ("%c%s", 3411 (char) TOUPPER ((unsigned char) name[0]), 3412 &name[1])); 3413 st->n.sym = sym; 3414 sym->refs++; 3415 sym->attr.imported = 1; 3416 } 3417 3418 goto next_item; 3419 3420 case MATCH_NO: 3421 break; 3422 3423 case MATCH_ERROR: 3424 return MATCH_ERROR; 3425 } 3426 3427 next_item: 3428 if (gfc_match_eos () == MATCH_YES) 3429 break; 3430 if (gfc_match_char (',') != MATCH_YES) 3431 goto syntax; 3432 } 3433 3434 return MATCH_YES; 3435 3436syntax: 3437 gfc_error ("Syntax error in IMPORT statement at %C"); 3438 return MATCH_ERROR; 3439} 3440 3441 3442/* A minimal implementation of gfc_match without whitespace, escape 3443 characters or variable arguments. Returns true if the next 3444 characters match the TARGET template exactly. */ 3445 3446static bool 3447match_string_p (const char *target) 3448{ 3449 const char *p; 3450 3451 for (p = target; *p; p++) 3452 if ((char) gfc_next_ascii_char () != *p) 3453 return false; 3454 return true; 3455} 3456 3457/* Matches an attribute specification including array specs. If 3458 successful, leaves the variables current_attr and current_as 3459 holding the specification. Also sets the colon_seen variable for 3460 later use by matchers associated with initializations. 3461 3462 This subroutine is a little tricky in the sense that we don't know 3463 if we really have an attr-spec until we hit the double colon. 3464 Until that time, we can only return MATCH_NO. This forces us to 3465 check for duplicate specification at this level. */ 3466 3467static match 3468match_attr_spec (void) 3469{ 3470 /* Modifiers that can exist in a type statement. */ 3471 enum 3472 { GFC_DECL_BEGIN = 0, 3473 DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL, 3474 DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, 3475 DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, 3476 DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, 3477 DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, 3478 DECL_NONE, GFC_DECL_END /* Sentinel */ 3479 }; 3480 3481/* GFC_DECL_END is the sentinel, index starts at 0. */ 3482#define NUM_DECL GFC_DECL_END 3483 3484 locus start, seen_at[NUM_DECL]; 3485 int seen[NUM_DECL]; 3486 unsigned int d; 3487 const char *attr; 3488 match m; 3489 bool t; 3490 3491 gfc_clear_attr (¤t_attr); 3492 start = gfc_current_locus; 3493 3494 current_as = NULL; 3495 colon_seen = 0; 3496 3497 /* See if we get all of the keywords up to the final double colon. */ 3498 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 3499 seen[d] = 0; 3500 3501 for (;;) 3502 { 3503 char ch; 3504 3505 d = DECL_NONE; 3506 gfc_gobble_whitespace (); 3507 3508 ch = gfc_next_ascii_char (); 3509 if (ch == ':') 3510 { 3511 /* This is the successful exit condition for the loop. */ 3512 if (gfc_next_ascii_char () == ':') 3513 break; 3514 } 3515 else if (ch == ',') 3516 { 3517 gfc_gobble_whitespace (); 3518 switch (gfc_peek_ascii_char ()) 3519 { 3520 case 'a': 3521 gfc_next_ascii_char (); 3522 switch (gfc_next_ascii_char ()) 3523 { 3524 case 'l': 3525 if (match_string_p ("locatable")) 3526 { 3527 /* Matched "allocatable". */ 3528 d = DECL_ALLOCATABLE; 3529 } 3530 break; 3531 3532 case 's': 3533 if (match_string_p ("ynchronous")) 3534 { 3535 /* Matched "asynchronous". */ 3536 d = DECL_ASYNCHRONOUS; 3537 } 3538 break; 3539 } 3540 break; 3541 3542 case 'b': 3543 /* Try and match the bind(c). */ 3544 m = gfc_match_bind_c (NULL, true); 3545 if (m == MATCH_YES) 3546 d = DECL_IS_BIND_C; 3547 else if (m == MATCH_ERROR) 3548 goto cleanup; 3549 break; 3550 3551 case 'c': 3552 gfc_next_ascii_char (); 3553 if ('o' != gfc_next_ascii_char ()) 3554 break; 3555 switch (gfc_next_ascii_char ()) 3556 { 3557 case 'd': 3558 if (match_string_p ("imension")) 3559 { 3560 d = DECL_CODIMENSION; 3561 break; 3562 } 3563 case 'n': 3564 if (match_string_p ("tiguous")) 3565 { 3566 d = DECL_CONTIGUOUS; 3567 break; 3568 } 3569 } 3570 break; 3571 3572 case 'd': 3573 if (match_string_p ("dimension")) 3574 d = DECL_DIMENSION; 3575 break; 3576 3577 case 'e': 3578 if (match_string_p ("external")) 3579 d = DECL_EXTERNAL; 3580 break; 3581 3582 case 'i': 3583 if (match_string_p ("int")) 3584 { 3585 ch = gfc_next_ascii_char (); 3586 if (ch == 'e') 3587 { 3588 if (match_string_p ("nt")) 3589 { 3590 /* Matched "intent". */ 3591 /* TODO: Call match_intent_spec from here. */ 3592 if (gfc_match (" ( in out )") == MATCH_YES) 3593 d = DECL_INOUT; 3594 else if (gfc_match (" ( in )") == MATCH_YES) 3595 d = DECL_IN; 3596 else if (gfc_match (" ( out )") == MATCH_YES) 3597 d = DECL_OUT; 3598 } 3599 } 3600 else if (ch == 'r') 3601 { 3602 if (match_string_p ("insic")) 3603 { 3604 /* Matched "intrinsic". */ 3605 d = DECL_INTRINSIC; 3606 } 3607 } 3608 } 3609 break; 3610 3611 case 'o': 3612 if (match_string_p ("optional")) 3613 d = DECL_OPTIONAL; 3614 break; 3615 3616 case 'p': 3617 gfc_next_ascii_char (); 3618 switch (gfc_next_ascii_char ()) 3619 { 3620 case 'a': 3621 if (match_string_p ("rameter")) 3622 { 3623 /* Matched "parameter". */ 3624 d = DECL_PARAMETER; 3625 } 3626 break; 3627 3628 case 'o': 3629 if (match_string_p ("inter")) 3630 { 3631 /* Matched "pointer". */ 3632 d = DECL_POINTER; 3633 } 3634 break; 3635 3636 case 'r': 3637 ch = gfc_next_ascii_char (); 3638 if (ch == 'i') 3639 { 3640 if (match_string_p ("vate")) 3641 { 3642 /* Matched "private". */ 3643 d = DECL_PRIVATE; 3644 } 3645 } 3646 else if (ch == 'o') 3647 { 3648 if (match_string_p ("tected")) 3649 { 3650 /* Matched "protected". */ 3651 d = DECL_PROTECTED; 3652 } 3653 } 3654 break; 3655 3656 case 'u': 3657 if (match_string_p ("blic")) 3658 { 3659 /* Matched "public". */ 3660 d = DECL_PUBLIC; 3661 } 3662 break; 3663 } 3664 break; 3665 3666 case 's': 3667 if (match_string_p ("save")) 3668 d = DECL_SAVE; 3669 break; 3670 3671 case 't': 3672 if (match_string_p ("target")) 3673 d = DECL_TARGET; 3674 break; 3675 3676 case 'v': 3677 gfc_next_ascii_char (); 3678 ch = gfc_next_ascii_char (); 3679 if (ch == 'a') 3680 { 3681 if (match_string_p ("lue")) 3682 { 3683 /* Matched "value". */ 3684 d = DECL_VALUE; 3685 } 3686 } 3687 else if (ch == 'o') 3688 { 3689 if (match_string_p ("latile")) 3690 { 3691 /* Matched "volatile". */ 3692 d = DECL_VOLATILE; 3693 } 3694 } 3695 break; 3696 } 3697 } 3698 3699 /* No double colon and no recognizable decl_type, so assume that 3700 we've been looking at something else the whole time. */ 3701 if (d == DECL_NONE) 3702 { 3703 m = MATCH_NO; 3704 goto cleanup; 3705 } 3706 3707 /* Check to make sure any parens are paired up correctly. */ 3708 if (gfc_match_parens () == MATCH_ERROR) 3709 { 3710 m = MATCH_ERROR; 3711 goto cleanup; 3712 } 3713 3714 seen[d]++; 3715 seen_at[d] = gfc_current_locus; 3716 3717 if (d == DECL_DIMENSION || d == DECL_CODIMENSION) 3718 { 3719 gfc_array_spec *as = NULL; 3720 3721 m = gfc_match_array_spec (&as, d == DECL_DIMENSION, 3722 d == DECL_CODIMENSION); 3723 3724 if (current_as == NULL) 3725 current_as = as; 3726 else if (m == MATCH_YES) 3727 { 3728 if (!merge_array_spec (as, current_as, false)) 3729 m = MATCH_ERROR; 3730 free (as); 3731 } 3732 3733 if (m == MATCH_NO) 3734 { 3735 if (d == DECL_CODIMENSION) 3736 gfc_error ("Missing codimension specification at %C"); 3737 else 3738 gfc_error ("Missing dimension specification at %C"); 3739 m = MATCH_ERROR; 3740 } 3741 3742 if (m == MATCH_ERROR) 3743 goto cleanup; 3744 } 3745 } 3746 3747 /* Since we've seen a double colon, we have to be looking at an 3748 attr-spec. This means that we can now issue errors. */ 3749 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 3750 if (seen[d] > 1) 3751 { 3752 switch (d) 3753 { 3754 case DECL_ALLOCATABLE: 3755 attr = "ALLOCATABLE"; 3756 break; 3757 case DECL_ASYNCHRONOUS: 3758 attr = "ASYNCHRONOUS"; 3759 break; 3760 case DECL_CODIMENSION: 3761 attr = "CODIMENSION"; 3762 break; 3763 case DECL_CONTIGUOUS: 3764 attr = "CONTIGUOUS"; 3765 break; 3766 case DECL_DIMENSION: 3767 attr = "DIMENSION"; 3768 break; 3769 case DECL_EXTERNAL: 3770 attr = "EXTERNAL"; 3771 break; 3772 case DECL_IN: 3773 attr = "INTENT (IN)"; 3774 break; 3775 case DECL_OUT: 3776 attr = "INTENT (OUT)"; 3777 break; 3778 case DECL_INOUT: 3779 attr = "INTENT (IN OUT)"; 3780 break; 3781 case DECL_INTRINSIC: 3782 attr = "INTRINSIC"; 3783 break; 3784 case DECL_OPTIONAL: 3785 attr = "OPTIONAL"; 3786 break; 3787 case DECL_PARAMETER: 3788 attr = "PARAMETER"; 3789 break; 3790 case DECL_POINTER: 3791 attr = "POINTER"; 3792 break; 3793 case DECL_PROTECTED: 3794 attr = "PROTECTED"; 3795 break; 3796 case DECL_PRIVATE: 3797 attr = "PRIVATE"; 3798 break; 3799 case DECL_PUBLIC: 3800 attr = "PUBLIC"; 3801 break; 3802 case DECL_SAVE: 3803 attr = "SAVE"; 3804 break; 3805 case DECL_TARGET: 3806 attr = "TARGET"; 3807 break; 3808 case DECL_IS_BIND_C: 3809 attr = "IS_BIND_C"; 3810 break; 3811 case DECL_VALUE: 3812 attr = "VALUE"; 3813 break; 3814 case DECL_VOLATILE: 3815 attr = "VOLATILE"; 3816 break; 3817 default: 3818 attr = NULL; /* This shouldn't happen. */ 3819 } 3820 3821 gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); 3822 m = MATCH_ERROR; 3823 goto cleanup; 3824 } 3825 3826 /* Now that we've dealt with duplicate attributes, add the attributes 3827 to the current attribute. */ 3828 for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) 3829 { 3830 if (seen[d] == 0) 3831 continue; 3832 3833 if (gfc_current_state () == COMP_DERIVED 3834 && d != DECL_DIMENSION && d != DECL_CODIMENSION 3835 && d != DECL_POINTER && d != DECL_PRIVATE 3836 && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) 3837 { 3838 if (d == DECL_ALLOCATABLE) 3839 { 3840 if (!gfc_notify_std (GFC_STD_F2003, "ALLOCATABLE " 3841 "attribute at %C in a TYPE definition")) 3842 { 3843 m = MATCH_ERROR; 3844 goto cleanup; 3845 } 3846 } 3847 else 3848 { 3849 gfc_error ("Attribute at %L is not allowed in a TYPE definition", 3850 &seen_at[d]); 3851 m = MATCH_ERROR; 3852 goto cleanup; 3853 } 3854 } 3855 3856 if ((d == DECL_PRIVATE || d == DECL_PUBLIC) 3857 && gfc_current_state () != COMP_MODULE) 3858 { 3859 if (d == DECL_PRIVATE) 3860 attr = "PRIVATE"; 3861 else 3862 attr = "PUBLIC"; 3863 if (gfc_current_state () == COMP_DERIVED 3864 && gfc_state_stack->previous 3865 && gfc_state_stack->previous->state == COMP_MODULE) 3866 { 3867 if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s " 3868 "at %L in a TYPE definition", attr, 3869 &seen_at[d])) 3870 { 3871 m = MATCH_ERROR; 3872 goto cleanup; 3873 } 3874 } 3875 else 3876 { 3877 gfc_error ("%s attribute at %L is not allowed outside of the " 3878 "specification part of a module", attr, &seen_at[d]); 3879 m = MATCH_ERROR; 3880 goto cleanup; 3881 } 3882 } 3883 3884 switch (d) 3885 { 3886 case DECL_ALLOCATABLE: 3887 t = gfc_add_allocatable (¤t_attr, &seen_at[d]); 3888 break; 3889 3890 case DECL_ASYNCHRONOUS: 3891 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C")) 3892 t = false; 3893 else 3894 t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); 3895 break; 3896 3897 case DECL_CODIMENSION: 3898 t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); 3899 break; 3900 3901 case DECL_CONTIGUOUS: 3902 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C")) 3903 t = false; 3904 else 3905 t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]); 3906 break; 3907 3908 case DECL_DIMENSION: 3909 t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); 3910 break; 3911 3912 case DECL_EXTERNAL: 3913 t = gfc_add_external (¤t_attr, &seen_at[d]); 3914 break; 3915 3916 case DECL_IN: 3917 t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); 3918 break; 3919 3920 case DECL_OUT: 3921 t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); 3922 break; 3923 3924 case DECL_INOUT: 3925 t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); 3926 break; 3927 3928 case DECL_INTRINSIC: 3929 t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); 3930 break; 3931 3932 case DECL_OPTIONAL: 3933 t = gfc_add_optional (¤t_attr, &seen_at[d]); 3934 break; 3935 3936 case DECL_PARAMETER: 3937 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]); 3938 break; 3939 3940 case DECL_POINTER: 3941 t = gfc_add_pointer (¤t_attr, &seen_at[d]); 3942 break; 3943 3944 case DECL_PROTECTED: 3945 if (gfc_current_state () != COMP_MODULE 3946 || (gfc_current_ns->proc_name 3947 && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) 3948 { 3949 gfc_error ("PROTECTED at %C only allowed in specification " 3950 "part of a module"); 3951 t = false; 3952 break; 3953 } 3954 3955 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C")) 3956 t = false; 3957 else 3958 t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]); 3959 break; 3960 3961 case DECL_PRIVATE: 3962 t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL, 3963 &seen_at[d]); 3964 break; 3965 3966 case DECL_PUBLIC: 3967 t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL, 3968 &seen_at[d]); 3969 break; 3970 3971 case DECL_SAVE: 3972 t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]); 3973 break; 3974 3975 case DECL_TARGET: 3976 t = gfc_add_target (¤t_attr, &seen_at[d]); 3977 break; 3978 3979 case DECL_IS_BIND_C: 3980 t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0); 3981 break; 3982 3983 case DECL_VALUE: 3984 if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C")) 3985 t = false; 3986 else 3987 t = gfc_add_value (¤t_attr, NULL, &seen_at[d]); 3988 break; 3989 3990 case DECL_VOLATILE: 3991 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C")) 3992 t = false; 3993 else 3994 t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]); 3995 break; 3996 3997 default: 3998 gfc_internal_error ("match_attr_spec(): Bad attribute"); 3999 } 4000 4001 if (!t) 4002 { 4003 m = MATCH_ERROR; 4004 goto cleanup; 4005 } 4006 } 4007 4008 /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ 4009 if (gfc_current_state () == COMP_MODULE && !current_attr.save 4010 && (gfc_option.allow_std & GFC_STD_F2008) != 0) 4011 current_attr.save = SAVE_IMPLICIT; 4012 4013 colon_seen = 1; 4014 return MATCH_YES; 4015 4016cleanup: 4017 gfc_current_locus = start; 4018 gfc_free_array_spec (current_as); 4019 current_as = NULL; 4020 return m; 4021} 4022 4023 4024/* Set the binding label, dest_label, either with the binding label 4025 stored in the given gfc_typespec, ts, or if none was provided, it 4026 will be the symbol name in all lower case, as required by the draft 4027 (J3/04-007, section 15.4.1). If a binding label was given and 4028 there is more than one argument (num_idents), it is an error. */ 4029 4030static bool 4031set_binding_label (const char **dest_label, const char *sym_name, 4032 int num_idents) 4033{ 4034 if (num_idents > 1 && has_name_equals) 4035 { 4036 gfc_error ("Multiple identifiers provided with " 4037 "single NAME= specifier at %C"); 4038 return false; 4039 } 4040 4041 if (curr_binding_label) 4042 /* Binding label given; store in temp holder till have sym. */ 4043 *dest_label = curr_binding_label; 4044 else 4045 { 4046 /* No binding label given, and the NAME= specifier did not exist, 4047 which means there was no NAME="". */ 4048 if (sym_name != NULL && has_name_equals == 0) 4049 *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name)); 4050 } 4051 4052 return true; 4053} 4054 4055 4056/* Set the status of the given common block as being BIND(C) or not, 4057 depending on the given parameter, is_bind_c. */ 4058 4059void 4060set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) 4061{ 4062 com_block->is_bind_c = is_bind_c; 4063 return; 4064} 4065 4066 4067/* Verify that the given gfc_typespec is for a C interoperable type. */ 4068 4069bool 4070gfc_verify_c_interop (gfc_typespec *ts) 4071{ 4072 if (ts->type == BT_DERIVED && ts->u.derived != NULL) 4073 return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) 4074 ? true : false; 4075 else if (ts->type == BT_CLASS) 4076 return false; 4077 else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) 4078 return false; 4079 4080 return true; 4081} 4082 4083 4084/* Verify that the variables of a given common block, which has been 4085 defined with the attribute specifier bind(c), to be of a C 4086 interoperable type. Errors will be reported here, if 4087 encountered. */ 4088 4089bool 4090verify_com_block_vars_c_interop (gfc_common_head *com_block) 4091{ 4092 gfc_symbol *curr_sym = NULL; 4093 bool retval = true; 4094 4095 curr_sym = com_block->head; 4096 4097 /* Make sure we have at least one symbol. */ 4098 if (curr_sym == NULL) 4099 return retval; 4100 4101 /* Here we know we have a symbol, so we'll execute this loop 4102 at least once. */ 4103 do 4104 { 4105 /* The second to last param, 1, says this is in a common block. */ 4106 retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); 4107 curr_sym = curr_sym->common_next; 4108 } while (curr_sym != NULL); 4109 4110 return retval; 4111} 4112 4113 4114/* Verify that a given BIND(C) symbol is C interoperable. If it is not, 4115 an appropriate error message is reported. */ 4116 4117bool 4118verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, 4119 int is_in_common, gfc_common_head *com_block) 4120{ 4121 bool bind_c_function = false; 4122 bool retval = true; 4123 4124 if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) 4125 bind_c_function = true; 4126 4127 if (tmp_sym->attr.function && tmp_sym->result != NULL) 4128 { 4129 tmp_sym = tmp_sym->result; 4130 /* Make sure it wasn't an implicitly typed result. */ 4131 if (tmp_sym->attr.implicit_type && warn_c_binding_type) 4132 { 4133 gfc_warning (OPT_Wc_binding_type, 4134 "Implicitly declared BIND(C) function %qs at " 4135 "%L may not be C interoperable", tmp_sym->name, 4136 &tmp_sym->declared_at); 4137 tmp_sym->ts.f90_type = tmp_sym->ts.type; 4138 /* Mark it as C interoperable to prevent duplicate warnings. */ 4139 tmp_sym->ts.is_c_interop = 1; 4140 tmp_sym->attr.is_c_interop = 1; 4141 } 4142 } 4143 4144 /* Here, we know we have the bind(c) attribute, so if we have 4145 enough type info, then verify that it's a C interop kind. 4146 The info could be in the symbol already, or possibly still in 4147 the given ts (current_ts), so look in both. */ 4148 if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 4149 { 4150 if (!gfc_verify_c_interop (&(tmp_sym->ts))) 4151 { 4152 /* See if we're dealing with a sym in a common block or not. */ 4153 if (is_in_common == 1 && warn_c_binding_type) 4154 { 4155 gfc_warning (OPT_Wc_binding_type, 4156 "Variable %qs in common block %qs at %L " 4157 "may not be a C interoperable " 4158 "kind though common block %qs is BIND(C)", 4159 tmp_sym->name, com_block->name, 4160 &(tmp_sym->declared_at), com_block->name); 4161 } 4162 else 4163 { 4164 if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED) 4165 gfc_error ("Type declaration %qs at %L is not C " 4166 "interoperable but it is BIND(C)", 4167 tmp_sym->name, &(tmp_sym->declared_at)); 4168 else if (warn_c_binding_type) 4169 gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " 4170 "may not be a C interoperable " 4171 "kind but it is BIND(C)", 4172 tmp_sym->name, &(tmp_sym->declared_at)); 4173 } 4174 } 4175 4176 /* Variables declared w/in a common block can't be bind(c) 4177 since there's no way for C to see these variables, so there's 4178 semantically no reason for the attribute. */ 4179 if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) 4180 { 4181 gfc_error ("Variable %qs in common block %qs at " 4182 "%L cannot be declared with BIND(C) " 4183 "since it is not a global", 4184 tmp_sym->name, com_block->name, 4185 &(tmp_sym->declared_at)); 4186 retval = false; 4187 } 4188 4189 /* Scalar variables that are bind(c) can not have the pointer 4190 or allocatable attributes. */ 4191 if (tmp_sym->attr.is_bind_c == 1) 4192 { 4193 if (tmp_sym->attr.pointer == 1) 4194 { 4195 gfc_error ("Variable %qs at %L cannot have both the " 4196 "POINTER and BIND(C) attributes", 4197 tmp_sym->name, &(tmp_sym->declared_at)); 4198 retval = false; 4199 } 4200 4201 if (tmp_sym->attr.allocatable == 1) 4202 { 4203 gfc_error ("Variable %qs at %L cannot have both the " 4204 "ALLOCATABLE and BIND(C) attributes", 4205 tmp_sym->name, &(tmp_sym->declared_at)); 4206 retval = false; 4207 } 4208 4209 } 4210 4211 /* If it is a BIND(C) function, make sure the return value is a 4212 scalar value. The previous tests in this function made sure 4213 the type is interoperable. */ 4214 if (bind_c_function && tmp_sym->as != NULL) 4215 gfc_error ("Return type of BIND(C) function %qs at %L cannot " 4216 "be an array", tmp_sym->name, &(tmp_sym->declared_at)); 4217 4218 /* BIND(C) functions can not return a character string. */ 4219 if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) 4220 if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL 4221 || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT 4222 || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0) 4223 gfc_error ("Return type of BIND(C) function %qs at %L cannot " 4224 "be a character string", tmp_sym->name, 4225 &(tmp_sym->declared_at)); 4226 } 4227 4228 /* See if the symbol has been marked as private. If it has, make sure 4229 there is no binding label and warn the user if there is one. */ 4230 if (tmp_sym->attr.access == ACCESS_PRIVATE 4231 && tmp_sym->binding_label) 4232 /* Use gfc_warning_now because we won't say that the symbol fails 4233 just because of this. */ 4234 gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " 4235 "given the binding label %qs", tmp_sym->name, 4236 &(tmp_sym->declared_at), tmp_sym->binding_label); 4237 4238 return retval; 4239} 4240 4241 4242/* Set the appropriate fields for a symbol that's been declared as 4243 BIND(C) (the is_bind_c flag and the binding label), and verify that 4244 the type is C interoperable. Errors are reported by the functions 4245 used to set/test these fields. */ 4246 4247bool 4248set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) 4249{ 4250 bool retval = true; 4251 4252 /* TODO: Do we need to make sure the vars aren't marked private? */ 4253 4254 /* Set the is_bind_c bit in symbol_attribute. */ 4255 gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); 4256 4257 if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents)) 4258 return false; 4259 4260 return retval; 4261} 4262 4263 4264/* Set the fields marking the given common block as BIND(C), including 4265 a binding label, and report any errors encountered. */ 4266 4267bool 4268set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) 4269{ 4270 bool retval = true; 4271 4272 /* destLabel, common name, typespec (which may have binding label). */ 4273 if (!set_binding_label (&com_block->binding_label, com_block->name, 4274 num_idents)) 4275 return false; 4276 4277 /* Set the given common block (com_block) to being bind(c) (1). */ 4278 set_com_block_bind_c (com_block, 1); 4279 4280 return retval; 4281} 4282 4283 4284/* Retrieve the list of one or more identifiers that the given bind(c) 4285 attribute applies to. */ 4286 4287bool 4288get_bind_c_idents (void) 4289{ 4290 char name[GFC_MAX_SYMBOL_LEN + 1]; 4291 int num_idents = 0; 4292 gfc_symbol *tmp_sym = NULL; 4293 match found_id; 4294 gfc_common_head *com_block = NULL; 4295 4296 if (gfc_match_name (name) == MATCH_YES) 4297 { 4298 found_id = MATCH_YES; 4299 gfc_get_ha_symbol (name, &tmp_sym); 4300 } 4301 else if (match_common_name (name) == MATCH_YES) 4302 { 4303 found_id = MATCH_YES; 4304 com_block = gfc_get_common (name, 0); 4305 } 4306 else 4307 { 4308 gfc_error ("Need either entity or common block name for " 4309 "attribute specification statement at %C"); 4310 return false; 4311 } 4312 4313 /* Save the current identifier and look for more. */ 4314 do 4315 { 4316 /* Increment the number of identifiers found for this spec stmt. */ 4317 num_idents++; 4318 4319 /* Make sure we have a sym or com block, and verify that it can 4320 be bind(c). Set the appropriate field(s) and look for more 4321 identifiers. */ 4322 if (tmp_sym != NULL || com_block != NULL) 4323 { 4324 if (tmp_sym != NULL) 4325 { 4326 if (!set_verify_bind_c_sym (tmp_sym, num_idents)) 4327 return false; 4328 } 4329 else 4330 { 4331 if (!set_verify_bind_c_com_block (com_block, num_idents)) 4332 return false; 4333 } 4334 4335 /* Look to see if we have another identifier. */ 4336 tmp_sym = NULL; 4337 if (gfc_match_eos () == MATCH_YES) 4338 found_id = MATCH_NO; 4339 else if (gfc_match_char (',') != MATCH_YES) 4340 found_id = MATCH_NO; 4341 else if (gfc_match_name (name) == MATCH_YES) 4342 { 4343 found_id = MATCH_YES; 4344 gfc_get_ha_symbol (name, &tmp_sym); 4345 } 4346 else if (match_common_name (name) == MATCH_YES) 4347 { 4348 found_id = MATCH_YES; 4349 com_block = gfc_get_common (name, 0); 4350 } 4351 else 4352 { 4353 gfc_error ("Missing entity or common block name for " 4354 "attribute specification statement at %C"); 4355 return false; 4356 } 4357 } 4358 else 4359 { 4360 gfc_internal_error ("Missing symbol"); 4361 } 4362 } while (found_id == MATCH_YES); 4363 4364 /* if we get here we were successful */ 4365 return true; 4366} 4367 4368 4369/* Try and match a BIND(C) attribute specification statement. */ 4370 4371match 4372gfc_match_bind_c_stmt (void) 4373{ 4374 match found_match = MATCH_NO; 4375 gfc_typespec *ts; 4376 4377 ts = ¤t_ts; 4378 4379 /* This may not be necessary. */ 4380 gfc_clear_ts (ts); 4381 /* Clear the temporary binding label holder. */ 4382 curr_binding_label = NULL; 4383 4384 /* Look for the bind(c). */ 4385 found_match = gfc_match_bind_c (NULL, true); 4386 4387 if (found_match == MATCH_YES) 4388 { 4389 if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C")) 4390 return MATCH_ERROR; 4391 4392 /* Look for the :: now, but it is not required. */ 4393 gfc_match (" :: "); 4394 4395 /* Get the identifier(s) that needs to be updated. This may need to 4396 change to hand the flag(s) for the attr specified so all identifiers 4397 found can have all appropriate parts updated (assuming that the same 4398 spec stmt can have multiple attrs, such as both bind(c) and 4399 allocatable...). */ 4400 if (!get_bind_c_idents ()) 4401 /* Error message should have printed already. */ 4402 return MATCH_ERROR; 4403 } 4404 4405 return found_match; 4406} 4407 4408 4409/* Match a data declaration statement. */ 4410 4411match 4412gfc_match_data_decl (void) 4413{ 4414 gfc_symbol *sym; 4415 match m; 4416 int elem; 4417 4418 num_idents_on_line = 0; 4419 4420 m = gfc_match_decl_type_spec (¤t_ts, 0); 4421 if (m != MATCH_YES) 4422 return m; 4423 4424 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 4425 && gfc_current_state () != COMP_DERIVED) 4426 { 4427 sym = gfc_use_derived (current_ts.u.derived); 4428 4429 if (sym == NULL) 4430 { 4431 m = MATCH_ERROR; 4432 goto cleanup; 4433 } 4434 4435 current_ts.u.derived = sym; 4436 } 4437 4438 m = match_attr_spec (); 4439 if (m == MATCH_ERROR) 4440 { 4441 m = MATCH_NO; 4442 goto cleanup; 4443 } 4444 4445 if (current_ts.type == BT_CLASS 4446 && current_ts.u.derived->attr.unlimited_polymorphic) 4447 goto ok; 4448 4449 if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) 4450 && current_ts.u.derived->components == NULL 4451 && !current_ts.u.derived->attr.zero_comp) 4452 { 4453 4454 if (current_attr.pointer && gfc_current_state () == COMP_DERIVED) 4455 goto ok; 4456 4457 gfc_find_symbol (current_ts.u.derived->name, 4458 current_ts.u.derived->ns, 1, &sym); 4459 4460 /* Any symbol that we find had better be a type definition 4461 which has its components defined. */ 4462 if (sym != NULL && sym->attr.flavor == FL_DERIVED 4463 && (current_ts.u.derived->components != NULL 4464 || current_ts.u.derived->attr.zero_comp)) 4465 goto ok; 4466 4467 gfc_error ("Derived type at %C has not been previously defined " 4468 "and so cannot appear in a derived type definition"); 4469 m = MATCH_ERROR; 4470 goto cleanup; 4471 } 4472 4473ok: 4474 /* If we have an old-style character declaration, and no new-style 4475 attribute specifications, then there a comma is optional between 4476 the type specification and the variable list. */ 4477 if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) 4478 gfc_match_char (','); 4479 4480 /* Give the types/attributes to symbols that follow. Give the element 4481 a number so that repeat character length expressions can be copied. */ 4482 elem = 1; 4483 for (;;) 4484 { 4485 num_idents_on_line++; 4486 m = variable_decl (elem++); 4487 if (m == MATCH_ERROR) 4488 goto cleanup; 4489 if (m == MATCH_NO) 4490 break; 4491 4492 if (gfc_match_eos () == MATCH_YES) 4493 goto cleanup; 4494 if (gfc_match_char (',') != MATCH_YES) 4495 break; 4496 } 4497 4498 if (!gfc_error_flag_test ()) 4499 gfc_error ("Syntax error in data declaration at %C"); 4500 m = MATCH_ERROR; 4501 4502 gfc_free_data_all (gfc_current_ns); 4503 4504cleanup: 4505 gfc_free_array_spec (current_as); 4506 current_as = NULL; 4507 return m; 4508} 4509 4510 4511/* Match a prefix associated with a function or subroutine 4512 declaration. If the typespec pointer is nonnull, then a typespec 4513 can be matched. Note that if nothing matches, MATCH_YES is 4514 returned (the null string was matched). */ 4515 4516match 4517gfc_match_prefix (gfc_typespec *ts) 4518{ 4519 bool seen_type; 4520 bool seen_impure; 4521 bool found_prefix; 4522 4523 gfc_clear_attr (¤t_attr); 4524 seen_type = false; 4525 seen_impure = false; 4526 4527 gcc_assert (!gfc_matching_prefix); 4528 gfc_matching_prefix = true; 4529 4530 do 4531 { 4532 found_prefix = false; 4533 4534 if (!seen_type && ts != NULL 4535 && gfc_match_decl_type_spec (ts, 0) == MATCH_YES 4536 && gfc_match_space () == MATCH_YES) 4537 { 4538 4539 seen_type = true; 4540 found_prefix = true; 4541 } 4542 4543 if (gfc_match ("elemental% ") == MATCH_YES) 4544 { 4545 if (!gfc_add_elemental (¤t_attr, NULL)) 4546 goto error; 4547 4548 found_prefix = true; 4549 } 4550 4551 if (gfc_match ("pure% ") == MATCH_YES) 4552 { 4553 if (!gfc_add_pure (¤t_attr, NULL)) 4554 goto error; 4555 4556 found_prefix = true; 4557 } 4558 4559 if (gfc_match ("recursive% ") == MATCH_YES) 4560 { 4561 if (!gfc_add_recursive (¤t_attr, NULL)) 4562 goto error; 4563 4564 found_prefix = true; 4565 } 4566 4567 /* IMPURE is a somewhat special case, as it needs not set an actual 4568 attribute but rather only prevents ELEMENTAL routines from being 4569 automatically PURE. */ 4570 if (gfc_match ("impure% ") == MATCH_YES) 4571 { 4572 if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C")) 4573 goto error; 4574 4575 seen_impure = true; 4576 found_prefix = true; 4577 } 4578 } 4579 while (found_prefix); 4580 4581 /* IMPURE and PURE must not both appear, of course. */ 4582 if (seen_impure && current_attr.pure) 4583 { 4584 gfc_error ("PURE and IMPURE must not appear both at %C"); 4585 goto error; 4586 } 4587 4588 /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */ 4589 if (!seen_impure && current_attr.elemental && !current_attr.pure) 4590 { 4591 if (!gfc_add_pure (¤t_attr, NULL)) 4592 goto error; 4593 } 4594 4595 /* At this point, the next item is not a prefix. */ 4596 gcc_assert (gfc_matching_prefix); 4597 gfc_matching_prefix = false; 4598 return MATCH_YES; 4599 4600error: 4601 gcc_assert (gfc_matching_prefix); 4602 gfc_matching_prefix = false; 4603 return MATCH_ERROR; 4604} 4605 4606 4607/* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */ 4608 4609static bool 4610copy_prefix (symbol_attribute *dest, locus *where) 4611{ 4612 if (current_attr.pure && !gfc_add_pure (dest, where)) 4613 return false; 4614 4615 if (current_attr.elemental && !gfc_add_elemental (dest, where)) 4616 return false; 4617 4618 if (current_attr.recursive && !gfc_add_recursive (dest, where)) 4619 return false; 4620 4621 return true; 4622} 4623 4624 4625/* Match a formal argument list. */ 4626 4627match 4628gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag) 4629{ 4630 gfc_formal_arglist *head, *tail, *p, *q; 4631 char name[GFC_MAX_SYMBOL_LEN + 1]; 4632 gfc_symbol *sym; 4633 match m; 4634 4635 head = tail = NULL; 4636 4637 if (gfc_match_char ('(') != MATCH_YES) 4638 { 4639 if (null_flag) 4640 goto ok; 4641 return MATCH_NO; 4642 } 4643 4644 if (gfc_match_char (')') == MATCH_YES) 4645 goto ok; 4646 4647 for (;;) 4648 { 4649 if (gfc_match_char ('*') == MATCH_YES) 4650 { 4651 sym = NULL; 4652 if (!gfc_notify_std (GFC_STD_F95_OBS, "Alternate-return argument " 4653 "at %C")) 4654 { 4655 m = MATCH_ERROR; 4656 goto cleanup; 4657 } 4658 } 4659 else 4660 { 4661 m = gfc_match_name (name); 4662 if (m != MATCH_YES) 4663 goto cleanup; 4664 4665 if (gfc_get_symbol (name, NULL, &sym)) 4666 goto cleanup; 4667 } 4668 4669 p = gfc_get_formal_arglist (); 4670 4671 if (head == NULL) 4672 head = tail = p; 4673 else 4674 { 4675 tail->next = p; 4676 tail = p; 4677 } 4678 4679 tail->sym = sym; 4680 4681 /* We don't add the VARIABLE flavor because the name could be a 4682 dummy procedure. We don't apply these attributes to formal 4683 arguments of statement functions. */ 4684 if (sym != NULL && !st_flag 4685 && (!gfc_add_dummy(&sym->attr, sym->name, NULL) 4686 || !gfc_missing_attr (&sym->attr, NULL))) 4687 { 4688 m = MATCH_ERROR; 4689 goto cleanup; 4690 } 4691 4692 /* The name of a program unit can be in a different namespace, 4693 so check for it explicitly. After the statement is accepted, 4694 the name is checked for especially in gfc_get_symbol(). */ 4695 if (gfc_new_block != NULL && sym != NULL 4696 && strcmp (sym->name, gfc_new_block->name) == 0) 4697 { 4698 gfc_error ("Name %qs at %C is the name of the procedure", 4699 sym->name); 4700 m = MATCH_ERROR; 4701 goto cleanup; 4702 } 4703 4704 if (gfc_match_char (')') == MATCH_YES) 4705 goto ok; 4706 4707 m = gfc_match_char (','); 4708 if (m != MATCH_YES) 4709 { 4710 gfc_error ("Unexpected junk in formal argument list at %C"); 4711 goto cleanup; 4712 } 4713 } 4714 4715ok: 4716 /* Check for duplicate symbols in the formal argument list. */ 4717 if (head != NULL) 4718 { 4719 for (p = head; p->next; p = p->next) 4720 { 4721 if (p->sym == NULL) 4722 continue; 4723 4724 for (q = p->next; q; q = q->next) 4725 if (p->sym == q->sym) 4726 { 4727 gfc_error ("Duplicate symbol %qs in formal argument list " 4728 "at %C", p->sym->name); 4729 4730 m = MATCH_ERROR; 4731 goto cleanup; 4732 } 4733 } 4734 } 4735 4736 if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)) 4737 { 4738 m = MATCH_ERROR; 4739 goto cleanup; 4740 } 4741 4742 return MATCH_YES; 4743 4744cleanup: 4745 gfc_free_formal_arglist (head); 4746 return m; 4747} 4748 4749 4750/* Match a RESULT specification following a function declaration or 4751 ENTRY statement. Also matches the end-of-statement. */ 4752 4753static match 4754match_result (gfc_symbol *function, gfc_symbol **result) 4755{ 4756 char name[GFC_MAX_SYMBOL_LEN + 1]; 4757 gfc_symbol *r; 4758 match m; 4759 4760 if (gfc_match (" result (") != MATCH_YES) 4761 return MATCH_NO; 4762 4763 m = gfc_match_name (name); 4764 if (m != MATCH_YES) 4765 return m; 4766 4767 /* Get the right paren, and that's it because there could be the 4768 bind(c) attribute after the result clause. */ 4769 if (gfc_match_char (')') != MATCH_YES) 4770 { 4771 /* TODO: should report the missing right paren here. */ 4772 return MATCH_ERROR; 4773 } 4774 4775 if (strcmp (function->name, name) == 0) 4776 { 4777 gfc_error ("RESULT variable at %C must be different than function name"); 4778 return MATCH_ERROR; 4779 } 4780 4781 if (gfc_get_symbol (name, NULL, &r)) 4782 return MATCH_ERROR; 4783 4784 if (!gfc_add_result (&r->attr, r->name, NULL)) 4785 return MATCH_ERROR; 4786 4787 *result = r; 4788 4789 return MATCH_YES; 4790} 4791 4792 4793/* Match a function suffix, which could be a combination of a result 4794 clause and BIND(C), either one, or neither. The draft does not 4795 require them to come in a specific order. */ 4796 4797match 4798gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result) 4799{ 4800 match is_bind_c; /* Found bind(c). */ 4801 match is_result; /* Found result clause. */ 4802 match found_match; /* Status of whether we've found a good match. */ 4803 char peek_char; /* Character we're going to peek at. */ 4804 bool allow_binding_name; 4805 4806 /* Initialize to having found nothing. */ 4807 found_match = MATCH_NO; 4808 is_bind_c = MATCH_NO; 4809 is_result = MATCH_NO; 4810 4811 /* Get the next char to narrow between result and bind(c). */ 4812 gfc_gobble_whitespace (); 4813 peek_char = gfc_peek_ascii_char (); 4814 4815 /* C binding names are not allowed for internal procedures. */ 4816 if (gfc_current_state () == COMP_CONTAINS 4817 && sym->ns->proc_name->attr.flavor != FL_MODULE) 4818 allow_binding_name = false; 4819 else 4820 allow_binding_name = true; 4821 4822 switch (peek_char) 4823 { 4824 case 'r': 4825 /* Look for result clause. */ 4826 is_result = match_result (sym, result); 4827 if (is_result == MATCH_YES) 4828 { 4829 /* Now see if there is a bind(c) after it. */ 4830 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 4831 /* We've found the result clause and possibly bind(c). */ 4832 found_match = MATCH_YES; 4833 } 4834 else 4835 /* This should only be MATCH_ERROR. */ 4836 found_match = is_result; 4837 break; 4838 case 'b': 4839 /* Look for bind(c) first. */ 4840 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 4841 if (is_bind_c == MATCH_YES) 4842 { 4843 /* Now see if a result clause followed it. */ 4844 is_result = match_result (sym, result); 4845 found_match = MATCH_YES; 4846 } 4847 else 4848 { 4849 /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */ 4850 found_match = MATCH_ERROR; 4851 } 4852 break; 4853 default: 4854 gfc_error ("Unexpected junk after function declaration at %C"); 4855 found_match = MATCH_ERROR; 4856 break; 4857 } 4858 4859 if (is_bind_c == MATCH_YES) 4860 { 4861 /* Fortran 2008 draft allows BIND(C) for internal procedures. */ 4862 if (gfc_current_state () == COMP_CONTAINS 4863 && sym->ns->proc_name->attr.flavor != FL_MODULE 4864 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " 4865 "at %L may not be specified for an internal " 4866 "procedure", &gfc_current_locus)) 4867 return MATCH_ERROR; 4868 4869 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)) 4870 return MATCH_ERROR; 4871 } 4872 4873 return found_match; 4874} 4875 4876 4877/* Procedure pointer return value without RESULT statement: 4878 Add "hidden" result variable named "ppr@". */ 4879 4880static bool 4881add_hidden_procptr_result (gfc_symbol *sym) 4882{ 4883 bool case1,case2; 4884 4885 if (gfc_notification_std (GFC_STD_F2003) == ERROR) 4886 return false; 4887 4888 /* First usage case: PROCEDURE and EXTERNAL statements. */ 4889 case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block () 4890 && strcmp (gfc_current_block ()->name, sym->name) == 0 4891 && sym->attr.external; 4892 /* Second usage case: INTERFACE statements. */ 4893 case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous 4894 && gfc_state_stack->previous->state == COMP_FUNCTION 4895 && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0; 4896 4897 if (case1 || case2) 4898 { 4899 gfc_symtree *stree; 4900 if (case1) 4901 gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false); 4902 else if (case2) 4903 { 4904 gfc_symtree *st2; 4905 gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false); 4906 st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@"); 4907 st2->n.sym = stree->n.sym; 4908 } 4909 sym->result = stree->n.sym; 4910 4911 sym->result->attr.proc_pointer = sym->attr.proc_pointer; 4912 sym->result->attr.pointer = sym->attr.pointer; 4913 sym->result->attr.external = sym->attr.external; 4914 sym->result->attr.referenced = sym->attr.referenced; 4915 sym->result->ts = sym->ts; 4916 sym->attr.proc_pointer = 0; 4917 sym->attr.pointer = 0; 4918 sym->attr.external = 0; 4919 if (sym->result->attr.external && sym->result->attr.pointer) 4920 { 4921 sym->result->attr.pointer = 0; 4922 sym->result->attr.proc_pointer = 1; 4923 } 4924 4925 return gfc_add_result (&sym->result->attr, sym->result->name, NULL); 4926 } 4927 /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */ 4928 else if (sym->attr.function && !sym->attr.external && sym->attr.pointer 4929 && sym->result && sym->result != sym && sym->result->attr.external 4930 && sym == gfc_current_ns->proc_name 4931 && sym == sym->result->ns->proc_name 4932 && strcmp ("ppr@", sym->result->name) == 0) 4933 { 4934 sym->result->attr.proc_pointer = 1; 4935 sym->attr.pointer = 0; 4936 return true; 4937 } 4938 else 4939 return false; 4940} 4941 4942 4943/* Match the interface for a PROCEDURE declaration, 4944 including brackets (R1212). */ 4945 4946static match 4947match_procedure_interface (gfc_symbol **proc_if) 4948{ 4949 match m; 4950 gfc_symtree *st; 4951 locus old_loc, entry_loc; 4952 gfc_namespace *old_ns = gfc_current_ns; 4953 char name[GFC_MAX_SYMBOL_LEN + 1]; 4954 4955 old_loc = entry_loc = gfc_current_locus; 4956 gfc_clear_ts (¤t_ts); 4957 4958 if (gfc_match (" (") != MATCH_YES) 4959 { 4960 gfc_current_locus = entry_loc; 4961 return MATCH_NO; 4962 } 4963 4964 /* Get the type spec. for the procedure interface. */ 4965 old_loc = gfc_current_locus; 4966 m = gfc_match_decl_type_spec (¤t_ts, 0); 4967 gfc_gobble_whitespace (); 4968 if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')')) 4969 goto got_ts; 4970 4971 if (m == MATCH_ERROR) 4972 return m; 4973 4974 /* Procedure interface is itself a procedure. */ 4975 gfc_current_locus = old_loc; 4976 m = gfc_match_name (name); 4977 4978 /* First look to see if it is already accessible in the current 4979 namespace because it is use associated or contained. */ 4980 st = NULL; 4981 if (gfc_find_sym_tree (name, NULL, 0, &st)) 4982 return MATCH_ERROR; 4983 4984 /* If it is still not found, then try the parent namespace, if it 4985 exists and create the symbol there if it is still not found. */ 4986 if (gfc_current_ns->parent) 4987 gfc_current_ns = gfc_current_ns->parent; 4988 if (st == NULL && gfc_get_ha_sym_tree (name, &st)) 4989 return MATCH_ERROR; 4990 4991 gfc_current_ns = old_ns; 4992 *proc_if = st->n.sym; 4993 4994 if (*proc_if) 4995 { 4996 (*proc_if)->refs++; 4997 /* Resolve interface if possible. That way, attr.procedure is only set 4998 if it is declared by a later procedure-declaration-stmt, which is 4999 invalid per F08:C1216 (cf. resolve_procedure_interface). */ 5000 while ((*proc_if)->ts.interface) 5001 *proc_if = (*proc_if)->ts.interface; 5002 5003 if ((*proc_if)->attr.flavor == FL_UNKNOWN 5004 && (*proc_if)->ts.type == BT_UNKNOWN 5005 && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE, 5006 (*proc_if)->name, NULL)) 5007 return MATCH_ERROR; 5008 } 5009 5010got_ts: 5011 if (gfc_match (" )") != MATCH_YES) 5012 { 5013 gfc_current_locus = entry_loc; 5014 return MATCH_NO; 5015 } 5016 5017 return MATCH_YES; 5018} 5019 5020 5021/* Match a PROCEDURE declaration (R1211). */ 5022 5023static match 5024match_procedure_decl (void) 5025{ 5026 match m; 5027 gfc_symbol *sym, *proc_if = NULL; 5028 int num; 5029 gfc_expr *initializer = NULL; 5030 5031 /* Parse interface (with brackets). */ 5032 m = match_procedure_interface (&proc_if); 5033 if (m != MATCH_YES) 5034 return m; 5035 5036 /* Parse attributes (with colons). */ 5037 m = match_attr_spec(); 5038 if (m == MATCH_ERROR) 5039 return MATCH_ERROR; 5040 5041 if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c) 5042 { 5043 current_attr.is_bind_c = 1; 5044 has_name_equals = 0; 5045 curr_binding_label = NULL; 5046 } 5047 5048 /* Get procedure symbols. */ 5049 for(num=1;;num++) 5050 { 5051 m = gfc_match_symbol (&sym, 0); 5052 if (m == MATCH_NO) 5053 goto syntax; 5054 else if (m == MATCH_ERROR) 5055 return m; 5056 5057 /* Add current_attr to the symbol attributes. */ 5058 if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL)) 5059 return MATCH_ERROR; 5060 5061 if (sym->attr.is_bind_c) 5062 { 5063 /* Check for C1218. */ 5064 if (!proc_if || !proc_if->attr.is_bind_c) 5065 { 5066 gfc_error ("BIND(C) attribute at %C requires " 5067 "an interface with BIND(C)"); 5068 return MATCH_ERROR; 5069 } 5070 /* Check for C1217. */ 5071 if (has_name_equals && sym->attr.pointer) 5072 { 5073 gfc_error ("BIND(C) procedure with NAME may not have " 5074 "POINTER attribute at %C"); 5075 return MATCH_ERROR; 5076 } 5077 if (has_name_equals && sym->attr.dummy) 5078 { 5079 gfc_error ("Dummy procedure at %C may not have " 5080 "BIND(C) attribute with NAME"); 5081 return MATCH_ERROR; 5082 } 5083 /* Set binding label for BIND(C). */ 5084 if (!set_binding_label (&sym->binding_label, sym->name, num)) 5085 return MATCH_ERROR; 5086 } 5087 5088 if (!gfc_add_external (&sym->attr, NULL)) 5089 return MATCH_ERROR; 5090 5091 if (add_hidden_procptr_result (sym)) 5092 sym = sym->result; 5093 5094 if (!gfc_add_proc (&sym->attr, sym->name, NULL)) 5095 return MATCH_ERROR; 5096 5097 /* Set interface. */ 5098 if (proc_if != NULL) 5099 { 5100 if (sym->ts.type != BT_UNKNOWN) 5101 { 5102 gfc_error ("Procedure %qs at %L already has basic type of %s", 5103 sym->name, &gfc_current_locus, 5104 gfc_basic_typename (sym->ts.type)); 5105 return MATCH_ERROR; 5106 } 5107 sym->ts.interface = proc_if; 5108 sym->attr.untyped = 1; 5109 sym->attr.if_source = IFSRC_IFBODY; 5110 } 5111 else if (current_ts.type != BT_UNKNOWN) 5112 { 5113 if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) 5114 return MATCH_ERROR; 5115 sym->ts.interface = gfc_new_symbol ("", gfc_current_ns); 5116 sym->ts.interface->ts = current_ts; 5117 sym->ts.interface->attr.flavor = FL_PROCEDURE; 5118 sym->ts.interface->attr.function = 1; 5119 sym->attr.function = 1; 5120 sym->attr.if_source = IFSRC_UNKNOWN; 5121 } 5122 5123 if (gfc_match (" =>") == MATCH_YES) 5124 { 5125 if (!current_attr.pointer) 5126 { 5127 gfc_error ("Initialization at %C isn't for a pointer variable"); 5128 m = MATCH_ERROR; 5129 goto cleanup; 5130 } 5131 5132 m = match_pointer_init (&initializer, 1); 5133 if (m != MATCH_YES) 5134 goto cleanup; 5135 5136 if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus)) 5137 goto cleanup; 5138 5139 } 5140 5141 if (gfc_match_eos () == MATCH_YES) 5142 return MATCH_YES; 5143 if (gfc_match_char (',') != MATCH_YES) 5144 goto syntax; 5145 } 5146 5147syntax: 5148 gfc_error ("Syntax error in PROCEDURE statement at %C"); 5149 return MATCH_ERROR; 5150 5151cleanup: 5152 /* Free stuff up and return. */ 5153 gfc_free_expr (initializer); 5154 return m; 5155} 5156 5157 5158static match 5159match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc); 5160 5161 5162/* Match a procedure pointer component declaration (R445). */ 5163 5164static match 5165match_ppc_decl (void) 5166{ 5167 match m; 5168 gfc_symbol *proc_if = NULL; 5169 gfc_typespec ts; 5170 int num; 5171 gfc_component *c; 5172 gfc_expr *initializer = NULL; 5173 gfc_typebound_proc* tb; 5174 char name[GFC_MAX_SYMBOL_LEN + 1]; 5175 5176 /* Parse interface (with brackets). */ 5177 m = match_procedure_interface (&proc_if); 5178 if (m != MATCH_YES) 5179 goto syntax; 5180 5181 /* Parse attributes. */ 5182 tb = XCNEW (gfc_typebound_proc); 5183 tb->where = gfc_current_locus; 5184 m = match_binding_attributes (tb, false, true); 5185 if (m == MATCH_ERROR) 5186 return m; 5187 5188 gfc_clear_attr (¤t_attr); 5189 current_attr.procedure = 1; 5190 current_attr.proc_pointer = 1; 5191 current_attr.access = tb->access; 5192 current_attr.flavor = FL_PROCEDURE; 5193 5194 /* Match the colons (required). */ 5195 if (gfc_match (" ::") != MATCH_YES) 5196 { 5197 gfc_error ("Expected %<::%> after binding-attributes at %C"); 5198 return MATCH_ERROR; 5199 } 5200 5201 /* Check for C450. */ 5202 if (!tb->nopass && proc_if == NULL) 5203 { 5204 gfc_error("NOPASS or explicit interface required at %C"); 5205 return MATCH_ERROR; 5206 } 5207 5208 if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C")) 5209 return MATCH_ERROR; 5210 5211 /* Match PPC names. */ 5212 ts = current_ts; 5213 for(num=1;;num++) 5214 { 5215 m = gfc_match_name (name); 5216 if (m == MATCH_NO) 5217 goto syntax; 5218 else if (m == MATCH_ERROR) 5219 return m; 5220 5221 if (!gfc_add_component (gfc_current_block(), name, &c)) 5222 return MATCH_ERROR; 5223 5224 /* Add current_attr to the symbol attributes. */ 5225 if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL)) 5226 return MATCH_ERROR; 5227 5228 if (!gfc_add_external (&c->attr, NULL)) 5229 return MATCH_ERROR; 5230 5231 if (!gfc_add_proc (&c->attr, name, NULL)) 5232 return MATCH_ERROR; 5233 5234 if (num == 1) 5235 c->tb = tb; 5236 else 5237 { 5238 c->tb = XCNEW (gfc_typebound_proc); 5239 c->tb->where = gfc_current_locus; 5240 *c->tb = *tb; 5241 } 5242 5243 /* Set interface. */ 5244 if (proc_if != NULL) 5245 { 5246 c->ts.interface = proc_if; 5247 c->attr.untyped = 1; 5248 c->attr.if_source = IFSRC_IFBODY; 5249 } 5250 else if (ts.type != BT_UNKNOWN) 5251 { 5252 c->ts = ts; 5253 c->ts.interface = gfc_new_symbol ("", gfc_current_ns); 5254 c->ts.interface->result = c->ts.interface; 5255 c->ts.interface->ts = ts; 5256 c->ts.interface->attr.flavor = FL_PROCEDURE; 5257 c->ts.interface->attr.function = 1; 5258 c->attr.function = 1; 5259 c->attr.if_source = IFSRC_UNKNOWN; 5260 } 5261 5262 if (gfc_match (" =>") == MATCH_YES) 5263 { 5264 m = match_pointer_init (&initializer, 1); 5265 if (m != MATCH_YES) 5266 { 5267 gfc_free_expr (initializer); 5268 return m; 5269 } 5270 c->initializer = initializer; 5271 } 5272 5273 if (gfc_match_eos () == MATCH_YES) 5274 return MATCH_YES; 5275 if (gfc_match_char (',') != MATCH_YES) 5276 goto syntax; 5277 } 5278 5279syntax: 5280 gfc_error ("Syntax error in procedure pointer component at %C"); 5281 return MATCH_ERROR; 5282} 5283 5284 5285/* Match a PROCEDURE declaration inside an interface (R1206). */ 5286 5287static match 5288match_procedure_in_interface (void) 5289{ 5290 match m; 5291 gfc_symbol *sym; 5292 char name[GFC_MAX_SYMBOL_LEN + 1]; 5293 locus old_locus; 5294 5295 if (current_interface.type == INTERFACE_NAMELESS 5296 || current_interface.type == INTERFACE_ABSTRACT) 5297 { 5298 gfc_error ("PROCEDURE at %C must be in a generic interface"); 5299 return MATCH_ERROR; 5300 } 5301 5302 /* Check if the F2008 optional double colon appears. */ 5303 gfc_gobble_whitespace (); 5304 old_locus = gfc_current_locus; 5305 if (gfc_match ("::") == MATCH_YES) 5306 { 5307 if (!gfc_notify_std (GFC_STD_F2008, "double colon in " 5308 "MODULE PROCEDURE statement at %L", &old_locus)) 5309 return MATCH_ERROR; 5310 } 5311 else 5312 gfc_current_locus = old_locus; 5313 5314 for(;;) 5315 { 5316 m = gfc_match_name (name); 5317 if (m == MATCH_NO) 5318 goto syntax; 5319 else if (m == MATCH_ERROR) 5320 return m; 5321 if (gfc_get_symbol (name, gfc_current_ns->parent, &sym)) 5322 return MATCH_ERROR; 5323 5324 if (!gfc_add_interface (sym)) 5325 return MATCH_ERROR; 5326 5327 if (gfc_match_eos () == MATCH_YES) 5328 break; 5329 if (gfc_match_char (',') != MATCH_YES) 5330 goto syntax; 5331 } 5332 5333 return MATCH_YES; 5334 5335syntax: 5336 gfc_error ("Syntax error in PROCEDURE statement at %C"); 5337 return MATCH_ERROR; 5338} 5339 5340 5341/* General matcher for PROCEDURE declarations. */ 5342 5343static match match_procedure_in_type (void); 5344 5345match 5346gfc_match_procedure (void) 5347{ 5348 match m; 5349 5350 switch (gfc_current_state ()) 5351 { 5352 case COMP_NONE: 5353 case COMP_PROGRAM: 5354 case COMP_MODULE: 5355 case COMP_SUBROUTINE: 5356 case COMP_FUNCTION: 5357 case COMP_BLOCK: 5358 m = match_procedure_decl (); 5359 break; 5360 case COMP_INTERFACE: 5361 m = match_procedure_in_interface (); 5362 break; 5363 case COMP_DERIVED: 5364 m = match_ppc_decl (); 5365 break; 5366 case COMP_DERIVED_CONTAINS: 5367 m = match_procedure_in_type (); 5368 break; 5369 default: 5370 return MATCH_NO; 5371 } 5372 5373 if (m != MATCH_YES) 5374 return m; 5375 5376 if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C")) 5377 return MATCH_ERROR; 5378 5379 return m; 5380} 5381 5382 5383/* Warn if a matched procedure has the same name as an intrinsic; this is 5384 simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current 5385 parser-state-stack to find out whether we're in a module. */ 5386 5387static void 5388do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func) 5389{ 5390 bool in_module; 5391 5392 in_module = (gfc_state_stack->previous 5393 && gfc_state_stack->previous->state == COMP_MODULE); 5394 5395 gfc_warn_intrinsic_shadow (sym, in_module, func); 5396} 5397 5398 5399/* Match a function declaration. */ 5400 5401match 5402gfc_match_function_decl (void) 5403{ 5404 char name[GFC_MAX_SYMBOL_LEN + 1]; 5405 gfc_symbol *sym, *result; 5406 locus old_loc; 5407 match m; 5408 match suffix_match; 5409 match found_match; /* Status returned by match func. */ 5410 5411 if (gfc_current_state () != COMP_NONE 5412 && gfc_current_state () != COMP_INTERFACE 5413 && gfc_current_state () != COMP_CONTAINS) 5414 return MATCH_NO; 5415 5416 gfc_clear_ts (¤t_ts); 5417 5418 old_loc = gfc_current_locus; 5419 5420 m = gfc_match_prefix (¤t_ts); 5421 if (m != MATCH_YES) 5422 { 5423 gfc_current_locus = old_loc; 5424 return m; 5425 } 5426 5427 if (gfc_match ("function% %n", name) != MATCH_YES) 5428 { 5429 gfc_current_locus = old_loc; 5430 return MATCH_NO; 5431 } 5432 if (get_proc_name (name, &sym, false)) 5433 return MATCH_ERROR; 5434 5435 if (add_hidden_procptr_result (sym)) 5436 sym = sym->result; 5437 5438 gfc_new_block = sym; 5439 5440 m = gfc_match_formal_arglist (sym, 0, 0); 5441 if (m == MATCH_NO) 5442 { 5443 gfc_error ("Expected formal argument list in function " 5444 "definition at %C"); 5445 m = MATCH_ERROR; 5446 goto cleanup; 5447 } 5448 else if (m == MATCH_ERROR) 5449 goto cleanup; 5450 5451 result = NULL; 5452 5453 /* According to the draft, the bind(c) and result clause can 5454 come in either order after the formal_arg_list (i.e., either 5455 can be first, both can exist together or by themselves or neither 5456 one). Therefore, the match_result can't match the end of the 5457 string, and check for the bind(c) or result clause in either order. */ 5458 found_match = gfc_match_eos (); 5459 5460 /* Make sure that it isn't already declared as BIND(C). If it is, it 5461 must have been marked BIND(C) with a BIND(C) attribute and that is 5462 not allowed for procedures. */ 5463 if (sym->attr.is_bind_c == 1) 5464 { 5465 sym->attr.is_bind_c = 0; 5466 if (sym->old_symbol != NULL) 5467 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5468 "variables or common blocks", 5469 &(sym->old_symbol->declared_at)); 5470 else 5471 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5472 "variables or common blocks", &gfc_current_locus); 5473 } 5474 5475 if (found_match != MATCH_YES) 5476 { 5477 /* If we haven't found the end-of-statement, look for a suffix. */ 5478 suffix_match = gfc_match_suffix (sym, &result); 5479 if (suffix_match == MATCH_YES) 5480 /* Need to get the eos now. */ 5481 found_match = gfc_match_eos (); 5482 else 5483 found_match = suffix_match; 5484 } 5485 5486 if(found_match != MATCH_YES) 5487 m = MATCH_ERROR; 5488 else 5489 { 5490 /* Make changes to the symbol. */ 5491 m = MATCH_ERROR; 5492 5493 if (!gfc_add_function (&sym->attr, sym->name, NULL)) 5494 goto cleanup; 5495 5496 if (!gfc_missing_attr (&sym->attr, NULL) 5497 || !copy_prefix (&sym->attr, &sym->declared_at)) 5498 goto cleanup; 5499 5500 /* Delay matching the function characteristics until after the 5501 specification block by signalling kind=-1. */ 5502 sym->declared_at = old_loc; 5503 if (current_ts.type != BT_UNKNOWN) 5504 current_ts.kind = -1; 5505 else 5506 current_ts.kind = 0; 5507 5508 if (result == NULL) 5509 { 5510 if (current_ts.type != BT_UNKNOWN 5511 && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) 5512 goto cleanup; 5513 sym->result = sym; 5514 } 5515 else 5516 { 5517 if (current_ts.type != BT_UNKNOWN 5518 && !gfc_add_type (result, ¤t_ts, &gfc_current_locus)) 5519 goto cleanup; 5520 sym->result = result; 5521 } 5522 5523 /* Warn if this procedure has the same name as an intrinsic. */ 5524 do_warn_intrinsic_shadow (sym, true); 5525 5526 return MATCH_YES; 5527 } 5528 5529cleanup: 5530 gfc_current_locus = old_loc; 5531 return m; 5532} 5533 5534 5535/* This is mostly a copy of parse.c(add_global_procedure) but modified to 5536 pass the name of the entry, rather than the gfc_current_block name, and 5537 to return false upon finding an existing global entry. */ 5538 5539static bool 5540add_global_entry (const char *name, const char *binding_label, bool sub, 5541 locus *where) 5542{ 5543 gfc_gsymbol *s; 5544 enum gfc_symbol_type type; 5545 5546 type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; 5547 5548 /* Only in Fortran 2003: For procedures with a binding label also the Fortran 5549 name is a global identifier. */ 5550 if (!binding_label || gfc_notification_std (GFC_STD_F2008)) 5551 { 5552 s = gfc_get_gsymbol (name); 5553 5554 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) 5555 { 5556 gfc_global_used (s, where); 5557 return false; 5558 } 5559 else 5560 { 5561 s->type = type; 5562 s->sym_name = name; 5563 s->where = *where; 5564 s->defined = 1; 5565 s->ns = gfc_current_ns; 5566 } 5567 } 5568 5569 /* Don't add the symbol multiple times. */ 5570 if (binding_label 5571 && (!gfc_notification_std (GFC_STD_F2008) 5572 || strcmp (name, binding_label) != 0)) 5573 { 5574 s = gfc_get_gsymbol (binding_label); 5575 5576 if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type)) 5577 { 5578 gfc_global_used (s, where); 5579 return false; 5580 } 5581 else 5582 { 5583 s->type = type; 5584 s->sym_name = name; 5585 s->binding_label = binding_label; 5586 s->where = *where; 5587 s->defined = 1; 5588 s->ns = gfc_current_ns; 5589 } 5590 } 5591 5592 return true; 5593} 5594 5595 5596/* Match an ENTRY statement. */ 5597 5598match 5599gfc_match_entry (void) 5600{ 5601 gfc_symbol *proc; 5602 gfc_symbol *result; 5603 gfc_symbol *entry; 5604 char name[GFC_MAX_SYMBOL_LEN + 1]; 5605 gfc_compile_state state; 5606 match m; 5607 gfc_entry_list *el; 5608 locus old_loc; 5609 bool module_procedure; 5610 char peek_char; 5611 match is_bind_c; 5612 5613 m = gfc_match_name (name); 5614 if (m != MATCH_YES) 5615 return m; 5616 5617 if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C")) 5618 return MATCH_ERROR; 5619 5620 state = gfc_current_state (); 5621 if (state != COMP_SUBROUTINE && state != COMP_FUNCTION) 5622 { 5623 switch (state) 5624 { 5625 case COMP_PROGRAM: 5626 gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM"); 5627 break; 5628 case COMP_MODULE: 5629 gfc_error ("ENTRY statement at %C cannot appear within a MODULE"); 5630 break; 5631 case COMP_BLOCK_DATA: 5632 gfc_error ("ENTRY statement at %C cannot appear within " 5633 "a BLOCK DATA"); 5634 break; 5635 case COMP_INTERFACE: 5636 gfc_error ("ENTRY statement at %C cannot appear within " 5637 "an INTERFACE"); 5638 break; 5639 case COMP_DERIVED: 5640 gfc_error ("ENTRY statement at %C cannot appear within " 5641 "a DERIVED TYPE block"); 5642 break; 5643 case COMP_IF: 5644 gfc_error ("ENTRY statement at %C cannot appear within " 5645 "an IF-THEN block"); 5646 break; 5647 case COMP_DO: 5648 case COMP_DO_CONCURRENT: 5649 gfc_error ("ENTRY statement at %C cannot appear within " 5650 "a DO block"); 5651 break; 5652 case COMP_SELECT: 5653 gfc_error ("ENTRY statement at %C cannot appear within " 5654 "a SELECT block"); 5655 break; 5656 case COMP_FORALL: 5657 gfc_error ("ENTRY statement at %C cannot appear within " 5658 "a FORALL block"); 5659 break; 5660 case COMP_WHERE: 5661 gfc_error ("ENTRY statement at %C cannot appear within " 5662 "a WHERE block"); 5663 break; 5664 case COMP_CONTAINS: 5665 gfc_error ("ENTRY statement at %C cannot appear within " 5666 "a contained subprogram"); 5667 break; 5668 default: 5669 gfc_error ("Unexpected ENTRY statement at %C"); 5670 } 5671 return MATCH_ERROR; 5672 } 5673 5674 if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION) 5675 && gfc_state_stack->previous->state == COMP_INTERFACE) 5676 { 5677 gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE"); 5678 return MATCH_ERROR; 5679 } 5680 5681 module_procedure = gfc_current_ns->parent != NULL 5682 && gfc_current_ns->parent->proc_name 5683 && gfc_current_ns->parent->proc_name->attr.flavor 5684 == FL_MODULE; 5685 5686 if (gfc_current_ns->parent != NULL 5687 && gfc_current_ns->parent->proc_name 5688 && !module_procedure) 5689 { 5690 gfc_error("ENTRY statement at %C cannot appear in a " 5691 "contained procedure"); 5692 return MATCH_ERROR; 5693 } 5694 5695 /* Module function entries need special care in get_proc_name 5696 because previous references within the function will have 5697 created symbols attached to the current namespace. */ 5698 if (get_proc_name (name, &entry, 5699 gfc_current_ns->parent != NULL 5700 && module_procedure)) 5701 return MATCH_ERROR; 5702 5703 proc = gfc_current_block (); 5704 5705 /* Make sure that it isn't already declared as BIND(C). If it is, it 5706 must have been marked BIND(C) with a BIND(C) attribute and that is 5707 not allowed for procedures. */ 5708 if (entry->attr.is_bind_c == 1) 5709 { 5710 entry->attr.is_bind_c = 0; 5711 if (entry->old_symbol != NULL) 5712 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5713 "variables or common blocks", 5714 &(entry->old_symbol->declared_at)); 5715 else 5716 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5717 "variables or common blocks", &gfc_current_locus); 5718 } 5719 5720 /* Check what next non-whitespace character is so we can tell if there 5721 is the required parens if we have a BIND(C). */ 5722 old_loc = gfc_current_locus; 5723 gfc_gobble_whitespace (); 5724 peek_char = gfc_peek_ascii_char (); 5725 5726 if (state == COMP_SUBROUTINE) 5727 { 5728 m = gfc_match_formal_arglist (entry, 0, 1); 5729 if (m != MATCH_YES) 5730 return MATCH_ERROR; 5731 5732 /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can 5733 never be an internal procedure. */ 5734 is_bind_c = gfc_match_bind_c (entry, true); 5735 if (is_bind_c == MATCH_ERROR) 5736 return MATCH_ERROR; 5737 if (is_bind_c == MATCH_YES) 5738 { 5739 if (peek_char != '(') 5740 { 5741 gfc_error ("Missing required parentheses before BIND(C) at %C"); 5742 return MATCH_ERROR; 5743 } 5744 if (!gfc_add_is_bind_c (&(entry->attr), entry->name, 5745 &(entry->declared_at), 1)) 5746 return MATCH_ERROR; 5747 } 5748 5749 if (!gfc_current_ns->parent 5750 && !add_global_entry (name, entry->binding_label, true, 5751 &old_loc)) 5752 return MATCH_ERROR; 5753 5754 /* An entry in a subroutine. */ 5755 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 5756 || !gfc_add_subroutine (&entry->attr, entry->name, NULL)) 5757 return MATCH_ERROR; 5758 } 5759 else 5760 { 5761 /* An entry in a function. 5762 We need to take special care because writing 5763 ENTRY f() 5764 as 5765 ENTRY f 5766 is allowed, whereas 5767 ENTRY f() RESULT (r) 5768 can't be written as 5769 ENTRY f RESULT (r). */ 5770 if (gfc_match_eos () == MATCH_YES) 5771 { 5772 gfc_current_locus = old_loc; 5773 /* Match the empty argument list, and add the interface to 5774 the symbol. */ 5775 m = gfc_match_formal_arglist (entry, 0, 1); 5776 } 5777 else 5778 m = gfc_match_formal_arglist (entry, 0, 0); 5779 5780 if (m != MATCH_YES) 5781 return MATCH_ERROR; 5782 5783 result = NULL; 5784 5785 if (gfc_match_eos () == MATCH_YES) 5786 { 5787 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 5788 || !gfc_add_function (&entry->attr, entry->name, NULL)) 5789 return MATCH_ERROR; 5790 5791 entry->result = entry; 5792 } 5793 else 5794 { 5795 m = gfc_match_suffix (entry, &result); 5796 if (m == MATCH_NO) 5797 gfc_syntax_error (ST_ENTRY); 5798 if (m != MATCH_YES) 5799 return MATCH_ERROR; 5800 5801 if (result) 5802 { 5803 if (!gfc_add_result (&result->attr, result->name, NULL) 5804 || !gfc_add_entry (&entry->attr, result->name, NULL) 5805 || !gfc_add_function (&entry->attr, result->name, NULL)) 5806 return MATCH_ERROR; 5807 entry->result = result; 5808 } 5809 else 5810 { 5811 if (!gfc_add_entry (&entry->attr, entry->name, NULL) 5812 || !gfc_add_function (&entry->attr, entry->name, NULL)) 5813 return MATCH_ERROR; 5814 entry->result = entry; 5815 } 5816 } 5817 5818 if (!gfc_current_ns->parent 5819 && !add_global_entry (name, entry->binding_label, false, 5820 &old_loc)) 5821 return MATCH_ERROR; 5822 } 5823 5824 if (gfc_match_eos () != MATCH_YES) 5825 { 5826 gfc_syntax_error (ST_ENTRY); 5827 return MATCH_ERROR; 5828 } 5829 5830 entry->attr.recursive = proc->attr.recursive; 5831 entry->attr.elemental = proc->attr.elemental; 5832 entry->attr.pure = proc->attr.pure; 5833 5834 el = gfc_get_entry_list (); 5835 el->sym = entry; 5836 el->next = gfc_current_ns->entries; 5837 gfc_current_ns->entries = el; 5838 if (el->next) 5839 el->id = el->next->id + 1; 5840 else 5841 el->id = 1; 5842 5843 new_st.op = EXEC_ENTRY; 5844 new_st.ext.entry = el; 5845 5846 return MATCH_YES; 5847} 5848 5849 5850/* Match a subroutine statement, including optional prefixes. */ 5851 5852match 5853gfc_match_subroutine (void) 5854{ 5855 char name[GFC_MAX_SYMBOL_LEN + 1]; 5856 gfc_symbol *sym; 5857 match m; 5858 match is_bind_c; 5859 char peek_char; 5860 bool allow_binding_name; 5861 5862 if (gfc_current_state () != COMP_NONE 5863 && gfc_current_state () != COMP_INTERFACE 5864 && gfc_current_state () != COMP_CONTAINS) 5865 return MATCH_NO; 5866 5867 m = gfc_match_prefix (NULL); 5868 if (m != MATCH_YES) 5869 return m; 5870 5871 m = gfc_match ("subroutine% %n", name); 5872 if (m != MATCH_YES) 5873 return m; 5874 5875 if (get_proc_name (name, &sym, false)) 5876 return MATCH_ERROR; 5877 5878 /* Set declared_at as it might point to, e.g., a PUBLIC statement, if 5879 the symbol existed before. */ 5880 sym->declared_at = gfc_current_locus; 5881 5882 if (add_hidden_procptr_result (sym)) 5883 sym = sym->result; 5884 5885 gfc_new_block = sym; 5886 5887 /* Check what next non-whitespace character is so we can tell if there 5888 is the required parens if we have a BIND(C). */ 5889 gfc_gobble_whitespace (); 5890 peek_char = gfc_peek_ascii_char (); 5891 5892 if (!gfc_add_subroutine (&sym->attr, sym->name, NULL)) 5893 return MATCH_ERROR; 5894 5895 if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES) 5896 return MATCH_ERROR; 5897 5898 /* Make sure that it isn't already declared as BIND(C). If it is, it 5899 must have been marked BIND(C) with a BIND(C) attribute and that is 5900 not allowed for procedures. */ 5901 if (sym->attr.is_bind_c == 1) 5902 { 5903 sym->attr.is_bind_c = 0; 5904 if (sym->old_symbol != NULL) 5905 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5906 "variables or common blocks", 5907 &(sym->old_symbol->declared_at)); 5908 else 5909 gfc_error_now ("BIND(C) attribute at %L can only be used for " 5910 "variables or common blocks", &gfc_current_locus); 5911 } 5912 5913 /* C binding names are not allowed for internal procedures. */ 5914 if (gfc_current_state () == COMP_CONTAINS 5915 && sym->ns->proc_name->attr.flavor != FL_MODULE) 5916 allow_binding_name = false; 5917 else 5918 allow_binding_name = true; 5919 5920 /* Here, we are just checking if it has the bind(c) attribute, and if 5921 so, then we need to make sure it's all correct. If it doesn't, 5922 we still need to continue matching the rest of the subroutine line. */ 5923 is_bind_c = gfc_match_bind_c (sym, allow_binding_name); 5924 if (is_bind_c == MATCH_ERROR) 5925 { 5926 /* There was an attempt at the bind(c), but it was wrong. An 5927 error message should have been printed w/in the gfc_match_bind_c 5928 so here we'll just return the MATCH_ERROR. */ 5929 return MATCH_ERROR; 5930 } 5931 5932 if (is_bind_c == MATCH_YES) 5933 { 5934 /* The following is allowed in the Fortran 2008 draft. */ 5935 if (gfc_current_state () == COMP_CONTAINS 5936 && sym->ns->proc_name->attr.flavor != FL_MODULE 5937 && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute " 5938 "at %L may not be specified for an internal " 5939 "procedure", &gfc_current_locus)) 5940 return MATCH_ERROR; 5941 5942 if (peek_char != '(') 5943 { 5944 gfc_error ("Missing required parentheses before BIND(C) at %C"); 5945 return MATCH_ERROR; 5946 } 5947 if (!gfc_add_is_bind_c (&(sym->attr), sym->name, 5948 &(sym->declared_at), 1)) 5949 return MATCH_ERROR; 5950 } 5951 5952 if (gfc_match_eos () != MATCH_YES) 5953 { 5954 gfc_syntax_error (ST_SUBROUTINE); 5955 return MATCH_ERROR; 5956 } 5957 5958 if (!copy_prefix (&sym->attr, &sym->declared_at)) 5959 return MATCH_ERROR; 5960 5961 /* Warn if it has the same name as an intrinsic. */ 5962 do_warn_intrinsic_shadow (sym, false); 5963 5964 return MATCH_YES; 5965} 5966 5967 5968/* Check that the NAME identifier in a BIND attribute or statement 5969 is conform to C identifier rules. */ 5970 5971match 5972check_bind_name_identifier (char **name) 5973{ 5974 char *n = *name, *p; 5975 5976 /* Remove leading spaces. */ 5977 while (*n == ' ') 5978 n++; 5979 5980 /* On an empty string, free memory and set name to NULL. */ 5981 if (*n == '\0') 5982 { 5983 free (*name); 5984 *name = NULL; 5985 return MATCH_YES; 5986 } 5987 5988 /* Remove trailing spaces. */ 5989 p = n + strlen(n) - 1; 5990 while (*p == ' ') 5991 *(p--) = '\0'; 5992 5993 /* Insert the identifier into the symbol table. */ 5994 p = xstrdup (n); 5995 free (*name); 5996 *name = p; 5997 5998 /* Now check that identifier is valid under C rules. */ 5999 if (ISDIGIT (*p)) 6000 { 6001 gfc_error ("Invalid C identifier in NAME= specifier at %C"); 6002 return MATCH_ERROR; 6003 } 6004 6005 for (; *p; p++) 6006 if (!(ISALNUM (*p) || *p == '_' || *p == '$')) 6007 { 6008 gfc_error ("Invalid C identifier in NAME= specifier at %C"); 6009 return MATCH_ERROR; 6010 } 6011 6012 return MATCH_YES; 6013} 6014 6015 6016/* Match a BIND(C) specifier, with the optional 'name=' specifier if 6017 given, and set the binding label in either the given symbol (if not 6018 NULL), or in the current_ts. The symbol may be NULL because we may 6019 encounter the BIND(C) before the declaration itself. Return 6020 MATCH_NO if what we're looking at isn't a BIND(C) specifier, 6021 MATCH_ERROR if it is a BIND(C) clause but an error was encountered, 6022 or MATCH_YES if the specifier was correct and the binding label and 6023 bind(c) fields were set correctly for the given symbol or the 6024 current_ts. If allow_binding_name is false, no binding name may be 6025 given. */ 6026 6027match 6028gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name) 6029{ 6030 char *binding_label = NULL; 6031 gfc_expr *e = NULL; 6032 6033 /* Initialize the flag that specifies whether we encountered a NAME= 6034 specifier or not. */ 6035 has_name_equals = 0; 6036 6037 /* This much we have to be able to match, in this order, if 6038 there is a bind(c) label. */ 6039 if (gfc_match (" bind ( c ") != MATCH_YES) 6040 return MATCH_NO; 6041 6042 /* Now see if there is a binding label, or if we've reached the 6043 end of the bind(c) attribute without one. */ 6044 if (gfc_match_char (',') == MATCH_YES) 6045 { 6046 if (gfc_match (" name = ") != MATCH_YES) 6047 { 6048 gfc_error ("Syntax error in NAME= specifier for binding label " 6049 "at %C"); 6050 /* should give an error message here */ 6051 return MATCH_ERROR; 6052 } 6053 6054 has_name_equals = 1; 6055 6056 if (gfc_match_init_expr (&e) != MATCH_YES) 6057 { 6058 gfc_free_expr (e); 6059 return MATCH_ERROR; 6060 } 6061 6062 if (!gfc_simplify_expr(e, 0)) 6063 { 6064 gfc_error ("NAME= specifier at %C should be a constant expression"); 6065 gfc_free_expr (e); 6066 return MATCH_ERROR; 6067 } 6068 6069 if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER 6070 || e->ts.kind != gfc_default_character_kind || e->rank != 0) 6071 { 6072 gfc_error ("NAME= specifier at %C should be a scalar of " 6073 "default character kind"); 6074 gfc_free_expr(e); 6075 return MATCH_ERROR; 6076 } 6077 6078 // Get a C string from the Fortran string constant 6079 binding_label = gfc_widechar_to_char (e->value.character.string, 6080 e->value.character.length); 6081 gfc_free_expr(e); 6082 6083 // Check that it is valid (old gfc_match_name_C) 6084 if (check_bind_name_identifier (&binding_label) != MATCH_YES) 6085 return MATCH_ERROR; 6086 } 6087 6088 /* Get the required right paren. */ 6089 if (gfc_match_char (')') != MATCH_YES) 6090 { 6091 gfc_error ("Missing closing paren for binding label at %C"); 6092 return MATCH_ERROR; 6093 } 6094 6095 if (has_name_equals && !allow_binding_name) 6096 { 6097 gfc_error ("No binding name is allowed in BIND(C) at %C"); 6098 return MATCH_ERROR; 6099 } 6100 6101 if (has_name_equals && sym != NULL && sym->attr.dummy) 6102 { 6103 gfc_error ("For dummy procedure %s, no binding name is " 6104 "allowed in BIND(C) at %C", sym->name); 6105 return MATCH_ERROR; 6106 } 6107 6108 6109 /* Save the binding label to the symbol. If sym is null, we're 6110 probably matching the typespec attributes of a declaration and 6111 haven't gotten the name yet, and therefore, no symbol yet. */ 6112 if (binding_label) 6113 { 6114 if (sym != NULL) 6115 sym->binding_label = binding_label; 6116 else 6117 curr_binding_label = binding_label; 6118 } 6119 else if (allow_binding_name) 6120 { 6121 /* No binding label, but if symbol isn't null, we 6122 can set the label for it here. 6123 If name="" or allow_binding_name is false, no C binding name is 6124 created. */ 6125 if (sym != NULL && sym->name != NULL && has_name_equals == 0) 6126 sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name)); 6127 } 6128 6129 if (has_name_equals && gfc_current_state () == COMP_INTERFACE 6130 && current_interface.type == INTERFACE_ABSTRACT) 6131 { 6132 gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C"); 6133 return MATCH_ERROR; 6134 } 6135 6136 return MATCH_YES; 6137} 6138 6139 6140/* Return nonzero if we're currently compiling a contained procedure. */ 6141 6142static int 6143contained_procedure (void) 6144{ 6145 gfc_state_data *s = gfc_state_stack; 6146 6147 if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION) 6148 && s->previous != NULL && s->previous->state == COMP_CONTAINS) 6149 return 1; 6150 6151 return 0; 6152} 6153 6154/* Set the kind of each enumerator. The kind is selected such that it is 6155 interoperable with the corresponding C enumeration type, making 6156 sure that -fshort-enums is honored. */ 6157 6158static void 6159set_enum_kind(void) 6160{ 6161 enumerator_history *current_history = NULL; 6162 int kind; 6163 int i; 6164 6165 if (max_enum == NULL || enum_history == NULL) 6166 return; 6167 6168 if (!flag_short_enums) 6169 return; 6170 6171 i = 0; 6172 do 6173 { 6174 kind = gfc_integer_kinds[i++].kind; 6175 } 6176 while (kind < gfc_c_int_kind 6177 && gfc_check_integer_range (max_enum->initializer->value.integer, 6178 kind) != ARITH_OK); 6179 6180 current_history = enum_history; 6181 while (current_history != NULL) 6182 { 6183 current_history->sym->ts.kind = kind; 6184 current_history = current_history->next; 6185 } 6186} 6187 6188 6189/* Match any of the various end-block statements. Returns the type of 6190 END to the caller. The END INTERFACE, END IF, END DO, END SELECT 6191 and END BLOCK statements cannot be replaced by a single END statement. */ 6192 6193match 6194gfc_match_end (gfc_statement *st) 6195{ 6196 char name[GFC_MAX_SYMBOL_LEN + 1]; 6197 gfc_compile_state state; 6198 locus old_loc; 6199 const char *block_name; 6200 const char *target; 6201 int eos_ok; 6202 match m; 6203 gfc_namespace *parent_ns, *ns, *prev_ns; 6204 gfc_namespace **nsp; 6205 6206 old_loc = gfc_current_locus; 6207 if (gfc_match ("end") != MATCH_YES) 6208 return MATCH_NO; 6209 6210 state = gfc_current_state (); 6211 block_name = gfc_current_block () == NULL 6212 ? NULL : gfc_current_block ()->name; 6213 6214 switch (state) 6215 { 6216 case COMP_ASSOCIATE: 6217 case COMP_BLOCK: 6218 if (!strncmp (block_name, "block@", strlen("block@"))) 6219 block_name = NULL; 6220 break; 6221 6222 case COMP_CONTAINS: 6223 case COMP_DERIVED_CONTAINS: 6224 state = gfc_state_stack->previous->state; 6225 block_name = gfc_state_stack->previous->sym == NULL 6226 ? NULL : gfc_state_stack->previous->sym->name; 6227 break; 6228 6229 default: 6230 break; 6231 } 6232 6233 switch (state) 6234 { 6235 case COMP_NONE: 6236 case COMP_PROGRAM: 6237 *st = ST_END_PROGRAM; 6238 target = " program"; 6239 eos_ok = 1; 6240 break; 6241 6242 case COMP_SUBROUTINE: 6243 *st = ST_END_SUBROUTINE; 6244 target = " subroutine"; 6245 eos_ok = !contained_procedure (); 6246 break; 6247 6248 case COMP_FUNCTION: 6249 *st = ST_END_FUNCTION; 6250 target = " function"; 6251 eos_ok = !contained_procedure (); 6252 break; 6253 6254 case COMP_BLOCK_DATA: 6255 *st = ST_END_BLOCK_DATA; 6256 target = " block data"; 6257 eos_ok = 1; 6258 break; 6259 6260 case COMP_MODULE: 6261 *st = ST_END_MODULE; 6262 target = " module"; 6263 eos_ok = 1; 6264 break; 6265 6266 case COMP_INTERFACE: 6267 *st = ST_END_INTERFACE; 6268 target = " interface"; 6269 eos_ok = 0; 6270 break; 6271 6272 case COMP_DERIVED: 6273 case COMP_DERIVED_CONTAINS: 6274 *st = ST_END_TYPE; 6275 target = " type"; 6276 eos_ok = 0; 6277 break; 6278 6279 case COMP_ASSOCIATE: 6280 *st = ST_END_ASSOCIATE; 6281 target = " associate"; 6282 eos_ok = 0; 6283 break; 6284 6285 case COMP_BLOCK: 6286 *st = ST_END_BLOCK; 6287 target = " block"; 6288 eos_ok = 0; 6289 break; 6290 6291 case COMP_IF: 6292 *st = ST_ENDIF; 6293 target = " if"; 6294 eos_ok = 0; 6295 break; 6296 6297 case COMP_DO: 6298 case COMP_DO_CONCURRENT: 6299 *st = ST_ENDDO; 6300 target = " do"; 6301 eos_ok = 0; 6302 break; 6303 6304 case COMP_CRITICAL: 6305 *st = ST_END_CRITICAL; 6306 target = " critical"; 6307 eos_ok = 0; 6308 break; 6309 6310 case COMP_SELECT: 6311 case COMP_SELECT_TYPE: 6312 *st = ST_END_SELECT; 6313 target = " select"; 6314 eos_ok = 0; 6315 break; 6316 6317 case COMP_FORALL: 6318 *st = ST_END_FORALL; 6319 target = " forall"; 6320 eos_ok = 0; 6321 break; 6322 6323 case COMP_WHERE: 6324 *st = ST_END_WHERE; 6325 target = " where"; 6326 eos_ok = 0; 6327 break; 6328 6329 case COMP_ENUM: 6330 *st = ST_END_ENUM; 6331 target = " enum"; 6332 eos_ok = 0; 6333 last_initializer = NULL; 6334 set_enum_kind (); 6335 gfc_free_enum_history (); 6336 break; 6337 6338 default: 6339 gfc_error ("Unexpected END statement at %C"); 6340 goto cleanup; 6341 } 6342 6343 old_loc = gfc_current_locus; 6344 if (gfc_match_eos () == MATCH_YES) 6345 { 6346 if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION)) 6347 { 6348 if (!gfc_notify_std (GFC_STD_F2008, "END statement " 6349 "instead of %s statement at %L", 6350 gfc_ascii_statement(*st), &old_loc)) 6351 goto cleanup; 6352 } 6353 else if (!eos_ok) 6354 { 6355 /* We would have required END [something]. */ 6356 gfc_error ("%s statement expected at %L", 6357 gfc_ascii_statement (*st), &old_loc); 6358 goto cleanup; 6359 } 6360 6361 return MATCH_YES; 6362 } 6363 6364 /* Verify that we've got the sort of end-block that we're expecting. */ 6365 if (gfc_match (target) != MATCH_YES) 6366 { 6367 gfc_error ("Expecting %s statement at %L", gfc_ascii_statement (*st), 6368 &old_loc); 6369 goto cleanup; 6370 } 6371 6372 old_loc = gfc_current_locus; 6373 /* If we're at the end, make sure a block name wasn't required. */ 6374 if (gfc_match_eos () == MATCH_YES) 6375 { 6376 6377 if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT 6378 && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK 6379 && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL) 6380 return MATCH_YES; 6381 6382 if (!block_name) 6383 return MATCH_YES; 6384 6385 gfc_error ("Expected block name of %qs in %s statement at %L", 6386 block_name, gfc_ascii_statement (*st), &old_loc); 6387 6388 return MATCH_ERROR; 6389 } 6390 6391 /* END INTERFACE has a special handler for its several possible endings. */ 6392 if (*st == ST_END_INTERFACE) 6393 return gfc_match_end_interface (); 6394 6395 /* We haven't hit the end of statement, so what is left must be an 6396 end-name. */ 6397 m = gfc_match_space (); 6398 if (m == MATCH_YES) 6399 m = gfc_match_name (name); 6400 6401 if (m == MATCH_NO) 6402 gfc_error ("Expected terminating name at %C"); 6403 if (m != MATCH_YES) 6404 goto cleanup; 6405 6406 if (block_name == NULL) 6407 goto syntax; 6408 6409 if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0) 6410 { 6411 gfc_error ("Expected label %qs for %s statement at %C", block_name, 6412 gfc_ascii_statement (*st)); 6413 goto cleanup; 6414 } 6415 /* Procedure pointer as function result. */ 6416 else if (strcmp (block_name, "ppr@") == 0 6417 && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0) 6418 { 6419 gfc_error ("Expected label %qs for %s statement at %C", 6420 gfc_current_block ()->ns->proc_name->name, 6421 gfc_ascii_statement (*st)); 6422 goto cleanup; 6423 } 6424 6425 if (gfc_match_eos () == MATCH_YES) 6426 return MATCH_YES; 6427 6428syntax: 6429 gfc_syntax_error (*st); 6430 6431cleanup: 6432 gfc_current_locus = old_loc; 6433 6434 /* If we are missing an END BLOCK, we created a half-ready namespace. 6435 Remove it from the parent namespace's sibling list. */ 6436 6437 if (state == COMP_BLOCK) 6438 { 6439 parent_ns = gfc_current_ns->parent; 6440 6441 nsp = &(gfc_state_stack->previous->tail->ext.block.ns); 6442 6443 prev_ns = NULL; 6444 ns = *nsp; 6445 while (ns) 6446 { 6447 if (ns == gfc_current_ns) 6448 { 6449 if (prev_ns == NULL) 6450 *nsp = NULL; 6451 else 6452 prev_ns->sibling = ns->sibling; 6453 } 6454 prev_ns = ns; 6455 ns = ns->sibling; 6456 } 6457 6458 if (parent_ns) 6459 { 6460 /* Free the current namespace only when the parent one exists. This 6461 prevents an ICE when more END BLOCK then BLOCK statements are 6462 present. It does not mean any further harm, because we already 6463 have errored. */ 6464 gfc_free_namespace (gfc_current_ns); 6465 gfc_current_ns = parent_ns; 6466 } 6467 } 6468 6469 return MATCH_ERROR; 6470} 6471 6472 6473 6474/***************** Attribute declaration statements ****************/ 6475 6476/* Set the attribute of a single variable. */ 6477 6478static match 6479attr_decl1 (void) 6480{ 6481 char name[GFC_MAX_SYMBOL_LEN + 1]; 6482 gfc_array_spec *as; 6483 6484 /* Workaround -Wmaybe-uninitialized false positive during 6485 profiledbootstrap by initializing them. */ 6486 gfc_symbol *sym = NULL; 6487 locus var_locus; 6488 match m; 6489 6490 as = NULL; 6491 6492 m = gfc_match_name (name); 6493 if (m != MATCH_YES) 6494 goto cleanup; 6495 6496 if (find_special (name, &sym, false)) 6497 return MATCH_ERROR; 6498 6499 if (!check_function_name (name)) 6500 { 6501 m = MATCH_ERROR; 6502 goto cleanup; 6503 } 6504 6505 var_locus = gfc_current_locus; 6506 6507 /* Deal with possible array specification for certain attributes. */ 6508 if (current_attr.dimension 6509 || current_attr.codimension 6510 || current_attr.allocatable 6511 || current_attr.pointer 6512 || current_attr.target) 6513 { 6514 m = gfc_match_array_spec (&as, !current_attr.codimension, 6515 !current_attr.dimension 6516 && !current_attr.pointer 6517 && !current_attr.target); 6518 if (m == MATCH_ERROR) 6519 goto cleanup; 6520 6521 if (current_attr.dimension && m == MATCH_NO) 6522 { 6523 gfc_error ("Missing array specification at %L in DIMENSION " 6524 "statement", &var_locus); 6525 m = MATCH_ERROR; 6526 goto cleanup; 6527 } 6528 6529 if (current_attr.dimension && sym->value) 6530 { 6531 gfc_error ("Dimensions specified for %s at %L after its " 6532 "initialisation", sym->name, &var_locus); 6533 m = MATCH_ERROR; 6534 goto cleanup; 6535 } 6536 6537 if (current_attr.codimension && m == MATCH_NO) 6538 { 6539 gfc_error ("Missing array specification at %L in CODIMENSION " 6540 "statement", &var_locus); 6541 m = MATCH_ERROR; 6542 goto cleanup; 6543 } 6544 6545 if ((current_attr.allocatable || current_attr.pointer) 6546 && (m == MATCH_YES) && (as->type != AS_DEFERRED)) 6547 { 6548 gfc_error ("Array specification must be deferred at %L", &var_locus); 6549 m = MATCH_ERROR; 6550 goto cleanup; 6551 } 6552 } 6553 6554 /* Update symbol table. DIMENSION attribute is set in 6555 gfc_set_array_spec(). For CLASS variables, this must be applied 6556 to the first component, or '_data' field. */ 6557 if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class) 6558 { 6559 if (!gfc_copy_attr (&CLASS_DATA(sym)->attr, ¤t_attr, &var_locus)) 6560 { 6561 m = MATCH_ERROR; 6562 goto cleanup; 6563 } 6564 } 6565 else 6566 { 6567 if (current_attr.dimension == 0 && current_attr.codimension == 0 6568 && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus)) 6569 { 6570 m = MATCH_ERROR; 6571 goto cleanup; 6572 } 6573 } 6574 6575 if (sym->ts.type == BT_CLASS 6576 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as)) 6577 { 6578 m = MATCH_ERROR; 6579 goto cleanup; 6580 } 6581 6582 if (!gfc_set_array_spec (sym, as, &var_locus)) 6583 { 6584 m = MATCH_ERROR; 6585 goto cleanup; 6586 } 6587 6588 if (sym->attr.cray_pointee && sym->as != NULL) 6589 { 6590 /* Fix the array spec. */ 6591 m = gfc_mod_pointee_as (sym->as); 6592 if (m == MATCH_ERROR) 6593 goto cleanup; 6594 } 6595 6596 if (!gfc_add_attribute (&sym->attr, &var_locus)) 6597 { 6598 m = MATCH_ERROR; 6599 goto cleanup; 6600 } 6601 6602 if ((current_attr.external || current_attr.intrinsic) 6603 && sym->attr.flavor != FL_PROCEDURE 6604 && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL)) 6605 { 6606 m = MATCH_ERROR; 6607 goto cleanup; 6608 } 6609 6610 add_hidden_procptr_result (sym); 6611 6612 return MATCH_YES; 6613 6614cleanup: 6615 gfc_free_array_spec (as); 6616 return m; 6617} 6618 6619 6620/* Generic attribute declaration subroutine. Used for attributes that 6621 just have a list of names. */ 6622 6623static match 6624attr_decl (void) 6625{ 6626 match m; 6627 6628 /* Gobble the optional double colon, by simply ignoring the result 6629 of gfc_match(). */ 6630 gfc_match (" ::"); 6631 6632 for (;;) 6633 { 6634 m = attr_decl1 (); 6635 if (m != MATCH_YES) 6636 break; 6637 6638 if (gfc_match_eos () == MATCH_YES) 6639 { 6640 m = MATCH_YES; 6641 break; 6642 } 6643 6644 if (gfc_match_char (',') != MATCH_YES) 6645 { 6646 gfc_error ("Unexpected character in variable list at %C"); 6647 m = MATCH_ERROR; 6648 break; 6649 } 6650 } 6651 6652 return m; 6653} 6654 6655 6656/* This routine matches Cray Pointer declarations of the form: 6657 pointer ( <pointer>, <pointee> ) 6658 or 6659 pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ... 6660 The pointer, if already declared, should be an integer. Otherwise, we 6661 set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may 6662 be either a scalar, or an array declaration. No space is allocated for 6663 the pointee. For the statement 6664 pointer (ipt, ar(10)) 6665 any subsequent uses of ar will be translated (in C-notation) as 6666 ar(i) => ((<type> *) ipt)(i) 6667 After gimplification, pointee variable will disappear in the code. */ 6668 6669static match 6670cray_pointer_decl (void) 6671{ 6672 match m; 6673 gfc_array_spec *as = NULL; 6674 gfc_symbol *cptr; /* Pointer symbol. */ 6675 gfc_symbol *cpte; /* Pointee symbol. */ 6676 locus var_locus; 6677 bool done = false; 6678 6679 while (!done) 6680 { 6681 if (gfc_match_char ('(') != MATCH_YES) 6682 { 6683 gfc_error ("Expected %<(%> at %C"); 6684 return MATCH_ERROR; 6685 } 6686 6687 /* Match pointer. */ 6688 var_locus = gfc_current_locus; 6689 gfc_clear_attr (¤t_attr); 6690 gfc_add_cray_pointer (¤t_attr, &var_locus); 6691 current_ts.type = BT_INTEGER; 6692 current_ts.kind = gfc_index_integer_kind; 6693 6694 m = gfc_match_symbol (&cptr, 0); 6695 if (m != MATCH_YES) 6696 { 6697 gfc_error ("Expected variable name at %C"); 6698 return m; 6699 } 6700 6701 if (!gfc_add_cray_pointer (&cptr->attr, &var_locus)) 6702 return MATCH_ERROR; 6703 6704 gfc_set_sym_referenced (cptr); 6705 6706 if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */ 6707 { 6708 cptr->ts.type = BT_INTEGER; 6709 cptr->ts.kind = gfc_index_integer_kind; 6710 } 6711 else if (cptr->ts.type != BT_INTEGER) 6712 { 6713 gfc_error ("Cray pointer at %C must be an integer"); 6714 return MATCH_ERROR; 6715 } 6716 else if (cptr->ts.kind < gfc_index_integer_kind) 6717 gfc_warning (0, "Cray pointer at %C has %d bytes of precision;" 6718 " memory addresses require %d bytes", 6719 cptr->ts.kind, gfc_index_integer_kind); 6720 6721 if (gfc_match_char (',') != MATCH_YES) 6722 { 6723 gfc_error ("Expected \",\" at %C"); 6724 return MATCH_ERROR; 6725 } 6726 6727 /* Match Pointee. */ 6728 var_locus = gfc_current_locus; 6729 gfc_clear_attr (¤t_attr); 6730 gfc_add_cray_pointee (¤t_attr, &var_locus); 6731 current_ts.type = BT_UNKNOWN; 6732 current_ts.kind = 0; 6733 6734 m = gfc_match_symbol (&cpte, 0); 6735 if (m != MATCH_YES) 6736 { 6737 gfc_error ("Expected variable name at %C"); 6738 return m; 6739 } 6740 6741 /* Check for an optional array spec. */ 6742 m = gfc_match_array_spec (&as, true, false); 6743 if (m == MATCH_ERROR) 6744 { 6745 gfc_free_array_spec (as); 6746 return m; 6747 } 6748 else if (m == MATCH_NO) 6749 { 6750 gfc_free_array_spec (as); 6751 as = NULL; 6752 } 6753 6754 if (!gfc_add_cray_pointee (&cpte->attr, &var_locus)) 6755 return MATCH_ERROR; 6756 6757 gfc_set_sym_referenced (cpte); 6758 6759 if (cpte->as == NULL) 6760 { 6761 if (!gfc_set_array_spec (cpte, as, &var_locus)) 6762 gfc_internal_error ("Couldn't set Cray pointee array spec."); 6763 } 6764 else if (as != NULL) 6765 { 6766 gfc_error ("Duplicate array spec for Cray pointee at %C"); 6767 gfc_free_array_spec (as); 6768 return MATCH_ERROR; 6769 } 6770 6771 as = NULL; 6772 6773 if (cpte->as != NULL) 6774 { 6775 /* Fix array spec. */ 6776 m = gfc_mod_pointee_as (cpte->as); 6777 if (m == MATCH_ERROR) 6778 return m; 6779 } 6780 6781 /* Point the Pointee at the Pointer. */ 6782 cpte->cp_pointer = cptr; 6783 6784 if (gfc_match_char (')') != MATCH_YES) 6785 { 6786 gfc_error ("Expected \")\" at %C"); 6787 return MATCH_ERROR; 6788 } 6789 m = gfc_match_char (','); 6790 if (m != MATCH_YES) 6791 done = true; /* Stop searching for more declarations. */ 6792 6793 } 6794 6795 if (m == MATCH_ERROR /* Failed when trying to find ',' above. */ 6796 || gfc_match_eos () != MATCH_YES) 6797 { 6798 gfc_error ("Expected %<,%> or end of statement at %C"); 6799 return MATCH_ERROR; 6800 } 6801 return MATCH_YES; 6802} 6803 6804 6805match 6806gfc_match_external (void) 6807{ 6808 6809 gfc_clear_attr (¤t_attr); 6810 current_attr.external = 1; 6811 6812 return attr_decl (); 6813} 6814 6815 6816match 6817gfc_match_intent (void) 6818{ 6819 sym_intent intent; 6820 6821 /* This is not allowed within a BLOCK construct! */ 6822 if (gfc_current_state () == COMP_BLOCK) 6823 { 6824 gfc_error ("INTENT is not allowed inside of BLOCK at %C"); 6825 return MATCH_ERROR; 6826 } 6827 6828 intent = match_intent_spec (); 6829 if (intent == INTENT_UNKNOWN) 6830 return MATCH_ERROR; 6831 6832 gfc_clear_attr (¤t_attr); 6833 current_attr.intent = intent; 6834 6835 return attr_decl (); 6836} 6837 6838 6839match 6840gfc_match_intrinsic (void) 6841{ 6842 6843 gfc_clear_attr (¤t_attr); 6844 current_attr.intrinsic = 1; 6845 6846 return attr_decl (); 6847} 6848 6849 6850match 6851gfc_match_optional (void) 6852{ 6853 /* This is not allowed within a BLOCK construct! */ 6854 if (gfc_current_state () == COMP_BLOCK) 6855 { 6856 gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C"); 6857 return MATCH_ERROR; 6858 } 6859 6860 gfc_clear_attr (¤t_attr); 6861 current_attr.optional = 1; 6862 6863 return attr_decl (); 6864} 6865 6866 6867match 6868gfc_match_pointer (void) 6869{ 6870 gfc_gobble_whitespace (); 6871 if (gfc_peek_ascii_char () == '(') 6872 { 6873 if (!flag_cray_pointer) 6874 { 6875 gfc_error ("Cray pointer declaration at %C requires -fcray-pointer " 6876 "flag"); 6877 return MATCH_ERROR; 6878 } 6879 return cray_pointer_decl (); 6880 } 6881 else 6882 { 6883 gfc_clear_attr (¤t_attr); 6884 current_attr.pointer = 1; 6885 6886 return attr_decl (); 6887 } 6888} 6889 6890 6891match 6892gfc_match_allocatable (void) 6893{ 6894 gfc_clear_attr (¤t_attr); 6895 current_attr.allocatable = 1; 6896 6897 return attr_decl (); 6898} 6899 6900 6901match 6902gfc_match_codimension (void) 6903{ 6904 gfc_clear_attr (¤t_attr); 6905 current_attr.codimension = 1; 6906 6907 return attr_decl (); 6908} 6909 6910 6911match 6912gfc_match_contiguous (void) 6913{ 6914 if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C")) 6915 return MATCH_ERROR; 6916 6917 gfc_clear_attr (¤t_attr); 6918 current_attr.contiguous = 1; 6919 6920 return attr_decl (); 6921} 6922 6923 6924match 6925gfc_match_dimension (void) 6926{ 6927 gfc_clear_attr (¤t_attr); 6928 current_attr.dimension = 1; 6929 6930 return attr_decl (); 6931} 6932 6933 6934match 6935gfc_match_target (void) 6936{ 6937 gfc_clear_attr (¤t_attr); 6938 current_attr.target = 1; 6939 6940 return attr_decl (); 6941} 6942 6943 6944/* Match the list of entities being specified in a PUBLIC or PRIVATE 6945 statement. */ 6946 6947static match 6948access_attr_decl (gfc_statement st) 6949{ 6950 char name[GFC_MAX_SYMBOL_LEN + 1]; 6951 interface_type type; 6952 gfc_user_op *uop; 6953 gfc_symbol *sym, *dt_sym; 6954 gfc_intrinsic_op op; 6955 match m; 6956 6957 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 6958 goto done; 6959 6960 for (;;) 6961 { 6962 m = gfc_match_generic_spec (&type, name, &op); 6963 if (m == MATCH_NO) 6964 goto syntax; 6965 if (m == MATCH_ERROR) 6966 return MATCH_ERROR; 6967 6968 switch (type) 6969 { 6970 case INTERFACE_NAMELESS: 6971 case INTERFACE_ABSTRACT: 6972 goto syntax; 6973 6974 case INTERFACE_GENERIC: 6975 if (gfc_get_symbol (name, NULL, &sym)) 6976 goto done; 6977 6978 if (!gfc_add_access (&sym->attr, 6979 (st == ST_PUBLIC) 6980 ? ACCESS_PUBLIC : ACCESS_PRIVATE, 6981 sym->name, NULL)) 6982 return MATCH_ERROR; 6983 6984 if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym)) 6985 && !gfc_add_access (&dt_sym->attr, 6986 (st == ST_PUBLIC) 6987 ? ACCESS_PUBLIC : ACCESS_PRIVATE, 6988 sym->name, NULL)) 6989 return MATCH_ERROR; 6990 6991 break; 6992 6993 case INTERFACE_INTRINSIC_OP: 6994 if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN) 6995 { 6996 gfc_intrinsic_op other_op; 6997 6998 gfc_current_ns->operator_access[op] = 6999 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; 7000 7001 /* Handle the case if there is another op with the same 7002 function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */ 7003 other_op = gfc_equivalent_op (op); 7004 7005 if (other_op != INTRINSIC_NONE) 7006 gfc_current_ns->operator_access[other_op] = 7007 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE; 7008 7009 } 7010 else 7011 { 7012 gfc_error ("Access specification of the %s operator at %C has " 7013 "already been specified", gfc_op2string (op)); 7014 goto done; 7015 } 7016 7017 break; 7018 7019 case INTERFACE_USER_OP: 7020 uop = gfc_get_uop (name); 7021 7022 if (uop->access == ACCESS_UNKNOWN) 7023 { 7024 uop->access = (st == ST_PUBLIC) 7025 ? ACCESS_PUBLIC : ACCESS_PRIVATE; 7026 } 7027 else 7028 { 7029 gfc_error ("Access specification of the .%s. operator at %C " 7030 "has already been specified", sym->name); 7031 goto done; 7032 } 7033 7034 break; 7035 } 7036 7037 if (gfc_match_char (',') == MATCH_NO) 7038 break; 7039 } 7040 7041 if (gfc_match_eos () != MATCH_YES) 7042 goto syntax; 7043 return MATCH_YES; 7044 7045syntax: 7046 gfc_syntax_error (st); 7047 7048done: 7049 return MATCH_ERROR; 7050} 7051 7052 7053match 7054gfc_match_protected (void) 7055{ 7056 gfc_symbol *sym; 7057 match m; 7058 7059 if (!gfc_current_ns->proc_name 7060 || gfc_current_ns->proc_name->attr.flavor != FL_MODULE) 7061 { 7062 gfc_error ("PROTECTED at %C only allowed in specification " 7063 "part of a module"); 7064 return MATCH_ERROR; 7065 7066 } 7067 7068 if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C")) 7069 return MATCH_ERROR; 7070 7071 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 7072 { 7073 return MATCH_ERROR; 7074 } 7075 7076 if (gfc_match_eos () == MATCH_YES) 7077 goto syntax; 7078 7079 for(;;) 7080 { 7081 m = gfc_match_symbol (&sym, 0); 7082 switch (m) 7083 { 7084 case MATCH_YES: 7085 if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)) 7086 return MATCH_ERROR; 7087 goto next_item; 7088 7089 case MATCH_NO: 7090 break; 7091 7092 case MATCH_ERROR: 7093 return MATCH_ERROR; 7094 } 7095 7096 next_item: 7097 if (gfc_match_eos () == MATCH_YES) 7098 break; 7099 if (gfc_match_char (',') != MATCH_YES) 7100 goto syntax; 7101 } 7102 7103 return MATCH_YES; 7104 7105syntax: 7106 gfc_error ("Syntax error in PROTECTED statement at %C"); 7107 return MATCH_ERROR; 7108} 7109 7110 7111/* The PRIVATE statement is a bit weird in that it can be an attribute 7112 declaration, but also works as a standalone statement inside of a 7113 type declaration or a module. */ 7114 7115match 7116gfc_match_private (gfc_statement *st) 7117{ 7118 7119 if (gfc_match ("private") != MATCH_YES) 7120 return MATCH_NO; 7121 7122 if (gfc_current_state () != COMP_MODULE 7123 && !(gfc_current_state () == COMP_DERIVED 7124 && gfc_state_stack->previous 7125 && gfc_state_stack->previous->state == COMP_MODULE) 7126 && !(gfc_current_state () == COMP_DERIVED_CONTAINS 7127 && gfc_state_stack->previous && gfc_state_stack->previous->previous 7128 && gfc_state_stack->previous->previous->state == COMP_MODULE)) 7129 { 7130 gfc_error ("PRIVATE statement at %C is only allowed in the " 7131 "specification part of a module"); 7132 return MATCH_ERROR; 7133 } 7134 7135 if (gfc_current_state () == COMP_DERIVED) 7136 { 7137 if (gfc_match_eos () == MATCH_YES) 7138 { 7139 *st = ST_PRIVATE; 7140 return MATCH_YES; 7141 } 7142 7143 gfc_syntax_error (ST_PRIVATE); 7144 return MATCH_ERROR; 7145 } 7146 7147 if (gfc_match_eos () == MATCH_YES) 7148 { 7149 *st = ST_PRIVATE; 7150 return MATCH_YES; 7151 } 7152 7153 *st = ST_ATTR_DECL; 7154 return access_attr_decl (ST_PRIVATE); 7155} 7156 7157 7158match 7159gfc_match_public (gfc_statement *st) 7160{ 7161 7162 if (gfc_match ("public") != MATCH_YES) 7163 return MATCH_NO; 7164 7165 if (gfc_current_state () != COMP_MODULE) 7166 { 7167 gfc_error ("PUBLIC statement at %C is only allowed in the " 7168 "specification part of a module"); 7169 return MATCH_ERROR; 7170 } 7171 7172 if (gfc_match_eos () == MATCH_YES) 7173 { 7174 *st = ST_PUBLIC; 7175 return MATCH_YES; 7176 } 7177 7178 *st = ST_ATTR_DECL; 7179 return access_attr_decl (ST_PUBLIC); 7180} 7181 7182 7183/* Workhorse for gfc_match_parameter. */ 7184 7185static match 7186do_parm (void) 7187{ 7188 gfc_symbol *sym; 7189 gfc_expr *init; 7190 match m; 7191 bool t; 7192 7193 m = gfc_match_symbol (&sym, 0); 7194 if (m == MATCH_NO) 7195 gfc_error ("Expected variable name at %C in PARAMETER statement"); 7196 7197 if (m != MATCH_YES) 7198 return m; 7199 7200 if (gfc_match_char ('=') == MATCH_NO) 7201 { 7202 gfc_error ("Expected = sign in PARAMETER statement at %C"); 7203 return MATCH_ERROR; 7204 } 7205 7206 m = gfc_match_init_expr (&init); 7207 if (m == MATCH_NO) 7208 gfc_error ("Expected expression at %C in PARAMETER statement"); 7209 if (m != MATCH_YES) 7210 return m; 7211 7212 if (sym->ts.type == BT_UNKNOWN 7213 && !gfc_set_default_type (sym, 1, NULL)) 7214 { 7215 m = MATCH_ERROR; 7216 goto cleanup; 7217 } 7218 7219 if (!gfc_check_assign_symbol (sym, NULL, init) 7220 || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL)) 7221 { 7222 m = MATCH_ERROR; 7223 goto cleanup; 7224 } 7225 7226 if (sym->value) 7227 { 7228 gfc_error ("Initializing already initialized variable at %C"); 7229 m = MATCH_ERROR; 7230 goto cleanup; 7231 } 7232 7233 t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus); 7234 return (t) ? MATCH_YES : MATCH_ERROR; 7235 7236cleanup: 7237 gfc_free_expr (init); 7238 return m; 7239} 7240 7241 7242/* Match a parameter statement, with the weird syntax that these have. */ 7243 7244match 7245gfc_match_parameter (void) 7246{ 7247 match m; 7248 7249 if (gfc_match_char ('(') == MATCH_NO) 7250 return MATCH_NO; 7251 7252 for (;;) 7253 { 7254 m = do_parm (); 7255 if (m != MATCH_YES) 7256 break; 7257 7258 if (gfc_match (" )%t") == MATCH_YES) 7259 break; 7260 7261 if (gfc_match_char (',') != MATCH_YES) 7262 { 7263 gfc_error ("Unexpected characters in PARAMETER statement at %C"); 7264 m = MATCH_ERROR; 7265 break; 7266 } 7267 } 7268 7269 return m; 7270} 7271 7272 7273/* Save statements have a special syntax. */ 7274 7275match 7276gfc_match_save (void) 7277{ 7278 char n[GFC_MAX_SYMBOL_LEN+1]; 7279 gfc_common_head *c; 7280 gfc_symbol *sym; 7281 match m; 7282 7283 if (gfc_match_eos () == MATCH_YES) 7284 { 7285 if (gfc_current_ns->seen_save) 7286 { 7287 if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C " 7288 "follows previous SAVE statement")) 7289 return MATCH_ERROR; 7290 } 7291 7292 gfc_current_ns->save_all = gfc_current_ns->seen_save = 1; 7293 return MATCH_YES; 7294 } 7295 7296 if (gfc_current_ns->save_all) 7297 { 7298 if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows " 7299 "blanket SAVE statement")) 7300 return MATCH_ERROR; 7301 } 7302 7303 gfc_match (" ::"); 7304 7305 for (;;) 7306 { 7307 m = gfc_match_symbol (&sym, 0); 7308 switch (m) 7309 { 7310 case MATCH_YES: 7311 if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, 7312 &gfc_current_locus)) 7313 return MATCH_ERROR; 7314 goto next_item; 7315 7316 case MATCH_NO: 7317 break; 7318 7319 case MATCH_ERROR: 7320 return MATCH_ERROR; 7321 } 7322 7323 m = gfc_match (" / %n /", &n); 7324 if (m == MATCH_ERROR) 7325 return MATCH_ERROR; 7326 if (m == MATCH_NO) 7327 goto syntax; 7328 7329 c = gfc_get_common (n, 0); 7330 c->saved = 1; 7331 7332 gfc_current_ns->seen_save = 1; 7333 7334 next_item: 7335 if (gfc_match_eos () == MATCH_YES) 7336 break; 7337 if (gfc_match_char (',') != MATCH_YES) 7338 goto syntax; 7339 } 7340 7341 return MATCH_YES; 7342 7343syntax: 7344 gfc_error ("Syntax error in SAVE statement at %C"); 7345 return MATCH_ERROR; 7346} 7347 7348 7349match 7350gfc_match_value (void) 7351{ 7352 gfc_symbol *sym; 7353 match m; 7354 7355 /* This is not allowed within a BLOCK construct! */ 7356 if (gfc_current_state () == COMP_BLOCK) 7357 { 7358 gfc_error ("VALUE is not allowed inside of BLOCK at %C"); 7359 return MATCH_ERROR; 7360 } 7361 7362 if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C")) 7363 return MATCH_ERROR; 7364 7365 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 7366 { 7367 return MATCH_ERROR; 7368 } 7369 7370 if (gfc_match_eos () == MATCH_YES) 7371 goto syntax; 7372 7373 for(;;) 7374 { 7375 m = gfc_match_symbol (&sym, 0); 7376 switch (m) 7377 { 7378 case MATCH_YES: 7379 if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)) 7380 return MATCH_ERROR; 7381 goto next_item; 7382 7383 case MATCH_NO: 7384 break; 7385 7386 case MATCH_ERROR: 7387 return MATCH_ERROR; 7388 } 7389 7390 next_item: 7391 if (gfc_match_eos () == MATCH_YES) 7392 break; 7393 if (gfc_match_char (',') != MATCH_YES) 7394 goto syntax; 7395 } 7396 7397 return MATCH_YES; 7398 7399syntax: 7400 gfc_error ("Syntax error in VALUE statement at %C"); 7401 return MATCH_ERROR; 7402} 7403 7404 7405match 7406gfc_match_volatile (void) 7407{ 7408 gfc_symbol *sym; 7409 match m; 7410 7411 if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C")) 7412 return MATCH_ERROR; 7413 7414 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 7415 { 7416 return MATCH_ERROR; 7417 } 7418 7419 if (gfc_match_eos () == MATCH_YES) 7420 goto syntax; 7421 7422 for(;;) 7423 { 7424 /* VOLATILE is special because it can be added to host-associated 7425 symbols locally. Except for coarrays. */ 7426 m = gfc_match_symbol (&sym, 1); 7427 switch (m) 7428 { 7429 case MATCH_YES: 7430 /* F2008, C560+C561. VOLATILE for host-/use-associated variable or 7431 for variable in a BLOCK which is defined outside of the BLOCK. */ 7432 if (sym->ns != gfc_current_ns && sym->attr.codimension) 7433 { 7434 gfc_error ("Specifying VOLATILE for coarray variable %qs at " 7435 "%C, which is use-/host-associated", sym->name); 7436 return MATCH_ERROR; 7437 } 7438 if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)) 7439 return MATCH_ERROR; 7440 goto next_item; 7441 7442 case MATCH_NO: 7443 break; 7444 7445 case MATCH_ERROR: 7446 return MATCH_ERROR; 7447 } 7448 7449 next_item: 7450 if (gfc_match_eos () == MATCH_YES) 7451 break; 7452 if (gfc_match_char (',') != MATCH_YES) 7453 goto syntax; 7454 } 7455 7456 return MATCH_YES; 7457 7458syntax: 7459 gfc_error ("Syntax error in VOLATILE statement at %C"); 7460 return MATCH_ERROR; 7461} 7462 7463 7464match 7465gfc_match_asynchronous (void) 7466{ 7467 gfc_symbol *sym; 7468 match m; 7469 7470 if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C")) 7471 return MATCH_ERROR; 7472 7473 if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO) 7474 { 7475 return MATCH_ERROR; 7476 } 7477 7478 if (gfc_match_eos () == MATCH_YES) 7479 goto syntax; 7480 7481 for(;;) 7482 { 7483 /* ASYNCHRONOUS is special because it can be added to host-associated 7484 symbols locally. */ 7485 m = gfc_match_symbol (&sym, 1); 7486 switch (m) 7487 { 7488 case MATCH_YES: 7489 if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus)) 7490 return MATCH_ERROR; 7491 goto next_item; 7492 7493 case MATCH_NO: 7494 break; 7495 7496 case MATCH_ERROR: 7497 return MATCH_ERROR; 7498 } 7499 7500 next_item: 7501 if (gfc_match_eos () == MATCH_YES) 7502 break; 7503 if (gfc_match_char (',') != MATCH_YES) 7504 goto syntax; 7505 } 7506 7507 return MATCH_YES; 7508 7509syntax: 7510 gfc_error ("Syntax error in ASYNCHRONOUS statement at %C"); 7511 return MATCH_ERROR; 7512} 7513 7514 7515/* Match a module procedure statement. Note that we have to modify 7516 symbols in the parent's namespace because the current one was there 7517 to receive symbols that are in an interface's formal argument list. */ 7518 7519match 7520gfc_match_modproc (void) 7521{ 7522 char name[GFC_MAX_SYMBOL_LEN + 1]; 7523 gfc_symbol *sym; 7524 match m; 7525 locus old_locus; 7526 gfc_namespace *module_ns; 7527 gfc_interface *old_interface_head, *interface; 7528 7529 if (gfc_state_stack->state != COMP_INTERFACE 7530 || gfc_state_stack->previous == NULL 7531 || current_interface.type == INTERFACE_NAMELESS 7532 || current_interface.type == INTERFACE_ABSTRACT) 7533 { 7534 gfc_error ("MODULE PROCEDURE at %C must be in a generic module " 7535 "interface"); 7536 return MATCH_ERROR; 7537 } 7538 7539 module_ns = gfc_current_ns->parent; 7540 for (; module_ns; module_ns = module_ns->parent) 7541 if (module_ns->proc_name->attr.flavor == FL_MODULE 7542 || module_ns->proc_name->attr.flavor == FL_PROGRAM 7543 || (module_ns->proc_name->attr.flavor == FL_PROCEDURE 7544 && !module_ns->proc_name->attr.contained)) 7545 break; 7546 7547 if (module_ns == NULL) 7548 return MATCH_ERROR; 7549 7550 /* Store the current state of the interface. We will need it if we 7551 end up with a syntax error and need to recover. */ 7552 old_interface_head = gfc_current_interface_head (); 7553 7554 /* Check if the F2008 optional double colon appears. */ 7555 gfc_gobble_whitespace (); 7556 old_locus = gfc_current_locus; 7557 if (gfc_match ("::") == MATCH_YES) 7558 { 7559 if (!gfc_notify_std (GFC_STD_F2008, "double colon in " 7560 "MODULE PROCEDURE statement at %L", &old_locus)) 7561 return MATCH_ERROR; 7562 } 7563 else 7564 gfc_current_locus = old_locus; 7565 7566 for (;;) 7567 { 7568 bool last = false; 7569 old_locus = gfc_current_locus; 7570 7571 m = gfc_match_name (name); 7572 if (m == MATCH_NO) 7573 goto syntax; 7574 if (m != MATCH_YES) 7575 return MATCH_ERROR; 7576 7577 /* Check for syntax error before starting to add symbols to the 7578 current namespace. */ 7579 if (gfc_match_eos () == MATCH_YES) 7580 last = true; 7581 7582 if (!last && gfc_match_char (',') != MATCH_YES) 7583 goto syntax; 7584 7585 /* Now we're sure the syntax is valid, we process this item 7586 further. */ 7587 if (gfc_get_symbol (name, module_ns, &sym)) 7588 return MATCH_ERROR; 7589 7590 if (sym->attr.intrinsic) 7591 { 7592 gfc_error ("Intrinsic procedure at %L cannot be a MODULE " 7593 "PROCEDURE", &old_locus); 7594 return MATCH_ERROR; 7595 } 7596 7597 if (sym->attr.proc != PROC_MODULE 7598 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 7599 return MATCH_ERROR; 7600 7601 if (!gfc_add_interface (sym)) 7602 return MATCH_ERROR; 7603 7604 sym->attr.mod_proc = 1; 7605 sym->declared_at = old_locus; 7606 7607 if (last) 7608 break; 7609 } 7610 7611 return MATCH_YES; 7612 7613syntax: 7614 /* Restore the previous state of the interface. */ 7615 interface = gfc_current_interface_head (); 7616 gfc_set_current_interface_head (old_interface_head); 7617 7618 /* Free the new interfaces. */ 7619 while (interface != old_interface_head) 7620 { 7621 gfc_interface *i = interface->next; 7622 free (interface); 7623 interface = i; 7624 } 7625 7626 /* And issue a syntax error. */ 7627 gfc_syntax_error (ST_MODULE_PROC); 7628 return MATCH_ERROR; 7629} 7630 7631 7632/* Check a derived type that is being extended. */ 7633 7634static gfc_symbol* 7635check_extended_derived_type (char *name) 7636{ 7637 gfc_symbol *extended; 7638 7639 if (gfc_find_symbol (name, gfc_current_ns, 1, &extended)) 7640 { 7641 gfc_error ("Ambiguous symbol in TYPE definition at %C"); 7642 return NULL; 7643 } 7644 7645 extended = gfc_find_dt_in_generic (extended); 7646 7647 /* F08:C428. */ 7648 if (!extended) 7649 { 7650 gfc_error ("Symbol %qs at %C has not been previously defined", name); 7651 return NULL; 7652 } 7653 7654 if (extended->attr.flavor != FL_DERIVED) 7655 { 7656 gfc_error ("%qs in EXTENDS expression at %C is not a " 7657 "derived type", name); 7658 return NULL; 7659 } 7660 7661 if (extended->attr.is_bind_c) 7662 { 7663 gfc_error ("%qs cannot be extended at %C because it " 7664 "is BIND(C)", extended->name); 7665 return NULL; 7666 } 7667 7668 if (extended->attr.sequence) 7669 { 7670 gfc_error ("%qs cannot be extended at %C because it " 7671 "is a SEQUENCE type", extended->name); 7672 return NULL; 7673 } 7674 7675 return extended; 7676} 7677 7678 7679/* Match the optional attribute specifiers for a type declaration. 7680 Return MATCH_ERROR if an error is encountered in one of the handled 7681 attributes (public, private, bind(c)), MATCH_NO if what's found is 7682 not a handled attribute, and MATCH_YES otherwise. TODO: More error 7683 checking on attribute conflicts needs to be done. */ 7684 7685match 7686gfc_get_type_attr_spec (symbol_attribute *attr, char *name) 7687{ 7688 /* See if the derived type is marked as private. */ 7689 if (gfc_match (" , private") == MATCH_YES) 7690 { 7691 if (gfc_current_state () != COMP_MODULE) 7692 { 7693 gfc_error ("Derived type at %C can only be PRIVATE in the " 7694 "specification part of a module"); 7695 return MATCH_ERROR; 7696 } 7697 7698 if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL)) 7699 return MATCH_ERROR; 7700 } 7701 else if (gfc_match (" , public") == MATCH_YES) 7702 { 7703 if (gfc_current_state () != COMP_MODULE) 7704 { 7705 gfc_error ("Derived type at %C can only be PUBLIC in the " 7706 "specification part of a module"); 7707 return MATCH_ERROR; 7708 } 7709 7710 if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL)) 7711 return MATCH_ERROR; 7712 } 7713 else if (gfc_match (" , bind ( c )") == MATCH_YES) 7714 { 7715 /* If the type is defined to be bind(c) it then needs to make 7716 sure that all fields are interoperable. This will 7717 need to be a semantic check on the finished derived type. 7718 See 15.2.3 (lines 9-12) of F2003 draft. */ 7719 if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0)) 7720 return MATCH_ERROR; 7721 7722 /* TODO: attr conflicts need to be checked, probably in symbol.c. */ 7723 } 7724 else if (gfc_match (" , abstract") == MATCH_YES) 7725 { 7726 if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C")) 7727 return MATCH_ERROR; 7728 7729 if (!gfc_add_abstract (attr, &gfc_current_locus)) 7730 return MATCH_ERROR; 7731 } 7732 else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES) 7733 { 7734 if (!gfc_add_extension (attr, &gfc_current_locus)) 7735 return MATCH_ERROR; 7736 } 7737 else 7738 return MATCH_NO; 7739 7740 /* If we get here, something matched. */ 7741 return MATCH_YES; 7742} 7743 7744 7745/* Match the beginning of a derived type declaration. If a type name 7746 was the result of a function, then it is possible to have a symbol 7747 already to be known as a derived type yet have no components. */ 7748 7749match 7750gfc_match_derived_decl (void) 7751{ 7752 char name[GFC_MAX_SYMBOL_LEN + 1]; 7753 char parent[GFC_MAX_SYMBOL_LEN + 1]; 7754 symbol_attribute attr; 7755 gfc_symbol *sym, *gensym; 7756 gfc_symbol *extended; 7757 match m; 7758 match is_type_attr_spec = MATCH_NO; 7759 bool seen_attr = false; 7760 gfc_interface *intr = NULL, *head; 7761 7762 if (gfc_current_state () == COMP_DERIVED) 7763 return MATCH_NO; 7764 7765 name[0] = '\0'; 7766 parent[0] = '\0'; 7767 gfc_clear_attr (&attr); 7768 extended = NULL; 7769 7770 do 7771 { 7772 is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent); 7773 if (is_type_attr_spec == MATCH_ERROR) 7774 return MATCH_ERROR; 7775 if (is_type_attr_spec == MATCH_YES) 7776 seen_attr = true; 7777 } while (is_type_attr_spec == MATCH_YES); 7778 7779 /* Deal with derived type extensions. The extension attribute has 7780 been added to 'attr' but now the parent type must be found and 7781 checked. */ 7782 if (parent[0]) 7783 extended = check_extended_derived_type (parent); 7784 7785 if (parent[0] && !extended) 7786 return MATCH_ERROR; 7787 7788 if (gfc_match (" ::") != MATCH_YES && seen_attr) 7789 { 7790 gfc_error ("Expected :: in TYPE definition at %C"); 7791 return MATCH_ERROR; 7792 } 7793 7794 m = gfc_match (" %n%t", name); 7795 if (m != MATCH_YES) 7796 return m; 7797 7798 /* Make sure the name is not the name of an intrinsic type. */ 7799 if (gfc_is_intrinsic_typename (name)) 7800 { 7801 gfc_error ("Type name %qs at %C cannot be the same as an intrinsic " 7802 "type", name); 7803 return MATCH_ERROR; 7804 } 7805 7806 if (gfc_get_symbol (name, NULL, &gensym)) 7807 return MATCH_ERROR; 7808 7809 if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN) 7810 { 7811 gfc_error ("Derived type name %qs at %C already has a basic type " 7812 "of %s", gensym->name, gfc_typename (&gensym->ts)); 7813 return MATCH_ERROR; 7814 } 7815 7816 if (!gensym->attr.generic 7817 && !gfc_add_generic (&gensym->attr, gensym->name, NULL)) 7818 return MATCH_ERROR; 7819 7820 if (!gensym->attr.function 7821 && !gfc_add_function (&gensym->attr, gensym->name, NULL)) 7822 return MATCH_ERROR; 7823 7824 sym = gfc_find_dt_in_generic (gensym); 7825 7826 if (sym && (sym->components != NULL || sym->attr.zero_comp)) 7827 { 7828 gfc_error ("Derived type definition of %qs at %C has already been " 7829 "defined", sym->name); 7830 return MATCH_ERROR; 7831 } 7832 7833 if (!sym) 7834 { 7835 /* Use upper case to save the actual derived-type symbol. */ 7836 gfc_get_symbol (gfc_get_string ("%c%s", 7837 (char) TOUPPER ((unsigned char) gensym->name[0]), 7838 &gensym->name[1]), NULL, &sym); 7839 sym->name = gfc_get_string (gensym->name); 7840 head = gensym->generic; 7841 intr = gfc_get_interface (); 7842 intr->sym = sym; 7843 intr->where = gfc_current_locus; 7844 intr->sym->declared_at = gfc_current_locus; 7845 intr->next = head; 7846 gensym->generic = intr; 7847 gensym->attr.if_source = IFSRC_DECL; 7848 } 7849 7850 /* The symbol may already have the derived attribute without the 7851 components. The ways this can happen is via a function 7852 definition, an INTRINSIC statement or a subtype in another 7853 derived type that is a pointer. The first part of the AND clause 7854 is true if the symbol is not the return value of a function. */ 7855 if (sym->attr.flavor != FL_DERIVED 7856 && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL)) 7857 return MATCH_ERROR; 7858 7859 if (attr.access != ACCESS_UNKNOWN 7860 && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL)) 7861 return MATCH_ERROR; 7862 else if (sym->attr.access == ACCESS_UNKNOWN 7863 && gensym->attr.access != ACCESS_UNKNOWN 7864 && !gfc_add_access (&sym->attr, gensym->attr.access, 7865 sym->name, NULL)) 7866 return MATCH_ERROR; 7867 7868 if (sym->attr.access != ACCESS_UNKNOWN 7869 && gensym->attr.access == ACCESS_UNKNOWN) 7870 gensym->attr.access = sym->attr.access; 7871 7872 /* See if the derived type was labeled as bind(c). */ 7873 if (attr.is_bind_c != 0) 7874 sym->attr.is_bind_c = attr.is_bind_c; 7875 7876 /* Construct the f2k_derived namespace if it is not yet there. */ 7877 if (!sym->f2k_derived) 7878 sym->f2k_derived = gfc_get_namespace (NULL, 0); 7879 7880 if (extended && !sym->components) 7881 { 7882 gfc_component *p; 7883 7884 /* Add the extended derived type as the first component. */ 7885 gfc_add_component (sym, parent, &p); 7886 extended->refs++; 7887 gfc_set_sym_referenced (extended); 7888 7889 p->ts.type = BT_DERIVED; 7890 p->ts.u.derived = extended; 7891 p->initializer = gfc_default_initializer (&p->ts); 7892 7893 /* Set extension level. */ 7894 if (extended->attr.extension == 255) 7895 { 7896 /* Since the extension field is 8 bit wide, we can only have 7897 up to 255 extension levels. */ 7898 gfc_error ("Maximum extension level reached with type %qs at %L", 7899 extended->name, &extended->declared_at); 7900 return MATCH_ERROR; 7901 } 7902 sym->attr.extension = extended->attr.extension + 1; 7903 7904 /* Provide the links between the extended type and its extension. */ 7905 if (!extended->f2k_derived) 7906 extended->f2k_derived = gfc_get_namespace (NULL, 0); 7907 } 7908 7909 if (!sym->hash_value) 7910 /* Set the hash for the compound name for this type. */ 7911 sym->hash_value = gfc_hash_value (sym); 7912 7913 /* Take over the ABSTRACT attribute. */ 7914 sym->attr.abstract = attr.abstract; 7915 7916 gfc_new_block = sym; 7917 7918 return MATCH_YES; 7919} 7920 7921 7922/* Cray Pointees can be declared as: 7923 pointer (ipt, a (n,m,...,*)) */ 7924 7925match 7926gfc_mod_pointee_as (gfc_array_spec *as) 7927{ 7928 as->cray_pointee = true; /* This will be useful to know later. */ 7929 if (as->type == AS_ASSUMED_SIZE) 7930 as->cp_was_assumed = true; 7931 else if (as->type == AS_ASSUMED_SHAPE) 7932 { 7933 gfc_error ("Cray Pointee at %C cannot be assumed shape array"); 7934 return MATCH_ERROR; 7935 } 7936 return MATCH_YES; 7937} 7938 7939 7940/* Match the enum definition statement, here we are trying to match 7941 the first line of enum definition statement. 7942 Returns MATCH_YES if match is found. */ 7943 7944match 7945gfc_match_enum (void) 7946{ 7947 match m; 7948 7949 m = gfc_match_eos (); 7950 if (m != MATCH_YES) 7951 return m; 7952 7953 if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C")) 7954 return MATCH_ERROR; 7955 7956 return MATCH_YES; 7957} 7958 7959 7960/* Returns an initializer whose value is one higher than the value of the 7961 LAST_INITIALIZER argument. If the argument is NULL, the 7962 initializers value will be set to zero. The initializer's kind 7963 will be set to gfc_c_int_kind. 7964 7965 If -fshort-enums is given, the appropriate kind will be selected 7966 later after all enumerators have been parsed. A warning is issued 7967 here if an initializer exceeds gfc_c_int_kind. */ 7968 7969static gfc_expr * 7970enum_initializer (gfc_expr *last_initializer, locus where) 7971{ 7972 gfc_expr *result; 7973 result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where); 7974 7975 mpz_init (result->value.integer); 7976 7977 if (last_initializer != NULL) 7978 { 7979 mpz_add_ui (result->value.integer, last_initializer->value.integer, 1); 7980 result->where = last_initializer->where; 7981 7982 if (gfc_check_integer_range (result->value.integer, 7983 gfc_c_int_kind) != ARITH_OK) 7984 { 7985 gfc_error ("Enumerator exceeds the C integer type at %C"); 7986 return NULL; 7987 } 7988 } 7989 else 7990 { 7991 /* Control comes here, if it's the very first enumerator and no 7992 initializer has been given. It will be initialized to zero. */ 7993 mpz_set_si (result->value.integer, 0); 7994 } 7995 7996 return result; 7997} 7998 7999 8000/* Match a variable name with an optional initializer. When this 8001 subroutine is called, a variable is expected to be parsed next. 8002 Depending on what is happening at the moment, updates either the 8003 symbol table or the current interface. */ 8004 8005static match 8006enumerator_decl (void) 8007{ 8008 char name[GFC_MAX_SYMBOL_LEN + 1]; 8009 gfc_expr *initializer; 8010 gfc_array_spec *as = NULL; 8011 gfc_symbol *sym; 8012 locus var_locus; 8013 match m; 8014 bool t; 8015 locus old_locus; 8016 8017 initializer = NULL; 8018 old_locus = gfc_current_locus; 8019 8020 /* When we get here, we've just matched a list of attributes and 8021 maybe a type and a double colon. The next thing we expect to see 8022 is the name of the symbol. */ 8023 m = gfc_match_name (name); 8024 if (m != MATCH_YES) 8025 goto cleanup; 8026 8027 var_locus = gfc_current_locus; 8028 8029 /* OK, we've successfully matched the declaration. Now put the 8030 symbol in the current namespace. If we fail to create the symbol, 8031 bail out. */ 8032 if (!build_sym (name, NULL, false, &as, &var_locus)) 8033 { 8034 m = MATCH_ERROR; 8035 goto cleanup; 8036 } 8037 8038 /* The double colon must be present in order to have initializers. 8039 Otherwise the statement is ambiguous with an assignment statement. */ 8040 if (colon_seen) 8041 { 8042 if (gfc_match_char ('=') == MATCH_YES) 8043 { 8044 m = gfc_match_init_expr (&initializer); 8045 if (m == MATCH_NO) 8046 { 8047 gfc_error ("Expected an initialization expression at %C"); 8048 m = MATCH_ERROR; 8049 } 8050 8051 if (m != MATCH_YES) 8052 goto cleanup; 8053 } 8054 } 8055 8056 /* If we do not have an initializer, the initialization value of the 8057 previous enumerator (stored in last_initializer) is incremented 8058 by 1 and is used to initialize the current enumerator. */ 8059 if (initializer == NULL) 8060 initializer = enum_initializer (last_initializer, old_locus); 8061 8062 if (initializer == NULL || initializer->ts.type != BT_INTEGER) 8063 { 8064 gfc_error ("ENUMERATOR %L not initialized with integer expression", 8065 &var_locus); 8066 m = MATCH_ERROR; 8067 goto cleanup; 8068 } 8069 8070 /* Store this current initializer, for the next enumerator variable 8071 to be parsed. add_init_expr_to_sym() zeros initializer, so we 8072 use last_initializer below. */ 8073 last_initializer = initializer; 8074 t = add_init_expr_to_sym (name, &initializer, &var_locus); 8075 8076 /* Maintain enumerator history. */ 8077 gfc_find_symbol (name, NULL, 0, &sym); 8078 create_enum_history (sym, last_initializer); 8079 8080 return (t) ? MATCH_YES : MATCH_ERROR; 8081 8082cleanup: 8083 /* Free stuff up and return. */ 8084 gfc_free_expr (initializer); 8085 8086 return m; 8087} 8088 8089 8090/* Match the enumerator definition statement. */ 8091 8092match 8093gfc_match_enumerator_def (void) 8094{ 8095 match m; 8096 bool t; 8097 8098 gfc_clear_ts (¤t_ts); 8099 8100 m = gfc_match (" enumerator"); 8101 if (m != MATCH_YES) 8102 return m; 8103 8104 m = gfc_match (" :: "); 8105 if (m == MATCH_ERROR) 8106 return m; 8107 8108 colon_seen = (m == MATCH_YES); 8109 8110 if (gfc_current_state () != COMP_ENUM) 8111 { 8112 gfc_error ("ENUM definition statement expected before %C"); 8113 gfc_free_enum_history (); 8114 return MATCH_ERROR; 8115 } 8116 8117 (¤t_ts)->type = BT_INTEGER; 8118 (¤t_ts)->kind = gfc_c_int_kind; 8119 8120 gfc_clear_attr (¤t_attr); 8121 t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL); 8122 if (!t) 8123 { 8124 m = MATCH_ERROR; 8125 goto cleanup; 8126 } 8127 8128 for (;;) 8129 { 8130 m = enumerator_decl (); 8131 if (m == MATCH_ERROR) 8132 { 8133 gfc_free_enum_history (); 8134 goto cleanup; 8135 } 8136 if (m == MATCH_NO) 8137 break; 8138 8139 if (gfc_match_eos () == MATCH_YES) 8140 goto cleanup; 8141 if (gfc_match_char (',') != MATCH_YES) 8142 break; 8143 } 8144 8145 if (gfc_current_state () == COMP_ENUM) 8146 { 8147 gfc_free_enum_history (); 8148 gfc_error ("Syntax error in ENUMERATOR definition at %C"); 8149 m = MATCH_ERROR; 8150 } 8151 8152cleanup: 8153 gfc_free_array_spec (current_as); 8154 current_as = NULL; 8155 return m; 8156 8157} 8158 8159 8160/* Match binding attributes. */ 8161 8162static match 8163match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc) 8164{ 8165 bool found_passing = false; 8166 bool seen_ptr = false; 8167 match m = MATCH_YES; 8168 8169 /* Initialize to defaults. Do so even before the MATCH_NO check so that in 8170 this case the defaults are in there. */ 8171 ba->access = ACCESS_UNKNOWN; 8172 ba->pass_arg = NULL; 8173 ba->pass_arg_num = 0; 8174 ba->nopass = 0; 8175 ba->non_overridable = 0; 8176 ba->deferred = 0; 8177 ba->ppc = ppc; 8178 8179 /* If we find a comma, we believe there are binding attributes. */ 8180 m = gfc_match_char (','); 8181 if (m == MATCH_NO) 8182 goto done; 8183 8184 do 8185 { 8186 /* Access specifier. */ 8187 8188 m = gfc_match (" public"); 8189 if (m == MATCH_ERROR) 8190 goto error; 8191 if (m == MATCH_YES) 8192 { 8193 if (ba->access != ACCESS_UNKNOWN) 8194 { 8195 gfc_error ("Duplicate access-specifier at %C"); 8196 goto error; 8197 } 8198 8199 ba->access = ACCESS_PUBLIC; 8200 continue; 8201 } 8202 8203 m = gfc_match (" private"); 8204 if (m == MATCH_ERROR) 8205 goto error; 8206 if (m == MATCH_YES) 8207 { 8208 if (ba->access != ACCESS_UNKNOWN) 8209 { 8210 gfc_error ("Duplicate access-specifier at %C"); 8211 goto error; 8212 } 8213 8214 ba->access = ACCESS_PRIVATE; 8215 continue; 8216 } 8217 8218 /* If inside GENERIC, the following is not allowed. */ 8219 if (!generic) 8220 { 8221 8222 /* NOPASS flag. */ 8223 m = gfc_match (" nopass"); 8224 if (m == MATCH_ERROR) 8225 goto error; 8226 if (m == MATCH_YES) 8227 { 8228 if (found_passing) 8229 { 8230 gfc_error ("Binding attributes already specify passing," 8231 " illegal NOPASS at %C"); 8232 goto error; 8233 } 8234 8235 found_passing = true; 8236 ba->nopass = 1; 8237 continue; 8238 } 8239 8240 /* PASS possibly including argument. */ 8241 m = gfc_match (" pass"); 8242 if (m == MATCH_ERROR) 8243 goto error; 8244 if (m == MATCH_YES) 8245 { 8246 char arg[GFC_MAX_SYMBOL_LEN + 1]; 8247 8248 if (found_passing) 8249 { 8250 gfc_error ("Binding attributes already specify passing," 8251 " illegal PASS at %C"); 8252 goto error; 8253 } 8254 8255 m = gfc_match (" ( %n )", arg); 8256 if (m == MATCH_ERROR) 8257 goto error; 8258 if (m == MATCH_YES) 8259 ba->pass_arg = gfc_get_string (arg); 8260 gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL)); 8261 8262 found_passing = true; 8263 ba->nopass = 0; 8264 continue; 8265 } 8266 8267 if (ppc) 8268 { 8269 /* POINTER flag. */ 8270 m = gfc_match (" pointer"); 8271 if (m == MATCH_ERROR) 8272 goto error; 8273 if (m == MATCH_YES) 8274 { 8275 if (seen_ptr) 8276 { 8277 gfc_error ("Duplicate POINTER attribute at %C"); 8278 goto error; 8279 } 8280 8281 seen_ptr = true; 8282 continue; 8283 } 8284 } 8285 else 8286 { 8287 /* NON_OVERRIDABLE flag. */ 8288 m = gfc_match (" non_overridable"); 8289 if (m == MATCH_ERROR) 8290 goto error; 8291 if (m == MATCH_YES) 8292 { 8293 if (ba->non_overridable) 8294 { 8295 gfc_error ("Duplicate NON_OVERRIDABLE at %C"); 8296 goto error; 8297 } 8298 8299 ba->non_overridable = 1; 8300 continue; 8301 } 8302 8303 /* DEFERRED flag. */ 8304 m = gfc_match (" deferred"); 8305 if (m == MATCH_ERROR) 8306 goto error; 8307 if (m == MATCH_YES) 8308 { 8309 if (ba->deferred) 8310 { 8311 gfc_error ("Duplicate DEFERRED at %C"); 8312 goto error; 8313 } 8314 8315 ba->deferred = 1; 8316 continue; 8317 } 8318 } 8319 8320 } 8321 8322 /* Nothing matching found. */ 8323 if (generic) 8324 gfc_error ("Expected access-specifier at %C"); 8325 else 8326 gfc_error ("Expected binding attribute at %C"); 8327 goto error; 8328 } 8329 while (gfc_match_char (',') == MATCH_YES); 8330 8331 /* NON_OVERRIDABLE and DEFERRED exclude themselves. */ 8332 if (ba->non_overridable && ba->deferred) 8333 { 8334 gfc_error ("NON_OVERRIDABLE and DEFERRED can't both appear at %C"); 8335 goto error; 8336 } 8337 8338 m = MATCH_YES; 8339 8340done: 8341 if (ba->access == ACCESS_UNKNOWN) 8342 ba->access = gfc_typebound_default_access; 8343 8344 if (ppc && !seen_ptr) 8345 { 8346 gfc_error ("POINTER attribute is required for procedure pointer component" 8347 " at %C"); 8348 goto error; 8349 } 8350 8351 return m; 8352 8353error: 8354 return MATCH_ERROR; 8355} 8356 8357 8358/* Match a PROCEDURE specific binding inside a derived type. */ 8359 8360static match 8361match_procedure_in_type (void) 8362{ 8363 char name[GFC_MAX_SYMBOL_LEN + 1]; 8364 char target_buf[GFC_MAX_SYMBOL_LEN + 1]; 8365 char* target = NULL, *ifc = NULL; 8366 gfc_typebound_proc tb; 8367 bool seen_colons; 8368 bool seen_attrs; 8369 match m; 8370 gfc_symtree* stree; 8371 gfc_namespace* ns; 8372 gfc_symbol* block; 8373 int num; 8374 8375 /* Check current state. */ 8376 gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS); 8377 block = gfc_state_stack->previous->sym; 8378 gcc_assert (block); 8379 8380 /* Try to match PROCEDURE(interface). */ 8381 if (gfc_match (" (") == MATCH_YES) 8382 { 8383 m = gfc_match_name (target_buf); 8384 if (m == MATCH_ERROR) 8385 return m; 8386 if (m != MATCH_YES) 8387 { 8388 gfc_error ("Interface-name expected after %<(%> at %C"); 8389 return MATCH_ERROR; 8390 } 8391 8392 if (gfc_match (" )") != MATCH_YES) 8393 { 8394 gfc_error ("%<)%> expected at %C"); 8395 return MATCH_ERROR; 8396 } 8397 8398 ifc = target_buf; 8399 } 8400 8401 /* Construct the data structure. */ 8402 memset (&tb, 0, sizeof (tb)); 8403 tb.where = gfc_current_locus; 8404 8405 /* Match binding attributes. */ 8406 m = match_binding_attributes (&tb, false, false); 8407 if (m == MATCH_ERROR) 8408 return m; 8409 seen_attrs = (m == MATCH_YES); 8410 8411 /* Check that attribute DEFERRED is given if an interface is specified. */ 8412 if (tb.deferred && !ifc) 8413 { 8414 gfc_error ("Interface must be specified for DEFERRED binding at %C"); 8415 return MATCH_ERROR; 8416 } 8417 if (ifc && !tb.deferred) 8418 { 8419 gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED"); 8420 return MATCH_ERROR; 8421 } 8422 8423 /* Match the colons. */ 8424 m = gfc_match (" ::"); 8425 if (m == MATCH_ERROR) 8426 return m; 8427 seen_colons = (m == MATCH_YES); 8428 if (seen_attrs && !seen_colons) 8429 { 8430 gfc_error ("Expected %<::%> after binding-attributes at %C"); 8431 return MATCH_ERROR; 8432 } 8433 8434 /* Match the binding names. */ 8435 for(num=1;;num++) 8436 { 8437 m = gfc_match_name (name); 8438 if (m == MATCH_ERROR) 8439 return m; 8440 if (m == MATCH_NO) 8441 { 8442 gfc_error ("Expected binding name at %C"); 8443 return MATCH_ERROR; 8444 } 8445 8446 if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C")) 8447 return MATCH_ERROR; 8448 8449 /* Try to match the '=> target', if it's there. */ 8450 target = ifc; 8451 m = gfc_match (" =>"); 8452 if (m == MATCH_ERROR) 8453 return m; 8454 if (m == MATCH_YES) 8455 { 8456 if (tb.deferred) 8457 { 8458 gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C"); 8459 return MATCH_ERROR; 8460 } 8461 8462 if (!seen_colons) 8463 { 8464 gfc_error ("%<::%> needed in PROCEDURE binding with explicit target" 8465 " at %C"); 8466 return MATCH_ERROR; 8467 } 8468 8469 m = gfc_match_name (target_buf); 8470 if (m == MATCH_ERROR) 8471 return m; 8472 if (m == MATCH_NO) 8473 { 8474 gfc_error ("Expected binding target after %<=>%> at %C"); 8475 return MATCH_ERROR; 8476 } 8477 target = target_buf; 8478 } 8479 8480 /* If no target was found, it has the same name as the binding. */ 8481 if (!target) 8482 target = name; 8483 8484 /* Get the namespace to insert the symbols into. */ 8485 ns = block->f2k_derived; 8486 gcc_assert (ns); 8487 8488 /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */ 8489 if (tb.deferred && !block->attr.abstract) 8490 { 8491 gfc_error ("Type %qs containing DEFERRED binding at %C " 8492 "is not ABSTRACT", block->name); 8493 return MATCH_ERROR; 8494 } 8495 8496 /* See if we already have a binding with this name in the symtree which 8497 would be an error. If a GENERIC already targeted this binding, it may 8498 be already there but then typebound is still NULL. */ 8499 stree = gfc_find_symtree (ns->tb_sym_root, name); 8500 if (stree && stree->n.tb) 8501 { 8502 gfc_error ("There is already a procedure with binding name %qs for " 8503 "the derived type %qs at %C", name, block->name); 8504 return MATCH_ERROR; 8505 } 8506 8507 /* Insert it and set attributes. */ 8508 8509 if (!stree) 8510 { 8511 stree = gfc_new_symtree (&ns->tb_sym_root, name); 8512 gcc_assert (stree); 8513 } 8514 stree->n.tb = gfc_get_typebound_proc (&tb); 8515 8516 if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific, 8517 false)) 8518 return MATCH_ERROR; 8519 gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym); 8520 8521 if (gfc_match_eos () == MATCH_YES) 8522 return MATCH_YES; 8523 if (gfc_match_char (',') != MATCH_YES) 8524 goto syntax; 8525 } 8526 8527syntax: 8528 gfc_error ("Syntax error in PROCEDURE statement at %C"); 8529 return MATCH_ERROR; 8530} 8531 8532 8533/* Match a GENERIC procedure binding inside a derived type. */ 8534 8535match 8536gfc_match_generic (void) 8537{ 8538 char name[GFC_MAX_SYMBOL_LEN + 1]; 8539 char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */ 8540 gfc_symbol* block; 8541 gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */ 8542 gfc_typebound_proc* tb; 8543 gfc_namespace* ns; 8544 interface_type op_type; 8545 gfc_intrinsic_op op; 8546 match m; 8547 8548 /* Check current state. */ 8549 if (gfc_current_state () == COMP_DERIVED) 8550 { 8551 gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS"); 8552 return MATCH_ERROR; 8553 } 8554 if (gfc_current_state () != COMP_DERIVED_CONTAINS) 8555 return MATCH_NO; 8556 block = gfc_state_stack->previous->sym; 8557 ns = block->f2k_derived; 8558 gcc_assert (block && ns); 8559 8560 memset (&tbattr, 0, sizeof (tbattr)); 8561 tbattr.where = gfc_current_locus; 8562 8563 /* See if we get an access-specifier. */ 8564 m = match_binding_attributes (&tbattr, true, false); 8565 if (m == MATCH_ERROR) 8566 goto error; 8567 8568 /* Now the colons, those are required. */ 8569 if (gfc_match (" ::") != MATCH_YES) 8570 { 8571 gfc_error ("Expected %<::%> at %C"); 8572 goto error; 8573 } 8574 8575 /* Match the binding name; depending on type (operator / generic) format 8576 it for future error messages into bind_name. */ 8577 8578 m = gfc_match_generic_spec (&op_type, name, &op); 8579 if (m == MATCH_ERROR) 8580 return MATCH_ERROR; 8581 if (m == MATCH_NO) 8582 { 8583 gfc_error ("Expected generic name or operator descriptor at %C"); 8584 goto error; 8585 } 8586 8587 switch (op_type) 8588 { 8589 case INTERFACE_GENERIC: 8590 snprintf (bind_name, sizeof (bind_name), "%s", name); 8591 break; 8592 8593 case INTERFACE_USER_OP: 8594 snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name); 8595 break; 8596 8597 case INTERFACE_INTRINSIC_OP: 8598 snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)", 8599 gfc_op2string (op)); 8600 break; 8601 8602 case INTERFACE_NAMELESS: 8603 gfc_error ("Malformed GENERIC statement at %C"); 8604 goto error; 8605 break; 8606 8607 default: 8608 gcc_unreachable (); 8609 } 8610 8611 /* Match the required =>. */ 8612 if (gfc_match (" =>") != MATCH_YES) 8613 { 8614 gfc_error ("Expected %<=>%> at %C"); 8615 goto error; 8616 } 8617 8618 /* Try to find existing GENERIC binding with this name / for this operator; 8619 if there is something, check that it is another GENERIC and then extend 8620 it rather than building a new node. Otherwise, create it and put it 8621 at the right position. */ 8622 8623 switch (op_type) 8624 { 8625 case INTERFACE_USER_OP: 8626 case INTERFACE_GENERIC: 8627 { 8628 const bool is_op = (op_type == INTERFACE_USER_OP); 8629 gfc_symtree* st; 8630 8631 st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name); 8632 if (st) 8633 { 8634 tb = st->n.tb; 8635 gcc_assert (tb); 8636 } 8637 else 8638 tb = NULL; 8639 8640 break; 8641 } 8642 8643 case INTERFACE_INTRINSIC_OP: 8644 tb = ns->tb_op[op]; 8645 break; 8646 8647 default: 8648 gcc_unreachable (); 8649 } 8650 8651 if (tb) 8652 { 8653 if (!tb->is_generic) 8654 { 8655 gcc_assert (op_type == INTERFACE_GENERIC); 8656 gfc_error ("There's already a non-generic procedure with binding name" 8657 " %qs for the derived type %qs at %C", 8658 bind_name, block->name); 8659 goto error; 8660 } 8661 8662 if (tb->access != tbattr.access) 8663 { 8664 gfc_error ("Binding at %C must have the same access as already" 8665 " defined binding %qs", bind_name); 8666 goto error; 8667 } 8668 } 8669 else 8670 { 8671 tb = gfc_get_typebound_proc (NULL); 8672 tb->where = gfc_current_locus; 8673 tb->access = tbattr.access; 8674 tb->is_generic = 1; 8675 tb->u.generic = NULL; 8676 8677 switch (op_type) 8678 { 8679 case INTERFACE_GENERIC: 8680 case INTERFACE_USER_OP: 8681 { 8682 const bool is_op = (op_type == INTERFACE_USER_OP); 8683 gfc_symtree* st; 8684 8685 st = gfc_new_symtree (is_op ? &ns->tb_uop_root : &ns->tb_sym_root, 8686 name); 8687 gcc_assert (st); 8688 st->n.tb = tb; 8689 8690 break; 8691 } 8692 8693 case INTERFACE_INTRINSIC_OP: 8694 ns->tb_op[op] = tb; 8695 break; 8696 8697 default: 8698 gcc_unreachable (); 8699 } 8700 } 8701 8702 /* Now, match all following names as specific targets. */ 8703 do 8704 { 8705 gfc_symtree* target_st; 8706 gfc_tbp_generic* target; 8707 8708 m = gfc_match_name (name); 8709 if (m == MATCH_ERROR) 8710 goto error; 8711 if (m == MATCH_NO) 8712 { 8713 gfc_error ("Expected specific binding name at %C"); 8714 goto error; 8715 } 8716 8717 target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name); 8718 8719 /* See if this is a duplicate specification. */ 8720 for (target = tb->u.generic; target; target = target->next) 8721 if (target_st == target->specific_st) 8722 { 8723 gfc_error ("%qs already defined as specific binding for the" 8724 " generic %qs at %C", name, bind_name); 8725 goto error; 8726 } 8727 8728 target = gfc_get_tbp_generic (); 8729 target->specific_st = target_st; 8730 target->specific = NULL; 8731 target->next = tb->u.generic; 8732 target->is_operator = ((op_type == INTERFACE_USER_OP) 8733 || (op_type == INTERFACE_INTRINSIC_OP)); 8734 tb->u.generic = target; 8735 } 8736 while (gfc_match (" ,") == MATCH_YES); 8737 8738 /* Here should be the end. */ 8739 if (gfc_match_eos () != MATCH_YES) 8740 { 8741 gfc_error ("Junk after GENERIC binding at %C"); 8742 goto error; 8743 } 8744 8745 return MATCH_YES; 8746 8747error: 8748 return MATCH_ERROR; 8749} 8750 8751 8752/* Match a FINAL declaration inside a derived type. */ 8753 8754match 8755gfc_match_final_decl (void) 8756{ 8757 char name[GFC_MAX_SYMBOL_LEN + 1]; 8758 gfc_symbol* sym; 8759 match m; 8760 gfc_namespace* module_ns; 8761 bool first, last; 8762 gfc_symbol* block; 8763 8764 if (gfc_current_form == FORM_FREE) 8765 { 8766 char c = gfc_peek_ascii_char (); 8767 if (!gfc_is_whitespace (c) && c != ':') 8768 return MATCH_NO; 8769 } 8770 8771 if (gfc_state_stack->state != COMP_DERIVED_CONTAINS) 8772 { 8773 if (gfc_current_form == FORM_FIXED) 8774 return MATCH_NO; 8775 8776 gfc_error ("FINAL declaration at %C must be inside a derived type " 8777 "CONTAINS section"); 8778 return MATCH_ERROR; 8779 } 8780 8781 block = gfc_state_stack->previous->sym; 8782 gcc_assert (block); 8783 8784 if (!gfc_state_stack->previous || !gfc_state_stack->previous->previous 8785 || gfc_state_stack->previous->previous->state != COMP_MODULE) 8786 { 8787 gfc_error ("Derived type declaration with FINAL at %C must be in the" 8788 " specification part of a MODULE"); 8789 return MATCH_ERROR; 8790 } 8791 8792 module_ns = gfc_current_ns; 8793 gcc_assert (module_ns); 8794 gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE); 8795 8796 /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */ 8797 if (gfc_match (" ::") == MATCH_ERROR) 8798 return MATCH_ERROR; 8799 8800 /* Match the sequence of procedure names. */ 8801 first = true; 8802 last = false; 8803 do 8804 { 8805 gfc_finalizer* f; 8806 8807 if (first && gfc_match_eos () == MATCH_YES) 8808 { 8809 gfc_error ("Empty FINAL at %C"); 8810 return MATCH_ERROR; 8811 } 8812 8813 m = gfc_match_name (name); 8814 if (m == MATCH_NO) 8815 { 8816 gfc_error ("Expected module procedure name at %C"); 8817 return MATCH_ERROR; 8818 } 8819 else if (m != MATCH_YES) 8820 return MATCH_ERROR; 8821 8822 if (gfc_match_eos () == MATCH_YES) 8823 last = true; 8824 if (!last && gfc_match_char (',') != MATCH_YES) 8825 { 8826 gfc_error ("Expected %<,%> at %C"); 8827 return MATCH_ERROR; 8828 } 8829 8830 if (gfc_get_symbol (name, module_ns, &sym)) 8831 { 8832 gfc_error ("Unknown procedure name %qs at %C", name); 8833 return MATCH_ERROR; 8834 } 8835 8836 /* Mark the symbol as module procedure. */ 8837 if (sym->attr.proc != PROC_MODULE 8838 && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL)) 8839 return MATCH_ERROR; 8840 8841 /* Check if we already have this symbol in the list, this is an error. */ 8842 for (f = block->f2k_derived->finalizers; f; f = f->next) 8843 if (f->proc_sym == sym) 8844 { 8845 gfc_error ("%qs at %C is already defined as FINAL procedure!", 8846 name); 8847 return MATCH_ERROR; 8848 } 8849 8850 /* Add this symbol to the list of finalizers. */ 8851 gcc_assert (block->f2k_derived); 8852 sym->refs++; 8853 f = XCNEW (gfc_finalizer); 8854 f->proc_sym = sym; 8855 f->proc_tree = NULL; 8856 f->where = gfc_current_locus; 8857 f->next = block->f2k_derived->finalizers; 8858 block->f2k_derived->finalizers = f; 8859 8860 first = false; 8861 } 8862 while (!last); 8863 8864 return MATCH_YES; 8865} 8866 8867 8868const ext_attr_t ext_attr_list[] = { 8869 { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" }, 8870 { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" }, 8871 { "cdecl", EXT_ATTR_CDECL, "cdecl" }, 8872 { "stdcall", EXT_ATTR_STDCALL, "stdcall" }, 8873 { "fastcall", EXT_ATTR_FASTCALL, "fastcall" }, 8874 { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL }, 8875 { NULL, EXT_ATTR_LAST, NULL } 8876}; 8877 8878/* Match a !GCC$ ATTRIBUTES statement of the form: 8879 !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ... 8880 When we come here, we have already matched the !GCC$ ATTRIBUTES string. 8881 8882 TODO: We should support all GCC attributes using the same syntax for 8883 the attribute list, i.e. the list in C 8884 __attributes(( attribute-list )) 8885 matches then 8886 !GCC$ ATTRIBUTES attribute-list :: 8887 Cf. c-parser.c's c_parser_attributes; the data can then directly be 8888 saved into a TREE. 8889 8890 As there is absolutely no risk of confusion, we should never return 8891 MATCH_NO. */ 8892match 8893gfc_match_gcc_attributes (void) 8894{ 8895 symbol_attribute attr; 8896 char name[GFC_MAX_SYMBOL_LEN + 1]; 8897 unsigned id; 8898 gfc_symbol *sym; 8899 match m; 8900 8901 gfc_clear_attr (&attr); 8902 for(;;) 8903 { 8904 char ch; 8905 8906 if (gfc_match_name (name) != MATCH_YES) 8907 return MATCH_ERROR; 8908 8909 for (id = 0; id < EXT_ATTR_LAST; id++) 8910 if (strcmp (name, ext_attr_list[id].name) == 0) 8911 break; 8912 8913 if (id == EXT_ATTR_LAST) 8914 { 8915 gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C"); 8916 return MATCH_ERROR; 8917 } 8918 8919 if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus)) 8920 return MATCH_ERROR; 8921 8922 gfc_gobble_whitespace (); 8923 ch = gfc_next_ascii_char (); 8924 if (ch == ':') 8925 { 8926 /* This is the successful exit condition for the loop. */ 8927 if (gfc_next_ascii_char () == ':') 8928 break; 8929 } 8930 8931 if (ch == ',') 8932 continue; 8933 8934 goto syntax; 8935 } 8936 8937 if (gfc_match_eos () == MATCH_YES) 8938 goto syntax; 8939 8940 for(;;) 8941 { 8942 m = gfc_match_name (name); 8943 if (m != MATCH_YES) 8944 return m; 8945 8946 if (find_special (name, &sym, true)) 8947 return MATCH_ERROR; 8948 8949 sym->attr.ext_attr |= attr.ext_attr; 8950 8951 if (gfc_match_eos () == MATCH_YES) 8952 break; 8953 8954 if (gfc_match_char (',') != MATCH_YES) 8955 goto syntax; 8956 } 8957 8958 return MATCH_YES; 8959 8960syntax: 8961 gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C"); 8962 return MATCH_ERROR; 8963} 8964