| File: | build/gcc/fortran/decl.cc |
| Warning: | line 6857, column 3 Value stored to 'is_result' is never read |
Press '?' to see keyboard shortcuts
Keyboard shortcuts:
| 1 | /* Declaration statement matcher |
| 2 | Copyright (C) 2002-2023 Free Software Foundation, Inc. |
| 3 | Contributed by Andy Vaught |
| 4 | |
| 5 | This file is part of GCC. |
| 6 | |
| 7 | GCC is free software; you can redistribute it and/or modify it under |
| 8 | the terms of the GNU General Public License as published by the Free |
| 9 | Software Foundation; either version 3, or (at your option) any later |
| 10 | version. |
| 11 | |
| 12 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
| 13 | WARRANTY; without even the implied warranty of MERCHANTABILITY or |
| 14 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
| 15 | for more details. |
| 16 | |
| 17 | You should have received a copy of the GNU General Public License |
| 18 | along with GCC; see the file COPYING3. If not see |
| 19 | <http://www.gnu.org/licenses/>. */ |
| 20 | |
| 21 | #include "config.h" |
| 22 | #include "system.h" |
| 23 | #include "coretypes.h" |
| 24 | #include "options.h" |
| 25 | #include "tree.h" |
| 26 | #include "gfortran.h" |
| 27 | #include "stringpool.h" |
| 28 | #include "match.h" |
| 29 | #include "parse.h" |
| 30 | #include "constructor.h" |
| 31 | #include "target.h" |
| 32 | |
| 33 | /* Macros to access allocate memory for gfc_data_variable, |
| 34 | gfc_data_value and gfc_data. */ |
| 35 | #define gfc_get_data_variable()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )) XCNEW (gfc_data_variable)((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )) |
| 36 | #define gfc_get_data_value()((gfc_data_value *) xcalloc (1, sizeof (gfc_data_value))) XCNEW (gfc_data_value)((gfc_data_value *) xcalloc (1, sizeof (gfc_data_value))) |
| 37 | #define gfc_get_data()((gfc_data *) xcalloc (1, sizeof (gfc_data))) XCNEW (gfc_data)((gfc_data *) xcalloc (1, sizeof (gfc_data))) |
| 38 | |
| 39 | |
| 40 | static bool set_binding_label (const char **, const char *, int); |
| 41 | |
| 42 | |
| 43 | /* This flag is set if an old-style length selector is matched |
| 44 | during a type-declaration statement. */ |
| 45 | |
| 46 | static int old_char_selector; |
| 47 | |
| 48 | /* When variables acquire types and attributes from a declaration |
| 49 | statement, they get them from the following static variables. The |
| 50 | first part of a declaration sets these variables and the second |
| 51 | part copies these into symbol structures. */ |
| 52 | |
| 53 | static gfc_typespec current_ts; |
| 54 | |
| 55 | static symbol_attribute current_attr; |
| 56 | static gfc_array_spec *current_as; |
| 57 | static int colon_seen; |
| 58 | static int attr_seen; |
| 59 | |
| 60 | /* The current binding label (if any). */ |
| 61 | static const char* curr_binding_label; |
| 62 | /* Need to know how many identifiers are on the current data declaration |
| 63 | line in case we're given the BIND(C) attribute with a NAME= specifier. */ |
| 64 | static int num_idents_on_line; |
| 65 | /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we |
| 66 | can supply a name if the curr_binding_label is nil and NAME= was not. */ |
| 67 | static int has_name_equals = 0; |
| 68 | |
| 69 | /* Initializer of the previous enumerator. */ |
| 70 | |
| 71 | static gfc_expr *last_initializer; |
| 72 | |
| 73 | /* History of all the enumerators is maintained, so that |
| 74 | kind values of all the enumerators could be updated depending |
| 75 | upon the maximum initialized value. */ |
| 76 | |
| 77 | typedef struct enumerator_history |
| 78 | { |
| 79 | gfc_symbol *sym; |
| 80 | gfc_expr *initializer; |
| 81 | struct enumerator_history *next; |
| 82 | } |
| 83 | enumerator_history; |
| 84 | |
| 85 | /* Header of enum history chain. */ |
| 86 | |
| 87 | static enumerator_history *enum_history = NULL__null; |
| 88 | |
| 89 | /* Pointer of enum history node containing largest initializer. */ |
| 90 | |
| 91 | static enumerator_history *max_enum = NULL__null; |
| 92 | |
| 93 | /* gfc_new_block points to the symbol of a newly matched block. */ |
| 94 | |
| 95 | gfc_symbol *gfc_new_block; |
| 96 | |
| 97 | bool gfc_matching_function; |
| 98 | |
| 99 | /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */ |
| 100 | int directive_unroll = -1; |
| 101 | |
| 102 | /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */ |
| 103 | bool directive_ivdep = false; |
| 104 | bool directive_vector = false; |
| 105 | bool directive_novector = false; |
| 106 | |
| 107 | /* Map of middle-end built-ins that should be vectorized. */ |
| 108 | hash_map<nofree_string_hash, int> *gfc_vectorized_builtins; |
| 109 | |
| 110 | /* If a kind expression of a component of a parameterized derived type is |
| 111 | parameterized, temporarily store the expression here. */ |
| 112 | static gfc_expr *saved_kind_expr = NULL__null; |
| 113 | |
| 114 | /* Used to store the parameter list arising in a PDT declaration and |
| 115 | in the typespec of a PDT variable or component. */ |
| 116 | static gfc_actual_arglist *decl_type_param_list; |
| 117 | static gfc_actual_arglist *type_param_spec_list; |
| 118 | |
| 119 | /********************* DATA statement subroutines *********************/ |
| 120 | |
| 121 | static bool in_match_data = false; |
| 122 | |
| 123 | bool |
| 124 | gfc_in_match_data (void) |
| 125 | { |
| 126 | return in_match_data; |
| 127 | } |
| 128 | |
| 129 | static void |
| 130 | set_in_match_data (bool set_value) |
| 131 | { |
| 132 | in_match_data = set_value; |
| 133 | } |
| 134 | |
| 135 | /* Free a gfc_data_variable structure and everything beneath it. */ |
| 136 | |
| 137 | static void |
| 138 | free_variable (gfc_data_variable *p) |
| 139 | { |
| 140 | gfc_data_variable *q; |
| 141 | |
| 142 | for (; p; p = q) |
| 143 | { |
| 144 | q = p->next; |
| 145 | gfc_free_expr (p->expr); |
| 146 | gfc_free_iterator (&p->iter, 0); |
| 147 | free_variable (p->list); |
| 148 | free (p); |
| 149 | } |
| 150 | } |
| 151 | |
| 152 | |
| 153 | /* Free a gfc_data_value structure and everything beneath it. */ |
| 154 | |
| 155 | static void |
| 156 | free_value (gfc_data_value *p) |
| 157 | { |
| 158 | gfc_data_value *q; |
| 159 | |
| 160 | for (; p; p = q) |
| 161 | { |
| 162 | q = p->next; |
| 163 | mpz_clear__gmpz_clear (p->repeat); |
| 164 | gfc_free_expr (p->expr); |
| 165 | free (p); |
| 166 | } |
| 167 | } |
| 168 | |
| 169 | |
| 170 | /* Free a list of gfc_data structures. */ |
| 171 | |
| 172 | void |
| 173 | gfc_free_data (gfc_data *p) |
| 174 | { |
| 175 | gfc_data *q; |
| 176 | |
| 177 | for (; p; p = q) |
| 178 | { |
| 179 | q = p->next; |
| 180 | free_variable (p->var); |
| 181 | free_value (p->value); |
| 182 | free (p); |
| 183 | } |
| 184 | } |
| 185 | |
| 186 | |
| 187 | /* Free all data in a namespace. */ |
| 188 | |
| 189 | static void |
| 190 | gfc_free_data_all (gfc_namespace *ns) |
| 191 | { |
| 192 | gfc_data *d; |
| 193 | |
| 194 | for (;ns->data;) |
| 195 | { |
| 196 | d = ns->data->next; |
| 197 | free (ns->data); |
| 198 | ns->data = d; |
| 199 | } |
| 200 | } |
| 201 | |
| 202 | /* Reject data parsed since the last restore point was marked. */ |
| 203 | |
| 204 | void |
| 205 | gfc_reject_data (gfc_namespace *ns) |
| 206 | { |
| 207 | gfc_data *d; |
| 208 | |
| 209 | while (ns->data && ns->data != ns->old_data) |
| 210 | { |
| 211 | d = ns->data->next; |
| 212 | free (ns->data); |
| 213 | ns->data = d; |
| 214 | } |
| 215 | } |
| 216 | |
| 217 | static match var_element (gfc_data_variable *); |
| 218 | |
| 219 | /* Match a list of variables terminated by an iterator and a right |
| 220 | parenthesis. */ |
| 221 | |
| 222 | static match |
| 223 | var_list (gfc_data_variable *parent) |
| 224 | { |
| 225 | gfc_data_variable *tail, var; |
| 226 | match m; |
| 227 | |
| 228 | m = var_element (&var); |
| 229 | if (m == MATCH_ERROR) |
| 230 | return MATCH_ERROR; |
| 231 | if (m == MATCH_NO) |
| 232 | goto syntax; |
| 233 | |
| 234 | tail = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )); |
| 235 | *tail = var; |
| 236 | |
| 237 | parent->list = tail; |
| 238 | |
| 239 | for (;;) |
| 240 | { |
| 241 | if (gfc_match_char (',') != MATCH_YES) |
| 242 | goto syntax; |
| 243 | |
| 244 | m = gfc_match_iterator (&parent->iter, 1); |
| 245 | if (m == MATCH_YES) |
| 246 | break; |
| 247 | if (m == MATCH_ERROR) |
| 248 | return MATCH_ERROR; |
| 249 | |
| 250 | m = var_element (&var); |
| 251 | if (m == MATCH_ERROR) |
| 252 | return MATCH_ERROR; |
| 253 | if (m == MATCH_NO) |
| 254 | goto syntax; |
| 255 | |
| 256 | tail->next = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )); |
| 257 | tail = tail->next; |
| 258 | |
| 259 | *tail = var; |
| 260 | } |
| 261 | |
| 262 | if (gfc_match_char (')') != MATCH_YES) |
| 263 | goto syntax; |
| 264 | return MATCH_YES; |
| 265 | |
| 266 | syntax: |
| 267 | gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));; |
| 268 | return MATCH_ERROR; |
| 269 | } |
| 270 | |
| 271 | |
| 272 | /* Match a single element in a data variable list, which can be a |
| 273 | variable-iterator list. */ |
| 274 | |
| 275 | static match |
| 276 | var_element (gfc_data_variable *new_var) |
| 277 | { |
| 278 | match m; |
| 279 | gfc_symbol *sym; |
| 280 | |
| 281 | memset (new_var, 0, sizeof (gfc_data_variable)); |
| 282 | |
| 283 | if (gfc_match_char ('(') == MATCH_YES) |
| 284 | return var_list (new_var); |
| 285 | |
| 286 | m = gfc_match_variable (&new_var->expr, 0); |
| 287 | if (m != MATCH_YES) |
| 288 | return m; |
| 289 | |
| 290 | if (new_var->expr->expr_type == EXPR_CONSTANT |
| 291 | && new_var->expr->symtree == NULL__null) |
| 292 | { |
| 293 | gfc_error ("Inquiry parameter cannot appear in a " |
| 294 | "data-stmt-object-list at %C"); |
| 295 | return MATCH_ERROR; |
| 296 | } |
| 297 | |
| 298 | sym = new_var->expr->symtree->n.sym; |
| 299 | |
| 300 | /* Symbol should already have an associated type. */ |
| 301 | if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus)) |
| 302 | return MATCH_ERROR; |
| 303 | |
| 304 | if (!sym->attr.function && gfc_current_ns->parent |
| 305 | && gfc_current_ns->parent == sym->ns) |
| 306 | { |
| 307 | gfc_error ("Host associated variable %qs may not be in the DATA " |
| 308 | "statement at %C", sym->name); |
| 309 | return MATCH_ERROR; |
| 310 | } |
| 311 | |
| 312 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK_DATA |
| 313 | && sym->attr.in_common |
| 314 | && !gfc_notify_std (GFC_STD_GNU(1<<5), "initialization of " |
| 315 | "common block variable %qs in DATA statement at %C", |
| 316 | sym->name)) |
| 317 | return MATCH_ERROR; |
| 318 | |
| 319 | if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where)) |
| 320 | return MATCH_ERROR; |
| 321 | |
| 322 | return MATCH_YES; |
| 323 | } |
| 324 | |
| 325 | |
| 326 | /* Match the top-level list of data variables. */ |
| 327 | |
| 328 | static match |
| 329 | top_var_list (gfc_data *d) |
| 330 | { |
| 331 | gfc_data_variable var, *tail, *new_var; |
| 332 | match m; |
| 333 | |
| 334 | tail = NULL__null; |
| 335 | |
| 336 | for (;;) |
| 337 | { |
| 338 | m = var_element (&var); |
| 339 | if (m == MATCH_NO) |
| 340 | goto syntax; |
| 341 | if (m == MATCH_ERROR) |
| 342 | return MATCH_ERROR; |
| 343 | |
| 344 | new_var = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )); |
| 345 | *new_var = var; |
| 346 | if (new_var->expr) |
| 347 | new_var->expr->where = gfc_current_locus; |
| 348 | |
| 349 | if (tail == NULL__null) |
| 350 | d->var = new_var; |
| 351 | else |
| 352 | tail->next = new_var; |
| 353 | |
| 354 | tail = new_var; |
| 355 | |
| 356 | if (gfc_match_char ('/') == MATCH_YES) |
| 357 | break; |
| 358 | if (gfc_match_char (',') != MATCH_YES) |
| 359 | goto syntax; |
| 360 | } |
| 361 | |
| 362 | return MATCH_YES; |
| 363 | |
| 364 | syntax: |
| 365 | gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));; |
| 366 | gfc_free_data_all (gfc_current_ns); |
| 367 | return MATCH_ERROR; |
| 368 | } |
| 369 | |
| 370 | |
| 371 | static match |
| 372 | match_data_constant (gfc_expr **result) |
| 373 | { |
| 374 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 375 | gfc_symbol *sym, *dt_sym = NULL__null; |
| 376 | gfc_expr *expr; |
| 377 | match m; |
| 378 | locus old_loc; |
| 379 | |
| 380 | m = gfc_match_literal_constant (&expr, 1); |
| 381 | if (m == MATCH_YES) |
| 382 | { |
| 383 | *result = expr; |
| 384 | return MATCH_YES; |
| 385 | } |
| 386 | |
| 387 | if (m == MATCH_ERROR) |
| 388 | return MATCH_ERROR; |
| 389 | |
| 390 | m = gfc_match_null (result); |
| 391 | if (m != MATCH_NO) |
| 392 | return m; |
| 393 | |
| 394 | old_loc = gfc_current_locus; |
| 395 | |
| 396 | /* Should this be a structure component, try to match it |
| 397 | before matching a name. */ |
| 398 | m = gfc_match_rvalue (result); |
| 399 | if (m == MATCH_ERROR) |
| 400 | return m; |
| 401 | |
| 402 | if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE) |
| 403 | { |
| 404 | if (!gfc_simplify_expr (*result, 0)) |
| 405 | m = MATCH_ERROR; |
| 406 | return m; |
| 407 | } |
| 408 | else if (m == MATCH_YES) |
| 409 | { |
| 410 | /* If a parameter inquiry ends up here, symtree is NULL but **result |
| 411 | contains the right constant expression. Check here. */ |
| 412 | if ((*result)->symtree == NULL__null |
| 413 | && (*result)->expr_type == EXPR_CONSTANT |
| 414 | && ((*result)->ts.type == BT_INTEGER |
| 415 | || (*result)->ts.type == BT_REAL)) |
| 416 | return m; |
| 417 | |
| 418 | /* F2018:R845 data-stmt-constant is initial-data-target. |
| 419 | A data-stmt-constant shall be ... initial-data-target if and |
| 420 | only if the corresponding data-stmt-object has the POINTER |
| 421 | attribute. ... If data-stmt-constant is initial-data-target |
| 422 | the corresponding data statement object shall be |
| 423 | data-pointer-initialization compatible (7.5.4.6) with the initial |
| 424 | data target; the data statement object is initially associated |
| 425 | with the target. */ |
| 426 | if ((*result)->symtree |
| 427 | && (*result)->symtree->n.sym->attr.save |
| 428 | && (*result)->symtree->n.sym->attr.target) |
| 429 | return m; |
| 430 | gfc_free_expr (*result); |
| 431 | } |
| 432 | |
| 433 | gfc_current_locus = old_loc; |
| 434 | |
| 435 | m = gfc_match_name (name); |
| 436 | if (m != MATCH_YES) |
| 437 | return m; |
| 438 | |
| 439 | if (gfc_find_symbol (name, NULL__null, 1, &sym)) |
| 440 | return MATCH_ERROR; |
| 441 | |
| 442 | if (sym && sym->attr.generic) |
| 443 | dt_sym = gfc_find_dt_in_generic (sym); |
| 444 | |
| 445 | if (sym == NULL__null |
| 446 | || (sym->attr.flavor != FL_PARAMETER |
| 447 | && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor)((dt_sym->attr.flavor) == FL_DERIVED || (dt_sym->attr.flavor ) == FL_UNION || (dt_sym->attr.flavor) == FL_STRUCT)))) |
| 448 | { |
| 449 | gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C", |
| 450 | name); |
| 451 | *result = NULL__null; |
| 452 | return MATCH_ERROR; |
| 453 | } |
| 454 | else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor)((dt_sym->attr.flavor) == FL_DERIVED || (dt_sym->attr.flavor ) == FL_UNION || (dt_sym->attr.flavor) == FL_STRUCT)) |
| 455 | return gfc_match_structure_constructor (dt_sym, result); |
| 456 | |
| 457 | /* Check to see if the value is an initialization array expression. */ |
| 458 | if (sym->value->expr_type == EXPR_ARRAY) |
| 459 | { |
| 460 | gfc_current_locus = old_loc; |
| 461 | |
| 462 | m = gfc_match_init_expr (result); |
| 463 | if (m == MATCH_ERROR) |
| 464 | return m; |
| 465 | |
| 466 | if (m == MATCH_YES) |
| 467 | { |
| 468 | if (!gfc_simplify_expr (*result, 0)) |
| 469 | m = MATCH_ERROR; |
| 470 | |
| 471 | if ((*result)->expr_type == EXPR_CONSTANT) |
| 472 | return m; |
| 473 | else |
| 474 | { |
| 475 | gfc_error ("Invalid initializer %s in Data statement at %C", name); |
| 476 | return MATCH_ERROR; |
| 477 | } |
| 478 | } |
| 479 | } |
| 480 | |
| 481 | *result = gfc_copy_expr (sym->value); |
| 482 | return MATCH_YES; |
| 483 | } |
| 484 | |
| 485 | |
| 486 | /* Match a list of values in a DATA statement. The leading '/' has |
| 487 | already been seen at this point. */ |
| 488 | |
| 489 | static match |
| 490 | top_val_list (gfc_data *data) |
| 491 | { |
| 492 | gfc_data_value *new_val, *tail; |
| 493 | gfc_expr *expr; |
| 494 | match m; |
| 495 | |
| 496 | tail = NULL__null; |
| 497 | |
| 498 | for (;;) |
| 499 | { |
| 500 | m = match_data_constant (&expr); |
| 501 | if (m == MATCH_NO) |
| 502 | goto syntax; |
| 503 | if (m == MATCH_ERROR) |
| 504 | return MATCH_ERROR; |
| 505 | |
| 506 | new_val = gfc_get_data_value ()((gfc_data_value *) xcalloc (1, sizeof (gfc_data_value))); |
| 507 | mpz_init__gmpz_init (new_val->repeat); |
| 508 | |
| 509 | if (tail == NULL__null) |
| 510 | data->value = new_val; |
| 511 | else |
| 512 | tail->next = new_val; |
| 513 | |
| 514 | tail = new_val; |
| 515 | |
| 516 | if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES) |
| 517 | { |
| 518 | tail->expr = expr; |
| 519 | mpz_set_ui__gmpz_set_ui (tail->repeat, 1); |
| 520 | } |
| 521 | else |
| 522 | { |
| 523 | mpz_set__gmpz_set (tail->repeat, expr->value.integer); |
| 524 | gfc_free_expr (expr); |
| 525 | |
| 526 | m = match_data_constant (&tail->expr); |
| 527 | if (m == MATCH_NO) |
| 528 | goto syntax; |
| 529 | if (m == MATCH_ERROR) |
| 530 | return MATCH_ERROR; |
| 531 | } |
| 532 | |
| 533 | if (gfc_match_char ('/') == MATCH_YES) |
| 534 | break; |
| 535 | if (gfc_match_char (',') == MATCH_NO) |
| 536 | goto syntax; |
| 537 | } |
| 538 | |
| 539 | return MATCH_YES; |
| 540 | |
| 541 | syntax: |
| 542 | gfc_syntax_error (ST_DATA)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_DATA));; |
| 543 | gfc_free_data_all (gfc_current_ns); |
| 544 | return MATCH_ERROR; |
| 545 | } |
| 546 | |
| 547 | |
| 548 | /* Matches an old style initialization. */ |
| 549 | |
| 550 | static match |
| 551 | match_old_style_init (const char *name) |
| 552 | { |
| 553 | match m; |
| 554 | gfc_symtree *st; |
| 555 | gfc_symbol *sym; |
| 556 | gfc_data *newdata, *nd; |
| 557 | |
| 558 | /* Set up data structure to hold initializers. */ |
| 559 | gfc_find_sym_tree (name, NULL__null, 0, &st); |
| 560 | sym = st->n.sym; |
| 561 | |
| 562 | newdata = gfc_get_data ()((gfc_data *) xcalloc (1, sizeof (gfc_data))); |
| 563 | newdata->var = gfc_get_data_variable ()((gfc_data_variable *) xcalloc (1, sizeof (gfc_data_variable) )); |
| 564 | newdata->var->expr = gfc_get_variable_expr (st); |
| 565 | newdata->var->expr->where = sym->declared_at; |
| 566 | newdata->where = gfc_current_locus; |
| 567 | |
| 568 | /* Match initial value list. This also eats the terminal '/'. */ |
| 569 | m = top_val_list (newdata); |
| 570 | if (m != MATCH_YES) |
| 571 | { |
| 572 | free (newdata); |
| 573 | return m; |
| 574 | } |
| 575 | |
| 576 | /* Check that a BOZ did not creep into an old-style initialization. */ |
| 577 | for (nd = newdata; nd; nd = nd->next) |
| 578 | { |
| 579 | if (nd->value->expr->ts.type == BT_BOZ |
| 580 | && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style ""BOZ at %L cannot appear in an old-style " "initialization" |
| 581 | "initialization")"BOZ at %L cannot appear in an old-style " "initialization", &nd->value->expr->where)) |
| 582 | return MATCH_ERROR; |
| 583 | |
| 584 | if (nd->var->expr->ts.type != BT_INTEGER |
| 585 | && nd->var->expr->ts.type != BT_REAL |
| 586 | && nd->value->expr->ts.type == BT_BOZ) |
| 587 | { |
| 588 | gfc_error (G_("BOZ literal constant near %L cannot be assigned to ""BOZ literal constant near %L cannot be assigned to " "a %qs variable in an old-style initialization" |
| 589 | "a %qs variable in an old-style initialization")"BOZ literal constant near %L cannot be assigned to " "a %qs variable in an old-style initialization", |
| 590 | &nd->value->expr->where, |
| 591 | gfc_typename (&nd->value->expr->ts)); |
| 592 | return MATCH_ERROR; |
| 593 | } |
| 594 | } |
| 595 | |
| 596 | if (gfc_pure (NULL__null)) |
| 597 | { |
| 598 | gfc_error ("Initialization at %C is not allowed in a PURE procedure"); |
| 599 | free (newdata); |
| 600 | return MATCH_ERROR; |
| 601 | } |
| 602 | gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
| 603 | |
| 604 | /* Mark the variable as having appeared in a data statement. */ |
| 605 | if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at)) |
| 606 | { |
| 607 | free (newdata); |
| 608 | return MATCH_ERROR; |
| 609 | } |
| 610 | |
| 611 | /* Chain in namespace list of DATA initializers. */ |
| 612 | newdata->next = gfc_current_ns->data; |
| 613 | gfc_current_ns->data = newdata; |
| 614 | |
| 615 | return m; |
| 616 | } |
| 617 | |
| 618 | |
| 619 | /* Match the stuff following a DATA statement. If ERROR_FLAG is set, |
| 620 | we are matching a DATA statement and are therefore issuing an error |
| 621 | if we encounter something unexpected, if not, we're trying to match |
| 622 | an old-style initialization expression of the form INTEGER I /2/. */ |
| 623 | |
| 624 | match |
| 625 | gfc_match_data (void) |
| 626 | { |
| 627 | gfc_data *new_data; |
| 628 | gfc_expr *e; |
| 629 | gfc_ref *ref; |
| 630 | match m; |
| 631 | char c; |
| 632 | |
| 633 | /* DATA has been matched. In free form source code, the next character |
| 634 | needs to be whitespace or '(' from an implied do-loop. Check that |
| 635 | here. */ |
| 636 | c = gfc_peek_ascii_char (); |
| 637 | if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c)((c==' ') || (c=='\t') || (c=='\f')) && c != '(') |
| 638 | return MATCH_NO; |
| 639 | |
| 640 | /* Before parsing the rest of a DATA statement, check F2008:c1206. */ |
| 641 | if ((gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION |
| 642 | || gfc_current_state ()(gfc_state_stack->state) == COMP_SUBROUTINE) |
| 643 | && gfc_state_stack->previous->state == COMP_INTERFACE) |
| 644 | { |
| 645 | gfc_error ("DATA statement at %C cannot appear within an INTERFACE"); |
| 646 | return MATCH_ERROR; |
| 647 | } |
| 648 | |
| 649 | set_in_match_data (true); |
| 650 | |
| 651 | for (;;) |
| 652 | { |
| 653 | new_data = gfc_get_data ()((gfc_data *) xcalloc (1, sizeof (gfc_data))); |
| 654 | new_data->where = gfc_current_locus; |
| 655 | |
| 656 | m = top_var_list (new_data); |
| 657 | if (m != MATCH_YES) |
| 658 | goto cleanup; |
| 659 | |
| 660 | if (new_data->var->iter.var |
| 661 | && new_data->var->iter.var->ts.type == BT_INTEGER |
| 662 | && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1 |
| 663 | && new_data->var->list |
| 664 | && new_data->var->list->expr |
| 665 | && new_data->var->list->expr->ts.type == BT_CHARACTER |
| 666 | && new_data->var->list->expr->ref |
| 667 | && new_data->var->list->expr->ref->type == REF_SUBSTRING) |
| 668 | { |
| 669 | gfc_error ("Invalid substring in data-implied-do at %L in DATA " |
| 670 | "statement", &new_data->var->list->expr->where); |
| 671 | goto cleanup; |
| 672 | } |
| 673 | |
| 674 | /* Check for an entity with an allocatable component, which is not |
| 675 | allowed. */ |
| 676 | e = new_data->var->expr; |
| 677 | if (e) |
| 678 | { |
| 679 | bool invalid; |
| 680 | |
| 681 | invalid = false; |
| 682 | for (ref = e->ref; ref; ref = ref->next) |
| 683 | if ((ref->type == REF_COMPONENT |
| 684 | && ref->u.c.component->attr.allocatable) |
| 685 | || (ref->type == REF_ARRAY |
| 686 | && e->symtree->n.sym->attr.pointer != 1 |
| 687 | && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED)) |
| 688 | invalid = true; |
| 689 | |
| 690 | if (invalid) |
| 691 | { |
| 692 | gfc_error ("Allocatable component or deferred-shaped array " |
| 693 | "near %C in DATA statement"); |
| 694 | goto cleanup; |
| 695 | } |
| 696 | |
| 697 | /* F2008:C567 (R536) A data-i-do-object or a variable that appears |
| 698 | as a data-stmt-object shall not be an object designator in which |
| 699 | a pointer appears other than as the entire rightmost part-ref. */ |
| 700 | if (!e->ref && e->ts.type == BT_DERIVED |
| 701 | && e->symtree->n.sym->attr.pointer) |
| 702 | goto partref; |
| 703 | |
| 704 | ref = e->ref; |
| 705 | if (e->symtree->n.sym->ts.type == BT_DERIVED |
| 706 | && e->symtree->n.sym->attr.pointer |
| 707 | && ref->type == REF_COMPONENT) |
| 708 | goto partref; |
| 709 | |
| 710 | for (; ref; ref = ref->next) |
| 711 | if (ref->type == REF_COMPONENT |
| 712 | && ref->u.c.component->attr.pointer |
| 713 | && ref->next) |
| 714 | goto partref; |
| 715 | } |
| 716 | |
| 717 | m = top_val_list (new_data); |
| 718 | if (m != MATCH_YES) |
| 719 | goto cleanup; |
| 720 | |
| 721 | new_data->next = gfc_current_ns->data; |
| 722 | gfc_current_ns->data = new_data; |
| 723 | |
| 724 | /* A BOZ literal constant cannot appear in a structure constructor. |
| 725 | Check for that here for a data statement value. */ |
| 726 | if (new_data->value->expr->ts.type == BT_DERIVED |
| 727 | && new_data->value->expr->value.constructor) |
| 728 | { |
| 729 | gfc_constructor *c; |
| 730 | c = gfc_constructor_first (new_data->value->expr->value.constructor); |
| 731 | for (; c; c = gfc_constructor_next (c)) |
| 732 | if (c->expr && c->expr->ts.type == BT_BOZ) |
| 733 | { |
| 734 | gfc_error ("BOZ literal constant at %L cannot appear in a " |
| 735 | "structure constructor", &c->expr->where); |
| 736 | return MATCH_ERROR; |
| 737 | } |
| 738 | } |
| 739 | |
| 740 | if (gfc_match_eos () == MATCH_YES) |
| 741 | break; |
| 742 | |
| 743 | gfc_match_char (','); /* Optional comma */ |
| 744 | } |
| 745 | |
| 746 | set_in_match_data (false); |
| 747 | |
| 748 | if (gfc_pure (NULL__null)) |
| 749 | { |
| 750 | gfc_error ("DATA statement at %C is not allowed in a PURE procedure"); |
| 751 | return MATCH_ERROR; |
| 752 | } |
| 753 | gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
| 754 | |
| 755 | return MATCH_YES; |
| 756 | |
| 757 | partref: |
| 758 | |
| 759 | gfc_error ("part-ref with pointer attribute near %L is not " |
| 760 | "rightmost part-ref of data-stmt-object", |
| 761 | &e->where); |
| 762 | |
| 763 | cleanup: |
| 764 | set_in_match_data (false); |
| 765 | gfc_free_data (new_data); |
| 766 | return MATCH_ERROR; |
| 767 | } |
| 768 | |
| 769 | |
| 770 | /************************ Declaration statements *********************/ |
| 771 | |
| 772 | |
| 773 | /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization |
| 774 | list). The difference here is the expression is a list of constants |
| 775 | and is surrounded by '/'. |
| 776 | The typespec ts must match the typespec of the variable which the |
| 777 | clist is initializing. |
| 778 | The arrayspec tells whether this should match a list of constants |
| 779 | corresponding to array elements or a scalar (as == NULL). */ |
| 780 | |
| 781 | static match |
| 782 | match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as) |
| 783 | { |
| 784 | gfc_constructor_base array_head = NULL__null; |
| 785 | gfc_expr *expr = NULL__null; |
| 786 | match m = MATCH_ERROR; |
| 787 | locus where; |
| 788 | mpz_t repeat, cons_size, as_size; |
| 789 | bool scalar; |
| 790 | int cmp; |
| 791 | |
| 792 | gcc_assert (ts)((void)(!(ts) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 792, __FUNCTION__), 0 : 0)); |
| 793 | |
| 794 | /* We have already matched '/' - now look for a constant list, as with |
| 795 | top_val_list from decl.cc, but append the result to an array. */ |
| 796 | if (gfc_match ("/") == MATCH_YES) |
| 797 | { |
| 798 | gfc_error ("Empty old style initializer list at %C"); |
| 799 | return MATCH_ERROR; |
| 800 | } |
| 801 | |
| 802 | where = gfc_current_locus; |
| 803 | scalar = !as || !as->rank; |
| 804 | |
| 805 | if (!scalar && !spec_size (as, &as_size)) |
| 806 | { |
| 807 | gfc_error ("Array in initializer list at %L must have an explicit shape", |
| 808 | as->type == AS_EXPLICIT ? &as->upper[0]->where : &where); |
| 809 | /* Nothing to cleanup yet. */ |
| 810 | return MATCH_ERROR; |
| 811 | } |
| 812 | |
| 813 | mpz_init_set_ui__gmpz_init_set_ui (repeat, 0); |
| 814 | |
| 815 | for (;;) |
| 816 | { |
| 817 | m = match_data_constant (&expr); |
| 818 | if (m != MATCH_YES) |
| 819 | expr = NULL__null; /* match_data_constant may set expr to garbage */ |
| 820 | if (m == MATCH_NO) |
| 821 | goto syntax; |
| 822 | if (m == MATCH_ERROR) |
| 823 | goto cleanup; |
| 824 | |
| 825 | /* Found r in repeat spec r*c; look for the constant to repeat. */ |
| 826 | if ( gfc_match_char ('*') == MATCH_YES) |
| 827 | { |
| 828 | if (scalar) |
| 829 | { |
| 830 | gfc_error ("Repeat spec invalid in scalar initializer at %C"); |
| 831 | goto cleanup; |
| 832 | } |
| 833 | if (expr->ts.type != BT_INTEGER) |
| 834 | { |
| 835 | gfc_error ("Repeat spec must be an integer at %C"); |
| 836 | goto cleanup; |
| 837 | } |
| 838 | mpz_set__gmpz_set (repeat, expr->value.integer); |
| 839 | gfc_free_expr (expr); |
| 840 | expr = NULL__null; |
| 841 | |
| 842 | m = match_data_constant (&expr); |
| 843 | if (m == MATCH_NO) |
| 844 | { |
| 845 | m = MATCH_ERROR; |
| 846 | gfc_error ("Expected data constant after repeat spec at %C"); |
| 847 | } |
| 848 | if (m != MATCH_YES) |
| 849 | goto cleanup; |
| 850 | } |
| 851 | /* No repeat spec, we matched the data constant itself. */ |
| 852 | else |
| 853 | mpz_set_ui__gmpz_set_ui (repeat, 1); |
| 854 | |
| 855 | if (!scalar) |
| 856 | { |
| 857 | /* Add the constant initializer as many times as repeated. */ |
| 858 | for (; mpz_cmp_ui (repeat, 0)(__builtin_constant_p (0) && (0) == 0 ? ((repeat)-> _mp_size < 0 ? -1 : (repeat)->_mp_size > 0) : __gmpz_cmp_ui (repeat,0)) > 0; mpz_sub_ui__gmpz_sub_ui (repeat, repeat, 1)) |
| 859 | { |
| 860 | /* Make sure types of elements match */ |
| 861 | if(ts && !gfc_compare_types (&expr->ts, ts) |
| 862 | && !gfc_convert_type (expr, ts, 1)) |
| 863 | goto cleanup; |
| 864 | |
| 865 | gfc_constructor_append_expr (&array_head, |
| 866 | gfc_copy_expr (expr), &gfc_current_locus); |
| 867 | } |
| 868 | |
| 869 | gfc_free_expr (expr); |
| 870 | expr = NULL__null; |
| 871 | } |
| 872 | |
| 873 | /* For scalar initializers quit after one element. */ |
| 874 | else |
| 875 | { |
| 876 | if(gfc_match_char ('/') != MATCH_YES) |
| 877 | { |
| 878 | gfc_error ("End of scalar initializer expected at %C"); |
| 879 | goto cleanup; |
| 880 | } |
| 881 | break; |
| 882 | } |
| 883 | |
| 884 | if (gfc_match_char ('/') == MATCH_YES) |
| 885 | break; |
| 886 | if (gfc_match_char (',') == MATCH_NO) |
| 887 | goto syntax; |
| 888 | } |
| 889 | |
| 890 | /* If we break early from here out, we encountered an error. */ |
| 891 | m = MATCH_ERROR; |
| 892 | |
| 893 | /* Set up expr as an array constructor. */ |
| 894 | if (!scalar) |
| 895 | { |
| 896 | expr = gfc_get_array_expr (ts->type, ts->kind, &where); |
| 897 | expr->ts = *ts; |
| 898 | expr->value.constructor = array_head; |
| 899 | |
| 900 | /* Validate sizes. We built expr ourselves, so cons_size will be |
| 901 | constant (we fail above for non-constant expressions). |
| 902 | We still need to verify that the sizes match. */ |
| 903 | gcc_assert (gfc_array_size (expr, &cons_size))((void)(!(gfc_array_size (expr, &cons_size)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 903, __FUNCTION__), 0 : 0)); |
| 904 | cmp = mpz_cmp__gmpz_cmp (cons_size, as_size); |
| 905 | if (cmp < 0) |
| 906 | gfc_error ("Not enough elements in array initializer at %C"); |
| 907 | else if (cmp > 0) |
| 908 | gfc_error ("Too many elements in array initializer at %C"); |
| 909 | mpz_clear__gmpz_clear (cons_size); |
| 910 | if (cmp) |
| 911 | goto cleanup; |
| 912 | |
| 913 | /* Set the rank/shape to match the LHS as auto-reshape is implied. */ |
| 914 | expr->rank = as->rank; |
| 915 | expr->shape = gfc_get_shape (as->rank)(((mpz_t *) xcalloc (((as->rank)), sizeof (mpz_t)))); |
| 916 | for (int i = 0; i < as->rank; ++i) |
| 917 | spec_dimen_size (as, i, &expr->shape[i]); |
| 918 | } |
| 919 | |
| 920 | /* Make sure scalar types match. */ |
| 921 | else if (!gfc_compare_types (&expr->ts, ts) |
| 922 | && !gfc_convert_type (expr, ts, 1)) |
| 923 | goto cleanup; |
| 924 | |
| 925 | if (expr->ts.u.cl) |
| 926 | expr->ts.u.cl->length_from_typespec = 1; |
| 927 | |
| 928 | *result = expr; |
| 929 | m = MATCH_YES; |
| 930 | goto done; |
| 931 | |
| 932 | syntax: |
| 933 | m = MATCH_ERROR; |
| 934 | gfc_error ("Syntax error in old style initializer list at %C"); |
| 935 | |
| 936 | cleanup: |
| 937 | if (expr) |
| 938 | expr->value.constructor = NULL__null; |
| 939 | gfc_free_expr (expr); |
| 940 | gfc_constructor_free (array_head); |
| 941 | |
| 942 | done: |
| 943 | mpz_clear__gmpz_clear (repeat); |
| 944 | if (!scalar) |
| 945 | mpz_clear__gmpz_clear (as_size); |
| 946 | return m; |
| 947 | } |
| 948 | |
| 949 | |
| 950 | /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */ |
| 951 | |
| 952 | static bool |
| 953 | merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy) |
| 954 | { |
| 955 | if ((from->type == AS_ASSUMED_RANK && to->corank) |
| 956 | || (to->type == AS_ASSUMED_RANK && from->corank)) |
| 957 | { |
| 958 | gfc_error ("The assumed-rank array at %C shall not have a codimension"); |
| 959 | return false; |
| 960 | } |
| 961 | |
| 962 | if (to->rank == 0 && from->rank > 0) |
| 963 | { |
| 964 | to->rank = from->rank; |
| 965 | to->type = from->type; |
| 966 | to->cray_pointee = from->cray_pointee; |
| 967 | to->cp_was_assumed = from->cp_was_assumed; |
| 968 | |
| 969 | for (int i = to->corank - 1; i >= 0; i--) |
| 970 | { |
| 971 | /* Do not exceed the limits on lower[] and upper[]. gfortran |
| 972 | cleans up elsewhere. */ |
| 973 | int j = from->rank + i; |
| 974 | if (j >= GFC_MAX_DIMENSIONS15) |
| 975 | break; |
| 976 | |
| 977 | to->lower[j] = to->lower[i]; |
| 978 | to->upper[j] = to->upper[i]; |
| 979 | } |
| 980 | for (int i = 0; i < from->rank; i++) |
| 981 | { |
| 982 | if (copy) |
| 983 | { |
| 984 | to->lower[i] = gfc_copy_expr (from->lower[i]); |
| 985 | to->upper[i] = gfc_copy_expr (from->upper[i]); |
| 986 | } |
| 987 | else |
| 988 | { |
| 989 | to->lower[i] = from->lower[i]; |
| 990 | to->upper[i] = from->upper[i]; |
| 991 | } |
| 992 | } |
| 993 | } |
| 994 | else if (to->corank == 0 && from->corank > 0) |
| 995 | { |
| 996 | to->corank = from->corank; |
| 997 | to->cotype = from->cotype; |
| 998 | |
| 999 | for (int i = 0; i < from->corank; i++) |
| 1000 | { |
| 1001 | /* Do not exceed the limits on lower[] and upper[]. gfortran |
| 1002 | cleans up elsewhere. */ |
| 1003 | int k = from->rank + i; |
| 1004 | int j = to->rank + i; |
| 1005 | if (j >= GFC_MAX_DIMENSIONS15) |
| 1006 | break; |
| 1007 | |
| 1008 | if (copy) |
| 1009 | { |
| 1010 | to->lower[j] = gfc_copy_expr (from->lower[k]); |
| 1011 | to->upper[j] = gfc_copy_expr (from->upper[k]); |
| 1012 | } |
| 1013 | else |
| 1014 | { |
| 1015 | to->lower[j] = from->lower[k]; |
| 1016 | to->upper[j] = from->upper[k]; |
| 1017 | } |
| 1018 | } |
| 1019 | } |
| 1020 | |
| 1021 | if (to->rank + to->corank > GFC_MAX_DIMENSIONS15) |
| 1022 | { |
| 1023 | gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum " |
| 1024 | "allowed dimensions of %d", |
| 1025 | to->rank, to->corank, GFC_MAX_DIMENSIONS15); |
| 1026 | to->corank = GFC_MAX_DIMENSIONS15 - to->rank; |
| 1027 | return false; |
| 1028 | } |
| 1029 | return true; |
| 1030 | } |
| 1031 | |
| 1032 | |
| 1033 | /* Match an intent specification. Since this can only happen after an |
| 1034 | INTENT word, a legal intent-spec must follow. */ |
| 1035 | |
| 1036 | static sym_intent |
| 1037 | match_intent_spec (void) |
| 1038 | { |
| 1039 | |
| 1040 | if (gfc_match (" ( in out )") == MATCH_YES) |
| 1041 | return INTENT_INOUT; |
| 1042 | if (gfc_match (" ( in )") == MATCH_YES) |
| 1043 | return INTENT_IN; |
| 1044 | if (gfc_match (" ( out )") == MATCH_YES) |
| 1045 | return INTENT_OUT; |
| 1046 | |
| 1047 | gfc_error ("Bad INTENT specification at %C"); |
| 1048 | return INTENT_UNKNOWN; |
| 1049 | } |
| 1050 | |
| 1051 | |
| 1052 | /* Matches a character length specification, which is either a |
| 1053 | specification expression, '*', or ':'. */ |
| 1054 | |
| 1055 | static match |
| 1056 | char_len_param_value (gfc_expr **expr, bool *deferred) |
| 1057 | { |
| 1058 | match m; |
| 1059 | |
| 1060 | *expr = NULL__null; |
| 1061 | *deferred = false; |
| 1062 | |
| 1063 | if (gfc_match_char ('*') == MATCH_YES) |
| 1064 | return MATCH_YES; |
| 1065 | |
| 1066 | if (gfc_match_char (':') == MATCH_YES) |
| 1067 | { |
| 1068 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "deferred type parameter at %C")) |
| 1069 | return MATCH_ERROR; |
| 1070 | |
| 1071 | *deferred = true; |
| 1072 | |
| 1073 | return MATCH_YES; |
| 1074 | } |
| 1075 | |
| 1076 | m = gfc_match_expr (expr); |
| 1077 | |
| 1078 | if (m == MATCH_NO || m == MATCH_ERROR) |
| 1079 | return m; |
| 1080 | |
| 1081 | if (!gfc_expr_check_typed (*expr, gfc_current_ns, false)) |
| 1082 | return MATCH_ERROR; |
| 1083 | |
| 1084 | /* If gfortran gets an EXPR_OP, try to simplifiy it. This catches things |
| 1085 | like CHARACTER(([1])). */ |
| 1086 | if ((*expr)->expr_type == EXPR_OP) |
| 1087 | gfc_simplify_expr (*expr, 1); |
| 1088 | |
| 1089 | if ((*expr)->expr_type == EXPR_FUNCTION) |
| 1090 | { |
| 1091 | if ((*expr)->ts.type == BT_INTEGER |
| 1092 | || ((*expr)->ts.type == BT_UNKNOWN |
| 1093 | && strcmp((*expr)->symtree->name, "null") != 0)) |
| 1094 | return MATCH_YES; |
| 1095 | |
| 1096 | goto syntax; |
| 1097 | } |
| 1098 | else if ((*expr)->expr_type == EXPR_CONSTANT) |
| 1099 | { |
| 1100 | /* F2008, 4.4.3.1: The length is a type parameter; its kind is |
| 1101 | processor dependent and its value is greater than or equal to zero. |
| 1102 | F2008, 4.4.3.2: If the character length parameter value evaluates |
| 1103 | to a negative value, the length of character entities declared |
| 1104 | is zero. */ |
| 1105 | |
| 1106 | if ((*expr)->ts.type == BT_INTEGER) |
| 1107 | { |
| 1108 | if (mpz_cmp_si ((*expr)->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( ((*expr)->value.integer)->_mp_size < 0 ? -1 : ((*expr )->value.integer)->_mp_size > 0) : __gmpz_cmp_ui ((* expr)->value.integer,(static_cast<unsigned long> (0) ))) : __gmpz_cmp_si ((*expr)->value.integer,0)) < 0) |
| 1109 | mpz_set_si__gmpz_set_si ((*expr)->value.integer, 0); |
| 1110 | } |
| 1111 | else |
| 1112 | goto syntax; |
| 1113 | } |
| 1114 | else if ((*expr)->expr_type == EXPR_ARRAY) |
| 1115 | goto syntax; |
| 1116 | else if ((*expr)->expr_type == EXPR_VARIABLE) |
| 1117 | { |
| 1118 | bool t; |
| 1119 | gfc_expr *e; |
| 1120 | |
| 1121 | e = gfc_copy_expr (*expr); |
| 1122 | |
| 1123 | /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']", |
| 1124 | which causes an ICE if gfc_reduce_init_expr() is called. */ |
| 1125 | if (e->ref && e->ref->type == REF_ARRAY |
| 1126 | && e->ref->u.ar.type == AR_UNKNOWN |
| 1127 | && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE) |
| 1128 | goto syntax; |
| 1129 | |
| 1130 | t = gfc_reduce_init_expr (e); |
| 1131 | |
| 1132 | if (!t && e->ts.type == BT_UNKNOWN |
| 1133 | && e->symtree->n.sym->attr.untyped == 1 |
| 1134 | && (flag_implicit_noneglobal_options.x_flag_implicit_none |
| 1135 | || e->symtree->n.sym->ns->seen_implicit_none == 1 |
| 1136 | || e->symtree->n.sym->ns->parent->seen_implicit_none == 1)) |
| 1137 | { |
| 1138 | gfc_free_expr (e); |
| 1139 | goto syntax; |
| 1140 | } |
| 1141 | |
| 1142 | if ((e->ref && e->ref->type == REF_ARRAY |
| 1143 | && e->ref->u.ar.type != AR_ELEMENT) |
| 1144 | || (!e->ref && e->expr_type == EXPR_ARRAY)) |
| 1145 | { |
| 1146 | gfc_free_expr (e); |
| 1147 | goto syntax; |
| 1148 | } |
| 1149 | |
| 1150 | gfc_free_expr (e); |
| 1151 | } |
| 1152 | |
| 1153 | if (gfc_seen_div0) |
| 1154 | m = MATCH_ERROR; |
| 1155 | |
| 1156 | return m; |
| 1157 | |
| 1158 | syntax: |
| 1159 | gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where); |
| 1160 | return MATCH_ERROR; |
| 1161 | } |
| 1162 | |
| 1163 | |
| 1164 | /* A character length is a '*' followed by a literal integer or a |
| 1165 | char_len_param_value in parenthesis. */ |
| 1166 | |
| 1167 | static match |
| 1168 | match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check) |
| 1169 | { |
| 1170 | int length; |
| 1171 | match m; |
| 1172 | |
| 1173 | *deferred = false; |
| 1174 | m = gfc_match_char ('*'); |
| 1175 | if (m != MATCH_YES) |
| 1176 | return m; |
| 1177 | |
| 1178 | m = gfc_match_small_literal_int (&length, NULL__null); |
| 1179 | if (m == MATCH_ERROR) |
| 1180 | return m; |
| 1181 | |
| 1182 | if (m == MATCH_YES) |
| 1183 | { |
| 1184 | if (obsolescent_check |
| 1185 | && !gfc_notify_std (GFC_STD_F95_OBS(1<<1), "Old-style character length at %C")) |
| 1186 | return MATCH_ERROR; |
| 1187 | *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, length); |
| 1188 | return m; |
| 1189 | } |
| 1190 | |
| 1191 | if (gfc_match_char ('(') == MATCH_NO) |
| 1192 | goto syntax; |
| 1193 | |
| 1194 | m = char_len_param_value (expr, deferred); |
| 1195 | if (m != MATCH_YES && gfc_matching_function) |
| 1196 | { |
| 1197 | gfc_undo_symbols (); |
| 1198 | m = MATCH_YES; |
| 1199 | } |
| 1200 | |
| 1201 | if (m == MATCH_ERROR) |
| 1202 | return m; |
| 1203 | if (m == MATCH_NO) |
| 1204 | goto syntax; |
| 1205 | |
| 1206 | if (gfc_match_char (')') == MATCH_NO) |
| 1207 | { |
| 1208 | gfc_free_expr (*expr); |
| 1209 | *expr = NULL__null; |
| 1210 | goto syntax; |
| 1211 | } |
| 1212 | |
| 1213 | return MATCH_YES; |
| 1214 | |
| 1215 | syntax: |
| 1216 | gfc_error ("Syntax error in character length specification at %C"); |
| 1217 | return MATCH_ERROR; |
| 1218 | } |
| 1219 | |
| 1220 | |
| 1221 | /* Special subroutine for finding a symbol. Check if the name is found |
| 1222 | in the current name space. If not, and we're compiling a function or |
| 1223 | subroutine and the parent compilation unit is an interface, then check |
| 1224 | to see if the name we've been given is the name of the interface |
| 1225 | (located in another namespace). */ |
| 1226 | |
| 1227 | static int |
| 1228 | find_special (const char *name, gfc_symbol **result, bool allow_subroutine) |
| 1229 | { |
| 1230 | gfc_state_data *s; |
| 1231 | gfc_symtree *st; |
| 1232 | int i; |
| 1233 | |
| 1234 | i = gfc_get_sym_tree (name, NULL__null, &st, allow_subroutine); |
| 1235 | if (i == 0) |
| 1236 | { |
| 1237 | *result = st ? st->n.sym : NULL__null; |
| 1238 | goto end; |
| 1239 | } |
| 1240 | |
| 1241 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_SUBROUTINE |
| 1242 | && gfc_current_state ()(gfc_state_stack->state) != COMP_FUNCTION) |
| 1243 | goto end; |
| 1244 | |
| 1245 | s = gfc_state_stack->previous; |
| 1246 | if (s == NULL__null) |
| 1247 | goto end; |
| 1248 | |
| 1249 | if (s->state != COMP_INTERFACE) |
| 1250 | goto end; |
| 1251 | if (s->sym == NULL__null) |
| 1252 | goto end; /* Nameless interface. */ |
| 1253 | |
| 1254 | if (strcmp (name, s->sym->name) == 0) |
| 1255 | { |
| 1256 | *result = s->sym; |
| 1257 | return 0; |
| 1258 | } |
| 1259 | |
| 1260 | end: |
| 1261 | return i; |
| 1262 | } |
| 1263 | |
| 1264 | |
| 1265 | /* Special subroutine for getting a symbol node associated with a |
| 1266 | procedure name, used in SUBROUTINE and FUNCTION statements. The |
| 1267 | symbol is created in the parent using with symtree node in the |
| 1268 | child unit pointing to the symbol. If the current namespace has no |
| 1269 | parent, then the symbol is just created in the current unit. */ |
| 1270 | |
| 1271 | static int |
| 1272 | get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry) |
| 1273 | { |
| 1274 | gfc_symtree *st; |
| 1275 | gfc_symbol *sym; |
| 1276 | int rc = 0; |
| 1277 | |
| 1278 | /* Module functions have to be left in their own namespace because |
| 1279 | they have potentially (almost certainly!) already been referenced. |
| 1280 | In this sense, they are rather like external functions. This is |
| 1281 | fixed up in resolve.cc(resolve_entries), where the symbol name- |
| 1282 | space is set to point to the master function, so that the fake |
| 1283 | result mechanism can work. */ |
| 1284 | if (module_fcn_entry) |
| 1285 | { |
| 1286 | /* Present if entry is declared to be a module procedure. */ |
| 1287 | rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result); |
| 1288 | |
| 1289 | if (*result == NULL__null) |
| 1290 | rc = gfc_get_symbol (name, NULL__null, result); |
| 1291 | else if (!gfc_get_symbol (name, NULL__null, &sym) && sym |
| 1292 | && (*result)->ts.type == BT_UNKNOWN |
| 1293 | && sym->attr.flavor == FL_UNKNOWN) |
| 1294 | /* Pick up the typespec for the entry, if declared in the function |
| 1295 | body. Note that this symbol is FL_UNKNOWN because it will |
| 1296 | only have appeared in a type declaration. The local symtree |
| 1297 | is set to point to the module symbol and a unique symtree |
| 1298 | to the local version. This latter ensures a correct clearing |
| 1299 | of the symbols. */ |
| 1300 | { |
| 1301 | /* If the ENTRY proceeds its specification, we need to ensure |
| 1302 | that this does not raise a "has no IMPLICIT type" error. */ |
| 1303 | if (sym->ts.type == BT_UNKNOWN) |
| 1304 | sym->attr.untyped = 1; |
| 1305 | |
| 1306 | (*result)->ts = sym->ts; |
| 1307 | |
| 1308 | /* Put the symbol in the procedure namespace so that, should |
| 1309 | the ENTRY precede its specification, the specification |
| 1310 | can be applied. */ |
| 1311 | (*result)->ns = gfc_current_ns; |
| 1312 | |
| 1313 | gfc_find_sym_tree (name, gfc_current_ns, 0, &st); |
| 1314 | st->n.sym = *result; |
| 1315 | st = gfc_get_unique_symtree (gfc_current_ns); |
| 1316 | sym->refs++; |
| 1317 | st->n.sym = sym; |
| 1318 | } |
| 1319 | } |
| 1320 | else |
| 1321 | rc = gfc_get_symbol (name, gfc_current_ns->parent, result); |
| 1322 | |
| 1323 | if (rc) |
| 1324 | return rc; |
| 1325 | |
| 1326 | sym = *result; |
| 1327 | if (sym->attr.proc == PROC_ST_FUNCTION) |
| 1328 | return rc; |
| 1329 | |
| 1330 | if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY) |
| 1331 | { |
| 1332 | /* Create a partially populated interface symbol to carry the |
| 1333 | characteristics of the procedure and the result. */ |
| 1334 | sym->tlink = gfc_new_symbol (name, sym->ns); |
| 1335 | gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus); |
| 1336 | gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL__null); |
| 1337 | if (sym->attr.dimension) |
| 1338 | sym->tlink->as = gfc_copy_array_spec (sym->as); |
| 1339 | |
| 1340 | /* Ideally, at this point, a copy would be made of the formal |
| 1341 | arguments and their namespace. However, this does not appear |
| 1342 | to be necessary, albeit at the expense of not being able to |
| 1343 | use gfc_compare_interfaces directly. */ |
| 1344 | |
| 1345 | if (sym->result && sym->result != sym) |
| 1346 | { |
| 1347 | sym->tlink->result = sym->result; |
| 1348 | sym->result = NULL__null; |
| 1349 | } |
| 1350 | else if (sym->result) |
| 1351 | { |
| 1352 | sym->tlink->result = sym->tlink; |
| 1353 | } |
| 1354 | } |
| 1355 | else if (sym && !sym->gfc_new |
| 1356 | && gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE) |
| 1357 | { |
| 1358 | /* Trap another encompassed procedure with the same name. All |
| 1359 | these conditions are necessary to avoid picking up an entry |
| 1360 | whose name clashes with that of the encompassing procedure; |
| 1361 | this is handled using gsymbols to register unique, globally |
| 1362 | accessible names. */ |
| 1363 | if (sym->attr.flavor != 0 |
| 1364 | && sym->attr.proc != 0 |
| 1365 | && (sym->attr.subroutine || sym->attr.function || sym->attr.entry) |
| 1366 | && sym->attr.if_source != IFSRC_UNKNOWN) |
| 1367 | { |
| 1368 | gfc_error_now ("Procedure %qs at %C is already defined at %L", |
| 1369 | name, &sym->declared_at); |
| 1370 | return true; |
| 1371 | } |
| 1372 | if (sym->attr.flavor != 0 |
| 1373 | && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN) |
| 1374 | { |
| 1375 | gfc_error_now ("Procedure %qs at %C is already defined at %L", |
| 1376 | name, &sym->declared_at); |
| 1377 | return true; |
| 1378 | } |
| 1379 | |
| 1380 | if (sym->attr.external && sym->attr.procedure |
| 1381 | && gfc_current_state ()(gfc_state_stack->state) == COMP_CONTAINS) |
| 1382 | { |
| 1383 | gfc_error_now ("Contained procedure %qs at %C clashes with " |
| 1384 | "procedure defined at %L", |
| 1385 | name, &sym->declared_at); |
| 1386 | return true; |
| 1387 | } |
| 1388 | |
| 1389 | /* Trap a procedure with a name the same as interface in the |
| 1390 | encompassing scope. */ |
| 1391 | if (sym->attr.generic != 0 |
| 1392 | && (sym->attr.subroutine || sym->attr.function) |
| 1393 | && !sym->attr.mod_proc) |
| 1394 | { |
| 1395 | gfc_error_now ("Name %qs at %C is already defined" |
| 1396 | " as a generic interface at %L", |
| 1397 | name, &sym->declared_at); |
| 1398 | return true; |
| 1399 | } |
| 1400 | |
| 1401 | /* Trap declarations of attributes in encompassing scope. The |
| 1402 | signature for this is that ts.kind is nonzero for no-CLASS |
| 1403 | entity. For a CLASS entity, ts.kind is zero. */ |
| 1404 | if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS) |
| 1405 | && !sym->attr.implicit_type |
| 1406 | && sym->attr.proc == 0 |
| 1407 | && gfc_current_ns->parent != NULL__null |
| 1408 | && sym->attr.access == 0 |
| 1409 | && !module_fcn_entry) |
| 1410 | { |
| 1411 | gfc_error_now ("Procedure %qs at %C has an explicit interface " |
| 1412 | "from a previous declaration", name); |
| 1413 | return true; |
| 1414 | } |
| 1415 | } |
| 1416 | |
| 1417 | /* C1246 (R1225) MODULE shall appear only in the function-stmt or |
| 1418 | subroutine-stmt of a module subprogram or of a nonabstract interface |
| 1419 | body that is declared in the scoping unit of a module or submodule. */ |
| 1420 | if (sym->attr.external |
| 1421 | && (sym->attr.subroutine || sym->attr.function) |
| 1422 | && sym->attr.if_source == IFSRC_IFBODY |
| 1423 | && !current_attr.module_procedure |
| 1424 | && sym->attr.proc == PROC_MODULE |
| 1425 | && gfc_state_stack->state == COMP_CONTAINS) |
| 1426 | { |
| 1427 | gfc_error_now ("Procedure %qs defined in interface body at %L " |
| 1428 | "clashes with internal procedure defined at %C", |
| 1429 | name, &sym->declared_at); |
| 1430 | return true; |
| 1431 | } |
| 1432 | |
| 1433 | if (sym && !sym->gfc_new |
| 1434 | && sym->attr.flavor != FL_UNKNOWN |
| 1435 | && sym->attr.referenced == 0 && sym->attr.subroutine == 1 |
| 1436 | && gfc_state_stack->state == COMP_CONTAINS |
| 1437 | && gfc_state_stack->previous->state == COMP_SUBROUTINE) |
| 1438 | { |
| 1439 | gfc_error_now ("Procedure %qs at %C is already defined at %L", |
| 1440 | name, &sym->declared_at); |
| 1441 | return true; |
| 1442 | } |
| 1443 | |
| 1444 | if (gfc_current_ns->parent == NULL__null || *result == NULL__null) |
| 1445 | return rc; |
| 1446 | |
| 1447 | /* Module function entries will already have a symtree in |
| 1448 | the current namespace but will need one at module level. */ |
| 1449 | if (module_fcn_entry) |
| 1450 | { |
| 1451 | /* Present if entry is declared to be a module procedure. */ |
| 1452 | rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st); |
| 1453 | if (st == NULL__null) |
| 1454 | st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name); |
| 1455 | } |
| 1456 | else |
| 1457 | st = gfc_new_symtree (&gfc_current_ns->sym_root, name); |
| 1458 | |
| 1459 | st->n.sym = sym; |
| 1460 | sym->refs++; |
| 1461 | |
| 1462 | /* See if the procedure should be a module procedure. */ |
| 1463 | |
| 1464 | if (((sym->ns->proc_name != NULL__null |
| 1465 | && sym->ns->proc_name->attr.flavor == FL_MODULE |
| 1466 | && sym->attr.proc != PROC_MODULE) |
| 1467 | || (module_fcn_entry && sym->attr.proc != PROC_MODULE)) |
| 1468 | && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL__null)) |
| 1469 | rc = 2; |
| 1470 | |
| 1471 | return rc; |
| 1472 | } |
| 1473 | |
| 1474 | |
| 1475 | /* Verify that the given symbol representing a parameter is C |
| 1476 | interoperable, by checking to see if it was marked as such after |
| 1477 | its declaration. If the given symbol is not interoperable, a |
| 1478 | warning is reported, thus removing the need to return the status to |
| 1479 | the calling function. The standard does not require the user use |
| 1480 | one of the iso_c_binding named constants to declare an |
| 1481 | interoperable parameter, but we can't be sure if the param is C |
| 1482 | interop or not if the user doesn't. For example, integer(4) may be |
| 1483 | legal Fortran, but doesn't have meaning in C. It may interop with |
| 1484 | a number of the C types, which causes a problem because the |
| 1485 | compiler can't know which one. This code is almost certainly not |
| 1486 | portable, and the user will get what they deserve if the C type |
| 1487 | across platforms isn't always interoperable with integer(4). If |
| 1488 | the user had used something like integer(c_int) or integer(c_long), |
| 1489 | the compiler could have automatically handled the varying sizes |
| 1490 | across platforms. */ |
| 1491 | |
| 1492 | bool |
| 1493 | gfc_verify_c_interop_param (gfc_symbol *sym) |
| 1494 | { |
| 1495 | int is_c_interop = 0; |
| 1496 | bool retval = true; |
| 1497 | |
| 1498 | /* We check implicitly typed variables in symbol.cc:gfc_set_default_type(). |
| 1499 | Don't repeat the checks here. */ |
| 1500 | if (sym->attr.implicit_type) |
| 1501 | return true; |
| 1502 | |
| 1503 | /* For subroutines or functions that are passed to a BIND(C) procedure, |
| 1504 | they're interoperable if they're BIND(C) and their params are all |
| 1505 | interoperable. */ |
| 1506 | if (sym->attr.flavor == FL_PROCEDURE) |
| 1507 | { |
| 1508 | if (sym->attr.is_bind_c == 0) |
| 1509 | { |
| 1510 | gfc_error_now ("Procedure %qs at %L must have the BIND(C) " |
| 1511 | "attribute to be C interoperable", sym->name, |
| 1512 | &(sym->declared_at)); |
| 1513 | return false; |
| 1514 | } |
| 1515 | else |
| 1516 | { |
| 1517 | if (sym->attr.is_c_interop == 1) |
| 1518 | /* We've already checked this procedure; don't check it again. */ |
| 1519 | return true; |
| 1520 | else |
| 1521 | return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common, |
| 1522 | sym->common_block); |
| 1523 | } |
| 1524 | } |
| 1525 | |
| 1526 | /* See if we've stored a reference to a procedure that owns sym. */ |
| 1527 | if (sym->ns != NULL__null && sym->ns->proc_name != NULL__null) |
| 1528 | { |
| 1529 | if (sym->ns->proc_name->attr.is_bind_c == 1) |
| 1530 | { |
| 1531 | is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0); |
| 1532 | |
| 1533 | if (is_c_interop != 1) |
| 1534 | { |
| 1535 | /* Make personalized messages to give better feedback. */ |
| 1536 | if (sym->ts.type == BT_DERIVED) |
| 1537 | gfc_error ("Variable %qs at %L is a dummy argument to the " |
| 1538 | "BIND(C) procedure %qs but is not C interoperable " |
| 1539 | "because derived type %qs is not C interoperable", |
| 1540 | sym->name, &(sym->declared_at), |
| 1541 | sym->ns->proc_name->name, |
| 1542 | sym->ts.u.derived->name); |
| 1543 | else if (sym->ts.type == BT_CLASS) |
| 1544 | gfc_error ("Variable %qs at %L is a dummy argument to the " |
| 1545 | "BIND(C) procedure %qs but is not C interoperable " |
| 1546 | "because it is polymorphic", |
| 1547 | sym->name, &(sym->declared_at), |
| 1548 | sym->ns->proc_name->name); |
| 1549 | else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type) |
| 1550 | gfc_warning (OPT_Wc_binding_type, |
| 1551 | "Variable %qs at %L is a dummy argument of the " |
| 1552 | "BIND(C) procedure %qs but may not be C " |
| 1553 | "interoperable", |
| 1554 | sym->name, &(sym->declared_at), |
| 1555 | sym->ns->proc_name->name); |
| 1556 | } |
| 1557 | |
| 1558 | /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */ |
| 1559 | if (sym->attr.pointer && sym->attr.contiguous) |
| 1560 | gfc_error ("Dummy argument %qs at %L may not be a pointer with " |
| 1561 | "CONTIGUOUS attribute as procedure %qs is BIND(C)", |
| 1562 | sym->name, &sym->declared_at, sym->ns->proc_name->name); |
| 1563 | |
| 1564 | /* Per F2018, C1557, pointer/allocatable dummies to a bind(c) |
| 1565 | procedure that are default-initialized are not permitted. */ |
| 1566 | if ((sym->attr.pointer || sym->attr.allocatable) |
| 1567 | && sym->ts.type == BT_DERIVED |
| 1568 | && gfc_has_default_initializer (sym->ts.u.derived)) |
| 1569 | { |
| 1570 | gfc_error ("Default-initialized %s dummy argument %qs " |
| 1571 | "at %L is not permitted in BIND(C) procedure %qs", |
| 1572 | (sym->attr.pointer ? "pointer" : "allocatable"), |
| 1573 | sym->name, &sym->declared_at, |
| 1574 | sym->ns->proc_name->name); |
| 1575 | retval = false; |
| 1576 | } |
| 1577 | |
| 1578 | /* Character strings are only C interoperable if they have a |
| 1579 | length of 1. However, as an argument they are also iteroperable |
| 1580 | when passed as descriptor (which requires len=: or len=*). */ |
| 1581 | if (sym->ts.type == BT_CHARACTER) |
| 1582 | { |
| 1583 | gfc_charlen *cl = sym->ts.u.cl; |
| 1584 | |
| 1585 | if (sym->attr.allocatable || sym->attr.pointer) |
| 1586 | { |
| 1587 | /* F2018, 18.3.6 (6). */ |
| 1588 | if (!sym->ts.deferred) |
| 1589 | { |
| 1590 | if (sym->attr.allocatable) |
| 1591 | gfc_error ("Allocatable character dummy argument %qs " |
| 1592 | "at %L must have deferred length as " |
| 1593 | "procedure %qs is BIND(C)", sym->name, |
| 1594 | &sym->declared_at, sym->ns->proc_name->name); |
| 1595 | else |
| 1596 | gfc_error ("Pointer character dummy argument %qs at %L " |
| 1597 | "must have deferred length as procedure %qs " |
| 1598 | "is BIND(C)", sym->name, &sym->declared_at, |
| 1599 | sym->ns->proc_name->name); |
| 1600 | retval = false; |
| 1601 | } |
| 1602 | else if (!gfc_notify_std (GFC_STD_F2018(1<<9), |
| 1603 | "Deferred-length character dummy " |
| 1604 | "argument %qs at %L of procedure " |
| 1605 | "%qs with BIND(C) attribute", |
| 1606 | sym->name, &sym->declared_at, |
| 1607 | sym->ns->proc_name->name)) |
| 1608 | retval = false; |
| 1609 | } |
| 1610 | else if (sym->attr.value |
| 1611 | && (!cl || !cl->length |
| 1612 | || cl->length->expr_type != EXPR_CONSTANT |
| 1613 | || mpz_cmp_si (cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (cl->length->value.integer)->_mp_size < 0 ? -1 : ( cl->length->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (cl->length->value.integer,(static_cast<unsigned long > (1)))) : __gmpz_cmp_si (cl->length->value.integer, 1)) != 0)) |
| 1614 | { |
| 1615 | gfc_error ("Character dummy argument %qs at %L must be " |
| 1616 | "of length 1 as it has the VALUE attribute", |
| 1617 | sym->name, &sym->declared_at); |
| 1618 | retval = false; |
| 1619 | } |
| 1620 | else if (!cl || !cl->length) |
| 1621 | { |
| 1622 | /* Assumed length; F2018, 18.3.6 (5)(2). |
| 1623 | Uses the CFI array descriptor - also for scalars and |
| 1624 | explicit-size/assumed-size arrays. */ |
| 1625 | if (!gfc_notify_std (GFC_STD_F2018(1<<9), |
| 1626 | "Assumed-length character dummy argument " |
| 1627 | "%qs at %L of procedure %qs with BIND(C) " |
| 1628 | "attribute", sym->name, &sym->declared_at, |
| 1629 | sym->ns->proc_name->name)) |
| 1630 | retval = false; |
| 1631 | } |
| 1632 | else if (cl->length->expr_type != EXPR_CONSTANT |
| 1633 | || mpz_cmp_si (cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (cl->length->value.integer)->_mp_size < 0 ? -1 : ( cl->length->value.integer)->_mp_size > 0) : __gmpz_cmp_ui (cl->length->value.integer,(static_cast<unsigned long > (1)))) : __gmpz_cmp_si (cl->length->value.integer, 1)) != 0) |
| 1634 | { |
| 1635 | /* F2018, 18.3.6, (5), item 4. */ |
| 1636 | if (!sym->attr.dimension |
| 1637 | || sym->as->type == AS_ASSUMED_SIZE |
| 1638 | || sym->as->type == AS_EXPLICIT) |
| 1639 | { |
| 1640 | gfc_error ("Character dummy argument %qs at %L must be " |
| 1641 | "of constant length of one or assumed length, " |
| 1642 | "unless it has assumed shape or assumed rank, " |
| 1643 | "as procedure %qs has the BIND(C) attribute", |
| 1644 | sym->name, &sym->declared_at, |
| 1645 | sym->ns->proc_name->name); |
| 1646 | retval = false; |
| 1647 | } |
| 1648 | /* else: valid only since F2018 - and an assumed-shape/rank |
| 1649 | array; however, gfc_notify_std is already called when |
| 1650 | those array types are used. Thus, silently accept F200x. */ |
| 1651 | } |
| 1652 | } |
| 1653 | |
| 1654 | /* We have to make sure that any param to a bind(c) routine does |
| 1655 | not have the allocatable, pointer, or optional attributes, |
| 1656 | according to J3/04-007, section 5.1. */ |
| 1657 | if (sym->attr.allocatable == 1 |
| 1658 | && !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs at %L with " |
| 1659 | "ALLOCATABLE attribute in procedure %qs " |
| 1660 | "with BIND(C)", sym->name, |
| 1661 | &(sym->declared_at), |
| 1662 | sym->ns->proc_name->name)) |
| 1663 | retval = false; |
| 1664 | |
| 1665 | if (sym->attr.pointer == 1 |
| 1666 | && !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs at %L with " |
| 1667 | "POINTER attribute in procedure %qs " |
| 1668 | "with BIND(C)", sym->name, |
| 1669 | &(sym->declared_at), |
| 1670 | sym->ns->proc_name->name)) |
| 1671 | retval = false; |
| 1672 | |
| 1673 | if (sym->attr.optional == 1 && sym->attr.value) |
| 1674 | { |
| 1675 | gfc_error ("Variable %qs at %L cannot have both the OPTIONAL " |
| 1676 | "and the VALUE attribute because procedure %qs " |
| 1677 | "is BIND(C)", sym->name, &(sym->declared_at), |
| 1678 | sym->ns->proc_name->name); |
| 1679 | retval = false; |
| 1680 | } |
| 1681 | else if (sym->attr.optional == 1 |
| 1682 | && !gfc_notify_std (GFC_STD_F2018(1<<9), "Variable %qs " |
| 1683 | "at %L with OPTIONAL attribute in " |
| 1684 | "procedure %qs which is BIND(C)", |
| 1685 | sym->name, &(sym->declared_at), |
| 1686 | sym->ns->proc_name->name)) |
| 1687 | retval = false; |
| 1688 | |
| 1689 | /* Make sure that if it has the dimension attribute, that it is |
| 1690 | either assumed size or explicit shape. Deferred shape is already |
| 1691 | covered by the pointer/allocatable attribute. */ |
| 1692 | if (sym->as != NULL__null && sym->as->type == AS_ASSUMED_SHAPE |
| 1693 | && !gfc_notify_std (GFC_STD_F2018(1<<9), "Assumed-shape array %qs " |
| 1694 | "at %L as dummy argument to the BIND(C) " |
| 1695 | "procedure %qs at %L", sym->name, |
| 1696 | &(sym->declared_at), |
| 1697 | sym->ns->proc_name->name, |
| 1698 | &(sym->ns->proc_name->declared_at))) |
| 1699 | retval = false; |
| 1700 | } |
| 1701 | } |
| 1702 | |
| 1703 | return retval; |
| 1704 | } |
| 1705 | |
| 1706 | |
| 1707 | |
| 1708 | /* Function called by variable_decl() that adds a name to the symbol table. */ |
| 1709 | |
| 1710 | static bool |
| 1711 | build_sym (const char *name, gfc_charlen *cl, bool cl_deferred, |
| 1712 | gfc_array_spec **as, locus *var_locus) |
| 1713 | { |
| 1714 | symbol_attribute attr; |
| 1715 | gfc_symbol *sym; |
| 1716 | int upper; |
| 1717 | gfc_symtree *st; |
| 1718 | |
| 1719 | /* Symbols in a submodule are host associated from the parent module or |
| 1720 | submodules. Therefore, they can be overridden by declarations in the |
| 1721 | submodule scope. Deal with this by attaching the existing symbol to |
| 1722 | a new symtree and recycling the old symtree with a new symbol... */ |
| 1723 | st = gfc_find_symtree (gfc_current_ns->sym_root, name); |
| 1724 | if (st != NULL__null && gfc_state_stack->state == COMP_SUBMODULE |
| 1725 | && st->n.sym != NULL__null |
| 1726 | && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule) |
| 1727 | { |
| 1728 | gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns); |
| 1729 | s->n.sym = st->n.sym; |
| 1730 | sym = gfc_new_symbol (name, gfc_current_ns); |
| 1731 | |
| 1732 | |
| 1733 | st->n.sym = sym; |
| 1734 | sym->refs++; |
| 1735 | gfc_set_sym_referenced (sym); |
| 1736 | } |
| 1737 | /* ...Otherwise generate a new symtree and new symbol. */ |
| 1738 | else if (gfc_get_symbol (name, NULL__null, &sym)) |
| 1739 | return false; |
| 1740 | |
| 1741 | /* Check if the name has already been defined as a type. The |
| 1742 | first letter of the symtree will be in upper case then. Of |
| 1743 | course, this is only necessary if the upper case letter is |
| 1744 | actually different. */ |
| 1745 | |
| 1746 | upper = TOUPPER(name[0])_sch_toupper[(name[0]) & 0xff]; |
| 1747 | if (upper != name[0]) |
| 1748 | { |
| 1749 | char u_name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 1750 | gfc_symtree *st; |
| 1751 | |
| 1752 | gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN)((void)(!(strlen(name) <= 63) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 1752, __FUNCTION__), 0 : 0)); |
| 1753 | strcpy (u_name, name); |
| 1754 | u_name[0] = upper; |
| 1755 | |
| 1756 | st = gfc_find_symtree (gfc_current_ns->sym_root, u_name); |
| 1757 | |
| 1758 | /* STRUCTURE types can alias symbol names */ |
| 1759 | if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT) |
| 1760 | { |
| 1761 | gfc_error ("Symbol %qs at %C also declared as a type at %L", name, |
| 1762 | &st->n.sym->declared_at); |
| 1763 | return false; |
| 1764 | } |
| 1765 | } |
| 1766 | |
| 1767 | /* Start updating the symbol table. Add basic type attribute if present. */ |
| 1768 | if (current_ts.type != BT_UNKNOWN |
| 1769 | && (sym->attr.implicit_type == 0 |
| 1770 | || !gfc_compare_types (&sym->ts, ¤t_ts)) |
| 1771 | && !gfc_add_type (sym, ¤t_ts, var_locus)) |
| 1772 | return false; |
| 1773 | |
| 1774 | if (sym->ts.type == BT_CHARACTER) |
| 1775 | { |
| 1776 | sym->ts.u.cl = cl; |
| 1777 | sym->ts.deferred = cl_deferred; |
| 1778 | } |
| 1779 | |
| 1780 | /* Add dimension attribute if present. */ |
| 1781 | if (!gfc_set_array_spec (sym, *as, var_locus)) |
| 1782 | return false; |
| 1783 | *as = NULL__null; |
| 1784 | |
| 1785 | /* Add attribute to symbol. The copy is so that we can reset the |
| 1786 | dimension attribute. */ |
| 1787 | attr = current_attr; |
| 1788 | attr.dimension = 0; |
| 1789 | attr.codimension = 0; |
| 1790 | |
| 1791 | if (!gfc_copy_attr (&sym->attr, &attr, var_locus)) |
| 1792 | return false; |
| 1793 | |
| 1794 | /* Finish any work that may need to be done for the binding label, |
| 1795 | if it's a bind(c). The bind(c) attr is found before the symbol |
| 1796 | is made, and before the symbol name (for data decls), so the |
| 1797 | current_ts is holding the binding label, or nothing if the |
| 1798 | name= attr wasn't given. Therefore, test here if we're dealing |
| 1799 | with a bind(c) and make sure the binding label is set correctly. */ |
| 1800 | if (sym->attr.is_bind_c == 1) |
| 1801 | { |
| 1802 | if (!sym->binding_label) |
| 1803 | { |
| 1804 | /* Set the binding label and verify that if a NAME= was specified |
| 1805 | then only one identifier was in the entity-decl-list. */ |
| 1806 | if (!set_binding_label (&sym->binding_label, sym->name, |
| 1807 | num_idents_on_line)) |
| 1808 | return false; |
| 1809 | } |
| 1810 | } |
| 1811 | |
| 1812 | /* See if we know we're in a common block, and if it's a bind(c) |
| 1813 | common then we need to make sure we're an interoperable type. */ |
| 1814 | if (sym->attr.in_common == 1) |
| 1815 | { |
| 1816 | /* Test the common block object. */ |
| 1817 | if (sym->common_block != NULL__null && sym->common_block->is_bind_c == 1 |
| 1818 | && sym->ts.is_c_interop != 1) |
| 1819 | { |
| 1820 | gfc_error_now ("Variable %qs in common block %qs at %C " |
| 1821 | "must be declared with a C interoperable " |
| 1822 | "kind since common block %qs is BIND(C)", |
| 1823 | sym->name, sym->common_block->name, |
| 1824 | sym->common_block->name); |
| 1825 | gfc_clear_error (); |
| 1826 | } |
| 1827 | } |
| 1828 | |
| 1829 | sym->attr.implied_index = 0; |
| 1830 | |
| 1831 | /* Use the parameter expressions for a parameterized derived type. */ |
| 1832 | if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS) |
| 1833 | && sym->ts.u.derived->attr.pdt_type && type_param_spec_list) |
| 1834 | sym->param_list = gfc_copy_actual_arglist (type_param_spec_list); |
| 1835 | |
| 1836 | if (sym->ts.type == BT_CLASS) |
| 1837 | return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as); |
| 1838 | |
| 1839 | return true; |
| 1840 | } |
| 1841 | |
| 1842 | |
| 1843 | /* Set character constant to the given length. The constant will be padded or |
| 1844 | truncated. If we're inside an array constructor without a typespec, we |
| 1845 | additionally check that all elements have the same length; check_len -1 |
| 1846 | means no checking. */ |
| 1847 | |
| 1848 | void |
| 1849 | gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr, |
| 1850 | gfc_charlen_t check_len) |
| 1851 | { |
| 1852 | gfc_char_t *s; |
| 1853 | gfc_charlen_t slen; |
| 1854 | |
| 1855 | if (expr->ts.type != BT_CHARACTER) |
| 1856 | return; |
| 1857 | |
| 1858 | if (expr->expr_type != EXPR_CONSTANT) |
| 1859 | { |
| 1860 | gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where); |
| 1861 | return; |
| 1862 | } |
| 1863 | |
| 1864 | slen = expr->value.character.length; |
| 1865 | if (len != slen) |
| 1866 | { |
| 1867 | s = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t))); |
| 1868 | memcpy (s, expr->value.character.string, |
| 1869 | MIN (len, slen)((len) < (slen) ? (len) : (slen)) * sizeof (gfc_char_t)); |
| 1870 | if (len > slen) |
| 1871 | gfc_wide_memset (&s[slen], ' ', len - slen); |
| 1872 | |
| 1873 | if (warn_character_truncationglobal_options.x_warn_character_truncation && slen > len) |
| 1874 | gfc_warning_now (OPT_Wcharacter_truncation, |
| 1875 | "CHARACTER expression at %L is being truncated " |
| 1876 | "(%ld/%ld)", &expr->where, |
| 1877 | (long) slen, (long) len); |
| 1878 | |
| 1879 | /* Apply the standard by 'hand' otherwise it gets cleared for |
| 1880 | initializers. */ |
| 1881 | if (check_len != -1 && slen != check_len |
| 1882 | && !(gfc_option.allow_std & GFC_STD_GNU(1<<5))) |
| 1883 | gfc_error_now ("The CHARACTER elements of the array constructor " |
| 1884 | "at %L must have the same length (%ld/%ld)", |
| 1885 | &expr->where, (long) slen, |
| 1886 | (long) check_len); |
| 1887 | |
| 1888 | s[len] = '\0'; |
| 1889 | free (expr->value.character.string); |
| 1890 | expr->value.character.string = s; |
| 1891 | expr->value.character.length = len; |
| 1892 | /* If explicit representation was given, clear it |
| 1893 | as it is no longer needed after padding. */ |
| 1894 | if (expr->representation.length) |
| 1895 | { |
| 1896 | expr->representation.length = 0; |
| 1897 | free (expr->representation.string); |
| 1898 | expr->representation.string = NULL__null; |
| 1899 | } |
| 1900 | } |
| 1901 | } |
| 1902 | |
| 1903 | |
| 1904 | /* Function to create and update the enumerator history |
| 1905 | using the information passed as arguments. |
| 1906 | Pointer "max_enum" is also updated, to point to |
| 1907 | enum history node containing largest initializer. |
| 1908 | |
| 1909 | SYM points to the symbol node of enumerator. |
| 1910 | INIT points to its enumerator value. */ |
| 1911 | |
| 1912 | static void |
| 1913 | create_enum_history (gfc_symbol *sym, gfc_expr *init) |
| 1914 | { |
| 1915 | enumerator_history *new_enum_history; |
| 1916 | gcc_assert (sym != NULL && init != NULL)((void)(!(sym != __null && init != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 1916, __FUNCTION__), 0 : 0)); |
| 1917 | |
| 1918 | new_enum_history = XCNEW (enumerator_history)((enumerator_history *) xcalloc (1, sizeof (enumerator_history ))); |
| 1919 | |
| 1920 | new_enum_history->sym = sym; |
| 1921 | new_enum_history->initializer = init; |
| 1922 | new_enum_history->next = NULL__null; |
| 1923 | |
| 1924 | if (enum_history == NULL__null) |
| 1925 | { |
| 1926 | enum_history = new_enum_history; |
| 1927 | max_enum = enum_history; |
| 1928 | } |
| 1929 | else |
| 1930 | { |
| 1931 | new_enum_history->next = enum_history; |
| 1932 | enum_history = new_enum_history; |
| 1933 | |
| 1934 | if (mpz_cmp__gmpz_cmp (max_enum->initializer->value.integer, |
| 1935 | new_enum_history->initializer->value.integer) < 0) |
| 1936 | max_enum = new_enum_history; |
| 1937 | } |
| 1938 | } |
| 1939 | |
| 1940 | |
| 1941 | /* Function to free enum kind history. */ |
| 1942 | |
| 1943 | void |
| 1944 | gfc_free_enum_history (void) |
| 1945 | { |
| 1946 | enumerator_history *current = enum_history; |
| 1947 | enumerator_history *next; |
| 1948 | |
| 1949 | while (current != NULL__null) |
| 1950 | { |
| 1951 | next = current->next; |
| 1952 | free (current); |
| 1953 | current = next; |
| 1954 | } |
| 1955 | max_enum = NULL__null; |
| 1956 | enum_history = NULL__null; |
| 1957 | } |
| 1958 | |
| 1959 | |
| 1960 | /* Function called by variable_decl() that adds an initialization |
| 1961 | expression to a symbol. */ |
| 1962 | |
| 1963 | static bool |
| 1964 | add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus) |
| 1965 | { |
| 1966 | symbol_attribute attr; |
| 1967 | gfc_symbol *sym; |
| 1968 | gfc_expr *init; |
| 1969 | |
| 1970 | init = *initp; |
| 1971 | if (find_special (name, &sym, false)) |
| 1972 | return false; |
| 1973 | |
| 1974 | attr = sym->attr; |
| 1975 | |
| 1976 | /* If this symbol is confirming an implicit parameter type, |
| 1977 | then an initialization expression is not allowed. */ |
| 1978 | if (attr.flavor == FL_PARAMETER && sym->value != NULL__null) |
| 1979 | { |
| 1980 | if (*initp != NULL__null) |
| 1981 | { |
| 1982 | gfc_error ("Initializer not allowed for PARAMETER %qs at %C", |
| 1983 | sym->name); |
| 1984 | return false; |
| 1985 | } |
| 1986 | else |
| 1987 | return true; |
| 1988 | } |
| 1989 | |
| 1990 | if (init == NULL__null) |
| 1991 | { |
| 1992 | /* An initializer is required for PARAMETER declarations. */ |
| 1993 | if (attr.flavor == FL_PARAMETER) |
| 1994 | { |
| 1995 | gfc_error ("PARAMETER at %L is missing an initializer", var_locus); |
| 1996 | return false; |
| 1997 | } |
| 1998 | } |
| 1999 | else |
| 2000 | { |
| 2001 | /* If a variable appears in a DATA block, it cannot have an |
| 2002 | initializer. */ |
| 2003 | if (sym->attr.data) |
| 2004 | { |
| 2005 | gfc_error ("Variable %qs at %C with an initializer already " |
| 2006 | "appears in a DATA statement", sym->name); |
| 2007 | return false; |
| 2008 | } |
| 2009 | |
| 2010 | /* Check if the assignment can happen. This has to be put off |
| 2011 | until later for derived type variables and procedure pointers. */ |
| 2012 | if (!gfc_bt_struct (sym->ts.type)((sym->ts.type) == BT_DERIVED || (sym->ts.type) == BT_UNION ) && !gfc_bt_struct (init->ts.type)((init->ts.type) == BT_DERIVED || (init->ts.type) == BT_UNION ) |
| 2013 | && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS |
| 2014 | && !sym->attr.proc_pointer |
| 2015 | && !gfc_check_assign_symbol (sym, NULL__null, init)) |
| 2016 | return false; |
| 2017 | |
| 2018 | if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl |
| 2019 | && init->ts.type == BT_CHARACTER) |
| 2020 | { |
| 2021 | /* Update symbol character length according initializer. */ |
| 2022 | if (!gfc_check_assign_symbol (sym, NULL__null, init)) |
| 2023 | return false; |
| 2024 | |
| 2025 | if (sym->ts.u.cl->length == NULL__null) |
| 2026 | { |
| 2027 | gfc_charlen_t clen; |
| 2028 | /* If there are multiple CHARACTER variables declared on the |
| 2029 | same line, we don't want them to share the same length. */ |
| 2030 | sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 2031 | |
| 2032 | if (sym->attr.flavor == FL_PARAMETER) |
| 2033 | { |
| 2034 | if (init->expr_type == EXPR_CONSTANT) |
| 2035 | { |
| 2036 | clen = init->value.character.length; |
| 2037 | sym->ts.u.cl->length |
| 2038 | = gfc_get_int_expr (gfc_charlen_int_kind, |
| 2039 | NULL__null, clen); |
| 2040 | } |
| 2041 | else if (init->expr_type == EXPR_ARRAY) |
| 2042 | { |
| 2043 | if (init->ts.u.cl && init->ts.u.cl->length) |
| 2044 | { |
| 2045 | const gfc_expr *length = init->ts.u.cl->length; |
| 2046 | if (length->expr_type != EXPR_CONSTANT) |
| 2047 | { |
| 2048 | gfc_error ("Cannot initialize parameter array " |
| 2049 | "at %L " |
| 2050 | "with variable length elements", |
| 2051 | &sym->declared_at); |
| 2052 | return false; |
| 2053 | } |
| 2054 | clen = mpz_get_si__gmpz_get_si (length->value.integer); |
| 2055 | } |
| 2056 | else if (init->value.constructor) |
| 2057 | { |
| 2058 | gfc_constructor *c; |
| 2059 | c = gfc_constructor_first (init->value.constructor); |
| 2060 | clen = c->expr->value.character.length; |
| 2061 | } |
| 2062 | else |
| 2063 | gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 2063, __FUNCTION__)); |
| 2064 | sym->ts.u.cl->length |
| 2065 | = gfc_get_int_expr (gfc_charlen_int_kind, |
| 2066 | NULL__null, clen); |
| 2067 | } |
| 2068 | else if (init->ts.u.cl && init->ts.u.cl->length) |
| 2069 | sym->ts.u.cl->length = |
| 2070 | gfc_copy_expr (init->ts.u.cl->length); |
| 2071 | } |
| 2072 | } |
| 2073 | /* Update initializer character length according symbol. */ |
| 2074 | else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT) |
| 2075 | { |
| 2076 | if (!gfc_specification_expr (sym->ts.u.cl->length)) |
| 2077 | return false; |
| 2078 | |
| 2079 | int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, |
| 2080 | false); |
| 2081 | /* resolve_charlen will complain later on if the length |
| 2082 | is too large. Just skeep the initialization in that case. */ |
| 2083 | if (mpz_cmp__gmpz_cmp (sym->ts.u.cl->length->value.integer, |
| 2084 | gfc_integer_kinds[k].huge) <= 0) |
| 2085 | { |
| 2086 | HOST_WIDE_INTlong len |
| 2087 | = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer); |
| 2088 | |
| 2089 | if (init->expr_type == EXPR_CONSTANT) |
| 2090 | gfc_set_constant_character_len (len, init, -1); |
| 2091 | else if (init->expr_type == EXPR_ARRAY) |
| 2092 | { |
| 2093 | gfc_constructor *c; |
| 2094 | |
| 2095 | /* Build a new charlen to prevent simplification from |
| 2096 | deleting the length before it is resolved. */ |
| 2097 | init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 2098 | init->ts.u.cl->length |
| 2099 | = gfc_copy_expr (sym->ts.u.cl->length); |
| 2100 | |
| 2101 | for (c = gfc_constructor_first (init->value.constructor); |
| 2102 | c; c = gfc_constructor_next (c)) |
| 2103 | gfc_set_constant_character_len (len, c->expr, -1); |
| 2104 | } |
| 2105 | } |
| 2106 | } |
| 2107 | } |
| 2108 | |
| 2109 | if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as |
| 2110 | && sym->as->rank && init->rank && init->rank != sym->as->rank) |
| 2111 | { |
| 2112 | gfc_error ("Rank mismatch of array at %L and its initializer " |
| 2113 | "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank); |
| 2114 | return false; |
| 2115 | } |
| 2116 | |
| 2117 | /* If sym is implied-shape, set its upper bounds from init. */ |
| 2118 | if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension |
| 2119 | && sym->as->type == AS_IMPLIED_SHAPE) |
| 2120 | { |
| 2121 | int dim; |
| 2122 | |
| 2123 | if (init->rank == 0) |
| 2124 | { |
| 2125 | gfc_error ("Cannot initialize implied-shape array at %L" |
| 2126 | " with scalar", &sym->declared_at); |
| 2127 | return false; |
| 2128 | } |
| 2129 | |
| 2130 | /* The shape may be NULL for EXPR_ARRAY, set it. */ |
| 2131 | if (init->shape == NULL__null) |
| 2132 | { |
| 2133 | if (init->expr_type != EXPR_ARRAY) |
| 2134 | { |
| 2135 | gfc_error ("Bad shape of initializer at %L", &init->where); |
| 2136 | return false; |
| 2137 | } |
| 2138 | |
| 2139 | init->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); |
| 2140 | if (!gfc_array_size (init, &init->shape[0])) |
| 2141 | { |
| 2142 | gfc_error ("Cannot determine shape of initializer at %L", |
| 2143 | &init->where); |
| 2144 | free (init->shape); |
| 2145 | init->shape = NULL__null; |
| 2146 | return false; |
| 2147 | } |
| 2148 | } |
| 2149 | |
| 2150 | for (dim = 0; dim < sym->as->rank; ++dim) |
| 2151 | { |
| 2152 | int k; |
| 2153 | gfc_expr *e, *lower; |
| 2154 | |
| 2155 | lower = sym->as->lower[dim]; |
| 2156 | |
| 2157 | /* If the lower bound is an array element from another |
| 2158 | parameterized array, then it is marked with EXPR_VARIABLE and |
| 2159 | is an initialization expression. Try to reduce it. */ |
| 2160 | if (lower->expr_type == EXPR_VARIABLE) |
| 2161 | gfc_reduce_init_expr (lower); |
| 2162 | |
| 2163 | if (lower->expr_type == EXPR_CONSTANT) |
| 2164 | { |
| 2165 | /* All dimensions must be without upper bound. */ |
| 2166 | gcc_assert (!sym->as->upper[dim])((void)(!(!sym->as->upper[dim]) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 2166, __FUNCTION__), 0 : 0)); |
| 2167 | |
| 2168 | k = lower->ts.kind; |
| 2169 | e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at); |
| 2170 | mpz_add__gmpz_add (e->value.integer, lower->value.integer, |
| 2171 | init->shape[dim]); |
| 2172 | mpz_sub_ui__gmpz_sub_ui (e->value.integer, e->value.integer, 1); |
| 2173 | sym->as->upper[dim] = e; |
| 2174 | } |
| 2175 | else |
| 2176 | { |
| 2177 | gfc_error ("Non-constant lower bound in implied-shape" |
| 2178 | " declaration at %L", &lower->where); |
| 2179 | return false; |
| 2180 | } |
| 2181 | } |
| 2182 | |
| 2183 | sym->as->type = AS_EXPLICIT; |
| 2184 | } |
| 2185 | |
| 2186 | /* Ensure that explicit bounds are simplified. */ |
| 2187 | if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension |
| 2188 | && sym->as->type == AS_EXPLICIT) |
| 2189 | { |
| 2190 | for (int dim = 0; dim < sym->as->rank; ++dim) |
| 2191 | { |
| 2192 | gfc_expr *e; |
| 2193 | |
| 2194 | e = sym->as->lower[dim]; |
| 2195 | if (e->expr_type != EXPR_CONSTANT) |
| 2196 | gfc_reduce_init_expr (e); |
| 2197 | |
| 2198 | e = sym->as->upper[dim]; |
| 2199 | if (e->expr_type != EXPR_CONSTANT) |
| 2200 | gfc_reduce_init_expr (e); |
| 2201 | } |
| 2202 | } |
| 2203 | |
| 2204 | /* Need to check if the expression we initialized this |
| 2205 | to was one of the iso_c_binding named constants. If so, |
| 2206 | and we're a parameter (constant), let it be iso_c. |
| 2207 | For example: |
| 2208 | integer(c_int), parameter :: my_int = c_int |
| 2209 | integer(my_int) :: my_int_2 |
| 2210 | If we mark my_int as iso_c (since we can see it's value |
| 2211 | is equal to one of the named constants), then my_int_2 |
| 2212 | will be considered C interoperable. */ |
| 2213 | if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type)((sym->ts.type) == BT_DERIVED || (sym->ts.type) == BT_UNION )) |
| 2214 | { |
| 2215 | sym->ts.is_iso_c |= init->ts.is_iso_c; |
| 2216 | sym->ts.is_c_interop |= init->ts.is_c_interop; |
| 2217 | /* attr bits needed for module files. */ |
| 2218 | sym->attr.is_iso_c |= init->ts.is_iso_c; |
| 2219 | sym->attr.is_c_interop |= init->ts.is_c_interop; |
| 2220 | if (init->ts.is_iso_c) |
| 2221 | sym->ts.f90_type = init->ts.f90_type; |
| 2222 | } |
| 2223 | |
| 2224 | /* Catch the case: type(t), parameter :: x = z'1'. */ |
| 2225 | if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ) |
| 2226 | { |
| 2227 | gfc_error ("Entity %qs at %L is incompatible with a BOZ " |
| 2228 | "literal constant", name, &sym->declared_at); |
| 2229 | return false; |
| 2230 | } |
| 2231 | |
| 2232 | /* Add initializer. Make sure we keep the ranks sane. */ |
| 2233 | if (sym->attr.dimension && init->rank == 0) |
| 2234 | { |
| 2235 | mpz_t size; |
| 2236 | gfc_expr *array; |
| 2237 | int n; |
| 2238 | if (sym->attr.flavor == FL_PARAMETER |
| 2239 | && gfc_is_constant_expr (init) |
| 2240 | && (init->expr_type == EXPR_CONSTANT |
| 2241 | || init->expr_type == EXPR_STRUCTURE) |
| 2242 | && spec_size (sym->as, &size) |
| 2243 | && mpz_cmp_si (size, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (size)->_mp_size < 0 ? -1 : (size)->_mp_size > 0) : __gmpz_cmp_ui (size,(static_cast<unsigned long> (0)) )) : __gmpz_cmp_si (size,0)) > 0) |
| 2244 | { |
| 2245 | array = gfc_get_array_expr (init->ts.type, init->ts.kind, |
| 2246 | &init->where); |
| 2247 | if (init->ts.type == BT_DERIVED) |
| 2248 | array->ts.u.derived = init->ts.u.derived; |
| 2249 | for (n = 0; n < (int)mpz_get_si__gmpz_get_si (size); n++) |
| 2250 | gfc_constructor_append_expr (&array->value.constructor, |
| 2251 | n == 0 |
| 2252 | ? init |
| 2253 | : gfc_copy_expr (init), |
| 2254 | &init->where); |
| 2255 | |
| 2256 | array->shape = gfc_get_shape (sym->as->rank)(((mpz_t *) xcalloc (((sym->as->rank)), sizeof (mpz_t)) )); |
| 2257 | for (n = 0; n < sym->as->rank; n++) |
| 2258 | spec_dimen_size (sym->as, n, &array->shape[n]); |
| 2259 | |
| 2260 | init = array; |
| 2261 | mpz_clear__gmpz_clear (size); |
| 2262 | } |
| 2263 | init->rank = sym->as->rank; |
| 2264 | } |
| 2265 | |
| 2266 | sym->value = init; |
| 2267 | if (sym->attr.save == SAVE_NONE) |
| 2268 | sym->attr.save = SAVE_IMPLICIT; |
| 2269 | *initp = NULL__null; |
| 2270 | } |
| 2271 | |
| 2272 | return true; |
| 2273 | } |
| 2274 | |
| 2275 | |
| 2276 | /* Function called by variable_decl() that adds a name to a structure |
| 2277 | being built. */ |
| 2278 | |
| 2279 | static bool |
| 2280 | build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, |
| 2281 | gfc_array_spec **as) |
| 2282 | { |
| 2283 | gfc_state_data *s; |
| 2284 | gfc_component *c; |
| 2285 | |
| 2286 | /* F03:C438/C439. If the current symbol is of the same derived type that we're |
| 2287 | constructing, it must have the pointer attribute. */ |
| 2288 | if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) |
| 2289 | && current_ts.u.derived == gfc_current_block ()(gfc_state_stack->sym) |
| 2290 | && current_attr.pointer == 0) |
| 2291 | { |
| 2292 | if (current_attr.allocatable |
| 2293 | && !gfc_notify_std(GFC_STD_F2008(1<<7), "Component at %C " |
| 2294 | "must have the POINTER attribute")) |
| 2295 | { |
| 2296 | return false; |
| 2297 | } |
| 2298 | else if (current_attr.allocatable == 0) |
| 2299 | { |
| 2300 | gfc_error ("Component at %C must have the POINTER attribute"); |
| 2301 | return false; |
| 2302 | } |
| 2303 | } |
| 2304 | |
| 2305 | /* F03:C437. */ |
| 2306 | if (current_ts.type == BT_CLASS |
| 2307 | && !(current_attr.pointer || current_attr.allocatable)) |
| 2308 | { |
| 2309 | gfc_error ("Component %qs with CLASS at %C must be allocatable " |
| 2310 | "or pointer", name); |
| 2311 | return false; |
| 2312 | } |
| 2313 | |
| 2314 | if (gfc_current_block ()(gfc_state_stack->sym)->attr.pointer && (*as)->rank != 0) |
| 2315 | { |
| 2316 | if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT) |
| 2317 | { |
| 2318 | gfc_error ("Array component of structure at %C must have explicit " |
| 2319 | "or deferred shape"); |
| 2320 | return false; |
| 2321 | } |
| 2322 | } |
| 2323 | |
| 2324 | /* If we are in a nested union/map definition, gfc_add_component will not |
| 2325 | properly find repeated components because: |
| 2326 | (i) gfc_add_component does a flat search, where components of unions |
| 2327 | and maps are implicity chained so nested components may conflict. |
| 2328 | (ii) Unions and maps are not linked as components of their parent |
| 2329 | structures until after they are parsed. |
| 2330 | For (i) we use gfc_find_component which searches recursively, and for (ii) |
| 2331 | we search each block directly from the parse stack until we find the top |
| 2332 | level structure. */ |
| 2333 | |
| 2334 | s = gfc_state_stack; |
| 2335 | if (s->state == COMP_UNION || s->state == COMP_MAP) |
| 2336 | { |
| 2337 | while (s->state == COMP_UNION || gfc_comp_struct (s->state)((s->state) == COMP_DERIVED || (s->state) == COMP_STRUCTURE || (s->state) == COMP_MAP)) |
| 2338 | { |
| 2339 | c = gfc_find_component (s->sym, name, true, true, NULL__null); |
| 2340 | if (c != NULL__null) |
| 2341 | { |
| 2342 | gfc_error_now ("Component %qs at %C already declared at %L", |
| 2343 | name, &c->loc); |
| 2344 | return false; |
| 2345 | } |
| 2346 | /* Break after we've searched the entire chain. */ |
| 2347 | if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE) |
| 2348 | break; |
| 2349 | s = s->previous; |
| 2350 | } |
| 2351 | } |
| 2352 | |
| 2353 | if (!gfc_add_component (gfc_current_block()(gfc_state_stack->sym), name, &c)) |
| 2354 | return false; |
| 2355 | |
| 2356 | c->ts = current_ts; |
| 2357 | if (c->ts.type == BT_CHARACTER) |
| 2358 | c->ts.u.cl = cl; |
| 2359 | |
| 2360 | if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED |
| 2361 | && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER) |
| 2362 | && saved_kind_expr != NULL__null) |
| 2363 | c->kind_expr = gfc_copy_expr (saved_kind_expr); |
| 2364 | |
| 2365 | c->attr = current_attr; |
| 2366 | |
| 2367 | c->initializer = *init; |
| 2368 | *init = NULL__null; |
| 2369 | |
| 2370 | c->as = *as; |
| 2371 | if (c->as != NULL__null) |
| 2372 | { |
| 2373 | if (c->as->corank) |
| 2374 | c->attr.codimension = 1; |
| 2375 | if (c->as->rank) |
| 2376 | c->attr.dimension = 1; |
| 2377 | } |
| 2378 | *as = NULL__null; |
| 2379 | |
| 2380 | gfc_apply_init (&c->ts, &c->attr, c->initializer); |
| 2381 | |
| 2382 | /* Check array components. */ |
| 2383 | if (!c->attr.dimension) |
| 2384 | goto scalar; |
| 2385 | |
| 2386 | if (c->attr.pointer) |
| 2387 | { |
| 2388 | if (c->as->type != AS_DEFERRED) |
| 2389 | { |
| 2390 | gfc_error ("Pointer array component of structure at %C must have a " |
| 2391 | "deferred shape"); |
| 2392 | return false; |
| 2393 | } |
| 2394 | } |
| 2395 | else if (c->attr.allocatable) |
| 2396 | { |
| 2397 | if (c->as->type != AS_DEFERRED) |
| 2398 | { |
| 2399 | gfc_error ("Allocatable component of structure at %C must have a " |
| 2400 | "deferred shape"); |
| 2401 | return false; |
| 2402 | } |
| 2403 | } |
| 2404 | else |
| 2405 | { |
| 2406 | if (c->as->type != AS_EXPLICIT) |
| 2407 | { |
| 2408 | gfc_error ("Array component of structure at %C must have an " |
| 2409 | "explicit shape"); |
| 2410 | return false; |
| 2411 | } |
| 2412 | } |
| 2413 | |
| 2414 | scalar: |
| 2415 | if (c->ts.type == BT_CLASS) |
| 2416 | return gfc_build_class_symbol (&c->ts, &c->attr, &c->as); |
| 2417 | |
| 2418 | if (c->attr.pdt_kind || c->attr.pdt_len) |
| 2419 | { |
| 2420 | gfc_symbol *sym; |
| 2421 | gfc_find_symbol (c->name, gfc_current_block ()(gfc_state_stack->sym)->f2k_derived, |
| 2422 | 0, &sym); |
| 2423 | if (sym == NULL__null) |
| 2424 | { |
| 2425 | gfc_error ("Type parameter %qs at %C has no corresponding entry " |
| 2426 | "in the type parameter name list at %L", |
| 2427 | c->name, &gfc_current_block ()(gfc_state_stack->sym)->declared_at); |
| 2428 | return false; |
| 2429 | } |
| 2430 | sym->ts = c->ts; |
| 2431 | sym->attr.pdt_kind = c->attr.pdt_kind; |
| 2432 | sym->attr.pdt_len = c->attr.pdt_len; |
| 2433 | if (c->initializer) |
| 2434 | sym->value = gfc_copy_expr (c->initializer); |
| 2435 | sym->attr.flavor = FL_VARIABLE; |
| 2436 | } |
| 2437 | |
| 2438 | if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) |
| 2439 | && c->ts.u.derived && c->ts.u.derived->attr.pdt_template |
| 2440 | && decl_type_param_list) |
| 2441 | c->param_list = gfc_copy_actual_arglist (decl_type_param_list); |
| 2442 | |
| 2443 | return true; |
| 2444 | } |
| 2445 | |
| 2446 | |
| 2447 | /* Match a 'NULL()', and possibly take care of some side effects. */ |
| 2448 | |
| 2449 | match |
| 2450 | gfc_match_null (gfc_expr **result) |
| 2451 | { |
| 2452 | gfc_symbol *sym; |
| 2453 | match m, m2 = MATCH_NO; |
| 2454 | |
| 2455 | if ((m = gfc_match (" null ( )")) == MATCH_ERROR) |
| 2456 | return MATCH_ERROR; |
| 2457 | |
| 2458 | if (m == MATCH_NO) |
| 2459 | { |
| 2460 | locus old_loc; |
| 2461 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 2462 | |
| 2463 | if ((m2 = gfc_match (" null (")) != MATCH_YES) |
| 2464 | return m2; |
| 2465 | |
| 2466 | old_loc = gfc_current_locus; |
| 2467 | if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR) |
| 2468 | return MATCH_ERROR; |
| 2469 | if (m2 != MATCH_YES |
| 2470 | && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR)) |
| 2471 | return MATCH_ERROR; |
| 2472 | if (m2 == MATCH_NO) |
| 2473 | { |
| 2474 | gfc_current_locus = old_loc; |
| 2475 | return MATCH_NO; |
| 2476 | } |
| 2477 | } |
| 2478 | |
| 2479 | /* The NULL symbol now has to be/become an intrinsic function. */ |
| 2480 | if (gfc_get_symbol ("null", NULL__null, &sym)) |
| 2481 | { |
| 2482 | gfc_error ("NULL() initialization at %C is ambiguous"); |
| 2483 | return MATCH_ERROR; |
| 2484 | } |
| 2485 | |
| 2486 | gfc_intrinsic_symbol (sym)sym->module = gfc_get_string ("(intrinsic)"); |
| 2487 | |
| 2488 | if (sym->attr.proc != PROC_INTRINSIC |
| 2489 | && !(sym->attr.use_assoc && sym->attr.intrinsic) |
| 2490 | && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL__null) |
| 2491 | || !gfc_add_function (&sym->attr, sym->name, NULL__null))) |
| 2492 | return MATCH_ERROR; |
| 2493 | |
| 2494 | *result = gfc_get_null_expr (&gfc_current_locus); |
| 2495 | |
| 2496 | /* Invalid per F2008, C512. */ |
| 2497 | if (m2 == MATCH_YES) |
| 2498 | { |
| 2499 | gfc_error ("NULL() initialization at %C may not have MOLD"); |
| 2500 | return MATCH_ERROR; |
| 2501 | } |
| 2502 | |
| 2503 | return MATCH_YES; |
| 2504 | } |
| 2505 | |
| 2506 | |
| 2507 | /* Match the initialization expr for a data pointer or procedure pointer. */ |
| 2508 | |
| 2509 | static match |
| 2510 | match_pointer_init (gfc_expr **init, int procptr) |
| 2511 | { |
| 2512 | match m; |
| 2513 | |
| 2514 | if (gfc_pure (NULL__null) && !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED || (gfc_state_stack ->state) == COMP_STRUCTURE || (gfc_state_stack->state) == COMP_MAP)) |
| 2515 | { |
| 2516 | gfc_error ("Initialization of pointer at %C is not allowed in " |
| 2517 | "a PURE procedure"); |
| 2518 | return MATCH_ERROR; |
| 2519 | } |
| 2520 | gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
| 2521 | |
| 2522 | /* Match NULL() initialization. */ |
| 2523 | m = gfc_match_null (init); |
| 2524 | if (m != MATCH_NO) |
| 2525 | return m; |
| 2526 | |
| 2527 | /* Match non-NULL initialization. */ |
| 2528 | gfc_matching_ptr_assignment = !procptr; |
| 2529 | gfc_matching_procptr_assignment = procptr; |
| 2530 | m = gfc_match_rvalue (init); |
| 2531 | gfc_matching_ptr_assignment = 0; |
| 2532 | gfc_matching_procptr_assignment = 0; |
| 2533 | if (m == MATCH_ERROR) |
| 2534 | return MATCH_ERROR; |
| 2535 | else if (m == MATCH_NO) |
| 2536 | { |
| 2537 | gfc_error ("Error in pointer initialization at %C"); |
| 2538 | return MATCH_ERROR; |
| 2539 | } |
| 2540 | |
| 2541 | if (!procptr && !gfc_resolve_expr (*init)) |
| 2542 | return MATCH_ERROR; |
| 2543 | |
| 2544 | if (!gfc_notify_std (GFC_STD_F2008(1<<7), "non-NULL pointer " |
| 2545 | "initialization at %C")) |
| 2546 | return MATCH_ERROR; |
| 2547 | |
| 2548 | return MATCH_YES; |
| 2549 | } |
| 2550 | |
| 2551 | |
| 2552 | static bool |
| 2553 | check_function_name (char *name) |
| 2554 | { |
| 2555 | /* In functions that have a RESULT variable defined, the function name always |
| 2556 | refers to function calls. Therefore, the name is not allowed to appear in |
| 2557 | specification statements. When checking this, be careful about |
| 2558 | 'hidden' procedure pointer results ('ppr@'). */ |
| 2559 | |
| 2560 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION) |
| 2561 | { |
| 2562 | gfc_symbol *block = gfc_current_block ()(gfc_state_stack->sym); |
| 2563 | if (block && block->result && block->result != block |
| 2564 | && strcmp (block->result->name, "ppr@") != 0 |
| 2565 | && strcmp (block->name, name) == 0) |
| 2566 | { |
| 2567 | gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C " |
| 2568 | "from appearing in a specification statement", |
| 2569 | block->result->name, &block->result->declared_at, name); |
| 2570 | return false; |
| 2571 | } |
| 2572 | } |
| 2573 | |
| 2574 | return true; |
| 2575 | } |
| 2576 | |
| 2577 | |
| 2578 | /* Match a variable name with an optional initializer. When this |
| 2579 | subroutine is called, a variable is expected to be parsed next. |
| 2580 | Depending on what is happening at the moment, updates either the |
| 2581 | symbol table or the current interface. */ |
| 2582 | |
| 2583 | static match |
| 2584 | variable_decl (int elem) |
| 2585 | { |
| 2586 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 2587 | static unsigned int fill_id = 0; |
| 2588 | gfc_expr *initializer, *char_len; |
| 2589 | gfc_array_spec *as; |
| 2590 | gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ |
| 2591 | gfc_charlen *cl; |
| 2592 | bool cl_deferred; |
| 2593 | locus var_locus; |
| 2594 | match m; |
| 2595 | bool t; |
| 2596 | gfc_symbol *sym; |
| 2597 | char c; |
| 2598 | |
| 2599 | initializer = NULL__null; |
| 2600 | as = NULL__null; |
| 2601 | cp_as = NULL__null; |
| 2602 | |
| 2603 | /* When we get here, we've just matched a list of attributes and |
| 2604 | maybe a type and a double colon. The next thing we expect to see |
| 2605 | is the name of the symbol. */ |
| 2606 | |
| 2607 | /* If we are parsing a structure with legacy support, we allow the symbol |
| 2608 | name to be '%FILL' which gives it an anonymous (inaccessible) name. */ |
| 2609 | m = MATCH_NO; |
| 2610 | gfc_gobble_whitespace (); |
| 2611 | c = gfc_peek_ascii_char (); |
| 2612 | if (c == '%') |
| 2613 | { |
| 2614 | gfc_next_ascii_char (); /* Burn % character. */ |
| 2615 | m = gfc_match ("fill"); |
| 2616 | if (m == MATCH_YES) |
| 2617 | { |
| 2618 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_STRUCTURE) |
| 2619 | { |
| 2620 | if (flag_dec_structureglobal_options.x_flag_dec_structure) |
| 2621 | gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL"); |
| 2622 | else |
| 2623 | gfc_error ("%qs at %C is a DEC extension, enable with " |
| 2624 | "%<-fdec-structure%>", "%FILL"); |
| 2625 | m = MATCH_ERROR; |
| 2626 | goto cleanup; |
| 2627 | } |
| 2628 | |
| 2629 | if (attr_seen) |
| 2630 | { |
| 2631 | gfc_error ("%qs entity cannot have attributes at %C", "%FILL"); |
| 2632 | m = MATCH_ERROR; |
| 2633 | goto cleanup; |
| 2634 | } |
| 2635 | |
| 2636 | /* %FILL components are given invalid fortran names. */ |
| 2637 | snprintf (name, GFC_MAX_SYMBOL_LEN63 + 1, "%%FILL%u", fill_id++); |
| 2638 | } |
| 2639 | else |
| 2640 | { |
| 2641 | gfc_error ("Invalid character %qc in variable name at %C", c); |
| 2642 | return MATCH_ERROR; |
| 2643 | } |
| 2644 | } |
| 2645 | else |
| 2646 | { |
| 2647 | m = gfc_match_name (name); |
| 2648 | if (m != MATCH_YES) |
| 2649 | goto cleanup; |
| 2650 | } |
| 2651 | |
| 2652 | var_locus = gfc_current_locus; |
| 2653 | |
| 2654 | /* Now we could see the optional array spec. or character length. */ |
| 2655 | m = gfc_match_array_spec (&as, true, true); |
| 2656 | if (m == MATCH_ERROR) |
| 2657 | goto cleanup; |
| 2658 | |
| 2659 | if (m == MATCH_NO) |
| 2660 | as = gfc_copy_array_spec (current_as); |
| 2661 | else if (current_as |
| 2662 | && !merge_array_spec (current_as, as, true)) |
| 2663 | { |
| 2664 | m = MATCH_ERROR; |
| 2665 | goto cleanup; |
| 2666 | } |
| 2667 | |
| 2668 | if (flag_cray_pointerglobal_options.x_flag_cray_pointer) |
| 2669 | cp_as = gfc_copy_array_spec (as); |
| 2670 | |
| 2671 | /* At this point, we know for sure if the symbol is PARAMETER and can thus |
| 2672 | determine (and check) whether it can be implied-shape. If it |
| 2673 | was parsed as assumed-size, change it because PARAMETERs cannot |
| 2674 | be assumed-size. |
| 2675 | |
| 2676 | An explicit-shape-array cannot appear under several conditions. |
| 2677 | That check is done here as well. */ |
| 2678 | if (as) |
| 2679 | { |
| 2680 | if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER) |
| 2681 | { |
| 2682 | m = MATCH_ERROR; |
| 2683 | gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape", |
| 2684 | name, &var_locus); |
| 2685 | goto cleanup; |
| 2686 | } |
| 2687 | |
| 2688 | if (as->type == AS_ASSUMED_SIZE && as->rank == 1 |
| 2689 | && current_attr.flavor == FL_PARAMETER) |
| 2690 | as->type = AS_IMPLIED_SHAPE; |
| 2691 | |
| 2692 | if (as->type == AS_IMPLIED_SHAPE |
| 2693 | && !gfc_notify_std (GFC_STD_F2008(1<<7), "Implied-shape array at %L", |
| 2694 | &var_locus)) |
| 2695 | { |
| 2696 | m = MATCH_ERROR; |
| 2697 | goto cleanup; |
| 2698 | } |
| 2699 | |
| 2700 | gfc_seen_div0 = false; |
| 2701 | |
| 2702 | /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not |
| 2703 | constant expressions shall appear only in a subprogram, derived |
| 2704 | type definition, BLOCK construct, or interface body. */ |
| 2705 | if (as->type == AS_EXPLICIT |
| 2706 | && gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK |
| 2707 | && gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED |
| 2708 | && gfc_current_state ()(gfc_state_stack->state) != COMP_FUNCTION |
| 2709 | && gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE |
| 2710 | && gfc_current_state ()(gfc_state_stack->state) != COMP_SUBROUTINE) |
| 2711 | { |
| 2712 | gfc_expr *e; |
| 2713 | bool not_constant = false; |
| 2714 | |
| 2715 | for (int i = 0; i < as->rank; i++) |
| 2716 | { |
| 2717 | e = gfc_copy_expr (as->lower[i]); |
| 2718 | if (!gfc_resolve_expr (e) && gfc_seen_div0) |
| 2719 | { |
| 2720 | m = MATCH_ERROR; |
| 2721 | goto cleanup; |
| 2722 | } |
| 2723 | |
| 2724 | gfc_simplify_expr (e, 0); |
| 2725 | if (e && (e->expr_type != EXPR_CONSTANT)) |
| 2726 | { |
| 2727 | not_constant = true; |
| 2728 | break; |
| 2729 | } |
| 2730 | gfc_free_expr (e); |
| 2731 | |
| 2732 | e = gfc_copy_expr (as->upper[i]); |
| 2733 | if (!gfc_resolve_expr (e) && gfc_seen_div0) |
| 2734 | { |
| 2735 | m = MATCH_ERROR; |
| 2736 | goto cleanup; |
| 2737 | } |
| 2738 | |
| 2739 | gfc_simplify_expr (e, 0); |
| 2740 | if (e && (e->expr_type != EXPR_CONSTANT)) |
| 2741 | { |
| 2742 | not_constant = true; |
| 2743 | break; |
| 2744 | } |
| 2745 | gfc_free_expr (e); |
| 2746 | } |
| 2747 | |
| 2748 | if (not_constant && e->ts.type != BT_INTEGER) |
| 2749 | { |
| 2750 | gfc_error ("Explicit array shape at %C must be constant of " |
| 2751 | "INTEGER type and not %s type", |
| 2752 | gfc_basic_typename (e->ts.type)); |
| 2753 | m = MATCH_ERROR; |
| 2754 | goto cleanup; |
| 2755 | } |
| 2756 | if (not_constant) |
| 2757 | { |
| 2758 | gfc_error ("Explicit shaped array with nonconstant bounds at %C"); |
| 2759 | m = MATCH_ERROR; |
| 2760 | goto cleanup; |
| 2761 | } |
| 2762 | } |
| 2763 | if (as->type == AS_EXPLICIT) |
| 2764 | { |
| 2765 | for (int i = 0; i < as->rank; i++) |
| 2766 | { |
| 2767 | gfc_expr *e, *n; |
| 2768 | e = as->lower[i]; |
| 2769 | if (e->expr_type != EXPR_CONSTANT) |
| 2770 | { |
| 2771 | n = gfc_copy_expr (e); |
| 2772 | if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) |
| 2773 | { |
| 2774 | m = MATCH_ERROR; |
| 2775 | goto cleanup; |
| 2776 | } |
| 2777 | |
| 2778 | if (n->expr_type == EXPR_CONSTANT) |
| 2779 | gfc_replace_expr (e, n); |
| 2780 | else |
| 2781 | gfc_free_expr (n); |
| 2782 | } |
| 2783 | e = as->upper[i]; |
| 2784 | if (e->expr_type != EXPR_CONSTANT) |
| 2785 | { |
| 2786 | n = gfc_copy_expr (e); |
| 2787 | if (!gfc_simplify_expr (n, 1) && gfc_seen_div0) |
| 2788 | { |
| 2789 | m = MATCH_ERROR; |
| 2790 | goto cleanup; |
| 2791 | } |
| 2792 | |
| 2793 | if (n->expr_type == EXPR_CONSTANT) |
| 2794 | gfc_replace_expr (e, n); |
| 2795 | else |
| 2796 | gfc_free_expr (n); |
| 2797 | } |
| 2798 | /* For an explicit-shape spec with constant bounds, ensure |
| 2799 | that the effective upper bound is not lower than the |
| 2800 | respective lower bound minus one. Otherwise adjust it so |
| 2801 | that the extent is trivially derived to be zero. */ |
| 2802 | if (as->lower[i]->expr_type == EXPR_CONSTANT |
| 2803 | && as->upper[i]->expr_type == EXPR_CONSTANT |
| 2804 | && as->lower[i]->ts.type == BT_INTEGER |
| 2805 | && as->upper[i]->ts.type == BT_INTEGER |
| 2806 | && mpz_cmp__gmpz_cmp (as->upper[i]->value.integer, |
| 2807 | as->lower[i]->value.integer) < 0) |
| 2808 | mpz_sub_ui__gmpz_sub_ui (as->upper[i]->value.integer, |
| 2809 | as->lower[i]->value.integer, 1); |
| 2810 | } |
| 2811 | } |
| 2812 | } |
| 2813 | |
| 2814 | char_len = NULL__null; |
| 2815 | cl = NULL__null; |
| 2816 | cl_deferred = false; |
| 2817 | |
| 2818 | if (current_ts.type == BT_CHARACTER) |
| 2819 | { |
| 2820 | switch (match_char_length (&char_len, &cl_deferred, false)) |
| 2821 | { |
| 2822 | case MATCH_YES: |
| 2823 | cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 2824 | |
| 2825 | cl->length = char_len; |
| 2826 | break; |
| 2827 | |
| 2828 | /* Non-constant lengths need to be copied after the first |
| 2829 | element. Also copy assumed lengths. */ |
| 2830 | case MATCH_NO: |
| 2831 | if (elem > 1 |
| 2832 | && (current_ts.u.cl->length == NULL__null |
| 2833 | || current_ts.u.cl->length->expr_type != EXPR_CONSTANT)) |
| 2834 | { |
| 2835 | cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 2836 | cl->length = gfc_copy_expr (current_ts.u.cl->length); |
| 2837 | } |
| 2838 | else |
| 2839 | cl = current_ts.u.cl; |
| 2840 | |
| 2841 | cl_deferred = current_ts.deferred; |
| 2842 | |
| 2843 | break; |
| 2844 | |
| 2845 | case MATCH_ERROR: |
| 2846 | goto cleanup; |
| 2847 | } |
| 2848 | } |
| 2849 | |
| 2850 | /* The dummy arguments and result of the abreviated form of MODULE |
| 2851 | PROCEDUREs, used in SUBMODULES should not be redefined. */ |
| 2852 | if (gfc_current_ns->proc_name |
| 2853 | && gfc_current_ns->proc_name->abr_modproc_decl) |
| 2854 | { |
| 2855 | gfc_find_symbol (name, gfc_current_ns, 1, &sym); |
| 2856 | if (sym != NULL__null && (sym->attr.dummy || sym->attr.result)) |
| 2857 | { |
| 2858 | m = MATCH_ERROR; |
| 2859 | gfc_error ("%qs at %C is a redefinition of the declaration " |
| 2860 | "in the corresponding interface for MODULE " |
| 2861 | "PROCEDURE %qs", sym->name, |
| 2862 | gfc_current_ns->proc_name->name); |
| 2863 | goto cleanup; |
| 2864 | } |
| 2865 | } |
| 2866 | |
| 2867 | /* %FILL components may not have initializers. */ |
| 2868 | if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES) |
| 2869 | { |
| 2870 | gfc_error ("%qs entity cannot have an initializer at %C", "%FILL"); |
| 2871 | m = MATCH_ERROR; |
| 2872 | goto cleanup; |
| 2873 | } |
| 2874 | |
| 2875 | /* If this symbol has already shown up in a Cray Pointer declaration, |
| 2876 | and this is not a component declaration, |
| 2877 | then we want to set the type & bail out. */ |
| 2878 | if (flag_cray_pointerglobal_options.x_flag_cray_pointer && !gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 2879 | { |
| 2880 | gfc_find_symbol (name, gfc_current_ns, 0, &sym); |
| 2881 | if (sym != NULL__null && sym->attr.cray_pointee) |
| 2882 | { |
| 2883 | m = MATCH_YES; |
| 2884 | if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus)) |
| 2885 | { |
| 2886 | m = MATCH_ERROR; |
| 2887 | goto cleanup; |
| 2888 | } |
| 2889 | |
| 2890 | /* Check to see if we have an array specification. */ |
| 2891 | if (cp_as != NULL__null) |
| 2892 | { |
| 2893 | if (sym->as != NULL__null) |
| 2894 | { |
| 2895 | gfc_error ("Duplicate array spec for Cray pointee at %C"); |
| 2896 | gfc_free_array_spec (cp_as); |
| 2897 | m = MATCH_ERROR; |
| 2898 | goto cleanup; |
| 2899 | } |
| 2900 | else |
| 2901 | { |
| 2902 | if (!gfc_set_array_spec (sym, cp_as, &var_locus)) |
| 2903 | gfc_internal_error ("Cannot set pointee array spec."); |
| 2904 | |
| 2905 | /* Fix the array spec. */ |
| 2906 | m = gfc_mod_pointee_as (sym->as); |
| 2907 | if (m == MATCH_ERROR) |
| 2908 | goto cleanup; |
| 2909 | } |
| 2910 | } |
| 2911 | goto cleanup; |
| 2912 | } |
| 2913 | else |
| 2914 | { |
| 2915 | gfc_free_array_spec (cp_as); |
| 2916 | } |
| 2917 | } |
| 2918 | |
| 2919 | /* Procedure pointer as function result. */ |
| 2920 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION |
| 2921 | && strcmp ("ppr@", gfc_current_block ()(gfc_state_stack->sym)->name) == 0 |
| 2922 | && strcmp (name, gfc_current_block ()(gfc_state_stack->sym)->ns->proc_name->name) == 0) |
| 2923 | strcpy (name, "ppr@"); |
| 2924 | |
| 2925 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION |
| 2926 | && strcmp (name, gfc_current_block ()(gfc_state_stack->sym)->name) == 0 |
| 2927 | && gfc_current_block ()(gfc_state_stack->sym)->result |
| 2928 | && strcmp ("ppr@", gfc_current_block ()(gfc_state_stack->sym)->result->name) == 0) |
| 2929 | strcpy (name, "ppr@"); |
| 2930 | |
| 2931 | /* OK, we've successfully matched the declaration. Now put the |
| 2932 | symbol in the current namespace, because it might be used in the |
| 2933 | optional initialization expression for this symbol, e.g. this is |
| 2934 | perfectly legal: |
| 2935 | |
| 2936 | integer, parameter :: i = huge(i) |
| 2937 | |
| 2938 | This is only true for parameters or variables of a basic type. |
| 2939 | For components of derived types, it is not true, so we don't |
| 2940 | create a symbol for those yet. If we fail to create the symbol, |
| 2941 | bail out. */ |
| 2942 | if (!gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP) |
| 2943 | && !build_sym (name, cl, cl_deferred, &as, &var_locus)) |
| 2944 | { |
| 2945 | m = MATCH_ERROR; |
| 2946 | goto cleanup; |
| 2947 | } |
| 2948 | |
| 2949 | if (!check_function_name (name)) |
| 2950 | { |
| 2951 | m = MATCH_ERROR; |
| 2952 | goto cleanup; |
| 2953 | } |
| 2954 | |
| 2955 | /* We allow old-style initializations of the form |
| 2956 | integer i /2/, j(4) /3*3, 1/ |
| 2957 | (if no colon has been seen). These are different from data |
| 2958 | statements in that initializers are only allowed to apply to the |
| 2959 | variable immediately preceding, i.e. |
| 2960 | integer i, j /1, 2/ |
| 2961 | is not allowed. Therefore we have to do some work manually, that |
| 2962 | could otherwise be left to the matchers for DATA statements. */ |
| 2963 | |
| 2964 | if (!colon_seen && gfc_match (" /") == MATCH_YES) |
| 2965 | { |
| 2966 | if (!gfc_notify_std (GFC_STD_GNU(1<<5), "Old-style " |
| 2967 | "initialization at %C")) |
| 2968 | return MATCH_ERROR; |
| 2969 | |
| 2970 | /* Allow old style initializations for components of STRUCTUREs and MAPs |
| 2971 | but not components of derived types. */ |
| 2972 | else if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED) |
| 2973 | { |
| 2974 | gfc_error ("Invalid old style initialization for derived type " |
| 2975 | "component at %C"); |
| 2976 | m = MATCH_ERROR; |
| 2977 | goto cleanup; |
| 2978 | } |
| 2979 | |
| 2980 | /* For structure components, read the initializer as a special |
| 2981 | expression and let the rest of this function apply the initializer |
| 2982 | as usual. */ |
| 2983 | else if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 2984 | { |
| 2985 | m = match_clist_expr (&initializer, ¤t_ts, as); |
| 2986 | if (m == MATCH_NO) |
| 2987 | gfc_error ("Syntax error in old style initialization of %s at %C", |
| 2988 | name); |
| 2989 | if (m != MATCH_YES) |
| 2990 | goto cleanup; |
| 2991 | } |
| 2992 | |
| 2993 | /* Otherwise we treat the old style initialization just like a |
| 2994 | DATA declaration for the current variable. */ |
| 2995 | else |
| 2996 | return match_old_style_init (name); |
| 2997 | } |
| 2998 | |
| 2999 | /* The double colon must be present in order to have initializers. |
| 3000 | Otherwise the statement is ambiguous with an assignment statement. */ |
| 3001 | if (colon_seen) |
| 3002 | { |
| 3003 | if (gfc_match (" =>") == MATCH_YES) |
| 3004 | { |
| 3005 | if (!current_attr.pointer) |
| 3006 | { |
| 3007 | gfc_error ("Initialization at %C isn't for a pointer variable"); |
| 3008 | m = MATCH_ERROR; |
| 3009 | goto cleanup; |
| 3010 | } |
| 3011 | |
| 3012 | m = match_pointer_init (&initializer, 0); |
| 3013 | if (m != MATCH_YES) |
| 3014 | goto cleanup; |
| 3015 | |
| 3016 | /* The target of a pointer initialization must have the SAVE |
| 3017 | attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope |
| 3018 | is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */ |
| 3019 | if (initializer->expr_type == EXPR_VARIABLE |
| 3020 | && initializer->symtree->n.sym->attr.save == SAVE_NONE |
| 3021 | && (gfc_current_state ()(gfc_state_stack->state) == COMP_PROGRAM |
| 3022 | || gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE |
| 3023 | || gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE)) |
| 3024 | initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT; |
| 3025 | } |
| 3026 | else if (gfc_match_char ('=') == MATCH_YES) |
| 3027 | { |
| 3028 | if (current_attr.pointer) |
| 3029 | { |
| 3030 | gfc_error ("Pointer initialization at %C requires %<=>%>, " |
| 3031 | "not %<=%>"); |
| 3032 | m = MATCH_ERROR; |
| 3033 | goto cleanup; |
| 3034 | } |
| 3035 | |
| 3036 | m = gfc_match_init_expr (&initializer); |
| 3037 | if (m == MATCH_NO) |
| 3038 | { |
| 3039 | gfc_error ("Expected an initialization expression at %C"); |
| 3040 | m = MATCH_ERROR; |
| 3041 | } |
| 3042 | |
| 3043 | if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL__null) |
| 3044 | && !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED || (gfc_state_stack ->state) == COMP_STRUCTURE || (gfc_state_stack->state) == COMP_MAP)) |
| 3045 | { |
| 3046 | gfc_error ("Initialization of variable at %C is not allowed in " |
| 3047 | "a PURE procedure"); |
| 3048 | m = MATCH_ERROR; |
| 3049 | } |
| 3050 | |
| 3051 | if (current_attr.flavor != FL_PARAMETER |
| 3052 | && !gfc_comp_struct (gfc_state_stack->state)((gfc_state_stack->state) == COMP_DERIVED || (gfc_state_stack ->state) == COMP_STRUCTURE || (gfc_state_stack->state) == COMP_MAP)) |
| 3053 | gfc_unset_implicit_pure (gfc_current_ns->proc_name); |
| 3054 | |
| 3055 | if (m != MATCH_YES) |
| 3056 | goto cleanup; |
| 3057 | } |
| 3058 | } |
| 3059 | |
| 3060 | if (initializer != NULL__null && current_attr.allocatable |
| 3061 | && gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 3062 | { |
| 3063 | gfc_error ("Initialization of allocatable component at %C is not " |
| 3064 | "allowed"); |
| 3065 | m = MATCH_ERROR; |
| 3066 | goto cleanup; |
| 3067 | } |
| 3068 | |
| 3069 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED |
| 3070 | && initializer && initializer->ts.type == BT_HOLLERITH) |
| 3071 | { |
| 3072 | gfc_error ("Initialization of structure component with a HOLLERITH " |
| 3073 | "constant at %L is not allowed", &initializer->where); |
| 3074 | m = MATCH_ERROR; |
| 3075 | goto cleanup; |
| 3076 | } |
| 3077 | |
| 3078 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED |
| 3079 | && gfc_current_block ()(gfc_state_stack->sym)->attr.pdt_template) |
| 3080 | { |
| 3081 | gfc_symbol *param; |
| 3082 | gfc_find_symbol (name, gfc_current_block ()(gfc_state_stack->sym)->f2k_derived, |
| 3083 | 0, ¶m); |
| 3084 | if (!param && (current_attr.pdt_kind || current_attr.pdt_len)) |
| 3085 | { |
| 3086 | gfc_error ("The component with KIND or LEN attribute at %C does not " |
| 3087 | "not appear in the type parameter list at %L", |
| 3088 | &gfc_current_block ()(gfc_state_stack->sym)->declared_at); |
| 3089 | m = MATCH_ERROR; |
| 3090 | goto cleanup; |
| 3091 | } |
| 3092 | else if (param && !(current_attr.pdt_kind || current_attr.pdt_len)) |
| 3093 | { |
| 3094 | gfc_error ("The component at %C that appears in the type parameter " |
| 3095 | "list at %L has neither the KIND nor LEN attribute", |
| 3096 | &gfc_current_block ()(gfc_state_stack->sym)->declared_at); |
| 3097 | m = MATCH_ERROR; |
| 3098 | goto cleanup; |
| 3099 | } |
| 3100 | else if (as && (current_attr.pdt_kind || current_attr.pdt_len)) |
| 3101 | { |
| 3102 | gfc_error ("The component at %C which is a type parameter must be " |
| 3103 | "a scalar"); |
| 3104 | m = MATCH_ERROR; |
| 3105 | goto cleanup; |
| 3106 | } |
| 3107 | else if (param && initializer) |
| 3108 | { |
| 3109 | if (initializer->ts.type == BT_BOZ) |
| 3110 | { |
| 3111 | gfc_error ("BOZ literal constant at %L cannot appear as an " |
| 3112 | "initializer", &initializer->where); |
| 3113 | m = MATCH_ERROR; |
| 3114 | goto cleanup; |
| 3115 | } |
| 3116 | param->value = gfc_copy_expr (initializer); |
| 3117 | } |
| 3118 | } |
| 3119 | |
| 3120 | /* Before adding a possible initilizer, do a simple check for compatibility |
| 3121 | of lhs and rhs types. Assigning a REAL value to a derived type is not a |
| 3122 | good thing. */ |
| 3123 | if (current_ts.type == BT_DERIVED && initializer |
| 3124 | && (gfc_numeric_ts (&initializer->ts) |
| 3125 | || initializer->ts.type == BT_LOGICAL |
| 3126 | || initializer->ts.type == BT_CHARACTER)) |
| 3127 | { |
| 3128 | gfc_error ("Incompatible initialization between a derived type " |
| 3129 | "entity and an entity with %qs type at %C", |
| 3130 | gfc_typename (initializer)); |
| 3131 | m = MATCH_ERROR; |
| 3132 | goto cleanup; |
| 3133 | } |
| 3134 | |
| 3135 | |
| 3136 | /* Add the initializer. Note that it is fine if initializer is |
| 3137 | NULL here, because we sometimes also need to check if a |
| 3138 | declaration *must* have an initialization expression. */ |
| 3139 | if (!gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 3140 | t = add_init_expr_to_sym (name, &initializer, &var_locus); |
| 3141 | else |
| 3142 | { |
| 3143 | if (current_ts.type == BT_DERIVED |
| 3144 | && !current_attr.pointer && !initializer) |
| 3145 | initializer = gfc_default_initializer (¤t_ts); |
| 3146 | t = build_struct (name, cl, &initializer, &as); |
| 3147 | |
| 3148 | /* If we match a nested structure definition we expect to see the |
| 3149 | * body even if the variable declarations blow up, so we need to keep |
| 3150 | * the structure declaration around. */ |
| 3151 | if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT) |
| 3152 | gfc_commit_symbol (gfc_new_block); |
| 3153 | } |
| 3154 | |
| 3155 | m = (t) ? MATCH_YES : MATCH_ERROR; |
| 3156 | |
| 3157 | cleanup: |
| 3158 | /* Free stuff up and return. */ |
| 3159 | gfc_seen_div0 = false; |
| 3160 | gfc_free_expr (initializer); |
| 3161 | gfc_free_array_spec (as); |
| 3162 | |
| 3163 | return m; |
| 3164 | } |
| 3165 | |
| 3166 | |
| 3167 | /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification. |
| 3168 | This assumes that the byte size is equal to the kind number for |
| 3169 | non-COMPLEX types, and equal to twice the kind number for COMPLEX. */ |
| 3170 | |
| 3171 | static match |
| 3172 | gfc_match_old_kind_spec (gfc_typespec *ts) |
| 3173 | { |
| 3174 | match m; |
| 3175 | int original_kind; |
| 3176 | |
| 3177 | if (gfc_match_char ('*') != MATCH_YES) |
| 3178 | return MATCH_NO; |
| 3179 | |
| 3180 | m = gfc_match_small_literal_int (&ts->kind, NULL__null); |
| 3181 | if (m != MATCH_YES) |
| 3182 | return MATCH_ERROR; |
| 3183 | |
| 3184 | original_kind = ts->kind; |
| 3185 | |
| 3186 | /* Massage the kind numbers for complex types. */ |
| 3187 | if (ts->type == BT_COMPLEX) |
| 3188 | { |
| 3189 | if (ts->kind % 2) |
| 3190 | { |
| 3191 | gfc_error ("Old-style type declaration %s*%d not supported at %C", |
| 3192 | gfc_basic_typename (ts->type), original_kind); |
| 3193 | return MATCH_ERROR; |
| 3194 | } |
| 3195 | ts->kind /= 2; |
| 3196 | |
| 3197 | } |
| 3198 | |
| 3199 | if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kindglobal_options.x_flag_integer4_kind == 8) |
| 3200 | ts->kind = 8; |
| 3201 | |
| 3202 | if (ts->type == BT_REAL || ts->type == BT_COMPLEX) |
| 3203 | { |
| 3204 | if (ts->kind == 4) |
| 3205 | { |
| 3206 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 8) |
| 3207 | ts->kind = 8; |
| 3208 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 10) |
| 3209 | ts->kind = 10; |
| 3210 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 16) |
| 3211 | ts->kind = 16; |
| 3212 | } |
| 3213 | else if (ts->kind == 8) |
| 3214 | { |
| 3215 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 4) |
| 3216 | ts->kind = 4; |
| 3217 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 10) |
| 3218 | ts->kind = 10; |
| 3219 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 16) |
| 3220 | ts->kind = 16; |
| 3221 | } |
| 3222 | } |
| 3223 | |
| 3224 | if (gfc_validate_kind (ts->type, ts->kind, true) < 0) |
| 3225 | { |
| 3226 | gfc_error ("Old-style type declaration %s*%d not supported at %C", |
| 3227 | gfc_basic_typename (ts->type), original_kind); |
| 3228 | return MATCH_ERROR; |
| 3229 | } |
| 3230 | |
| 3231 | if (!gfc_notify_std (GFC_STD_GNU(1<<5), |
| 3232 | "Nonstandard type declaration %s*%d at %C", |
| 3233 | gfc_basic_typename(ts->type), original_kind)) |
| 3234 | return MATCH_ERROR; |
| 3235 | |
| 3236 | return MATCH_YES; |
| 3237 | } |
| 3238 | |
| 3239 | |
| 3240 | /* Match a kind specification. Since kinds are generally optional, we |
| 3241 | usually return MATCH_NO if something goes wrong. If a "kind=" |
| 3242 | string is found, then we know we have an error. */ |
| 3243 | |
| 3244 | match |
| 3245 | gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only) |
| 3246 | { |
| 3247 | locus where, loc; |
| 3248 | gfc_expr *e; |
| 3249 | match m, n; |
| 3250 | char c; |
| 3251 | |
| 3252 | m = MATCH_NO; |
| 3253 | n = MATCH_YES; |
| 3254 | e = NULL__null; |
| 3255 | saved_kind_expr = NULL__null; |
| 3256 | |
| 3257 | where = loc = gfc_current_locus; |
| 3258 | |
| 3259 | if (kind_expr_only) |
| 3260 | goto kind_expr; |
| 3261 | |
| 3262 | if (gfc_match_char ('(') == MATCH_NO) |
| 3263 | return MATCH_NO; |
| 3264 | |
| 3265 | /* Also gobbles optional text. */ |
| 3266 | if (gfc_match (" kind = ") == MATCH_YES) |
| 3267 | m = MATCH_ERROR; |
| 3268 | |
| 3269 | loc = gfc_current_locus; |
| 3270 | |
| 3271 | kind_expr: |
| 3272 | |
| 3273 | n = gfc_match_init_expr (&e); |
| 3274 | |
| 3275 | if (gfc_derived_parameter_expr (e)) |
| 3276 | { |
| 3277 | ts->kind = 0; |
| 3278 | saved_kind_expr = gfc_copy_expr (e); |
| 3279 | goto close_brackets; |
| 3280 | } |
| 3281 | |
| 3282 | if (n != MATCH_YES) |
| 3283 | { |
| 3284 | if (gfc_matching_function) |
| 3285 | { |
| 3286 | /* The function kind expression might include use associated or |
| 3287 | imported parameters and try again after the specification |
| 3288 | expressions..... */ |
| 3289 | if (gfc_match_char (')') != MATCH_YES) |
| 3290 | { |
| 3291 | gfc_error ("Missing right parenthesis at %C"); |
| 3292 | m = MATCH_ERROR; |
| 3293 | goto no_match; |
| 3294 | } |
| 3295 | |
| 3296 | gfc_free_expr (e); |
| 3297 | gfc_undo_symbols (); |
| 3298 | return MATCH_YES; |
| 3299 | } |
| 3300 | else |
| 3301 | { |
| 3302 | /* ....or else, the match is real. */ |
| 3303 | if (n == MATCH_NO) |
| 3304 | gfc_error ("Expected initialization expression at %C"); |
| 3305 | if (n != MATCH_YES) |
| 3306 | return MATCH_ERROR; |
| 3307 | } |
| 3308 | } |
| 3309 | |
| 3310 | if (e->rank != 0) |
| 3311 | { |
| 3312 | gfc_error ("Expected scalar initialization expression at %C"); |
| 3313 | m = MATCH_ERROR; |
| 3314 | goto no_match; |
| 3315 | } |
| 3316 | |
| 3317 | if (gfc_extract_int (e, &ts->kind, 1)) |
| 3318 | { |
| 3319 | m = MATCH_ERROR; |
| 3320 | goto no_match; |
| 3321 | } |
| 3322 | |
| 3323 | /* Before throwing away the expression, let's see if we had a |
| 3324 | C interoperable kind (and store the fact). */ |
| 3325 | if (e->ts.is_c_interop == 1) |
| 3326 | { |
| 3327 | /* Mark this as C interoperable if being declared with one |
| 3328 | of the named constants from iso_c_binding. */ |
| 3329 | ts->is_c_interop = e->ts.is_iso_c; |
| 3330 | ts->f90_type = e->ts.f90_type; |
| 3331 | if (e->symtree) |
| 3332 | ts->interop_kind = e->symtree->n.sym; |
| 3333 | } |
| 3334 | |
| 3335 | gfc_free_expr (e); |
| 3336 | e = NULL__null; |
| 3337 | |
| 3338 | /* Ignore errors to this point, if we've gotten here. This means |
| 3339 | we ignore the m=MATCH_ERROR from above. */ |
| 3340 | if (gfc_validate_kind (ts->type, ts->kind, true) < 0) |
| 3341 | { |
| 3342 | gfc_error ("Kind %d not supported for type %s at %C", ts->kind, |
| 3343 | gfc_basic_typename (ts->type)); |
| 3344 | gfc_current_locus = where; |
| 3345 | return MATCH_ERROR; |
| 3346 | } |
| 3347 | |
| 3348 | /* Warn if, e.g., c_int is used for a REAL variable, but not |
| 3349 | if, e.g., c_double is used for COMPLEX as the standard |
| 3350 | explicitly says that the kind type parameter for complex and real |
| 3351 | variable is the same, i.e. c_float == c_float_complex. */ |
| 3352 | if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type |
| 3353 | && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX) |
| 3354 | || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL))) |
| 3355 | gfc_warning_now (0, "C kind type parameter is for type %s but type at %L " |
| 3356 | "is %s", gfc_basic_typename (ts->f90_type), &where, |
| 3357 | gfc_basic_typename (ts->type)); |
| 3358 | |
| 3359 | close_brackets: |
| 3360 | |
| 3361 | gfc_gobble_whitespace (); |
| 3362 | if ((c = gfc_next_ascii_char ()) != ')' |
| 3363 | && (ts->type != BT_CHARACTER || c != ',')) |
| 3364 | { |
| 3365 | if (ts->type == BT_CHARACTER) |
| 3366 | gfc_error ("Missing right parenthesis or comma at %C"); |
| 3367 | else |
| 3368 | gfc_error ("Missing right parenthesis at %C"); |
| 3369 | m = MATCH_ERROR; |
| 3370 | } |
| 3371 | else |
| 3372 | /* All tests passed. */ |
| 3373 | m = MATCH_YES; |
| 3374 | |
| 3375 | if(m == MATCH_ERROR) |
| 3376 | gfc_current_locus = where; |
| 3377 | |
| 3378 | if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kindglobal_options.x_flag_integer4_kind == 8) |
| 3379 | ts->kind = 8; |
| 3380 | |
| 3381 | if (ts->type == BT_REAL || ts->type == BT_COMPLEX) |
| 3382 | { |
| 3383 | if (ts->kind == 4) |
| 3384 | { |
| 3385 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 8) |
| 3386 | ts->kind = 8; |
| 3387 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 10) |
| 3388 | ts->kind = 10; |
| 3389 | if (flag_real4_kindglobal_options.x_flag_real4_kind == 16) |
| 3390 | ts->kind = 16; |
| 3391 | } |
| 3392 | else if (ts->kind == 8) |
| 3393 | { |
| 3394 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 4) |
| 3395 | ts->kind = 4; |
| 3396 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 10) |
| 3397 | ts->kind = 10; |
| 3398 | if (flag_real8_kindglobal_options.x_flag_real8_kind == 16) |
| 3399 | ts->kind = 16; |
| 3400 | } |
| 3401 | } |
| 3402 | |
| 3403 | /* Return what we know from the test(s). */ |
| 3404 | return m; |
| 3405 | |
| 3406 | no_match: |
| 3407 | gfc_free_expr (e); |
| 3408 | gfc_current_locus = where; |
| 3409 | return m; |
| 3410 | } |
| 3411 | |
| 3412 | |
| 3413 | static match |
| 3414 | match_char_kind (int * kind, int * is_iso_c) |
| 3415 | { |
| 3416 | locus where; |
| 3417 | gfc_expr *e; |
| 3418 | match m, n; |
| 3419 | bool fail; |
| 3420 | |
| 3421 | m = MATCH_NO; |
| 3422 | e = NULL__null; |
| 3423 | where = gfc_current_locus; |
| 3424 | |
| 3425 | n = gfc_match_init_expr (&e); |
| 3426 | |
| 3427 | if (n != MATCH_YES && gfc_matching_function) |
| 3428 | { |
| 3429 | /* The expression might include use-associated or imported |
| 3430 | parameters and try again after the specification |
| 3431 | expressions. */ |
| 3432 | gfc_free_expr (e); |
| 3433 | gfc_undo_symbols (); |
| 3434 | return MATCH_YES; |
| 3435 | } |
| 3436 | |
| 3437 | if (n == MATCH_NO) |
| 3438 | gfc_error ("Expected initialization expression at %C"); |
| 3439 | if (n != MATCH_YES) |
| 3440 | return MATCH_ERROR; |
| 3441 | |
| 3442 | if (e->rank != 0) |
| 3443 | { |
| 3444 | gfc_error ("Expected scalar initialization expression at %C"); |
| 3445 | m = MATCH_ERROR; |
| 3446 | goto no_match; |
| 3447 | } |
| 3448 | |
| 3449 | if (gfc_derived_parameter_expr (e)) |
| 3450 | { |
| 3451 | saved_kind_expr = e; |
| 3452 | *kind = 0; |
| 3453 | return MATCH_YES; |
| 3454 | } |
| 3455 | |
| 3456 | fail = gfc_extract_int (e, kind, 1); |
| 3457 | *is_iso_c = e->ts.is_iso_c; |
| 3458 | if (fail) |
| 3459 | { |
| 3460 | m = MATCH_ERROR; |
| 3461 | goto no_match; |
| 3462 | } |
| 3463 | |
| 3464 | gfc_free_expr (e); |
| 3465 | |
| 3466 | /* Ignore errors to this point, if we've gotten here. This means |
| 3467 | we ignore the m=MATCH_ERROR from above. */ |
| 3468 | if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0) |
| 3469 | { |
| 3470 | gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind); |
| 3471 | m = MATCH_ERROR; |
| 3472 | } |
| 3473 | else |
| 3474 | /* All tests passed. */ |
| 3475 | m = MATCH_YES; |
| 3476 | |
| 3477 | if (m == MATCH_ERROR) |
| 3478 | gfc_current_locus = where; |
| 3479 | |
| 3480 | /* Return what we know from the test(s). */ |
| 3481 | return m; |
| 3482 | |
| 3483 | no_match: |
| 3484 | gfc_free_expr (e); |
| 3485 | gfc_current_locus = where; |
| 3486 | return m; |
| 3487 | } |
| 3488 | |
| 3489 | |
| 3490 | /* Match the various kind/length specifications in a CHARACTER |
| 3491 | declaration. We don't return MATCH_NO. */ |
| 3492 | |
| 3493 | match |
| 3494 | gfc_match_char_spec (gfc_typespec *ts) |
| 3495 | { |
| 3496 | int kind, seen_length, is_iso_c; |
| 3497 | gfc_charlen *cl; |
| 3498 | gfc_expr *len; |
| 3499 | match m; |
| 3500 | bool deferred; |
| 3501 | |
| 3502 | len = NULL__null; |
| 3503 | seen_length = 0; |
| 3504 | kind = 0; |
| 3505 | is_iso_c = 0; |
| 3506 | deferred = false; |
| 3507 | |
| 3508 | /* Try the old-style specification first. */ |
| 3509 | old_char_selector = 0; |
| 3510 | |
| 3511 | m = match_char_length (&len, &deferred, true); |
| 3512 | if (m != MATCH_NO) |
| 3513 | { |
| 3514 | if (m == MATCH_YES) |
| 3515 | old_char_selector = 1; |
| 3516 | seen_length = 1; |
| 3517 | goto done; |
| 3518 | } |
| 3519 | |
| 3520 | m = gfc_match_char ('('); |
| 3521 | if (m != MATCH_YES) |
| 3522 | { |
| 3523 | m = MATCH_YES; /* Character without length is a single char. */ |
| 3524 | goto done; |
| 3525 | } |
| 3526 | |
| 3527 | /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */ |
| 3528 | if (gfc_match (" kind =") == MATCH_YES) |
| 3529 | { |
| 3530 | m = match_char_kind (&kind, &is_iso_c); |
| 3531 | |
| 3532 | if (m == MATCH_ERROR) |
| 3533 | goto done; |
| 3534 | if (m == MATCH_NO) |
| 3535 | goto syntax; |
| 3536 | |
| 3537 | if (gfc_match (" , len =") == MATCH_NO) |
| 3538 | goto rparen; |
| 3539 | |
| 3540 | m = char_len_param_value (&len, &deferred); |
| 3541 | if (m == MATCH_NO) |
| 3542 | goto syntax; |
| 3543 | if (m == MATCH_ERROR) |
| 3544 | goto done; |
| 3545 | seen_length = 1; |
| 3546 | |
| 3547 | goto rparen; |
| 3548 | } |
| 3549 | |
| 3550 | /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */ |
| 3551 | if (gfc_match (" len =") == MATCH_YES) |
| 3552 | { |
| 3553 | m = char_len_param_value (&len, &deferred); |
| 3554 | if (m == MATCH_NO) |
| 3555 | goto syntax; |
| 3556 | if (m == MATCH_ERROR) |
| 3557 | goto done; |
| 3558 | seen_length = 1; |
| 3559 | |
| 3560 | if (gfc_match_char (')') == MATCH_YES) |
| 3561 | goto done; |
| 3562 | |
| 3563 | if (gfc_match (" , kind =") != MATCH_YES) |
| 3564 | goto syntax; |
| 3565 | |
| 3566 | if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR) |
| 3567 | goto done; |
| 3568 | |
| 3569 | goto rparen; |
| 3570 | } |
| 3571 | |
| 3572 | /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */ |
| 3573 | m = char_len_param_value (&len, &deferred); |
| 3574 | if (m == MATCH_NO) |
| 3575 | goto syntax; |
| 3576 | if (m == MATCH_ERROR) |
| 3577 | goto done; |
| 3578 | seen_length = 1; |
| 3579 | |
| 3580 | m = gfc_match_char (')'); |
| 3581 | if (m == MATCH_YES) |
| 3582 | goto done; |
| 3583 | |
| 3584 | if (gfc_match_char (',') != MATCH_YES) |
| 3585 | goto syntax; |
| 3586 | |
| 3587 | gfc_match (" kind ="); /* Gobble optional text. */ |
| 3588 | |
| 3589 | m = match_char_kind (&kind, &is_iso_c); |
| 3590 | if (m == MATCH_ERROR) |
| 3591 | goto done; |
| 3592 | if (m == MATCH_NO) |
| 3593 | goto syntax; |
| 3594 | |
| 3595 | rparen: |
| 3596 | /* Require a right-paren at this point. */ |
| 3597 | m = gfc_match_char (')'); |
| 3598 | if (m == MATCH_YES) |
| 3599 | goto done; |
| 3600 | |
| 3601 | syntax: |
| 3602 | gfc_error ("Syntax error in CHARACTER declaration at %C"); |
| 3603 | m = MATCH_ERROR; |
| 3604 | gfc_free_expr (len); |
| 3605 | return m; |
| 3606 | |
| 3607 | done: |
| 3608 | /* Deal with character functions after USE and IMPORT statements. */ |
| 3609 | if (gfc_matching_function) |
| 3610 | { |
| 3611 | gfc_free_expr (len); |
| 3612 | gfc_undo_symbols (); |
| 3613 | return MATCH_YES; |
| 3614 | } |
| 3615 | |
| 3616 | if (m != MATCH_YES) |
| 3617 | { |
| 3618 | gfc_free_expr (len); |
| 3619 | return m; |
| 3620 | } |
| 3621 | |
| 3622 | /* Do some final massaging of the length values. */ |
| 3623 | cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 3624 | |
| 3625 | if (seen_length == 0) |
| 3626 | cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL__null, 1); |
| 3627 | else |
| 3628 | { |
| 3629 | /* If gfortran ends up here, then len may be reducible to a constant. |
| 3630 | Try to do that here. If it does not reduce, simply assign len to |
| 3631 | charlen. A complication occurs with user-defined generic functions, |
| 3632 | which are not resolved. Use a private namespace to deal with |
| 3633 | generic functions. */ |
| 3634 | |
| 3635 | if (len && len->expr_type != EXPR_CONSTANT) |
| 3636 | { |
| 3637 | gfc_namespace *old_ns; |
| 3638 | gfc_expr *e; |
| 3639 | |
| 3640 | old_ns = gfc_current_ns; |
| 3641 | gfc_current_ns = gfc_get_namespace (NULL__null, 0); |
| 3642 | |
| 3643 | e = gfc_copy_expr (len); |
| 3644 | gfc_push_suppress_errors (); |
| 3645 | gfc_reduce_init_expr (e); |
| 3646 | gfc_pop_suppress_errors (); |
| 3647 | if (e->expr_type == EXPR_CONSTANT) |
| 3648 | { |
| 3649 | gfc_replace_expr (len, e); |
| 3650 | if (mpz_cmp_si (len->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (0))) && ((static_cast<unsigned long> (0))) == 0 ? ( (len->value.integer)->_mp_size < 0 ? -1 : (len->value .integer)->_mp_size > 0) : __gmpz_cmp_ui (len->value .integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (len->value.integer,0)) < 0) |
| 3651 | mpz_set_ui__gmpz_set_ui (len->value.integer, 0); |
| 3652 | } |
| 3653 | else |
| 3654 | gfc_free_expr (e); |
| 3655 | |
| 3656 | gfc_free_namespace (gfc_current_ns); |
| 3657 | gfc_current_ns = old_ns; |
| 3658 | } |
| 3659 | |
| 3660 | cl->length = len; |
| 3661 | } |
| 3662 | |
| 3663 | ts->u.cl = cl; |
| 3664 | ts->kind = kind == 0 ? gfc_default_character_kind : kind; |
| 3665 | ts->deferred = deferred; |
| 3666 | |
| 3667 | /* We have to know if it was a C interoperable kind so we can |
| 3668 | do accurate type checking of bind(c) procs, etc. */ |
| 3669 | if (kind != 0) |
| 3670 | /* Mark this as C interoperable if being declared with one |
| 3671 | of the named constants from iso_c_binding. */ |
| 3672 | ts->is_c_interop = is_iso_c; |
| 3673 | else if (len != NULL__null) |
| 3674 | /* Here, we might have parsed something such as: character(c_char) |
| 3675 | In this case, the parsing code above grabs the c_char when |
| 3676 | looking for the length (line 1690, roughly). it's the last |
| 3677 | testcase for parsing the kind params of a character variable. |
| 3678 | However, it's not actually the length. this seems like it |
| 3679 | could be an error. |
| 3680 | To see if the user used a C interop kind, test the expr |
| 3681 | of the so called length, and see if it's C interoperable. */ |
| 3682 | ts->is_c_interop = len->ts.is_iso_c; |
| 3683 | |
| 3684 | return MATCH_YES; |
| 3685 | } |
| 3686 | |
| 3687 | |
| 3688 | /* Matches a RECORD declaration. */ |
| 3689 | |
| 3690 | static match |
| 3691 | match_record_decl (char *name) |
| 3692 | { |
| 3693 | locus old_loc; |
| 3694 | old_loc = gfc_current_locus; |
| 3695 | match m; |
| 3696 | |
| 3697 | m = gfc_match (" record /"); |
| 3698 | if (m == MATCH_YES) |
| 3699 | { |
| 3700 | if (!flag_dec_structureglobal_options.x_flag_dec_structure) |
| 3701 | { |
| 3702 | gfc_current_locus = old_loc; |
| 3703 | gfc_error ("RECORD at %C is an extension, enable it with " |
| 3704 | "%<-fdec-structure%>"); |
| 3705 | return MATCH_ERROR; |
| 3706 | } |
| 3707 | m = gfc_match (" %n/", name); |
| 3708 | if (m == MATCH_YES) |
| 3709 | return MATCH_YES; |
| 3710 | } |
| 3711 | |
| 3712 | gfc_current_locus = old_loc; |
| 3713 | if (flag_dec_structureglobal_options.x_flag_dec_structure |
| 3714 | && (gfc_match (" record% ") == MATCH_YES |
| 3715 | || gfc_match (" record%t") == MATCH_YES)) |
| 3716 | gfc_error ("Structure name expected after RECORD at %C"); |
| 3717 | if (m == MATCH_NO) |
| 3718 | return MATCH_NO; |
| 3719 | |
| 3720 | return MATCH_ERROR; |
| 3721 | } |
| 3722 | |
| 3723 | |
| 3724 | /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source |
| 3725 | of expressions to substitute into the possibly parameterized expression |
| 3726 | 'e'. Using a list is inefficient but should not be too bad since the |
| 3727 | number of type parameters is not likely to be large. */ |
| 3728 | static bool |
| 3729 | insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED__attribute__ ((__unused__)), |
| 3730 | int* f) |
| 3731 | { |
| 3732 | gfc_actual_arglist *param; |
| 3733 | gfc_expr *copy; |
| 3734 | |
| 3735 | if (e->expr_type != EXPR_VARIABLE) |
| 3736 | return false; |
| 3737 | |
| 3738 | gcc_assert (e->symtree)((void)(!(e->symtree) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 3738, __FUNCTION__), 0 : 0)); |
| 3739 | if (e->symtree->n.sym->attr.pdt_kind |
| 3740 | || (*f != 0 && e->symtree->n.sym->attr.pdt_len)) |
| 3741 | { |
| 3742 | for (param = type_param_spec_list; param; param = param->next) |
| 3743 | if (strcmp (e->symtree->n.sym->name, param->name) == 0) |
| 3744 | break; |
| 3745 | |
| 3746 | if (param) |
| 3747 | { |
| 3748 | copy = gfc_copy_expr (param->expr); |
| 3749 | *e = *copy; |
| 3750 | free (copy); |
| 3751 | } |
| 3752 | } |
| 3753 | |
| 3754 | return false; |
| 3755 | } |
| 3756 | |
| 3757 | |
| 3758 | static bool |
| 3759 | gfc_insert_kind_parameter_exprs (gfc_expr *e) |
| 3760 | { |
| 3761 | return gfc_traverse_expr (e, NULL__null, &insert_parameter_exprs, 0); |
| 3762 | } |
| 3763 | |
| 3764 | |
| 3765 | bool |
| 3766 | gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list) |
| 3767 | { |
| 3768 | gfc_actual_arglist *old_param_spec_list = type_param_spec_list; |
| 3769 | type_param_spec_list = param_list; |
| 3770 | bool res = gfc_traverse_expr (e, NULL__null, &insert_parameter_exprs, 1); |
| 3771 | type_param_spec_list = old_param_spec_list; |
| 3772 | return res; |
| 3773 | } |
| 3774 | |
| 3775 | /* Determines the instance of a parameterized derived type to be used by |
| 3776 | matching determining the values of the kind parameters and using them |
| 3777 | in the name of the instance. If the instance exists, it is used, otherwise |
| 3778 | a new derived type is created. */ |
| 3779 | match |
| 3780 | gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, |
| 3781 | gfc_actual_arglist **ext_param_list) |
| 3782 | { |
| 3783 | /* The PDT template symbol. */ |
| 3784 | gfc_symbol *pdt = *sym; |
| 3785 | /* The symbol for the parameter in the template f2k_namespace. */ |
| 3786 | gfc_symbol *param; |
| 3787 | /* The hoped for instance of the PDT. */ |
| 3788 | gfc_symbol *instance; |
| 3789 | /* The list of parameters appearing in the PDT declaration. */ |
| 3790 | gfc_formal_arglist *type_param_name_list; |
| 3791 | /* Used to store the parameter specification list during recursive calls. */ |
| 3792 | gfc_actual_arglist *old_param_spec_list; |
| 3793 | /* Pointers to the parameter specification being used. */ |
| 3794 | gfc_actual_arglist *actual_param; |
| 3795 | gfc_actual_arglist *tail = NULL__null; |
| 3796 | /* Used to build up the name of the PDT instance. The prefix uses 4 |
| 3797 | characters and each KIND parameter 2 more. Allow 8 of the latter. */ |
| 3798 | char name[GFC_MAX_SYMBOL_LEN63 + 21]; |
| 3799 | |
| 3800 | bool name_seen = (param_list == NULL__null); |
| 3801 | bool assumed_seen = false; |
| 3802 | bool deferred_seen = false; |
| 3803 | bool spec_error = false; |
| 3804 | int kind_value, i; |
| 3805 | gfc_expr *kind_expr; |
| 3806 | gfc_component *c1, *c2; |
| 3807 | match m; |
| 3808 | |
| 3809 | type_param_spec_list = NULL__null; |
| 3810 | |
| 3811 | type_param_name_list = pdt->formal; |
| 3812 | actual_param = param_list; |
| 3813 | sprintf (name, "Pdt%s", pdt->name); |
| 3814 | |
| 3815 | /* Run through the parameter name list and pick up the actual |
| 3816 | parameter values or use the default values in the PDT declaration. */ |
| 3817 | for (; type_param_name_list; |
| 3818 | type_param_name_list = type_param_name_list->next) |
| 3819 | { |
| 3820 | if (actual_param && actual_param->spec_type != SPEC_EXPLICIT) |
| 3821 | { |
| 3822 | if (actual_param->spec_type == SPEC_ASSUMED) |
| 3823 | spec_error = deferred_seen; |
| 3824 | else |
| 3825 | spec_error = assumed_seen; |
| 3826 | |
| 3827 | if (spec_error) |
| 3828 | { |
| 3829 | gfc_error ("The type parameter spec list at %C cannot contain " |
| 3830 | "both ASSUMED and DEFERRED parameters"); |
| 3831 | goto error_return; |
| 3832 | } |
| 3833 | } |
| 3834 | |
| 3835 | if (actual_param && actual_param->name) |
| 3836 | name_seen = true; |
| 3837 | param = type_param_name_list->sym; |
| 3838 | |
| 3839 | if (!param || !param->name) |
| 3840 | continue; |
| 3841 | |
| 3842 | c1 = gfc_find_component (pdt, param->name, false, true, NULL__null); |
| 3843 | /* An error should already have been thrown in resolve.cc |
| 3844 | (resolve_fl_derived0). */ |
| 3845 | if (!pdt->attr.use_assoc && !c1) |
| 3846 | goto error_return; |
| 3847 | |
| 3848 | kind_expr = NULL__null; |
| 3849 | if (!name_seen) |
| 3850 | { |
| 3851 | if (!actual_param && !(c1 && c1->initializer)) |
| 3852 | { |
| 3853 | gfc_error ("The type parameter spec list at %C does not contain " |
| 3854 | "enough parameter expressions"); |
| 3855 | goto error_return; |
| 3856 | } |
| 3857 | else if (!actual_param && c1 && c1->initializer) |
| 3858 | kind_expr = gfc_copy_expr (c1->initializer); |
| 3859 | else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) |
| 3860 | kind_expr = gfc_copy_expr (actual_param->expr); |
| 3861 | } |
| 3862 | else |
| 3863 | { |
| 3864 | actual_param = param_list; |
| 3865 | for (;actual_param; actual_param = actual_param->next) |
| 3866 | if (actual_param->name |
| 3867 | && strcmp (actual_param->name, param->name) == 0) |
| 3868 | break; |
| 3869 | if (actual_param && actual_param->spec_type == SPEC_EXPLICIT) |
| 3870 | kind_expr = gfc_copy_expr (actual_param->expr); |
| 3871 | else |
| 3872 | { |
| 3873 | if (c1->initializer) |
| 3874 | kind_expr = gfc_copy_expr (c1->initializer); |
| 3875 | else if (!(actual_param && param->attr.pdt_len)) |
| 3876 | { |
| 3877 | gfc_error ("The derived parameter %qs at %C does not " |
| 3878 | "have a default value", param->name); |
| 3879 | goto error_return; |
| 3880 | } |
| 3881 | } |
| 3882 | } |
| 3883 | |
| 3884 | /* Store the current parameter expressions in a temporary actual |
| 3885 | arglist 'list' so that they can be substituted in the corresponding |
| 3886 | expressions in the PDT instance. */ |
| 3887 | if (type_param_spec_list == NULL__null) |
| 3888 | { |
| 3889 | type_param_spec_list = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist ))); |
| 3890 | tail = type_param_spec_list; |
| 3891 | } |
| 3892 | else |
| 3893 | { |
| 3894 | tail->next = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist ))); |
| 3895 | tail = tail->next; |
| 3896 | } |
| 3897 | tail->name = param->name; |
| 3898 | |
| 3899 | if (kind_expr) |
| 3900 | { |
| 3901 | /* Try simplification even for LEN expressions. */ |
| 3902 | bool ok; |
| 3903 | gfc_resolve_expr (kind_expr); |
| 3904 | ok = gfc_simplify_expr (kind_expr, 1); |
| 3905 | /* Variable expressions seem to default to BT_PROCEDURE. |
| 3906 | TODO find out why this is and fix it. */ |
| 3907 | if (kind_expr->ts.type != BT_INTEGER |
| 3908 | && kind_expr->ts.type != BT_PROCEDURE) |
| 3909 | { |
| 3910 | gfc_error ("The parameter expression at %C must be of " |
| 3911 | "INTEGER type and not %s type", |
| 3912 | gfc_basic_typename (kind_expr->ts.type)); |
| 3913 | goto error_return; |
| 3914 | } |
| 3915 | if (kind_expr->ts.type == BT_INTEGER && !ok) |
| 3916 | { |
| 3917 | gfc_error ("The parameter expression at %C does not " |
| 3918 | "simplify to an INTEGER constant"); |
| 3919 | goto error_return; |
| 3920 | } |
| 3921 | |
| 3922 | tail->expr = gfc_copy_expr (kind_expr); |
| 3923 | } |
| 3924 | |
| 3925 | if (actual_param) |
| 3926 | tail->spec_type = actual_param->spec_type; |
| 3927 | |
| 3928 | if (!param->attr.pdt_kind) |
| 3929 | { |
| 3930 | if (!name_seen && actual_param) |
| 3931 | actual_param = actual_param->next; |
| 3932 | if (kind_expr) |
| 3933 | { |
| 3934 | gfc_free_expr (kind_expr); |
| 3935 | kind_expr = NULL__null; |
| 3936 | } |
| 3937 | continue; |
| 3938 | } |
| 3939 | |
| 3940 | if (actual_param |
| 3941 | && (actual_param->spec_type == SPEC_ASSUMED |
| 3942 | || actual_param->spec_type == SPEC_DEFERRED)) |
| 3943 | { |
| 3944 | gfc_error ("The KIND parameter %qs at %C cannot either be " |
| 3945 | "ASSUMED or DEFERRED", param->name); |
| 3946 | goto error_return; |
| 3947 | } |
| 3948 | |
| 3949 | if (!kind_expr || !gfc_is_constant_expr (kind_expr)) |
| 3950 | { |
| 3951 | gfc_error ("The value for the KIND parameter %qs at %C does not " |
| 3952 | "reduce to a constant expression", param->name); |
| 3953 | goto error_return; |
| 3954 | } |
| 3955 | |
| 3956 | gfc_extract_int (kind_expr, &kind_value); |
| 3957 | sprintf (name + strlen (name), "_%d", kind_value); |
| 3958 | |
| 3959 | if (!name_seen && actual_param) |
| 3960 | actual_param = actual_param->next; |
| 3961 | gfc_free_expr (kind_expr); |
| 3962 | } |
| 3963 | |
| 3964 | if (!name_seen && actual_param) |
| 3965 | { |
| 3966 | gfc_error ("The type parameter spec list at %C contains too many " |
| 3967 | "parameter expressions"); |
| 3968 | goto error_return; |
| 3969 | } |
| 3970 | |
| 3971 | /* Now we search for the PDT instance 'name'. If it doesn't exist, we |
| 3972 | build it, using 'pdt' as a template. */ |
| 3973 | if (gfc_get_symbol (name, pdt->ns, &instance)) |
| 3974 | { |
| 3975 | gfc_error ("Parameterized derived type at %C is ambiguous"); |
| 3976 | goto error_return; |
| 3977 | } |
| 3978 | |
| 3979 | m = MATCH_YES; |
| 3980 | |
| 3981 | if (instance->attr.flavor == FL_DERIVED |
| 3982 | && instance->attr.pdt_type) |
| 3983 | { |
| 3984 | instance->refs++; |
| 3985 | if (ext_param_list) |
| 3986 | *ext_param_list = type_param_spec_list; |
| 3987 | *sym = instance; |
| 3988 | gfc_commit_symbols (); |
| 3989 | return m; |
| 3990 | } |
| 3991 | |
| 3992 | /* Start building the new instance of the parameterized type. */ |
| 3993 | gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at); |
| 3994 | instance->attr.pdt_template = 0; |
| 3995 | instance->attr.pdt_type = 1; |
| 3996 | instance->declared_at = gfc_current_locus; |
| 3997 | |
| 3998 | /* Add the components, replacing the parameters in all expressions |
| 3999 | with the expressions for their values in 'type_param_spec_list'. */ |
| 4000 | c1 = pdt->components; |
| 4001 | tail = type_param_spec_list; |
| 4002 | for (; c1; c1 = c1->next) |
| 4003 | { |
| 4004 | gfc_add_component (instance, c1->name, &c2); |
| 4005 | |
| 4006 | c2->ts = c1->ts; |
| 4007 | c2->attr = c1->attr; |
| 4008 | |
| 4009 | /* The order of declaration of the type_specs might not be the |
| 4010 | same as that of the components. */ |
| 4011 | if (c1->attr.pdt_kind || c1->attr.pdt_len) |
| 4012 | { |
| 4013 | for (tail = type_param_spec_list; tail; tail = tail->next) |
| 4014 | if (strcmp (c1->name, tail->name) == 0) |
| 4015 | break; |
| 4016 | } |
| 4017 | |
| 4018 | /* Deal with type extension by recursively calling this function |
| 4019 | to obtain the instance of the extended type. */ |
| 4020 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED |
| 4021 | && c1 == pdt->components |
| 4022 | && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) |
| 4023 | && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template |
| 4024 | && gfc_get_derived_super_type (*sym) == c2->ts.u.derived) |
| 4025 | { |
| 4026 | gfc_formal_arglist *f; |
| 4027 | |
| 4028 | old_param_spec_list = type_param_spec_list; |
| 4029 | |
| 4030 | /* Obtain a spec list appropriate to the extended type..*/ |
| 4031 | actual_param = gfc_copy_actual_arglist (type_param_spec_list); |
| 4032 | type_param_spec_list = actual_param; |
| 4033 | for (f = c1->ts.u.derived->formal; f && f->next; f = f->next) |
| 4034 | actual_param = actual_param->next; |
| 4035 | if (actual_param) |
| 4036 | { |
| 4037 | gfc_free_actual_arglist (actual_param->next); |
| 4038 | actual_param->next = NULL__null; |
| 4039 | } |
| 4040 | |
| 4041 | /* Now obtain the PDT instance for the extended type. */ |
| 4042 | c2->param_list = type_param_spec_list; |
| 4043 | m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived, |
| 4044 | NULL__null); |
| 4045 | type_param_spec_list = old_param_spec_list; |
| 4046 | |
| 4047 | c2->ts.u.derived->refs++; |
| 4048 | gfc_set_sym_referenced (c2->ts.u.derived); |
| 4049 | |
| 4050 | /* Set extension level. */ |
| 4051 | if (c2->ts.u.derived->attr.extension == 255) |
| 4052 | { |
| 4053 | /* Since the extension field is 8 bit wide, we can only have |
| 4054 | up to 255 extension levels. */ |
| 4055 | gfc_error ("Maximum extension level reached with type %qs at %L", |
| 4056 | c2->ts.u.derived->name, |
| 4057 | &c2->ts.u.derived->declared_at); |
| 4058 | goto error_return; |
| 4059 | } |
| 4060 | instance->attr.extension = c2->ts.u.derived->attr.extension + 1; |
| 4061 | |
| 4062 | continue; |
| 4063 | } |
| 4064 | |
| 4065 | /* Set the component kind using the parameterized expression. */ |
| 4066 | if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER) |
| 4067 | && c1->kind_expr != NULL__null) |
| 4068 | { |
| 4069 | gfc_expr *e = gfc_copy_expr (c1->kind_expr); |
| 4070 | gfc_insert_kind_parameter_exprs (e); |
| 4071 | gfc_simplify_expr (e, 1); |
| 4072 | gfc_extract_int (e, &c2->ts.kind); |
| 4073 | gfc_free_expr (e); |
| 4074 | if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0) |
| 4075 | { |
| 4076 | gfc_error ("Kind %d not supported for type %s at %C", |
| 4077 | c2->ts.kind, gfc_basic_typename (c2->ts.type)); |
| 4078 | goto error_return; |
| 4079 | } |
| 4080 | } |
| 4081 | |
| 4082 | /* Similarly, set the string length if parameterized. */ |
| 4083 | if (c1->ts.type == BT_CHARACTER |
| 4084 | && c1->ts.u.cl->length |
| 4085 | && gfc_derived_parameter_expr (c1->ts.u.cl->length)) |
| 4086 | { |
| 4087 | gfc_expr *e; |
| 4088 | e = gfc_copy_expr (c1->ts.u.cl->length); |
| 4089 | gfc_insert_kind_parameter_exprs (e); |
| 4090 | gfc_simplify_expr (e, 1); |
| 4091 | c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 4092 | c2->ts.u.cl->length = e; |
| 4093 | c2->attr.pdt_string = 1; |
| 4094 | } |
| 4095 | |
| 4096 | /* Set up either the KIND/LEN initializer, if constant, |
| 4097 | or the parameterized expression. Use the template |
| 4098 | initializer if one is not already set in this instance. */ |
| 4099 | if (c2->attr.pdt_kind || c2->attr.pdt_len) |
| 4100 | { |
| 4101 | if (tail && tail->expr && gfc_is_constant_expr (tail->expr)) |
| 4102 | c2->initializer = gfc_copy_expr (tail->expr); |
| 4103 | else if (tail && tail->expr) |
| 4104 | { |
| 4105 | c2->param_list = gfc_get_actual_arglist ()((gfc_actual_arglist *) xcalloc (1, sizeof (gfc_actual_arglist ))); |
| 4106 | c2->param_list->name = tail->name; |
| 4107 | c2->param_list->expr = gfc_copy_expr (tail->expr); |
| 4108 | c2->param_list->next = NULL__null; |
| 4109 | } |
| 4110 | |
| 4111 | if (!c2->initializer && c1->initializer) |
| 4112 | c2->initializer = gfc_copy_expr (c1->initializer); |
| 4113 | } |
| 4114 | |
| 4115 | /* Copy the array spec. */ |
| 4116 | c2->as = gfc_copy_array_spec (c1->as); |
| 4117 | if (c1->ts.type == BT_CLASS) |
| 4118 | CLASS_DATA (c2)c2->ts.u.derived->components->as = gfc_copy_array_spec (CLASS_DATA (c1)c1->ts.u.derived->components->as); |
| 4119 | |
| 4120 | /* Determine if an array spec is parameterized. If so, substitute |
| 4121 | in the parameter expressions for the bounds and set the pdt_array |
| 4122 | attribute. Notice that this attribute must be unconditionally set |
| 4123 | if this is an array of parameterized character length. */ |
| 4124 | if (c1->as && c1->as->type == AS_EXPLICIT) |
| 4125 | { |
| 4126 | bool pdt_array = false; |
| 4127 | |
| 4128 | /* Are the bounds of the array parameterized? */ |
| 4129 | for (i = 0; i < c1->as->rank; i++) |
| 4130 | { |
| 4131 | if (gfc_derived_parameter_expr (c1->as->lower[i])) |
| 4132 | pdt_array = true; |
| 4133 | if (gfc_derived_parameter_expr (c1->as->upper[i])) |
| 4134 | pdt_array = true; |
| 4135 | } |
| 4136 | |
| 4137 | /* If they are, free the expressions for the bounds and |
| 4138 | replace them with the template expressions with substitute |
| 4139 | values. */ |
| 4140 | for (i = 0; pdt_array && i < c1->as->rank; i++) |
| 4141 | { |
| 4142 | gfc_expr *e; |
| 4143 | e = gfc_copy_expr (c1->as->lower[i]); |
| 4144 | gfc_insert_kind_parameter_exprs (e); |
| 4145 | gfc_simplify_expr (e, 1); |
| 4146 | gfc_free_expr (c2->as->lower[i]); |
| 4147 | c2->as->lower[i] = e; |
| 4148 | e = gfc_copy_expr (c1->as->upper[i]); |
| 4149 | gfc_insert_kind_parameter_exprs (e); |
| 4150 | gfc_simplify_expr (e, 1); |
| 4151 | gfc_free_expr (c2->as->upper[i]); |
| 4152 | c2->as->upper[i] = e; |
| 4153 | } |
| 4154 | c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string; |
| 4155 | if (c1->initializer) |
| 4156 | { |
| 4157 | c2->initializer = gfc_copy_expr (c1->initializer); |
| 4158 | gfc_insert_kind_parameter_exprs (c2->initializer); |
| 4159 | gfc_simplify_expr (c2->initializer, 1); |
| 4160 | } |
| 4161 | } |
| 4162 | |
| 4163 | /* Recurse into this function for PDT components. */ |
| 4164 | if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS) |
| 4165 | && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template) |
| 4166 | { |
| 4167 | gfc_actual_arglist *params; |
| 4168 | /* The component in the template has a list of specification |
| 4169 | expressions derived from its declaration. */ |
| 4170 | params = gfc_copy_actual_arglist (c1->param_list); |
| 4171 | actual_param = params; |
| 4172 | /* Substitute the template parameters with the expressions |
| 4173 | from the specification list. */ |
| 4174 | for (;actual_param; actual_param = actual_param->next) |
| 4175 | gfc_insert_parameter_exprs (actual_param->expr, |
| 4176 | type_param_spec_list); |
| 4177 | |
| 4178 | /* Now obtain the PDT instance for the component. */ |
| 4179 | old_param_spec_list = type_param_spec_list; |
| 4180 | m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL__null); |
| 4181 | type_param_spec_list = old_param_spec_list; |
| 4182 | |
| 4183 | c2->param_list = params; |
| 4184 | if (!(c2->attr.pointer || c2->attr.allocatable)) |
| 4185 | c2->initializer = gfc_default_initializer (&c2->ts); |
| 4186 | |
| 4187 | if (c2->attr.allocatable) |
| 4188 | instance->attr.alloc_comp = 1; |
| 4189 | } |
| 4190 | } |
| 4191 | |
| 4192 | gfc_commit_symbol (instance); |
| 4193 | if (ext_param_list) |
| 4194 | *ext_param_list = type_param_spec_list; |
| 4195 | *sym = instance; |
| 4196 | return m; |
| 4197 | |
| 4198 | error_return: |
| 4199 | gfc_free_actual_arglist (type_param_spec_list); |
| 4200 | return MATCH_ERROR; |
| 4201 | } |
| 4202 | |
| 4203 | |
| 4204 | /* Match a legacy nonstandard BYTE type-spec. */ |
| 4205 | |
| 4206 | static match |
| 4207 | match_byte_typespec (gfc_typespec *ts) |
| 4208 | { |
| 4209 | if (gfc_match (" byte") == MATCH_YES) |
| 4210 | { |
| 4211 | if (!gfc_notify_std (GFC_STD_GNU(1<<5), "BYTE type at %C")) |
| 4212 | return MATCH_ERROR; |
| 4213 | |
| 4214 | if (gfc_current_form == FORM_FREE) |
| 4215 | { |
| 4216 | char c = gfc_peek_ascii_char (); |
| 4217 | if (!gfc_is_whitespace (c)((c==' ') || (c=='\t') || (c=='\f')) && c != ',') |
| 4218 | return MATCH_NO; |
| 4219 | } |
| 4220 | |
| 4221 | if (gfc_validate_kind (BT_INTEGER, 1, true) < 0) |
| 4222 | { |
| 4223 | gfc_error ("BYTE type used at %C " |
| 4224 | "is not available on the target machine"); |
| 4225 | return MATCH_ERROR; |
| 4226 | } |
| 4227 | |
| 4228 | ts->type = BT_INTEGER; |
| 4229 | ts->kind = 1; |
| 4230 | return MATCH_YES; |
| 4231 | } |
| 4232 | return MATCH_NO; |
| 4233 | } |
| 4234 | |
| 4235 | |
| 4236 | /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts |
| 4237 | structure to the matched specification. This is necessary for FUNCTION and |
| 4238 | IMPLICIT statements. |
| 4239 | |
| 4240 | If implicit_flag is nonzero, then we don't check for the optional |
| 4241 | kind specification. Not doing so is needed for matching an IMPLICIT |
| 4242 | statement correctly. */ |
| 4243 | |
| 4244 | match |
| 4245 | gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) |
| 4246 | { |
| 4247 | /* Provide sufficient space to hold "pdtsymbol". */ |
| 4248 | char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1)((char *) __builtin_alloca(sizeof (char) * (63 + 1))); |
| 4249 | gfc_symbol *sym, *dt_sym; |
| 4250 | match m; |
| 4251 | char c; |
| 4252 | bool seen_deferred_kind, matched_type; |
| 4253 | const char *dt_name; |
| 4254 | |
| 4255 | decl_type_param_list = NULL__null; |
| 4256 | |
| 4257 | /* A belt and braces check that the typespec is correctly being treated |
| 4258 | as a deferred characteristic association. */ |
| 4259 | seen_deferred_kind = (gfc_current_state ()(gfc_state_stack->state) == COMP_FUNCTION) |
| 4260 | && (gfc_current_block ()(gfc_state_stack->sym)->result->ts.kind == -1) |
| 4261 | && (ts->kind == -1); |
| 4262 | gfc_clear_ts (ts); |
| 4263 | if (seen_deferred_kind) |
| 4264 | ts->kind = -1; |
| 4265 | |
| 4266 | /* Clear the current binding label, in case one is given. */ |
| 4267 | curr_binding_label = NULL__null; |
| 4268 | |
| 4269 | /* Match BYTE type-spec. */ |
| 4270 | m = match_byte_typespec (ts); |
| 4271 | if (m != MATCH_NO) |
| 4272 | return m; |
| 4273 | |
| 4274 | m = gfc_match (" type ("); |
| 4275 | matched_type = (m == MATCH_YES); |
| 4276 | if (matched_type) |
| 4277 | { |
| 4278 | gfc_gobble_whitespace (); |
| 4279 | if (gfc_peek_ascii_char () == '*') |
| 4280 | { |
| 4281 | if ((m = gfc_match ("* ) ")) != MATCH_YES) |
| 4282 | return m; |
| 4283 | if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 4284 | { |
| 4285 | gfc_error ("Assumed type at %C is not allowed for components"); |
| 4286 | return MATCH_ERROR; |
| 4287 | } |
| 4288 | if (!gfc_notify_std (GFC_STD_F2018(1<<9), "Assumed type at %C")) |
| 4289 | return MATCH_ERROR; |
| 4290 | ts->type = BT_ASSUMED; |
| 4291 | return MATCH_YES; |
| 4292 | } |
| 4293 | |
| 4294 | m = gfc_match ("%n", name); |
| 4295 | matched_type = (m == MATCH_YES); |
| 4296 | } |
| 4297 | |
| 4298 | if ((matched_type && strcmp ("integer", name) == 0) |
| 4299 | || (!matched_type && gfc_match (" integer") == MATCH_YES)) |
| 4300 | { |
| 4301 | ts->type = BT_INTEGER; |
| 4302 | ts->kind = gfc_default_integer_kind; |
| 4303 | goto get_kind; |
| 4304 | } |
| 4305 | |
| 4306 | if ((matched_type && strcmp ("character", name) == 0) |
| 4307 | || (!matched_type && gfc_match (" character") == MATCH_YES)) |
| 4308 | { |
| 4309 | if (matched_type |
| 4310 | && !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with " |
| 4311 | "intrinsic-type-spec at %C")) |
| 4312 | return MATCH_ERROR; |
| 4313 | |
| 4314 | ts->type = BT_CHARACTER; |
| 4315 | if (implicit_flag == 0) |
| 4316 | m = gfc_match_char_spec (ts); |
| 4317 | else |
| 4318 | m = MATCH_YES; |
| 4319 | |
| 4320 | if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES) |
| 4321 | { |
| 4322 | gfc_error ("Malformed type-spec at %C"); |
| 4323 | return MATCH_ERROR; |
| 4324 | } |
| 4325 | |
| 4326 | return m; |
| 4327 | } |
| 4328 | |
| 4329 | if ((matched_type && strcmp ("real", name) == 0) |
| 4330 | || (!matched_type && gfc_match (" real") == MATCH_YES)) |
| 4331 | { |
| 4332 | ts->type = BT_REAL; |
| 4333 | ts->kind = gfc_default_real_kind; |
| 4334 | goto get_kind; |
| 4335 | } |
| 4336 | |
| 4337 | if ((matched_type |
| 4338 | && (strcmp ("doubleprecision", name) == 0 |
| 4339 | || (strcmp ("double", name) == 0 |
| 4340 | && gfc_match (" precision") == MATCH_YES))) |
| 4341 | || (!matched_type && gfc_match (" double precision") == MATCH_YES)) |
| 4342 | { |
| 4343 | if (matched_type |
| 4344 | && !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with " |
| 4345 | "intrinsic-type-spec at %C")) |
| 4346 | return MATCH_ERROR; |
| 4347 | |
| 4348 | if (matched_type && gfc_match_char (')') != MATCH_YES) |
| 4349 | { |
| 4350 | gfc_error ("Malformed type-spec at %C"); |
| 4351 | return MATCH_ERROR; |
| 4352 | } |
| 4353 | |
| 4354 | ts->type = BT_REAL; |
| 4355 | ts->kind = gfc_default_double_kind; |
| 4356 | return MATCH_YES; |
| 4357 | } |
| 4358 | |
| 4359 | if ((matched_type && strcmp ("complex", name) == 0) |
| 4360 | || (!matched_type && gfc_match (" complex") == MATCH_YES)) |
| 4361 | { |
| 4362 | ts->type = BT_COMPLEX; |
| 4363 | ts->kind = gfc_default_complex_kind; |
| 4364 | goto get_kind; |
| 4365 | } |
| 4366 | |
| 4367 | if ((matched_type |
| 4368 | && (strcmp ("doublecomplex", name) == 0 |
| 4369 | || (strcmp ("double", name) == 0 |
| 4370 | && gfc_match (" complex") == MATCH_YES))) |
| 4371 | || (!matched_type && gfc_match (" double complex") == MATCH_YES)) |
| 4372 | { |
| 4373 | if (!gfc_notify_std (GFC_STD_GNU(1<<5), "DOUBLE COMPLEX at %C")) |
| 4374 | return MATCH_ERROR; |
| 4375 | |
| 4376 | if (matched_type |
| 4377 | && !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with " |
| 4378 | "intrinsic-type-spec at %C")) |
| 4379 | return MATCH_ERROR; |
| 4380 | |
| 4381 | if (matched_type && gfc_match_char (')') != MATCH_YES) |
| 4382 | { |
| 4383 | gfc_error ("Malformed type-spec at %C"); |
| 4384 | return MATCH_ERROR; |
| 4385 | } |
| 4386 | |
| 4387 | ts->type = BT_COMPLEX; |
| 4388 | ts->kind = gfc_default_double_kind; |
| 4389 | return MATCH_YES; |
| 4390 | } |
| 4391 | |
| 4392 | if ((matched_type && strcmp ("logical", name) == 0) |
| 4393 | || (!matched_type && gfc_match (" logical") == MATCH_YES)) |
| 4394 | { |
| 4395 | ts->type = BT_LOGICAL; |
| 4396 | ts->kind = gfc_default_logical_kind; |
| 4397 | goto get_kind; |
| 4398 | } |
| 4399 | |
| 4400 | if (matched_type) |
| 4401 | { |
| 4402 | m = gfc_match_actual_arglist (1, &decl_type_param_list, true); |
| 4403 | if (m == MATCH_ERROR) |
| 4404 | return m; |
| 4405 | |
| 4406 | gfc_gobble_whitespace (); |
| 4407 | if (gfc_peek_ascii_char () != ')') |
| 4408 | { |
| 4409 | gfc_error ("Malformed type-spec at %C"); |
| 4410 | return MATCH_ERROR; |
| 4411 | } |
| 4412 | m = gfc_match_char (')'); /* Burn closing ')'. */ |
| 4413 | } |
| 4414 | |
| 4415 | if (m != MATCH_YES) |
| 4416 | m = match_record_decl (name); |
| 4417 | |
| 4418 | if (matched_type || m == MATCH_YES) |
| 4419 | { |
| 4420 | ts->type = BT_DERIVED; |
| 4421 | /* We accept record/s/ or type(s) where s is a structure, but we |
| 4422 | * don't need all the extra derived-type stuff for structures. */ |
| 4423 | if (gfc_find_symbol (gfc_dt_upper_string (name), NULL__null, 1, &sym)) |
| 4424 | { |
| 4425 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 4426 | return MATCH_ERROR; |
| 4427 | } |
| 4428 | |
| 4429 | if (sym && sym->attr.flavor == FL_DERIVED |
| 4430 | && sym->attr.pdt_template |
| 4431 | && gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED) |
| 4432 | { |
| 4433 | m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL__null); |
| 4434 | if (m != MATCH_YES) |
| 4435 | return m; |
| 4436 | gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type)((void)(!(!sym->attr.pdt_template && sym->attr. pdt_type) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 4436, __FUNCTION__), 0 : 0)); |
| 4437 | ts->u.derived = sym; |
| 4438 | const char* lower = gfc_dt_lower_string (sym->name); |
| 4439 | size_t len = strlen (lower); |
| 4440 | /* Reallocate with sufficient size. */ |
| 4441 | if (len > GFC_MAX_SYMBOL_LEN63) |
| 4442 | name = XALLOCAVEC (char, len + 1)((char *) __builtin_alloca(sizeof (char) * (len + 1))); |
| 4443 | memcpy (name, lower, len); |
| 4444 | name[len] = '\0'; |
| 4445 | } |
| 4446 | |
| 4447 | if (sym && sym->attr.flavor == FL_STRUCT) |
| 4448 | { |
| 4449 | ts->u.derived = sym; |
| 4450 | return MATCH_YES; |
| 4451 | } |
| 4452 | /* Actually a derived type. */ |
| 4453 | } |
| 4454 | |
| 4455 | else |
| 4456 | { |
| 4457 | /* Match nested STRUCTURE declarations; only valid within another |
| 4458 | structure declaration. */ |
| 4459 | if (flag_dec_structureglobal_options.x_flag_dec_structure |
| 4460 | && (gfc_current_state ()(gfc_state_stack->state) == COMP_STRUCTURE |
| 4461 | || gfc_current_state ()(gfc_state_stack->state) == COMP_MAP)) |
| 4462 | { |
| 4463 | m = gfc_match (" structure"); |
| 4464 | if (m == MATCH_YES) |
| 4465 | { |
| 4466 | m = gfc_match_structure_decl (); |
| 4467 | if (m == MATCH_YES) |
| 4468 | { |
| 4469 | /* gfc_new_block is updated by match_structure_decl. */ |
| 4470 | ts->type = BT_DERIVED; |
| 4471 | ts->u.derived = gfc_new_block; |
| 4472 | return MATCH_YES; |
| 4473 | } |
| 4474 | } |
| 4475 | if (m == MATCH_ERROR) |
| 4476 | return MATCH_ERROR; |
| 4477 | } |
| 4478 | |
| 4479 | /* Match CLASS declarations. */ |
| 4480 | m = gfc_match (" class ( * )"); |
| 4481 | if (m == MATCH_ERROR) |
| 4482 | return MATCH_ERROR; |
| 4483 | else if (m == MATCH_YES) |
| 4484 | { |
| 4485 | gfc_symbol *upe; |
| 4486 | gfc_symtree *st; |
| 4487 | ts->type = BT_CLASS; |
| 4488 | gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe); |
| 4489 | if (upe == NULL__null) |
| 4490 | { |
| 4491 | upe = gfc_new_symbol ("STAR", gfc_current_ns); |
| 4492 | st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR"); |
| 4493 | st->n.sym = upe; |
| 4494 | gfc_set_sym_referenced (upe); |
| 4495 | upe->refs++; |
| 4496 | upe->ts.type = BT_VOID; |
| 4497 | upe->attr.unlimited_polymorphic = 1; |
| 4498 | /* This is essential to force the construction of |
| 4499 | unlimited polymorphic component class containers. */ |
| 4500 | upe->attr.zero_comp = 1; |
| 4501 | if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL__null, |
| 4502 | &gfc_current_locus)) |
| 4503 | return MATCH_ERROR; |
| 4504 | } |
| 4505 | else |
| 4506 | { |
| 4507 | st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR"); |
| 4508 | st->n.sym = upe; |
| 4509 | upe->refs++; |
| 4510 | } |
| 4511 | ts->u.derived = upe; |
| 4512 | return m; |
| 4513 | } |
| 4514 | |
| 4515 | m = gfc_match (" class ("); |
| 4516 | |
| 4517 | if (m == MATCH_YES) |
| 4518 | m = gfc_match ("%n", name); |
| 4519 | else |
| 4520 | return m; |
| 4521 | |
| 4522 | if (m != MATCH_YES) |
| 4523 | return m; |
| 4524 | ts->type = BT_CLASS; |
| 4525 | |
| 4526 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "CLASS statement at %C")) |
| 4527 | return MATCH_ERROR; |
| 4528 | |
| 4529 | m = gfc_match_actual_arglist (1, &decl_type_param_list, true); |
| 4530 | if (m == MATCH_ERROR) |
| 4531 | return m; |
| 4532 | |
| 4533 | m = gfc_match_char (')'); |
| 4534 | if (m != MATCH_YES) |
| 4535 | return m; |
| 4536 | } |
| 4537 | |
| 4538 | /* Defer association of the derived type until the end of the |
| 4539 | specification block. However, if the derived type can be |
| 4540 | found, add it to the typespec. */ |
| 4541 | if (gfc_matching_function) |
| 4542 | { |
| 4543 | ts->u.derived = NULL__null; |
| 4544 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_INTERFACE |
| 4545 | && !gfc_find_symbol (name, NULL__null, 1, &sym) && sym) |
| 4546 | { |
| 4547 | sym = gfc_find_dt_in_generic (sym); |
| 4548 | ts->u.derived = sym; |
| 4549 | } |
| 4550 | return MATCH_YES; |
| 4551 | } |
| 4552 | |
| 4553 | /* Search for the name but allow the components to be defined later. If |
| 4554 | type = -1, this typespec has been seen in a function declaration but |
| 4555 | the type could not be accessed at that point. The actual derived type is |
| 4556 | stored in a symtree with the first letter of the name capitalized; the |
| 4557 | symtree with the all lower-case name contains the associated |
| 4558 | generic function. */ |
| 4559 | dt_name = gfc_dt_upper_string (name); |
| 4560 | sym = NULL__null; |
| 4561 | dt_sym = NULL__null; |
| 4562 | if (ts->kind != -1) |
| 4563 | { |
| 4564 | gfc_get_ha_symbol (name, &sym); |
| 4565 | if (sym->generic && gfc_find_symbol (dt_name, NULL__null, 0, &dt_sym)) |
| 4566 | { |
| 4567 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 4568 | return MATCH_ERROR; |
| 4569 | } |
| 4570 | if (sym->generic && !dt_sym) |
| 4571 | dt_sym = gfc_find_dt_in_generic (sym); |
| 4572 | |
| 4573 | /* Host associated PDTs can get confused with their constructors |
| 4574 | because they ar instantiated in the template's namespace. */ |
| 4575 | if (!dt_sym) |
| 4576 | { |
| 4577 | if (gfc_find_symbol (dt_name, NULL__null, 1, &dt_sym)) |
| 4578 | { |
| 4579 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 4580 | return MATCH_ERROR; |
| 4581 | } |
| 4582 | if (dt_sym && !dt_sym->attr.pdt_type) |
| 4583 | dt_sym = NULL__null; |
| 4584 | } |
| 4585 | } |
| 4586 | else if (ts->kind == -1) |
| 4587 | { |
| 4588 | int iface = gfc_state_stack->previous->state != COMP_INTERFACE |
| 4589 | || gfc_current_ns->has_import_set; |
| 4590 | gfc_find_symbol (name, NULL__null, iface, &sym); |
| 4591 | if (sym && sym->generic && gfc_find_symbol (dt_name, NULL__null, 1, &dt_sym)) |
| 4592 | { |
| 4593 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 4594 | return MATCH_ERROR; |
| 4595 | } |
| 4596 | if (sym && sym->generic && !dt_sym) |
| 4597 | dt_sym = gfc_find_dt_in_generic (sym); |
| 4598 | |
| 4599 | ts->kind = 0; |
| 4600 | if (sym == NULL__null) |
| 4601 | return MATCH_NO; |
| 4602 | } |
| 4603 | |
| 4604 | if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT |
| 4605 | && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic)) |
| 4606 | || sym->attr.subroutine) |
| 4607 | { |
| 4608 | gfc_error ("Type name %qs at %C conflicts with previously declared " |
| 4609 | "entity at %L, which has the same name", name, |
| 4610 | &sym->declared_at); |
| 4611 | return MATCH_ERROR; |
| 4612 | } |
| 4613 | |
| 4614 | if (sym && sym->attr.flavor == FL_DERIVED |
| 4615 | && sym->attr.pdt_template |
| 4616 | && gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED) |
| 4617 | { |
| 4618 | m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL__null); |
| 4619 | if (m != MATCH_YES) |
| 4620 | return m; |
| 4621 | gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type)((void)(!(!sym->attr.pdt_template && sym->attr. pdt_type) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 4621, __FUNCTION__), 0 : 0)); |
| 4622 | ts->u.derived = sym; |
| 4623 | strcpy (name, gfc_dt_lower_string (sym->name)); |
| 4624 | } |
| 4625 | |
| 4626 | gfc_save_symbol_data (sym); |
| 4627 | gfc_set_sym_referenced (sym); |
| 4628 | if (!sym->attr.generic |
| 4629 | && !gfc_add_generic (&sym->attr, sym->name, NULL__null)) |
| 4630 | return MATCH_ERROR; |
| 4631 | |
| 4632 | if (!sym->attr.function |
| 4633 | && !gfc_add_function (&sym->attr, sym->name, NULL__null)) |
| 4634 | return MATCH_ERROR; |
| 4635 | |
| 4636 | if (dt_sym && dt_sym->attr.flavor == FL_DERIVED |
| 4637 | && dt_sym->attr.pdt_template |
| 4638 | && gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED) |
| 4639 | { |
| 4640 | m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL__null); |
| 4641 | if (m != MATCH_YES) |
| 4642 | return m; |
| 4643 | gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type)((void)(!(!dt_sym->attr.pdt_template && dt_sym-> attr.pdt_type) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 4643, __FUNCTION__), 0 : 0)); |
| 4644 | } |
| 4645 | |
| 4646 | if (!dt_sym) |
| 4647 | { |
| 4648 | gfc_interface *intr, *head; |
| 4649 | |
| 4650 | /* Use upper case to save the actual derived-type symbol. */ |
| 4651 | gfc_get_symbol (dt_name, NULL__null, &dt_sym); |
| 4652 | dt_sym->name = gfc_get_string ("%s", sym->name); |
| 4653 | head = sym->generic; |
| 4654 | intr = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface))); |
| 4655 | intr->sym = dt_sym; |
| 4656 | intr->where = gfc_current_locus; |
| 4657 | intr->next = head; |
| 4658 | sym->generic = intr; |
| 4659 | sym->attr.if_source = IFSRC_DECL; |
| 4660 | } |
| 4661 | else |
| 4662 | gfc_save_symbol_data (dt_sym); |
| 4663 | |
| 4664 | gfc_set_sym_referenced (dt_sym); |
| 4665 | |
| 4666 | if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT |
| 4667 | && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL__null)) |
| 4668 | return MATCH_ERROR; |
| 4669 | |
| 4670 | ts->u.derived = dt_sym; |
| 4671 | |
| 4672 | return MATCH_YES; |
| 4673 | |
| 4674 | get_kind: |
| 4675 | if (matched_type |
| 4676 | && !gfc_notify_std (GFC_STD_F2008(1<<7), "TYPE with " |
| 4677 | "intrinsic-type-spec at %C")) |
| 4678 | return MATCH_ERROR; |
| 4679 | |
| 4680 | /* For all types except double, derived and character, look for an |
| 4681 | optional kind specifier. MATCH_NO is actually OK at this point. */ |
| 4682 | if (implicit_flag == 1) |
| 4683 | { |
| 4684 | if (matched_type && gfc_match_char (')') != MATCH_YES) |
| 4685 | return MATCH_ERROR; |
| 4686 | |
| 4687 | return MATCH_YES; |
| 4688 | } |
| 4689 | |
| 4690 | if (gfc_current_form == FORM_FREE) |
| 4691 | { |
| 4692 | c = gfc_peek_ascii_char (); |
| 4693 | if (!gfc_is_whitespace (c)((c==' ') || (c=='\t') || (c=='\f')) && c != '*' && c != '(' |
| 4694 | && c != ':' && c != ',') |
| 4695 | { |
| 4696 | if (matched_type && c == ')') |
| 4697 | { |
| 4698 | gfc_next_ascii_char (); |
| 4699 | return MATCH_YES; |
| 4700 | } |
| 4701 | gfc_error ("Malformed type-spec at %C"); |
| 4702 | return MATCH_NO; |
| 4703 | } |
| 4704 | } |
| 4705 | |
| 4706 | m = gfc_match_kind_spec (ts, false); |
| 4707 | if (m == MATCH_NO && ts->type != BT_CHARACTER) |
| 4708 | { |
| 4709 | m = gfc_match_old_kind_spec (ts); |
| 4710 | if (gfc_validate_kind (ts->type, ts->kind, true) == -1) |
| 4711 | return MATCH_ERROR; |
| 4712 | } |
| 4713 | |
| 4714 | if (matched_type && gfc_match_char (')') != MATCH_YES) |
| 4715 | { |
| 4716 | gfc_error ("Malformed type-spec at %C"); |
| 4717 | return MATCH_ERROR; |
| 4718 | } |
| 4719 | |
| 4720 | /* Defer association of the KIND expression of function results |
| 4721 | until after USE and IMPORT statements. */ |
| 4722 | if ((gfc_current_state ()(gfc_state_stack->state) == COMP_NONE && gfc_error_flag_test ()) |
| 4723 | || gfc_matching_function) |
| 4724 | return MATCH_YES; |
| 4725 | |
| 4726 | if (m == MATCH_NO) |
| 4727 | m = MATCH_YES; /* No kind specifier found. */ |
| 4728 | |
| 4729 | return m; |
| 4730 | } |
| 4731 | |
| 4732 | |
| 4733 | /* Match an IMPLICIT NONE statement. Actually, this statement is |
| 4734 | already matched in parse.cc, or we would not end up here in the |
| 4735 | first place. So the only thing we need to check, is if there is |
| 4736 | trailing garbage. If not, the match is successful. */ |
| 4737 | |
| 4738 | match |
| 4739 | gfc_match_implicit_none (void) |
| 4740 | { |
| 4741 | char c; |
| 4742 | match m; |
| 4743 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 4744 | bool type = false; |
| 4745 | bool external = false; |
| 4746 | locus cur_loc = gfc_current_locus; |
| 4747 | |
| 4748 | if (gfc_current_ns->seen_implicit_none |
| 4749 | || gfc_current_ns->has_implicit_none_export) |
| 4750 | { |
| 4751 | gfc_error ("Duplicate IMPLICIT NONE statement at %C"); |
| 4752 | return MATCH_ERROR; |
| 4753 | } |
| 4754 | |
| 4755 | gfc_gobble_whitespace (); |
| 4756 | c = gfc_peek_ascii_char (); |
| 4757 | if (c == '(') |
| 4758 | { |
| 4759 | (void) gfc_next_ascii_char (); |
| 4760 | if (!gfc_notify_std (GFC_STD_F2018(1<<9), "IMPLICIT NONE with spec list at %C")) |
| 4761 | return MATCH_ERROR; |
| 4762 | |
| 4763 | gfc_gobble_whitespace (); |
| 4764 | if (gfc_peek_ascii_char () == ')') |
| 4765 | { |
| 4766 | (void) gfc_next_ascii_char (); |
| 4767 | type = true; |
| 4768 | } |
| 4769 | else |
| 4770 | for(;;) |
| 4771 | { |
| 4772 | m = gfc_match (" %n", name); |
| 4773 | if (m != MATCH_YES) |
| 4774 | return MATCH_ERROR; |
| 4775 | |
| 4776 | if (strcmp (name, "type") == 0) |
| 4777 | type = true; |
| 4778 | else if (strcmp (name, "external") == 0) |
| 4779 | external = true; |
| 4780 | else |
| 4781 | return MATCH_ERROR; |
| 4782 | |
| 4783 | gfc_gobble_whitespace (); |
| 4784 | c = gfc_next_ascii_char (); |
| 4785 | if (c == ',') |
| 4786 | continue; |
| 4787 | if (c == ')') |
| 4788 | break; |
| 4789 | return MATCH_ERROR; |
| 4790 | } |
| 4791 | } |
| 4792 | else |
| 4793 | type = true; |
| 4794 | |
| 4795 | if (gfc_match_eos () != MATCH_YES) |
| 4796 | return MATCH_ERROR; |
| 4797 | |
| 4798 | gfc_set_implicit_none (type, external, &cur_loc); |
| 4799 | |
| 4800 | return MATCH_YES; |
| 4801 | } |
| 4802 | |
| 4803 | |
| 4804 | /* Match the letter range(s) of an IMPLICIT statement. */ |
| 4805 | |
| 4806 | static match |
| 4807 | match_implicit_range (void) |
| 4808 | { |
| 4809 | char c, c1, c2; |
| 4810 | int inner; |
| 4811 | locus cur_loc; |
| 4812 | |
| 4813 | cur_loc = gfc_current_locus; |
| 4814 | |
| 4815 | gfc_gobble_whitespace (); |
| 4816 | c = gfc_next_ascii_char (); |
| 4817 | if (c != '(') |
| 4818 | { |
| 4819 | gfc_error ("Missing character range in IMPLICIT at %C"); |
| 4820 | goto bad; |
| 4821 | } |
| 4822 | |
| 4823 | inner = 1; |
| 4824 | while (inner) |
| 4825 | { |
| 4826 | gfc_gobble_whitespace (); |
| 4827 | c1 = gfc_next_ascii_char (); |
| 4828 | if (!ISALPHA (c1)(_sch_istable[(c1) & 0xff] & (unsigned short)(_sch_isalpha ))) |
| 4829 | goto bad; |
| 4830 | |
| 4831 | gfc_gobble_whitespace (); |
| 4832 | c = gfc_next_ascii_char (); |
| 4833 | |
| 4834 | switch (c) |
| 4835 | { |
| 4836 | case ')': |
| 4837 | inner = 0; /* Fall through. */ |
| 4838 | |
| 4839 | case ',': |
| 4840 | c2 = c1; |
| 4841 | break; |
| 4842 | |
| 4843 | case '-': |
| 4844 | gfc_gobble_whitespace (); |
| 4845 | c2 = gfc_next_ascii_char (); |
| 4846 | if (!ISALPHA (c2)(_sch_istable[(c2) & 0xff] & (unsigned short)(_sch_isalpha ))) |
| 4847 | goto bad; |
| 4848 | |
| 4849 | gfc_gobble_whitespace (); |
| 4850 | c = gfc_next_ascii_char (); |
| 4851 | |
| 4852 | if ((c != ',') && (c != ')')) |
| 4853 | goto bad; |
| 4854 | if (c == ')') |
| 4855 | inner = 0; |
| 4856 | |
| 4857 | break; |
| 4858 | |
| 4859 | default: |
| 4860 | goto bad; |
| 4861 | } |
| 4862 | |
| 4863 | if (c1 > c2) |
| 4864 | { |
| 4865 | gfc_error ("Letters must be in alphabetic order in " |
| 4866 | "IMPLICIT statement at %C"); |
| 4867 | goto bad; |
| 4868 | } |
| 4869 | |
| 4870 | /* See if we can add the newly matched range to the pending |
| 4871 | implicits from this IMPLICIT statement. We do not check for |
| 4872 | conflicts with whatever earlier IMPLICIT statements may have |
| 4873 | set. This is done when we've successfully finished matching |
| 4874 | the current one. */ |
| 4875 | if (!gfc_add_new_implicit_range (c1, c2)) |
| 4876 | goto bad; |
| 4877 | } |
| 4878 | |
| 4879 | return MATCH_YES; |
| 4880 | |
| 4881 | bad: |
| 4882 | gfc_syntax_error (ST_IMPLICIT)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_IMPLICIT));; |
| 4883 | |
| 4884 | gfc_current_locus = cur_loc; |
| 4885 | return MATCH_ERROR; |
| 4886 | } |
| 4887 | |
| 4888 | |
| 4889 | /* Match an IMPLICIT statement, storing the types for |
| 4890 | gfc_set_implicit() if the statement is accepted by the parser. |
| 4891 | There is a strange looking, but legal syntactic construction |
| 4892 | possible. It looks like: |
| 4893 | |
| 4894 | IMPLICIT INTEGER (a-b) (c-d) |
| 4895 | |
| 4896 | This is legal if "a-b" is a constant expression that happens to |
| 4897 | equal one of the legal kinds for integers. The real problem |
| 4898 | happens with an implicit specification that looks like: |
| 4899 | |
| 4900 | IMPLICIT INTEGER (a-b) |
| 4901 | |
| 4902 | In this case, a typespec matcher that is "greedy" (as most of the |
| 4903 | matchers are) gobbles the character range as a kindspec, leaving |
| 4904 | nothing left. We therefore have to go a bit more slowly in the |
| 4905 | matching process by inhibiting the kindspec checking during |
| 4906 | typespec matching and checking for a kind later. */ |
| 4907 | |
| 4908 | match |
| 4909 | gfc_match_implicit (void) |
| 4910 | { |
| 4911 | gfc_typespec ts; |
| 4912 | locus cur_loc; |
| 4913 | char c; |
| 4914 | match m; |
| 4915 | |
| 4916 | if (gfc_current_ns->seen_implicit_none) |
| 4917 | { |
| 4918 | gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) " |
| 4919 | "statement"); |
| 4920 | return MATCH_ERROR; |
| 4921 | } |
| 4922 | |
| 4923 | gfc_clear_ts (&ts); |
| 4924 | |
| 4925 | /* We don't allow empty implicit statements. */ |
| 4926 | if (gfc_match_eos () == MATCH_YES) |
| 4927 | { |
| 4928 | gfc_error ("Empty IMPLICIT statement at %C"); |
| 4929 | return MATCH_ERROR; |
| 4930 | } |
| 4931 | |
| 4932 | do |
| 4933 | { |
| 4934 | /* First cleanup. */ |
| 4935 | gfc_clear_new_implicit (); |
| 4936 | |
| 4937 | /* A basic type is mandatory here. */ |
| 4938 | m = gfc_match_decl_type_spec (&ts, 1); |
| 4939 | if (m == MATCH_ERROR) |
| 4940 | goto error; |
| 4941 | if (m == MATCH_NO) |
| 4942 | goto syntax; |
| 4943 | |
| 4944 | cur_loc = gfc_current_locus; |
| 4945 | m = match_implicit_range (); |
| 4946 | |
| 4947 | if (m == MATCH_YES) |
| 4948 | { |
| 4949 | /* We may have <TYPE> (<RANGE>). */ |
| 4950 | gfc_gobble_whitespace (); |
| 4951 | c = gfc_peek_ascii_char (); |
| 4952 | if (c == ',' || c == '\n' || c == ';' || c == '!') |
| 4953 | { |
| 4954 | /* Check for CHARACTER with no length parameter. */ |
| 4955 | if (ts.type == BT_CHARACTER && !ts.u.cl) |
| 4956 | { |
| 4957 | ts.kind = gfc_default_character_kind; |
| 4958 | ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null); |
| 4959 | ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind, |
| 4960 | NULL__null, 1); |
| 4961 | } |
| 4962 | |
| 4963 | /* Record the Successful match. */ |
| 4964 | if (!gfc_merge_new_implicit (&ts)) |
| 4965 | return MATCH_ERROR; |
| 4966 | if (c == ',') |
| 4967 | c = gfc_next_ascii_char (); |
| 4968 | else if (gfc_match_eos () == MATCH_ERROR) |
| 4969 | goto error; |
| 4970 | continue; |
| 4971 | } |
| 4972 | |
| 4973 | gfc_current_locus = cur_loc; |
| 4974 | } |
| 4975 | |
| 4976 | /* Discard the (incorrectly) matched range. */ |
| 4977 | gfc_clear_new_implicit (); |
| 4978 | |
| 4979 | /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */ |
| 4980 | if (ts.type == BT_CHARACTER) |
| 4981 | m = gfc_match_char_spec (&ts); |
| 4982 | else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL) |
| 4983 | { |
| 4984 | m = gfc_match_kind_spec (&ts, false); |
| 4985 | if (m == MATCH_NO) |
| 4986 | { |
| 4987 | m = gfc_match_old_kind_spec (&ts); |
| 4988 | if (m == MATCH_ERROR) |
| 4989 | goto error; |
| 4990 | if (m == MATCH_NO) |
| 4991 | goto syntax; |
| 4992 | } |
| 4993 | } |
| 4994 | if (m == MATCH_ERROR) |
| 4995 | goto error; |
| 4996 | |
| 4997 | m = match_implicit_range (); |
| 4998 | if (m == MATCH_ERROR) |
| 4999 | goto error; |
| 5000 | if (m == MATCH_NO) |
| 5001 | goto syntax; |
| 5002 | |
| 5003 | gfc_gobble_whitespace (); |
| 5004 | c = gfc_next_ascii_char (); |
| 5005 | if (c != ',' && gfc_match_eos () != MATCH_YES) |
| 5006 | goto syntax; |
| 5007 | |
| 5008 | if (!gfc_merge_new_implicit (&ts)) |
| 5009 | return MATCH_ERROR; |
| 5010 | } |
| 5011 | while (c == ','); |
| 5012 | |
| 5013 | return MATCH_YES; |
| 5014 | |
| 5015 | syntax: |
| 5016 | gfc_syntax_error (ST_IMPLICIT)gfc_error ("Syntax error in %s statement at %C", gfc_ascii_statement (ST_IMPLICIT));; |
| 5017 | |
| 5018 | error: |
| 5019 | return MATCH_ERROR; |
| 5020 | } |
| 5021 | |
| 5022 | |
| 5023 | match |
| 5024 | gfc_match_import (void) |
| 5025 | { |
| 5026 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 5027 | match m; |
| 5028 | gfc_symbol *sym; |
| 5029 | gfc_symtree *st; |
| 5030 | |
| 5031 | if (gfc_current_ns->proc_name == NULL__null |
| 5032 | || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY) |
| 5033 | { |
| 5034 | gfc_error ("IMPORT statement at %C only permitted in " |
| 5035 | "an INTERFACE body"); |
| 5036 | return MATCH_ERROR; |
| 5037 | } |
| 5038 | |
| 5039 | if (gfc_current_ns->proc_name->attr.module_procedure) |
| 5040 | { |
| 5041 | gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted " |
| 5042 | "in a module procedure interface body"); |
| 5043 | return MATCH_ERROR; |
| 5044 | } |
| 5045 | |
| 5046 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "IMPORT statement at %C")) |
| 5047 | return MATCH_ERROR; |
| 5048 | |
| 5049 | if (gfc_match_eos () == MATCH_YES) |
| 5050 | { |
| 5051 | /* All host variables should be imported. */ |
| 5052 | gfc_current_ns->has_import_set = 1; |
| 5053 | return MATCH_YES; |
| 5054 | } |
| 5055 | |
| 5056 | if (gfc_match (" ::") == MATCH_YES) |
| 5057 | { |
| 5058 | if (gfc_match_eos () == MATCH_YES) |
| 5059 | { |
| 5060 | gfc_error ("Expecting list of named entities at %C"); |
| 5061 | return MATCH_ERROR; |
| 5062 | } |
| 5063 | } |
| 5064 | |
| 5065 | for(;;) |
| 5066 | { |
| 5067 | sym = NULL__null; |
| 5068 | m = gfc_match (" %n", name); |
| 5069 | switch (m) |
| 5070 | { |
| 5071 | case MATCH_YES: |
| 5072 | if (gfc_current_ns->parent != NULL__null |
| 5073 | && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym)) |
| 5074 | { |
| 5075 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 5076 | return MATCH_ERROR; |
| 5077 | } |
| 5078 | else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL__null |
| 5079 | && gfc_find_symbol (name, |
| 5080 | gfc_current_ns->proc_name->ns->parent, |
| 5081 | 1, &sym)) |
| 5082 | { |
| 5083 | gfc_error ("Type name %qs at %C is ambiguous", name); |
| 5084 | return MATCH_ERROR; |
| 5085 | } |
| 5086 | |
| 5087 | if (sym == NULL__null) |
| 5088 | { |
| 5089 | gfc_error ("Cannot IMPORT %qs from host scoping unit " |
| 5090 | "at %C - does not exist.", name); |
| 5091 | return MATCH_ERROR; |
| 5092 | } |
| 5093 | |
| 5094 | if (gfc_find_symtree (gfc_current_ns->sym_root, name)) |
| 5095 | { |
| 5096 | gfc_warning (0, "%qs is already IMPORTed from host scoping unit " |
| 5097 | "at %C", name); |
| 5098 | goto next_item; |
| 5099 | } |
| 5100 | |
| 5101 | st = gfc_new_symtree (&gfc_current_ns->sym_root, name); |
| 5102 | st->n.sym = sym; |
| 5103 | sym->refs++; |
| 5104 | sym->attr.imported = 1; |
| 5105 | |
| 5106 | if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym))) |
| 5107 | { |
| 5108 | /* The actual derived type is stored in a symtree with the first |
| 5109 | letter of the name capitalized; the symtree with the all |
| 5110 | lower-case name contains the associated generic function. */ |
| 5111 | st = gfc_new_symtree (&gfc_current_ns->sym_root, |
| 5112 | gfc_dt_upper_string (name)); |
| 5113 | st->n.sym = sym; |
| 5114 | sym->refs++; |
| 5115 | sym->attr.imported = 1; |
| 5116 | } |
| 5117 | |
| 5118 | goto next_item; |
| 5119 | |
| 5120 | case MATCH_NO: |
| 5121 | break; |
| 5122 | |
| 5123 | case MATCH_ERROR: |
| 5124 | return MATCH_ERROR; |
| 5125 | } |
| 5126 | |
| 5127 | next_item: |
| 5128 | if (gfc_match_eos () == MATCH_YES) |
| 5129 | break; |
| 5130 | if (gfc_match_char (',') != MATCH_YES) |
| 5131 | goto syntax; |
| 5132 | } |
| 5133 | |
| 5134 | return MATCH_YES; |
| 5135 | |
| 5136 | syntax: |
| 5137 | gfc_error ("Syntax error in IMPORT statement at %C"); |
| 5138 | return MATCH_ERROR; |
| 5139 | } |
| 5140 | |
| 5141 | |
| 5142 | /* A minimal implementation of gfc_match without whitespace, escape |
| 5143 | characters or variable arguments. Returns true if the next |
| 5144 | characters match the TARGET template exactly. */ |
| 5145 | |
| 5146 | static bool |
| 5147 | match_string_p (const char *target) |
| 5148 | { |
| 5149 | const char *p; |
| 5150 | |
| 5151 | for (p = target; *p; p++) |
| 5152 | if ((char) gfc_next_ascii_char () != *p) |
| 5153 | return false; |
| 5154 | return true; |
| 5155 | } |
| 5156 | |
| 5157 | /* Matches an attribute specification including array specs. If |
| 5158 | successful, leaves the variables current_attr and current_as |
| 5159 | holding the specification. Also sets the colon_seen variable for |
| 5160 | later use by matchers associated with initializations. |
| 5161 | |
| 5162 | This subroutine is a little tricky in the sense that we don't know |
| 5163 | if we really have an attr-spec until we hit the double colon. |
| 5164 | Until that time, we can only return MATCH_NO. This forces us to |
| 5165 | check for duplicate specification at this level. */ |
| 5166 | |
| 5167 | static match |
| 5168 | match_attr_spec (void) |
| 5169 | { |
| 5170 | /* Modifiers that can exist in a type statement. */ |
| 5171 | enum |
| 5172 | { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN, |
| 5173 | DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT, |
| 5174 | DECL_DIMENSION, DECL_EXTERNAL, |
| 5175 | DECL_INTRINSIC, DECL_OPTIONAL, |
| 5176 | DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, |
| 5177 | DECL_STATIC, DECL_AUTOMATIC, |
| 5178 | DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, |
| 5179 | DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS, |
| 5180 | DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */ |
| 5181 | }; |
| 5182 | |
| 5183 | /* GFC_DECL_END is the sentinel, index starts at 0. */ |
| 5184 | #define NUM_DECLGFC_DECL_END GFC_DECL_END |
| 5185 | |
| 5186 | /* Make sure that values from sym_intent are safe to be used here. */ |
| 5187 | gcc_assert (INTENT_IN > 0)((void)(!(INTENT_IN > 0) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 5187, __FUNCTION__), 0 : 0)); |
| 5188 | |
| 5189 | locus start, seen_at[NUM_DECLGFC_DECL_END]; |
| 5190 | int seen[NUM_DECLGFC_DECL_END]; |
| 5191 | unsigned int d; |
| 5192 | const char *attr; |
| 5193 | match m; |
| 5194 | bool t; |
| 5195 | |
| 5196 | gfc_clear_attr (¤t_attr); |
| 5197 | start = gfc_current_locus; |
| 5198 | |
| 5199 | current_as = NULL__null; |
| 5200 | colon_seen = 0; |
| 5201 | attr_seen = 0; |
| 5202 | |
| 5203 | /* See if we get all of the keywords up to the final double colon. */ |
| 5204 | for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) |
| 5205 | seen[d] = 0; |
| 5206 | |
| 5207 | for (;;) |
| 5208 | { |
| 5209 | char ch; |
| 5210 | |
| 5211 | d = DECL_NONE; |
| 5212 | gfc_gobble_whitespace (); |
| 5213 | |
| 5214 | ch = gfc_next_ascii_char (); |
| 5215 | if (ch == ':') |
| 5216 | { |
| 5217 | /* This is the successful exit condition for the loop. */ |
| 5218 | if (gfc_next_ascii_char () == ':') |
| 5219 | break; |
| 5220 | } |
| 5221 | else if (ch == ',') |
| 5222 | { |
| 5223 | gfc_gobble_whitespace (); |
| 5224 | switch (gfc_peek_ascii_char ()) |
| 5225 | { |
| 5226 | case 'a': |
| 5227 | gfc_next_ascii_char (); |
| 5228 | switch (gfc_next_ascii_char ()) |
| 5229 | { |
| 5230 | case 'l': |
| 5231 | if (match_string_p ("locatable")) |
| 5232 | { |
| 5233 | /* Matched "allocatable". */ |
| 5234 | d = DECL_ALLOCATABLE; |
| 5235 | } |
| 5236 | break; |
| 5237 | |
| 5238 | case 's': |
| 5239 | if (match_string_p ("ynchronous")) |
| 5240 | { |
| 5241 | /* Matched "asynchronous". */ |
| 5242 | d = DECL_ASYNCHRONOUS; |
| 5243 | } |
| 5244 | break; |
| 5245 | |
| 5246 | case 'u': |
| 5247 | if (match_string_p ("tomatic")) |
| 5248 | { |
| 5249 | /* Matched "automatic". */ |
| 5250 | d = DECL_AUTOMATIC; |
| 5251 | } |
| 5252 | break; |
| 5253 | } |
| 5254 | break; |
| 5255 | |
| 5256 | case 'b': |
| 5257 | /* Try and match the bind(c). */ |
| 5258 | m = gfc_match_bind_c (NULL__null, true); |
| 5259 | if (m == MATCH_YES) |
| 5260 | d = DECL_IS_BIND_C; |
| 5261 | else if (m == MATCH_ERROR) |
| 5262 | goto cleanup; |
| 5263 | break; |
| 5264 | |
| 5265 | case 'c': |
| 5266 | gfc_next_ascii_char (); |
| 5267 | if ('o' != gfc_next_ascii_char ()) |
| 5268 | break; |
| 5269 | switch (gfc_next_ascii_char ()) |
| 5270 | { |
| 5271 | case 'd': |
| 5272 | if (match_string_p ("imension")) |
| 5273 | { |
| 5274 | d = DECL_CODIMENSION; |
| 5275 | break; |
| 5276 | } |
| 5277 | /* FALLTHRU */ |
| 5278 | case 'n': |
| 5279 | if (match_string_p ("tiguous")) |
| 5280 | { |
| 5281 | d = DECL_CONTIGUOUS; |
| 5282 | break; |
| 5283 | } |
| 5284 | } |
| 5285 | break; |
| 5286 | |
| 5287 | case 'd': |
| 5288 | if (match_string_p ("dimension")) |
| 5289 | d = DECL_DIMENSION; |
| 5290 | break; |
| 5291 | |
| 5292 | case 'e': |
| 5293 | if (match_string_p ("external")) |
| 5294 | d = DECL_EXTERNAL; |
| 5295 | break; |
| 5296 | |
| 5297 | case 'i': |
| 5298 | if (match_string_p ("int")) |
| 5299 | { |
| 5300 | ch = gfc_next_ascii_char (); |
| 5301 | if (ch == 'e') |
| 5302 | { |
| 5303 | if (match_string_p ("nt")) |
| 5304 | { |
| 5305 | /* Matched "intent". */ |
| 5306 | d = match_intent_spec (); |
| 5307 | if (d == INTENT_UNKNOWN) |
| 5308 | { |
| 5309 | m = MATCH_ERROR; |
| 5310 | goto cleanup; |
| 5311 | } |
| 5312 | } |
| 5313 | } |
| 5314 | else if (ch == 'r') |
| 5315 | { |
| 5316 | if (match_string_p ("insic")) |
| 5317 | { |
| 5318 | /* Matched "intrinsic". */ |
| 5319 | d = DECL_INTRINSIC; |
| 5320 | } |
| 5321 | } |
| 5322 | } |
| 5323 | break; |
| 5324 | |
| 5325 | case 'k': |
| 5326 | if (match_string_p ("kind")) |
| 5327 | d = DECL_KIND; |
| 5328 | break; |
| 5329 | |
| 5330 | case 'l': |
| 5331 | if (match_string_p ("len")) |
| 5332 | d = DECL_LEN; |
| 5333 | break; |
| 5334 | |
| 5335 | case 'o': |
| 5336 | if (match_string_p ("optional")) |
| 5337 | d = DECL_OPTIONAL; |
| 5338 | break; |
| 5339 | |
| 5340 | case 'p': |
| 5341 | gfc_next_ascii_char (); |
| 5342 | switch (gfc_next_ascii_char ()) |
| 5343 | { |
| 5344 | case 'a': |
| 5345 | if (match_string_p ("rameter")) |
| 5346 | { |
| 5347 | /* Matched "parameter". */ |
| 5348 | d = DECL_PARAMETER; |
| 5349 | } |
| 5350 | break; |
| 5351 | |
| 5352 | case 'o': |
| 5353 | if (match_string_p ("inter")) |
| 5354 | { |
| 5355 | /* Matched "pointer". */ |
| 5356 | d = DECL_POINTER; |
| 5357 | } |
| 5358 | break; |
| 5359 | |
| 5360 | case 'r': |
| 5361 | ch = gfc_next_ascii_char (); |
| 5362 | if (ch == 'i') |
| 5363 | { |
| 5364 | if (match_string_p ("vate")) |
| 5365 | { |
| 5366 | /* Matched "private". */ |
| 5367 | d = DECL_PRIVATE; |
| 5368 | } |
| 5369 | } |
| 5370 | else if (ch == 'o') |
| 5371 | { |
| 5372 | if (match_string_p ("tected")) |
| 5373 | { |
| 5374 | /* Matched "protected". */ |
| 5375 | d = DECL_PROTECTED; |
| 5376 | } |
| 5377 | } |
| 5378 | break; |
| 5379 | |
| 5380 | case 'u': |
| 5381 | if (match_string_p ("blic")) |
| 5382 | { |
| 5383 | /* Matched "public". */ |
| 5384 | d = DECL_PUBLIC; |
| 5385 | } |
| 5386 | break; |
| 5387 | } |
| 5388 | break; |
| 5389 | |
| 5390 | case 's': |
| 5391 | gfc_next_ascii_char (); |
| 5392 | switch (gfc_next_ascii_char ()) |
| 5393 | { |
| 5394 | case 'a': |
| 5395 | if (match_string_p ("ve")) |
| 5396 | { |
| 5397 | /* Matched "save". */ |
| 5398 | d = DECL_SAVE; |
| 5399 | } |
| 5400 | break; |
| 5401 | |
| 5402 | case 't': |
| 5403 | if (match_string_p ("atic")) |
| 5404 | { |
| 5405 | /* Matched "static". */ |
| 5406 | d = DECL_STATIC; |
| 5407 | } |
| 5408 | break; |
| 5409 | } |
| 5410 | break; |
| 5411 | |
| 5412 | case 't': |
| 5413 | if (match_string_p ("target")) |
| 5414 | d = DECL_TARGET; |
| 5415 | break; |
| 5416 | |
| 5417 | case 'v': |
| 5418 | gfc_next_ascii_char (); |
| 5419 | ch = gfc_next_ascii_char (); |
| 5420 | if (ch == 'a') |
| 5421 | { |
| 5422 | if (match_string_p ("lue")) |
| 5423 | { |
| 5424 | /* Matched "value". */ |
| 5425 | d = DECL_VALUE; |
| 5426 | } |
| 5427 | } |
| 5428 | else if (ch == 'o') |
| 5429 | { |
| 5430 | if (match_string_p ("latile")) |
| 5431 | { |
| 5432 | /* Matched "volatile". */ |
| 5433 | d = DECL_VOLATILE; |
| 5434 | } |
| 5435 | } |
| 5436 | break; |
| 5437 | } |
| 5438 | } |
| 5439 | |
| 5440 | /* No double colon and no recognizable decl_type, so assume that |
| 5441 | we've been looking at something else the whole time. */ |
| 5442 | if (d == DECL_NONE) |
| 5443 | { |
| 5444 | m = MATCH_NO; |
| 5445 | goto cleanup; |
| 5446 | } |
| 5447 | |
| 5448 | /* Check to make sure any parens are paired up correctly. */ |
| 5449 | if (gfc_match_parens () == MATCH_ERROR) |
| 5450 | { |
| 5451 | m = MATCH_ERROR; |
| 5452 | goto cleanup; |
| 5453 | } |
| 5454 | |
| 5455 | seen[d]++; |
| 5456 | seen_at[d] = gfc_current_locus; |
| 5457 | |
| 5458 | if (d == DECL_DIMENSION || d == DECL_CODIMENSION) |
| 5459 | { |
| 5460 | gfc_array_spec *as = NULL__null; |
| 5461 | |
| 5462 | m = gfc_match_array_spec (&as, d == DECL_DIMENSION, |
| 5463 | d == DECL_CODIMENSION); |
| 5464 | |
| 5465 | if (current_as == NULL__null) |
| 5466 | current_as = as; |
| 5467 | else if (m == MATCH_YES) |
| 5468 | { |
| 5469 | if (!merge_array_spec (as, current_as, false)) |
| 5470 | m = MATCH_ERROR; |
| 5471 | free (as); |
| 5472 | } |
| 5473 | |
| 5474 | if (m == MATCH_NO) |
| 5475 | { |
| 5476 | if (d == DECL_CODIMENSION) |
| 5477 | gfc_error ("Missing codimension specification at %C"); |
| 5478 | else |
| 5479 | gfc_error ("Missing dimension specification at %C"); |
| 5480 | m = MATCH_ERROR; |
| 5481 | } |
| 5482 | |
| 5483 | if (m == MATCH_ERROR) |
| 5484 | goto cleanup; |
| 5485 | } |
| 5486 | } |
| 5487 | |
| 5488 | /* Since we've seen a double colon, we have to be looking at an |
| 5489 | attr-spec. This means that we can now issue errors. */ |
| 5490 | for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) |
| 5491 | if (seen[d] > 1) |
| 5492 | { |
| 5493 | switch (d) |
| 5494 | { |
| 5495 | case DECL_ALLOCATABLE: |
| 5496 | attr = "ALLOCATABLE"; |
| 5497 | break; |
| 5498 | case DECL_ASYNCHRONOUS: |
| 5499 | attr = "ASYNCHRONOUS"; |
| 5500 | break; |
| 5501 | case DECL_CODIMENSION: |
| 5502 | attr = "CODIMENSION"; |
| 5503 | break; |
| 5504 | case DECL_CONTIGUOUS: |
| 5505 | attr = "CONTIGUOUS"; |
| 5506 | break; |
| 5507 | case DECL_DIMENSION: |
| 5508 | attr = "DIMENSION"; |
| 5509 | break; |
| 5510 | case DECL_EXTERNAL: |
| 5511 | attr = "EXTERNAL"; |
| 5512 | break; |
| 5513 | case DECL_IN: |
| 5514 | attr = "INTENT (IN)"; |
| 5515 | break; |
| 5516 | case DECL_OUT: |
| 5517 | attr = "INTENT (OUT)"; |
| 5518 | break; |
| 5519 | case DECL_INOUT: |
| 5520 | attr = "INTENT (IN OUT)"; |
| 5521 | break; |
| 5522 | case DECL_INTRINSIC: |
| 5523 | attr = "INTRINSIC"; |
| 5524 | break; |
| 5525 | case DECL_OPTIONAL: |
| 5526 | attr = "OPTIONAL"; |
| 5527 | break; |
| 5528 | case DECL_KIND: |
| 5529 | attr = "KIND"; |
| 5530 | break; |
| 5531 | case DECL_LEN: |
| 5532 | attr = "LEN"; |
| 5533 | break; |
| 5534 | case DECL_PARAMETER: |
| 5535 | attr = "PARAMETER"; |
| 5536 | break; |
| 5537 | case DECL_POINTER: |
| 5538 | attr = "POINTER"; |
| 5539 | break; |
| 5540 | case DECL_PROTECTED: |
| 5541 | attr = "PROTECTED"; |
| 5542 | break; |
| 5543 | case DECL_PRIVATE: |
| 5544 | attr = "PRIVATE"; |
| 5545 | break; |
| 5546 | case DECL_PUBLIC: |
| 5547 | attr = "PUBLIC"; |
| 5548 | break; |
| 5549 | case DECL_SAVE: |
| 5550 | attr = "SAVE"; |
| 5551 | break; |
| 5552 | case DECL_STATIC: |
| 5553 | attr = "STATIC"; |
| 5554 | break; |
| 5555 | case DECL_AUTOMATIC: |
| 5556 | attr = "AUTOMATIC"; |
| 5557 | break; |
| 5558 | case DECL_TARGET: |
| 5559 | attr = "TARGET"; |
| 5560 | break; |
| 5561 | case DECL_IS_BIND_C: |
| 5562 | attr = "IS_BIND_C"; |
| 5563 | break; |
| 5564 | case DECL_VALUE: |
| 5565 | attr = "VALUE"; |
| 5566 | break; |
| 5567 | case DECL_VOLATILE: |
| 5568 | attr = "VOLATILE"; |
| 5569 | break; |
| 5570 | default: |
| 5571 | attr = NULL__null; /* This shouldn't happen. */ |
| 5572 | } |
| 5573 | |
| 5574 | gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]); |
| 5575 | m = MATCH_ERROR; |
| 5576 | goto cleanup; |
| 5577 | } |
| 5578 | |
| 5579 | /* Now that we've dealt with duplicate attributes, add the attributes |
| 5580 | to the current attribute. */ |
| 5581 | for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++) |
| 5582 | { |
| 5583 | if (seen[d] == 0) |
| 5584 | continue; |
| 5585 | else |
| 5586 | attr_seen = 1; |
| 5587 | |
| 5588 | if ((d == DECL_STATIC || d == DECL_AUTOMATIC) |
| 5589 | && !flag_dec_staticglobal_options.x_flag_dec_static) |
| 5590 | { |
| 5591 | gfc_error ("%s at %L is a DEC extension, enable with " |
| 5592 | "%<-fdec-static%>", |
| 5593 | d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]); |
| 5594 | m = MATCH_ERROR; |
| 5595 | goto cleanup; |
| 5596 | } |
| 5597 | /* Allow SAVE with STATIC, but don't complain. */ |
| 5598 | if (d == DECL_STATIC && seen[DECL_SAVE]) |
| 5599 | continue; |
| 5600 | |
| 5601 | if (gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP) |
| 5602 | && d != DECL_DIMENSION && d != DECL_CODIMENSION |
| 5603 | && d != DECL_POINTER && d != DECL_PRIVATE |
| 5604 | && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE) |
| 5605 | { |
| 5606 | bool is_derived = gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED; |
| 5607 | if (d == DECL_ALLOCATABLE) |
| 5608 | { |
| 5609 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived |
| 5610 | ? G_("ALLOCATABLE attribute at %C in a ""ALLOCATABLE attribute at %C in a " "TYPE definition" |
| 5611 | "TYPE definition")"ALLOCATABLE attribute at %C in a " "TYPE definition" |
| 5612 | : G_("ALLOCATABLE attribute at %C in a ""ALLOCATABLE attribute at %C in a " "STRUCTURE definition" |
| 5613 | "STRUCTURE definition")"ALLOCATABLE attribute at %C in a " "STRUCTURE definition")) |
| 5614 | { |
| 5615 | m = MATCH_ERROR; |
| 5616 | goto cleanup; |
| 5617 | } |
| 5618 | } |
| 5619 | else if (d == DECL_KIND) |
| 5620 | { |
| 5621 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived |
| 5622 | ? G_("KIND attribute at %C in a ""KIND attribute at %C in a " "TYPE definition" |
| 5623 | "TYPE definition")"KIND attribute at %C in a " "TYPE definition" |
| 5624 | : G_("KIND attribute at %C in a ""KIND attribute at %C in a " "STRUCTURE definition" |
| 5625 | "STRUCTURE definition")"KIND attribute at %C in a " "STRUCTURE definition")) |
| 5626 | { |
| 5627 | m = MATCH_ERROR; |
| 5628 | goto cleanup; |
| 5629 | } |
| 5630 | if (current_ts.type != BT_INTEGER) |
| 5631 | { |
| 5632 | gfc_error ("Component with KIND attribute at %C must be " |
| 5633 | "INTEGER"); |
| 5634 | m = MATCH_ERROR; |
| 5635 | goto cleanup; |
| 5636 | } |
| 5637 | } |
| 5638 | else if (d == DECL_LEN) |
| 5639 | { |
| 5640 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), is_derived |
| 5641 | ? G_("LEN attribute at %C in a ""LEN attribute at %C in a " "TYPE definition" |
| 5642 | "TYPE definition")"LEN attribute at %C in a " "TYPE definition" |
| 5643 | : G_("LEN attribute at %C in a ""LEN attribute at %C in a " "STRUCTURE definition" |
| 5644 | "STRUCTURE definition")"LEN attribute at %C in a " "STRUCTURE definition")) |
| 5645 | { |
| 5646 | m = MATCH_ERROR; |
| 5647 | goto cleanup; |
| 5648 | } |
| 5649 | if (current_ts.type != BT_INTEGER) |
| 5650 | { |
| 5651 | gfc_error ("Component with LEN attribute at %C must be " |
| 5652 | "INTEGER"); |
| 5653 | m = MATCH_ERROR; |
| 5654 | goto cleanup; |
| 5655 | } |
| 5656 | } |
| 5657 | else |
| 5658 | { |
| 5659 | gfc_error (is_derived ? G_("Attribute at %L is not allowed in a ""Attribute at %L is not allowed in a " "TYPE definition" |
| 5660 | "TYPE definition")"Attribute at %L is not allowed in a " "TYPE definition" |
| 5661 | : G_("Attribute at %L is not allowed in a ""Attribute at %L is not allowed in a " "STRUCTURE definition" |
| 5662 | "STRUCTURE definition")"Attribute at %L is not allowed in a " "STRUCTURE definition", &seen_at[d]); |
| 5663 | m = MATCH_ERROR; |
| 5664 | goto cleanup; |
| 5665 | } |
| 5666 | } |
| 5667 | |
| 5668 | if ((d == DECL_PRIVATE || d == DECL_PUBLIC) |
| 5669 | && gfc_current_state ()(gfc_state_stack->state) != COMP_MODULE) |
| 5670 | { |
| 5671 | if (d == DECL_PRIVATE) |
| 5672 | attr = "PRIVATE"; |
| 5673 | else |
| 5674 | attr = "PUBLIC"; |
| 5675 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED |
| 5676 | && gfc_state_stack->previous |
| 5677 | && gfc_state_stack->previous->state == COMP_MODULE) |
| 5678 | { |
| 5679 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Attribute %s " |
| 5680 | "at %L in a TYPE definition", attr, |
| 5681 | &seen_at[d])) |
| 5682 | { |
| 5683 | m = MATCH_ERROR; |
| 5684 | goto cleanup; |
| 5685 | } |
| 5686 | } |
| 5687 | else |
| 5688 | { |
| 5689 | gfc_error ("%s attribute at %L is not allowed outside of the " |
| 5690 | "specification part of a module", attr, &seen_at[d]); |
| 5691 | m = MATCH_ERROR; |
| 5692 | goto cleanup; |
| 5693 | } |
| 5694 | } |
| 5695 | |
| 5696 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_DERIVED |
| 5697 | && (d == DECL_KIND || d == DECL_LEN)) |
| 5698 | { |
| 5699 | gfc_error ("Attribute at %L is not allowed outside a TYPE " |
| 5700 | "definition", &seen_at[d]); |
| 5701 | m = MATCH_ERROR; |
| 5702 | goto cleanup; |
| 5703 | } |
| 5704 | |
| 5705 | switch (d) |
| 5706 | { |
| 5707 | case DECL_ALLOCATABLE: |
| 5708 | t = gfc_add_allocatable (¤t_attr, &seen_at[d]); |
| 5709 | break; |
| 5710 | |
| 5711 | case DECL_ASYNCHRONOUS: |
| 5712 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "ASYNCHRONOUS attribute at %C")) |
| 5713 | t = false; |
| 5714 | else |
| 5715 | t = gfc_add_asynchronous (¤t_attr, NULL__null, &seen_at[d]); |
| 5716 | break; |
| 5717 | |
| 5718 | case DECL_CODIMENSION: |
| 5719 | t = gfc_add_codimension (¤t_attr, NULL__null, &seen_at[d]); |
| 5720 | break; |
| 5721 | |
| 5722 | case DECL_CONTIGUOUS: |
| 5723 | if (!gfc_notify_std (GFC_STD_F2008(1<<7), "CONTIGUOUS attribute at %C")) |
| 5724 | t = false; |
| 5725 | else |
| 5726 | t = gfc_add_contiguous (¤t_attr, NULL__null, &seen_at[d]); |
| 5727 | break; |
| 5728 | |
| 5729 | case DECL_DIMENSION: |
| 5730 | t = gfc_add_dimension (¤t_attr, NULL__null, &seen_at[d]); |
| 5731 | break; |
| 5732 | |
| 5733 | case DECL_EXTERNAL: |
| 5734 | t = gfc_add_external (¤t_attr, &seen_at[d]); |
| 5735 | break; |
| 5736 | |
| 5737 | case DECL_IN: |
| 5738 | t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]); |
| 5739 | break; |
| 5740 | |
| 5741 | case DECL_OUT: |
| 5742 | t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]); |
| 5743 | break; |
| 5744 | |
| 5745 | case DECL_INOUT: |
| 5746 | t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]); |
| 5747 | break; |
| 5748 | |
| 5749 | case DECL_INTRINSIC: |
| 5750 | t = gfc_add_intrinsic (¤t_attr, &seen_at[d]); |
| 5751 | break; |
| 5752 | |
| 5753 | case DECL_OPTIONAL: |
| 5754 | t = gfc_add_optional (¤t_attr, &seen_at[d]); |
| 5755 | break; |
| 5756 | |
| 5757 | case DECL_KIND: |
| 5758 | t = gfc_add_kind (¤t_attr, &seen_at[d]); |
| 5759 | break; |
| 5760 | |
| 5761 | case DECL_LEN: |
| 5762 | t = gfc_add_len (¤t_attr, &seen_at[d]); |
| 5763 | break; |
| 5764 | |
| 5765 | case DECL_PARAMETER: |
| 5766 | t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL__null, &seen_at[d]); |
| 5767 | break; |
| 5768 | |
| 5769 | case DECL_POINTER: |
| 5770 | t = gfc_add_pointer (¤t_attr, &seen_at[d]); |
| 5771 | break; |
| 5772 | |
| 5773 | case DECL_PROTECTED: |
| 5774 | if (gfc_current_state ()(gfc_state_stack->state) != COMP_MODULE |
| 5775 | || (gfc_current_ns->proc_name |
| 5776 | && gfc_current_ns->proc_name->attr.flavor != FL_MODULE)) |
| 5777 | { |
| 5778 | gfc_error ("PROTECTED at %C only allowed in specification " |
| 5779 | "part of a module"); |
| 5780 | t = false; |
| 5781 | break; |
| 5782 | } |
| 5783 | |
| 5784 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "PROTECTED attribute at %C")) |
| 5785 | t = false; |
| 5786 | else |
| 5787 | t = gfc_add_protected (¤t_attr, NULL__null, &seen_at[d]); |
| 5788 | break; |
| 5789 | |
| 5790 | case DECL_PRIVATE: |
| 5791 | t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL__null, |
| 5792 | &seen_at[d]); |
| 5793 | break; |
| 5794 | |
| 5795 | case DECL_PUBLIC: |
| 5796 | t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL__null, |
| 5797 | &seen_at[d]); |
| 5798 | break; |
| 5799 | |
| 5800 | case DECL_STATIC: |
| 5801 | case DECL_SAVE: |
| 5802 | t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL__null, &seen_at[d]); |
| 5803 | break; |
| 5804 | |
| 5805 | case DECL_AUTOMATIC: |
| 5806 | t = gfc_add_automatic (¤t_attr, NULL__null, &seen_at[d]); |
| 5807 | break; |
| 5808 | |
| 5809 | case DECL_TARGET: |
| 5810 | t = gfc_add_target (¤t_attr, &seen_at[d]); |
| 5811 | break; |
| 5812 | |
| 5813 | case DECL_IS_BIND_C: |
| 5814 | t = gfc_add_is_bind_c(¤t_attr, NULL__null, &seen_at[d], 0); |
| 5815 | break; |
| 5816 | |
| 5817 | case DECL_VALUE: |
| 5818 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "VALUE attribute at %C")) |
| 5819 | t = false; |
| 5820 | else |
| 5821 | t = gfc_add_value (¤t_attr, NULL__null, &seen_at[d]); |
| 5822 | break; |
| 5823 | |
| 5824 | case DECL_VOLATILE: |
| 5825 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "VOLATILE attribute at %C")) |
| 5826 | t = false; |
| 5827 | else |
| 5828 | t = gfc_add_volatile (¤t_attr, NULL__null, &seen_at[d]); |
| 5829 | break; |
| 5830 | |
| 5831 | default: |
| 5832 | gfc_internal_error ("match_attr_spec(): Bad attribute"); |
| 5833 | } |
| 5834 | |
| 5835 | if (!t) |
| 5836 | { |
| 5837 | m = MATCH_ERROR; |
| 5838 | goto cleanup; |
| 5839 | } |
| 5840 | } |
| 5841 | |
| 5842 | /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */ |
| 5843 | if ((gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE |
| 5844 | || gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE) |
| 5845 | && !current_attr.save |
| 5846 | && (gfc_option.allow_std & GFC_STD_F2008(1<<7)) != 0) |
| 5847 | current_attr.save = SAVE_IMPLICIT; |
| 5848 | |
| 5849 | colon_seen = 1; |
| 5850 | return MATCH_YES; |
| 5851 | |
| 5852 | cleanup: |
| 5853 | gfc_current_locus = start; |
| 5854 | gfc_free_array_spec (current_as); |
| 5855 | current_as = NULL__null; |
| 5856 | attr_seen = 0; |
| 5857 | return m; |
| 5858 | } |
| 5859 | |
| 5860 | |
| 5861 | /* Set the binding label, dest_label, either with the binding label |
| 5862 | stored in the given gfc_typespec, ts, or if none was provided, it |
| 5863 | will be the symbol name in all lower case, as required by the draft |
| 5864 | (J3/04-007, section 15.4.1). If a binding label was given and |
| 5865 | there is more than one argument (num_idents), it is an error. */ |
| 5866 | |
| 5867 | static bool |
| 5868 | set_binding_label (const char **dest_label, const char *sym_name, |
| 5869 | int num_idents) |
| 5870 | { |
| 5871 | if (num_idents > 1 && has_name_equals) |
| 5872 | { |
| 5873 | gfc_error ("Multiple identifiers provided with " |
| 5874 | "single NAME= specifier at %C"); |
| 5875 | return false; |
| 5876 | } |
| 5877 | |
| 5878 | if (curr_binding_label) |
| 5879 | /* Binding label given; store in temp holder till have sym. */ |
| 5880 | *dest_label = curr_binding_label; |
| 5881 | else |
| 5882 | { |
| 5883 | /* No binding label given, and the NAME= specifier did not exist, |
| 5884 | which means there was no NAME="". */ |
| 5885 | if (sym_name != NULL__null && has_name_equals == 0) |
| 5886 | *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name))((const char *) (tree_check (((__builtin_constant_p (sym_name ) ? get_identifier_with_length ((sym_name), strlen (sym_name) ) : get_identifier (sym_name))), "/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 5886, __FUNCTION__, (IDENTIFIER_NODE)))->identifier.id.str ); |
| 5887 | } |
| 5888 | |
| 5889 | return true; |
| 5890 | } |
| 5891 | |
| 5892 | |
| 5893 | /* Set the status of the given common block as being BIND(C) or not, |
| 5894 | depending on the given parameter, is_bind_c. */ |
| 5895 | |
| 5896 | static void |
| 5897 | set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c) |
| 5898 | { |
| 5899 | com_block->is_bind_c = is_bind_c; |
| 5900 | return; |
| 5901 | } |
| 5902 | |
| 5903 | |
| 5904 | /* Verify that the given gfc_typespec is for a C interoperable type. */ |
| 5905 | |
| 5906 | bool |
| 5907 | gfc_verify_c_interop (gfc_typespec *ts) |
| 5908 | { |
| 5909 | if (ts->type == BT_DERIVED && ts->u.derived != NULL__null) |
| 5910 | return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c) |
| 5911 | ? true : false; |
| 5912 | else if (ts->type == BT_CLASS) |
| 5913 | return false; |
| 5914 | else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED) |
| 5915 | return false; |
| 5916 | |
| 5917 | return true; |
| 5918 | } |
| 5919 | |
| 5920 | |
| 5921 | /* Verify that the variables of a given common block, which has been |
| 5922 | defined with the attribute specifier bind(c), to be of a C |
| 5923 | interoperable type. Errors will be reported here, if |
| 5924 | encountered. */ |
| 5925 | |
| 5926 | bool |
| 5927 | verify_com_block_vars_c_interop (gfc_common_head *com_block) |
| 5928 | { |
| 5929 | gfc_symbol *curr_sym = NULL__null; |
| 5930 | bool retval = true; |
| 5931 | |
| 5932 | curr_sym = com_block->head; |
| 5933 | |
| 5934 | /* Make sure we have at least one symbol. */ |
| 5935 | if (curr_sym == NULL__null) |
| 5936 | return retval; |
| 5937 | |
| 5938 | /* Here we know we have a symbol, so we'll execute this loop |
| 5939 | at least once. */ |
| 5940 | do |
| 5941 | { |
| 5942 | /* The second to last param, 1, says this is in a common block. */ |
| 5943 | retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block); |
| 5944 | curr_sym = curr_sym->common_next; |
| 5945 | } while (curr_sym != NULL__null); |
| 5946 | |
| 5947 | return retval; |
| 5948 | } |
| 5949 | |
| 5950 | |
| 5951 | /* Verify that a given BIND(C) symbol is C interoperable. If it is not, |
| 5952 | an appropriate error message is reported. */ |
| 5953 | |
| 5954 | bool |
| 5955 | verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts, |
| 5956 | int is_in_common, gfc_common_head *com_block) |
| 5957 | { |
| 5958 | bool bind_c_function = false; |
| 5959 | bool retval = true; |
| 5960 | |
| 5961 | if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c) |
| 5962 | bind_c_function = true; |
| 5963 | |
| 5964 | if (tmp_sym->attr.function && tmp_sym->result != NULL__null) |
| 5965 | { |
| 5966 | tmp_sym = tmp_sym->result; |
| 5967 | /* Make sure it wasn't an implicitly typed result. */ |
| 5968 | if (tmp_sym->attr.implicit_type && warn_c_binding_typeglobal_options.x_warn_c_binding_type) |
| 5969 | { |
| 5970 | gfc_warning (OPT_Wc_binding_type, |
| 5971 | "Implicitly declared BIND(C) function %qs at " |
| 5972 | "%L may not be C interoperable", tmp_sym->name, |
| 5973 | &tmp_sym->declared_at); |
| 5974 | tmp_sym->ts.f90_type = tmp_sym->ts.type; |
| 5975 | /* Mark it as C interoperable to prevent duplicate warnings. */ |
| 5976 | tmp_sym->ts.is_c_interop = 1; |
| 5977 | tmp_sym->attr.is_c_interop = 1; |
| 5978 | } |
| 5979 | } |
| 5980 | |
| 5981 | /* Here, we know we have the bind(c) attribute, so if we have |
| 5982 | enough type info, then verify that it's a C interop kind. |
| 5983 | The info could be in the symbol already, or possibly still in |
| 5984 | the given ts (current_ts), so look in both. */ |
| 5985 | if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) |
| 5986 | { |
| 5987 | if (!gfc_verify_c_interop (&(tmp_sym->ts))) |
| 5988 | { |
| 5989 | /* See if we're dealing with a sym in a common block or not. */ |
| 5990 | if (is_in_common == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type) |
| 5991 | { |
| 5992 | gfc_warning (OPT_Wc_binding_type, |
| 5993 | "Variable %qs in common block %qs at %L " |
| 5994 | "may not be a C interoperable " |
| 5995 | "kind though common block %qs is BIND(C)", |
| 5996 | tmp_sym->name, com_block->name, |
| 5997 | &(tmp_sym->declared_at), com_block->name); |
| 5998 | } |
| 5999 | else |
| 6000 | { |
| 6001 | if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED |
| 6002 | || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS) |
| 6003 | { |
| 6004 | gfc_error ("Type declaration %qs at %L is not C " |
| 6005 | "interoperable but it is BIND(C)", |
| 6006 | tmp_sym->name, &(tmp_sym->declared_at)); |
| 6007 | retval = false; |
| 6008 | } |
| 6009 | else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type) |
| 6010 | gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L " |
| 6011 | "may not be a C interoperable " |
| 6012 | "kind but it is BIND(C)", |
| 6013 | tmp_sym->name, &(tmp_sym->declared_at)); |
| 6014 | } |
| 6015 | } |
| 6016 | |
| 6017 | /* Variables declared w/in a common block can't be bind(c) |
| 6018 | since there's no way for C to see these variables, so there's |
| 6019 | semantically no reason for the attribute. */ |
| 6020 | if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1) |
| 6021 | { |
| 6022 | gfc_error ("Variable %qs in common block %qs at " |
| 6023 | "%L cannot be declared with BIND(C) " |
| 6024 | "since it is not a global", |
| 6025 | tmp_sym->name, com_block->name, |
| 6026 | &(tmp_sym->declared_at)); |
| 6027 | retval = false; |
| 6028 | } |
| 6029 | |
| 6030 | /* Scalar variables that are bind(c) cannot have the pointer |
| 6031 | or allocatable attributes. */ |
| 6032 | if (tmp_sym->attr.is_bind_c == 1) |
| 6033 | { |
| 6034 | if (tmp_sym->attr.pointer == 1) |
| 6035 | { |
| 6036 | gfc_error ("Variable %qs at %L cannot have both the " |
| 6037 | "POINTER and BIND(C) attributes", |
| 6038 | tmp_sym->name, &(tmp_sym->declared_at)); |
| 6039 | retval = false; |
| 6040 | } |
| 6041 | |
| 6042 | if (tmp_sym->attr.allocatable == 1) |
| 6043 | { |
| 6044 | gfc_error ("Variable %qs at %L cannot have both the " |
| 6045 | "ALLOCATABLE and BIND(C) attributes", |
| 6046 | tmp_sym->name, &(tmp_sym->declared_at)); |
| 6047 | retval = false; |
| 6048 | } |
| 6049 | |
| 6050 | } |
| 6051 | |
| 6052 | /* If it is a BIND(C) function, make sure the return value is a |
| 6053 | scalar value. The previous tests in this function made sure |
| 6054 | the type is interoperable. */ |
| 6055 | if (bind_c_function && tmp_sym->as != NULL__null) |
| 6056 | gfc_error ("Return type of BIND(C) function %qs at %L cannot " |
| 6057 | "be an array", tmp_sym->name, &(tmp_sym->declared_at)); |
| 6058 | |
| 6059 | /* BIND(C) functions cannot return a character string. */ |
| 6060 | if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER) |
| 6061 | if (tmp_sym->ts.u.cl == NULL__null || tmp_sym->ts.u.cl->length == NULL__null |
| 6062 | || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT |
| 6063 | || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? ( __builtin_constant_p ((static_cast<unsigned long> (1))) && ((static_cast<unsigned long> (1))) == 0 ? ( (tmp_sym->ts.u.cl->length->value.integer)->_mp_size < 0 ? -1 : (tmp_sym->ts.u.cl->length->value.integer )->_mp_size > 0) : __gmpz_cmp_ui (tmp_sym->ts.u.cl-> length->value.integer,(static_cast<unsigned long> (1 )))) : __gmpz_cmp_si (tmp_sym->ts.u.cl->length->value .integer,1)) != 0) |
| 6064 | gfc_error ("Return type of BIND(C) function %qs of character " |
| 6065 | "type at %L must have length 1", tmp_sym->name, |
| 6066 | &(tmp_sym->declared_at)); |
| 6067 | } |
| 6068 | |
| 6069 | /* See if the symbol has been marked as private. If it has, make sure |
| 6070 | there is no binding label and warn the user if there is one. */ |
| 6071 | if (tmp_sym->attr.access == ACCESS_PRIVATE |
| 6072 | && tmp_sym->binding_label) |
| 6073 | /* Use gfc_warning_now because we won't say that the symbol fails |
| 6074 | just because of this. */ |
| 6075 | gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been " |
| 6076 | "given the binding label %qs", tmp_sym->name, |
| 6077 | &(tmp_sym->declared_at), tmp_sym->binding_label); |
| 6078 | |
| 6079 | return retval; |
| 6080 | } |
| 6081 | |
| 6082 | |
| 6083 | /* Set the appropriate fields for a symbol that's been declared as |
| 6084 | BIND(C) (the is_bind_c flag and the binding label), and verify that |
| 6085 | the type is C interoperable. Errors are reported by the functions |
| 6086 | used to set/test these fields. */ |
| 6087 | |
| 6088 | static bool |
| 6089 | set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents) |
| 6090 | { |
| 6091 | bool retval = true; |
| 6092 | |
| 6093 | /* TODO: Do we need to make sure the vars aren't marked private? */ |
| 6094 | |
| 6095 | /* Set the is_bind_c bit in symbol_attribute. */ |
| 6096 | gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0); |
| 6097 | |
| 6098 | if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents)) |
| 6099 | return false; |
| 6100 | |
| 6101 | return retval; |
| 6102 | } |
| 6103 | |
| 6104 | |
| 6105 | /* Set the fields marking the given common block as BIND(C), including |
| 6106 | a binding label, and report any errors encountered. */ |
| 6107 | |
| 6108 | static bool |
| 6109 | set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents) |
| 6110 | { |
| 6111 | bool retval = true; |
| 6112 | |
| 6113 | /* destLabel, common name, typespec (which may have binding label). */ |
| 6114 | if (!set_binding_label (&com_block->binding_label, com_block->name, |
| 6115 | num_idents)) |
| 6116 | return false; |
| 6117 | |
| 6118 | /* Set the given common block (com_block) to being bind(c) (1). */ |
| 6119 | set_com_block_bind_c (com_block, 1); |
| 6120 | |
| 6121 | return retval; |
| 6122 | } |
| 6123 | |
| 6124 | |
| 6125 | /* Retrieve the list of one or more identifiers that the given bind(c) |
| 6126 | attribute applies to. */ |
| 6127 | |
| 6128 | static bool |
| 6129 | get_bind_c_idents (void) |
| 6130 | { |
| 6131 | char name[GFC_MAX_SYMBOL_LEN63 + 1]; |
| 6132 | int num_idents = 0; |
| 6133 | gfc_symbol *tmp_sym = NULL__null; |
| 6134 | match found_id; |
| 6135 | gfc_common_head *com_block = NULL__null; |
| 6136 | |
| 6137 | if (gfc_match_name (name) == MATCH_YES) |
| 6138 | { |
| 6139 | found_id = MATCH_YES; |
| 6140 | gfc_get_ha_symbol (name, &tmp_sym); |
| 6141 | } |
| 6142 | else if (gfc_match_common_name (name) == MATCH_YES) |
| 6143 | { |
| 6144 | found_id = MATCH_YES; |
| 6145 | com_block = gfc_get_common (name, 0); |
| 6146 | } |
| 6147 | else |
| 6148 | { |
| 6149 | gfc_error ("Need either entity or common block name for " |
| 6150 | "attribute specification statement at %C"); |
| 6151 | return false; |
| 6152 | } |
| 6153 | |
| 6154 | /* Save the current identifier and look for more. */ |
| 6155 | do |
| 6156 | { |
| 6157 | /* Increment the number of identifiers found for this spec stmt. */ |
| 6158 | num_idents++; |
| 6159 | |
| 6160 | /* Make sure we have a sym or com block, and verify that it can |
| 6161 | be bind(c). Set the appropriate field(s) and look for more |
| 6162 | identifiers. */ |
| 6163 | if (tmp_sym != NULL__null || com_block != NULL__null) |
| 6164 | { |
| 6165 | if (tmp_sym != NULL__null) |
| 6166 | { |
| 6167 | if (!set_verify_bind_c_sym (tmp_sym, num_idents)) |
| 6168 | return false; |
| 6169 | } |
| 6170 | else |
| 6171 | { |
| 6172 | if (!set_verify_bind_c_com_block (com_block, num_idents)) |
| 6173 | return false; |
| 6174 | } |
| 6175 | |
| 6176 | /* Look to see if we have another identifier. */ |
| 6177 | tmp_sym = NULL__null; |
| 6178 | if (gfc_match_eos () == MATCH_YES) |
| 6179 | found_id = MATCH_NO; |
| 6180 | else if (gfc_match_char (',') != MATCH_YES) |
| 6181 | found_id = MATCH_NO; |
| 6182 | else if (gfc_match_name (name) == MATCH_YES) |
| 6183 | { |
| 6184 | found_id = MATCH_YES; |
| 6185 | gfc_get_ha_symbol (name, &tmp_sym); |
| 6186 | } |
| 6187 | else if (gfc_match_common_name (name) == MATCH_YES) |
| 6188 | { |
| 6189 | found_id = MATCH_YES; |
| 6190 | com_block = gfc_get_common (name, 0); |
| 6191 | } |
| 6192 | else |
| 6193 | { |
| 6194 | gfc_error ("Missing entity or common block name for " |
| 6195 | "attribute specification statement at %C"); |
| 6196 | return false; |
| 6197 | } |
| 6198 | } |
| 6199 | else |
| 6200 | { |
| 6201 | gfc_internal_error ("Missing symbol"); |
| 6202 | } |
| 6203 | } while (found_id == MATCH_YES); |
| 6204 | |
| 6205 | /* if we get here we were successful */ |
| 6206 | return true; |
| 6207 | } |
| 6208 | |
| 6209 | |
| 6210 | /* Try and match a BIND(C) attribute specification statement. */ |
| 6211 | |
| 6212 | match |
| 6213 | gfc_match_bind_c_stmt (void) |
| 6214 | { |
| 6215 | match found_match = MATCH_NO; |
| 6216 | gfc_typespec *ts; |
| 6217 | |
| 6218 | ts = ¤t_ts; |
| 6219 | |
| 6220 | /* This may not be necessary. */ |
| 6221 | gfc_clear_ts (ts); |
| 6222 | /* Clear the temporary binding label holder. */ |
| 6223 | curr_binding_label = NULL__null; |
| 6224 | |
| 6225 | /* Look for the bind(c). */ |
| 6226 | found_match = gfc_match_bind_c (NULL__null, true); |
| 6227 | |
| 6228 | if (found_match == MATCH_YES) |
| 6229 | { |
| 6230 | if (!gfc_notify_std (GFC_STD_F2003(1<<4), "BIND(C) statement at %C")) |
| 6231 | return MATCH_ERROR; |
| 6232 | |
| 6233 | /* Look for the :: now, but it is not required. */ |
| 6234 | gfc_match (" :: "); |
| 6235 | |
| 6236 | /* Get the identifier(s) that needs to be updated. This may need to |
| 6237 | change to hand the flag(s) for the attr specified so all identifiers |
| 6238 | found can have all appropriate parts updated (assuming that the same |
| 6239 | spec stmt can have multiple attrs, such as both bind(c) and |
| 6240 | allocatable...). */ |
| 6241 | if (!get_bind_c_idents ()) |
| 6242 | /* Error message should have printed already. */ |
| 6243 | return MATCH_ERROR; |
| 6244 | } |
| 6245 | |
| 6246 | return found_match; |
| 6247 | } |
| 6248 | |
| 6249 | |
| 6250 | /* Match a data declaration statement. */ |
| 6251 | |
| 6252 | match |
| 6253 | gfc_match_data_decl (void) |
| 6254 | { |
| 6255 | gfc_symbol *sym; |
| 6256 | match m; |
| 6257 | int elem; |
| 6258 | |
| 6259 | type_param_spec_list = NULL__null; |
| 6260 | decl_type_param_list = NULL__null; |
| 6261 | |
| 6262 | num_idents_on_line = 0; |
| 6263 | |
| 6264 | m = gfc_match_decl_type_spec (¤t_ts, 0); |
| 6265 | if (m != MATCH_YES) |
| 6266 | return m; |
| 6267 | |
| 6268 | if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) |
| 6269 | && !gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 6270 | { |
| 6271 | sym = gfc_use_derived (current_ts.u.derived); |
| 6272 | |
| 6273 | if (sym == NULL__null) |
| 6274 | { |
| 6275 | m = MATCH_ERROR; |
| 6276 | goto cleanup; |
| 6277 | } |
| 6278 | |
| 6279 | current_ts.u.derived = sym; |
| 6280 | } |
| 6281 | |
| 6282 | m = match_attr_spec (); |
| 6283 | if (m == MATCH_ERROR) |
| 6284 | { |
| 6285 | m = MATCH_NO; |
| 6286 | goto cleanup; |
| 6287 | } |
| 6288 | |
| 6289 | /* F2018:C708. */ |
| 6290 | if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER) |
| 6291 | { |
| 6292 | gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute"); |
| 6293 | m = MATCH_ERROR; |
| 6294 | goto cleanup; |
| 6295 | } |
| 6296 | |
| 6297 | if (current_ts.type == BT_CLASS |
| 6298 | && current_ts.u.derived->attr.unlimited_polymorphic) |
| 6299 | goto ok; |
| 6300 | |
| 6301 | if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS) |
| 6302 | && current_ts.u.derived->components == NULL__null |
| 6303 | && !current_ts.u.derived->attr.zero_comp) |
| 6304 | { |
| 6305 | |
| 6306 | if (current_attr.pointer && gfc_comp_struct (gfc_current_state ())(((gfc_state_stack->state)) == COMP_DERIVED || ((gfc_state_stack ->state)) == COMP_STRUCTURE || ((gfc_state_stack->state )) == COMP_MAP)) |
| 6307 | goto ok; |
| 6308 | |
| 6309 | if (current_attr.allocatable && gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED) |
| 6310 | goto ok; |
| 6311 | |
| 6312 | gfc_find_symbol (current_ts.u.derived->name, |
| 6313 | current_ts.u.derived->ns, 1, &sym); |
| 6314 | |
| 6315 | /* Any symbol that we find had better be a type definition |
| 6316 | which has its components defined, or be a structure definition |
| 6317 | actively being parsed. */ |
| 6318 | if (sym != NULL__null && gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor) == FL_UNION || (sym->attr.flavor) == FL_STRUCT) |
| 6319 | && (current_ts.u.derived->components != NULL__null |
| 6320 | || current_ts.u.derived->attr.zero_comp |
| 6321 | || current_ts.u.derived == gfc_new_block)) |
| 6322 | goto ok; |
| 6323 | |
| 6324 | gfc_error ("Derived type at %C has not been previously defined " |
| 6325 | "and so cannot appear in a derived type definition"); |
| 6326 | m = MATCH_ERROR; |
| 6327 | goto cleanup; |
| 6328 | } |
| 6329 | |
| 6330 | ok: |
| 6331 | /* If we have an old-style character declaration, and no new-style |
| 6332 | attribute specifications, then there a comma is optional between |
| 6333 | the type specification and the variable list. */ |
| 6334 | if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector) |
| 6335 | gfc_match_char (','); |
| 6336 | |
| 6337 | /* Give the types/attributes to symbols that follow. Give the element |
| 6338 | a number so that repeat character length expressions can be copied. */ |
| 6339 | elem = 1; |
| 6340 | for (;;) |
| 6341 | { |
| 6342 | num_idents_on_line++; |
| 6343 | m = variable_decl (elem++); |
| 6344 | if (m == MATCH_ERROR) |
| 6345 | goto cleanup; |
| 6346 | if (m == MATCH_NO) |
| 6347 | break; |
| 6348 | |
| 6349 | if (gfc_match_eos () == MATCH_YES) |
| 6350 | goto cleanup; |
| 6351 | if (gfc_match_char (',') != MATCH_YES) |
| 6352 | break; |
| 6353 | } |
| 6354 | |
| 6355 | if (!gfc_error_flag_test ()) |
| 6356 | { |
| 6357 | /* An anonymous structure declaration is unambiguous; if we matched one |
| 6358 | according to gfc_match_structure_decl, we need to return MATCH_YES |
| 6359 | here to avoid confusing the remaining matchers, even if there was an |
| 6360 | error during variable_decl. We must flush any such errors. Note this |
| 6361 | causes the parser to gracefully continue parsing the remaining input |
| 6362 | as a structure body, which likely follows. */ |
| 6363 | if (current_ts.type == BT_DERIVED && current_ts.u.derived |
| 6364 | && gfc_fl_struct (current_ts.u.derived->attr.flavor)((current_ts.u.derived->attr.flavor) == FL_DERIVED || (current_ts .u.derived->attr.flavor) == FL_UNION || (current_ts.u.derived ->attr.flavor) == FL_STRUCT)) |
| 6365 | { |
| 6366 | gfc_error_now ("Syntax error in anonymous structure declaration" |
| 6367 | " at %C"); |
| 6368 | /* Skip the bad variable_decl and line up for the start of the |
| 6369 | structure body. */ |
| 6370 | gfc_error_recovery (); |
| 6371 | m = MATCH_YES; |
| 6372 | goto cleanup; |
| 6373 | } |
| 6374 | |
| 6375 | gfc_error ("Syntax error in data declaration at %C"); |
| 6376 | } |
| 6377 | |
| 6378 | m = MATCH_ERROR; |
| 6379 | |
| 6380 | gfc_free_data_all (gfc_current_ns); |
| 6381 | |
| 6382 | cleanup: |
| 6383 | if (saved_kind_expr) |
| 6384 | gfc_free_expr (saved_kind_expr); |
| 6385 | if (type_param_spec_list) |
| 6386 | gfc_free_actual_arglist (type_param_spec_list); |
| 6387 | if (decl_type_param_list) |
| 6388 | gfc_free_actual_arglist (decl_type_param_list); |
| 6389 | saved_kind_expr = NULL__null; |
| 6390 | gfc_free_array_spec (current_as); |
| 6391 | current_as = NULL__null; |
| 6392 | return m; |
| 6393 | } |
| 6394 | |
| 6395 | static bool |
| 6396 | in_module_or_interface(void) |
| 6397 | { |
| 6398 | if (gfc_current_state ()(gfc_state_stack->state) == COMP_MODULE |
| 6399 | || gfc_current_state ()(gfc_state_stack->state) == COMP_SUBMODULE |
| 6400 | || gfc_current_state ()(gfc_state_stack->state) == COMP_INTERFACE) |
| 6401 | return true; |
| 6402 | |
| 6403 | if (gfc_state_stack->state == COMP_CONTAINS |
| 6404 | || gfc_state_stack->state == COMP_FUNCTION |
| 6405 | || gfc_state_stack->state == COMP_SUBROUTINE) |
| 6406 | { |
| 6407 | gfc_state_data *p; |
| 6408 | for (p = gfc_state_stack->previous; p ; p = p->previous) |
| 6409 | { |
| 6410 | if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE |
| 6411 | || p->state == COMP_INTERFACE) |
| 6412 | return true; |
| 6413 | } |
| 6414 | } |
| 6415 | return false; |
| 6416 | } |
| 6417 | |
| 6418 | /* Match a prefix associated with a function or subroutine |
| 6419 | declaration. If the typespec pointer is nonnull, then a typespec |
| 6420 | can be matched. Note that if nothing matches, MATCH_YES is |
| 6421 | returned (the null string was matched). */ |
| 6422 | |
| 6423 | match |
| 6424 | gfc_match_prefix (gfc_typespec *ts) |
| 6425 | { |
| 6426 | bool seen_type; |
| 6427 | bool seen_impure; |
| 6428 | bool found_prefix; |
| 6429 | |
| 6430 | gfc_clear_attr (¤t_attr); |
| 6431 | seen_type = false; |
| 6432 | seen_impure = false; |
| 6433 | |
| 6434 | gcc_assert (!gfc_matching_prefix)((void)(!(!gfc_matching_prefix) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/decl.cc" , 6434, __FUNCTION__), 0 : 0)); |
| 6435 | gfc_matching_prefix = true; |
| 6436 | |
| 6437 | do |
| 6438 | { |
| 6439 | found_prefix = false; |
| 6440 | |
| 6441 | /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a |
| 6442 | corresponding attribute seems natural and distinguishes these |
| 6443 | procedures from procedure types of PROC_MODULE, which these are |
| 6444 | as well. */ |
| 6445 | if (gfc_match ("module% ") == MATCH_YES) |
| 6446 | { |
| 6447 | if (!gfc_notify_std (GFC_STD_F2008(1<<7), "MODULE prefix at %C")) |
| 6448 | goto error; |
| 6449 | |
| 6450 | if (!in_module_or_interface ()) |
| 6451 | { |
| 6452 | gfc_error ("MODULE prefix at %C found outside of a module, " |
| 6453 | "submodule, or interface"); |
| 6454 | goto error; |
| 6455 | } |
| 6456 | |
| 6457 | current_attr.module_procedure = 1; |
| 6458 | found_prefix = true; |
| 6459 | } |
| 6460 | |
| 6461 | if (!seen_type && ts != NULL__null) |
| 6462 | { |
| 6463 | match m; |
| 6464 | m = gfc_match_decl_type_spec (ts, 0); |
| 6465 | if (m == MATCH_ERROR) |
| 6466 | goto error; |
| 6467 | if (m == MATCH_YES && gfc_match_space () == MATCH_YES) |
| 6468 | { |
| 6469 | seen_type = true; |
| 6470 | found_prefix = true; |
| 6471 | } |
| 6472 | } |
| 6473 | |
| 6474 | if (gfc_match ("elemental% ") == MATCH_YES) |
| 6475 | { |
| 6476 | if (!gfc_add_elemental (¤t_attr, NULL__null)) |
| 6477 | goto error; |
| 6478 | |
| 6479 | found_prefix = true; |
| 6480 | } |
| 6481 | |
| 6482 | if (gfc_match ("pure% ") == MATCH_YES) |
| 6483 | { |
| 6484 | if (!gfc_add_pure (¤t_attr, NULL__null)) |
| 6485 | goto error; |
| 6486 | |
| 6487 | found_prefix = true; |
| 6488 | } |
| 6489 | |
| 6490 | if (gfc_match ("recursive% ") == MATCH_YES) |
| 6491 | { |