Line data Source code
1 : /* Declaration statement matcher
2 : Copyright (C) 2002-2026 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 : #include "flags.h"
33 :
34 : /* Macros to access allocate memory for gfc_data_variable,
35 : gfc_data_value and gfc_data. */
36 : #define gfc_get_data_variable() XCNEW (gfc_data_variable)
37 : #define gfc_get_data_value() XCNEW (gfc_data_value)
38 : #define gfc_get_data() XCNEW (gfc_data)
39 :
40 :
41 : static bool set_binding_label (const char **, const char *, int);
42 :
43 :
44 : /* This flag is set if an old-style length selector is matched
45 : during a type-declaration statement. */
46 :
47 : static int old_char_selector;
48 :
49 : /* When variables acquire types and attributes from a declaration
50 : statement, they get them from the following static variables. The
51 : first part of a declaration sets these variables and the second
52 : part copies these into symbol structures. */
53 :
54 : static gfc_typespec current_ts;
55 :
56 : static symbol_attribute current_attr;
57 : static gfc_array_spec *current_as;
58 : static int colon_seen;
59 : static int attr_seen;
60 :
61 : /* The current binding label (if any). */
62 : static const char* curr_binding_label;
63 : /* Need to know how many identifiers are on the current data declaration
64 : line in case we're given the BIND(C) attribute with a NAME= specifier. */
65 : static int num_idents_on_line;
66 : /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
67 : can supply a name if the curr_binding_label is nil and NAME= was not. */
68 : static int has_name_equals = 0;
69 :
70 : /* Initializer of the previous enumerator. */
71 :
72 : static gfc_expr *last_initializer;
73 :
74 : /* History of all the enumerators is maintained, so that
75 : kind values of all the enumerators could be updated depending
76 : upon the maximum initialized value. */
77 :
78 : typedef struct enumerator_history
79 : {
80 : gfc_symbol *sym;
81 : gfc_expr *initializer;
82 : struct enumerator_history *next;
83 : }
84 : enumerator_history;
85 :
86 : /* Header of enum history chain. */
87 :
88 : static enumerator_history *enum_history = NULL;
89 :
90 : /* Pointer of enum history node containing largest initializer. */
91 :
92 : static enumerator_history *max_enum = NULL;
93 :
94 : /* gfc_new_block points to the symbol of a newly matched block. */
95 :
96 : gfc_symbol *gfc_new_block;
97 :
98 : bool gfc_matching_function;
99 :
100 : /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
101 : int directive_unroll = -1;
102 :
103 : /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
104 : bool directive_ivdep = false;
105 : bool directive_vector = false;
106 : bool directive_novector = false;
107 :
108 : /* Map of middle-end built-ins that should be vectorized. */
109 : hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
110 :
111 : /* If a kind expression of a component of a parameterized derived type is
112 : parameterized, temporarily store the expression here. */
113 : static gfc_expr *saved_kind_expr = NULL;
114 :
115 : /* Used to store the parameter list arising in a PDT declaration and
116 : in the typespec of a PDT variable or component. */
117 : static gfc_actual_arglist *decl_type_param_list;
118 : static gfc_actual_arglist *type_param_spec_list;
119 :
120 : /* Drop an unattached gfc_charlen node from the current namespace. This is
121 : used when declaration processing created a length node for a symbol that is
122 : rejected before the node is attached to any surviving symbol. */
123 : static void
124 1 : discard_pending_charlen (gfc_charlen *cl)
125 : {
126 1 : if (!cl || !gfc_current_ns || gfc_current_ns->cl_list != cl)
127 : return;
128 :
129 1 : gfc_remove_saved_charlen (cl);
130 1 : gfc_current_ns->cl_list = cl->next;
131 1 : gfc_free_expr (cl->length);
132 1 : free (cl);
133 : }
134 :
135 : /* Drop the charlen nodes created while matching a declaration that is about
136 : to be rejected. Callers must clear any surviving owners before using this
137 : helper, so only the statement-local nodes remain on the namespace list. */
138 :
139 : static void
140 3 : discard_pending_charlens (gfc_charlen *saved_cl)
141 : {
142 3 : if (!gfc_current_ns)
143 : return;
144 :
145 14 : while (gfc_current_ns->cl_list != saved_cl)
146 : {
147 11 : gfc_charlen *cl = gfc_current_ns->cl_list;
148 :
149 11 : gcc_assert (cl);
150 11 : gfc_remove_saved_charlen (cl);
151 11 : gfc_current_ns->cl_list = cl->next;
152 11 : gfc_free_expr (cl->length);
153 11 : free (cl);
154 : }
155 : }
156 :
157 : /********************* DATA statement subroutines *********************/
158 :
159 : static bool in_match_data = false;
160 :
161 : bool
162 8479 : gfc_in_match_data (void)
163 : {
164 8479 : return in_match_data;
165 : }
166 :
167 : static void
168 4876 : set_in_match_data (bool set_value)
169 : {
170 4876 : in_match_data = set_value;
171 0 : }
172 :
173 : /* Free a gfc_data_variable structure and everything beneath it. */
174 :
175 : static void
176 5699 : free_variable (gfc_data_variable *p)
177 : {
178 5699 : gfc_data_variable *q;
179 :
180 8806 : for (; p; p = q)
181 : {
182 3107 : q = p->next;
183 3107 : gfc_free_expr (p->expr);
184 3107 : gfc_free_iterator (&p->iter, 0);
185 3107 : free_variable (p->list);
186 3107 : free (p);
187 : }
188 5699 : }
189 :
190 :
191 : /* Free a gfc_data_value structure and everything beneath it. */
192 :
193 : static void
194 2592 : free_value (gfc_data_value *p)
195 : {
196 2592 : gfc_data_value *q;
197 :
198 10922 : for (; p; p = q)
199 : {
200 8330 : q = p->next;
201 8330 : mpz_clear (p->repeat);
202 8330 : gfc_free_expr (p->expr);
203 8330 : free (p);
204 : }
205 2592 : }
206 :
207 :
208 : /* Free a list of gfc_data structures. */
209 :
210 : void
211 550715 : gfc_free_data (gfc_data *p)
212 : {
213 550715 : gfc_data *q;
214 :
215 553307 : for (; p; p = q)
216 : {
217 2592 : q = p->next;
218 2592 : free_variable (p->var);
219 2592 : free_value (p->value);
220 2592 : free (p);
221 : }
222 550715 : }
223 :
224 :
225 : /* Free all data in a namespace. */
226 :
227 : static void
228 41 : gfc_free_data_all (gfc_namespace *ns)
229 : {
230 41 : gfc_data *d;
231 :
232 47 : for (;ns->data;)
233 : {
234 6 : d = ns->data->next;
235 6 : free (ns->data);
236 6 : ns->data = d;
237 : }
238 41 : }
239 :
240 : /* Reject data parsed since the last restore point was marked. */
241 :
242 : void
243 9307431 : gfc_reject_data (gfc_namespace *ns)
244 : {
245 9307431 : gfc_data *d;
246 :
247 9307433 : while (ns->data && ns->data != ns->old_data)
248 : {
249 2 : d = ns->data->next;
250 2 : free (ns->data);
251 2 : ns->data = d;
252 : }
253 9307431 : }
254 :
255 : static match var_element (gfc_data_variable *);
256 :
257 : /* Match a list of variables terminated by an iterator and a right
258 : parenthesis. */
259 :
260 : static match
261 154 : var_list (gfc_data_variable *parent)
262 : {
263 154 : gfc_data_variable *tail, var;
264 154 : match m;
265 :
266 154 : m = var_element (&var);
267 154 : if (m == MATCH_ERROR)
268 : return MATCH_ERROR;
269 154 : if (m == MATCH_NO)
270 0 : goto syntax;
271 :
272 154 : tail = gfc_get_data_variable ();
273 154 : *tail = var;
274 :
275 154 : parent->list = tail;
276 :
277 156 : for (;;)
278 : {
279 155 : if (gfc_match_char (',') != MATCH_YES)
280 0 : goto syntax;
281 :
282 155 : m = gfc_match_iterator (&parent->iter, 1);
283 155 : if (m == MATCH_YES)
284 : break;
285 1 : if (m == MATCH_ERROR)
286 : return MATCH_ERROR;
287 :
288 1 : m = var_element (&var);
289 1 : if (m == MATCH_ERROR)
290 : return MATCH_ERROR;
291 1 : if (m == MATCH_NO)
292 0 : goto syntax;
293 :
294 1 : tail->next = gfc_get_data_variable ();
295 1 : tail = tail->next;
296 :
297 1 : *tail = var;
298 : }
299 :
300 154 : if (gfc_match_char (')') != MATCH_YES)
301 0 : goto syntax;
302 : return MATCH_YES;
303 :
304 0 : syntax:
305 0 : gfc_syntax_error (ST_DATA);
306 0 : return MATCH_ERROR;
307 : }
308 :
309 :
310 : /* Match a single element in a data variable list, which can be a
311 : variable-iterator list. */
312 :
313 : static match
314 3065 : var_element (gfc_data_variable *new_var)
315 : {
316 3065 : match m;
317 3065 : gfc_symbol *sym;
318 :
319 3065 : memset (new_var, 0, sizeof (gfc_data_variable));
320 :
321 3065 : if (gfc_match_char ('(') == MATCH_YES)
322 154 : return var_list (new_var);
323 :
324 2911 : m = gfc_match_variable (&new_var->expr, 0);
325 2911 : if (m != MATCH_YES)
326 : return m;
327 :
328 2907 : if (new_var->expr->expr_type == EXPR_CONSTANT
329 2 : && new_var->expr->symtree == NULL)
330 : {
331 2 : gfc_error ("Inquiry parameter cannot appear in a "
332 : "data-stmt-object-list at %C");
333 2 : return MATCH_ERROR;
334 : }
335 :
336 2905 : sym = new_var->expr->symtree->n.sym;
337 :
338 : /* Symbol should already have an associated type. */
339 2905 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
340 : return MATCH_ERROR;
341 :
342 2904 : if (!sym->attr.function && gfc_current_ns->parent
343 148 : && gfc_current_ns->parent == sym->ns)
344 : {
345 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
346 : "statement at %C", sym->name);
347 1 : return MATCH_ERROR;
348 : }
349 :
350 2903 : if (gfc_current_state () != COMP_BLOCK_DATA
351 2750 : && sym->attr.in_common
352 2932 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
353 : "common block variable %qs in DATA statement at %C",
354 : sym->name))
355 : return MATCH_ERROR;
356 :
357 2901 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
358 5 : return MATCH_ERROR;
359 :
360 : return MATCH_YES;
361 : }
362 :
363 :
364 : /* Match the top-level list of data variables. */
365 :
366 : static match
367 2535 : top_var_list (gfc_data *d)
368 : {
369 2535 : gfc_data_variable var, *tail, *new_var;
370 2535 : match m;
371 :
372 2535 : tail = NULL;
373 :
374 2910 : for (;;)
375 : {
376 2910 : m = var_element (&var);
377 2910 : if (m == MATCH_NO)
378 0 : goto syntax;
379 2910 : if (m == MATCH_ERROR)
380 : return MATCH_ERROR;
381 :
382 2895 : new_var = gfc_get_data_variable ();
383 2895 : *new_var = var;
384 2895 : if (new_var->expr)
385 2769 : new_var->expr->where = gfc_current_locus;
386 :
387 2895 : if (tail == NULL)
388 2520 : d->var = new_var;
389 : else
390 375 : tail->next = new_var;
391 :
392 2895 : tail = new_var;
393 :
394 2895 : if (gfc_match_char ('/') == MATCH_YES)
395 : break;
396 378 : if (gfc_match_char (',') != MATCH_YES)
397 3 : goto syntax;
398 : }
399 :
400 : return MATCH_YES;
401 :
402 3 : syntax:
403 3 : gfc_syntax_error (ST_DATA);
404 3 : gfc_free_data_all (gfc_current_ns);
405 3 : return MATCH_ERROR;
406 : }
407 :
408 :
409 : static match
410 8731 : match_data_constant (gfc_expr **result)
411 : {
412 8731 : char name[GFC_MAX_SYMBOL_LEN + 1];
413 8731 : gfc_symbol *sym, *dt_sym = NULL;
414 8731 : gfc_expr *expr;
415 8731 : match m;
416 8731 : locus old_loc;
417 8731 : gfc_symtree *symtree;
418 :
419 8731 : m = gfc_match_literal_constant (&expr, 1);
420 8731 : if (m == MATCH_YES)
421 : {
422 8368 : *result = expr;
423 8368 : return MATCH_YES;
424 : }
425 :
426 363 : if (m == MATCH_ERROR)
427 : return MATCH_ERROR;
428 :
429 355 : m = gfc_match_null (result);
430 355 : if (m != MATCH_NO)
431 : return m;
432 :
433 347 : old_loc = gfc_current_locus;
434 :
435 : /* Should this be a structure component, try to match it
436 : before matching a name. */
437 347 : m = gfc_match_rvalue (result);
438 347 : if (m == MATCH_ERROR)
439 : return m;
440 :
441 347 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
442 : {
443 4 : if (!gfc_simplify_expr (*result, 0))
444 0 : m = MATCH_ERROR;
445 : return m;
446 : }
447 337 : else if (m == MATCH_YES)
448 : {
449 : /* If a parameter inquiry ends up here, symtree is NULL but **result
450 : contains the right constant expression. Check here. */
451 337 : if ((*result)->symtree == NULL
452 37 : && (*result)->expr_type == EXPR_CONSTANT
453 37 : && ((*result)->ts.type == BT_INTEGER
454 1 : || (*result)->ts.type == BT_REAL))
455 : return m;
456 :
457 : /* F2018:R845 data-stmt-constant is initial-data-target.
458 : A data-stmt-constant shall be ... initial-data-target if and
459 : only if the corresponding data-stmt-object has the POINTER
460 : attribute. ... If data-stmt-constant is initial-data-target
461 : the corresponding data statement object shall be
462 : data-pointer-initialization compatible (7.5.4.6) with the initial
463 : data target; the data statement object is initially associated
464 : with the target. */
465 301 : if ((*result)->symtree
466 300 : && (*result)->symtree->n.sym->attr.save
467 236 : && (*result)->symtree->n.sym->attr.target)
468 : return m;
469 250 : gfc_free_expr (*result);
470 : }
471 :
472 256 : gfc_current_locus = old_loc;
473 :
474 256 : m = gfc_match_name (name);
475 256 : if (m != MATCH_YES)
476 : return m;
477 :
478 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
479 : return MATCH_ERROR;
480 :
481 250 : sym = symtree->n.sym;
482 :
483 250 : if (sym && sym->attr.generic)
484 60 : dt_sym = gfc_find_dt_in_generic (sym);
485 :
486 60 : if (sym == NULL
487 250 : || (sym->attr.flavor != FL_PARAMETER
488 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
489 : {
490 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
491 : name);
492 5 : *result = NULL;
493 5 : return MATCH_ERROR;
494 : }
495 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
496 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
497 :
498 : /* Check to see if the value is an initialization array expression. */
499 185 : if (sym->value->expr_type == EXPR_ARRAY)
500 : {
501 67 : gfc_current_locus = old_loc;
502 :
503 67 : m = gfc_match_init_expr (result);
504 67 : if (m == MATCH_ERROR)
505 : return m;
506 :
507 66 : if (m == MATCH_YES)
508 : {
509 66 : if (!gfc_simplify_expr (*result, 0))
510 0 : m = MATCH_ERROR;
511 :
512 66 : if ((*result)->expr_type == EXPR_CONSTANT)
513 : return m;
514 : else
515 : {
516 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
517 2 : return MATCH_ERROR;
518 : }
519 : }
520 : }
521 :
522 118 : *result = gfc_copy_expr (sym->value);
523 118 : return MATCH_YES;
524 : }
525 :
526 :
527 : /* Match a list of values in a DATA statement. The leading '/' has
528 : already been seen at this point. */
529 :
530 : static match
531 2578 : top_val_list (gfc_data *data)
532 : {
533 2578 : gfc_data_value *new_val, *tail;
534 2578 : gfc_expr *expr;
535 2578 : match m;
536 :
537 2578 : tail = NULL;
538 :
539 8367 : for (;;)
540 : {
541 8367 : m = match_data_constant (&expr);
542 8367 : if (m == MATCH_NO)
543 3 : goto syntax;
544 8364 : if (m == MATCH_ERROR)
545 : return MATCH_ERROR;
546 :
547 8342 : new_val = gfc_get_data_value ();
548 8342 : mpz_init (new_val->repeat);
549 :
550 8342 : if (tail == NULL)
551 2553 : data->value = new_val;
552 : else
553 5789 : tail->next = new_val;
554 :
555 8342 : tail = new_val;
556 :
557 8342 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
558 : {
559 8137 : tail->expr = expr;
560 8137 : mpz_set_ui (tail->repeat, 1);
561 : }
562 : else
563 : {
564 205 : mpz_set (tail->repeat, expr->value.integer);
565 205 : gfc_free_expr (expr);
566 :
567 205 : m = match_data_constant (&tail->expr);
568 205 : if (m == MATCH_NO)
569 0 : goto syntax;
570 205 : if (m == MATCH_ERROR)
571 : return MATCH_ERROR;
572 : }
573 :
574 8338 : if (gfc_match_char ('/') == MATCH_YES)
575 : break;
576 5790 : if (gfc_match_char (',') == MATCH_NO)
577 1 : goto syntax;
578 : }
579 :
580 : return MATCH_YES;
581 :
582 4 : syntax:
583 4 : gfc_syntax_error (ST_DATA);
584 4 : gfc_free_data_all (gfc_current_ns);
585 4 : return MATCH_ERROR;
586 : }
587 :
588 :
589 : /* Matches an old style initialization. */
590 :
591 : static match
592 70 : match_old_style_init (const char *name)
593 : {
594 70 : match m;
595 70 : gfc_symtree *st;
596 70 : gfc_symbol *sym;
597 70 : gfc_data *newdata, *nd;
598 :
599 : /* Set up data structure to hold initializers. */
600 70 : gfc_find_sym_tree (name, NULL, 0, &st);
601 70 : sym = st->n.sym;
602 :
603 70 : newdata = gfc_get_data ();
604 70 : newdata->var = gfc_get_data_variable ();
605 70 : newdata->var->expr = gfc_get_variable_expr (st);
606 70 : newdata->var->expr->where = sym->declared_at;
607 70 : newdata->where = gfc_current_locus;
608 :
609 : /* Match initial value list. This also eats the terminal '/'. */
610 70 : m = top_val_list (newdata);
611 70 : if (m != MATCH_YES)
612 : {
613 1 : free (newdata);
614 1 : return m;
615 : }
616 :
617 : /* Check that a BOZ did not creep into an old-style initialization. */
618 137 : for (nd = newdata; nd; nd = nd->next)
619 : {
620 69 : if (nd->value->expr->ts.type == BT_BOZ
621 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
622 : "initialization"), &nd->value->expr->where))
623 : return MATCH_ERROR;
624 :
625 68 : if (nd->var->expr->ts.type != BT_INTEGER
626 27 : && nd->var->expr->ts.type != BT_REAL
627 21 : && nd->value->expr->ts.type == BT_BOZ)
628 : {
629 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
630 : "a %qs variable in an old-style initialization"),
631 0 : &nd->value->expr->where,
632 : gfc_typename (&nd->value->expr->ts));
633 0 : return MATCH_ERROR;
634 : }
635 : }
636 :
637 68 : if (gfc_pure (NULL))
638 : {
639 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
640 1 : free (newdata);
641 1 : return MATCH_ERROR;
642 : }
643 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
644 :
645 : /* Mark the variable as having appeared in a data statement. */
646 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
647 : {
648 2 : free (newdata);
649 2 : return MATCH_ERROR;
650 : }
651 :
652 : /* Chain in namespace list of DATA initializers. */
653 65 : newdata->next = gfc_current_ns->data;
654 65 : gfc_current_ns->data = newdata;
655 :
656 65 : return m;
657 : }
658 :
659 :
660 : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
661 : we are matching a DATA statement and are therefore issuing an error
662 : if we encounter something unexpected, if not, we're trying to match
663 : an old-style initialization expression of the form INTEGER I /2/. */
664 :
665 : match
666 2440 : gfc_match_data (void)
667 : {
668 2440 : gfc_data *new_data;
669 2440 : gfc_expr *e;
670 2440 : gfc_ref *ref;
671 2440 : match m;
672 2440 : char c;
673 :
674 : /* DATA has been matched. In free form source code, the next character
675 : needs to be whitespace or '(' from an implied do-loop. Check that
676 : here. */
677 2440 : c = gfc_peek_ascii_char ();
678 2440 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
679 : return MATCH_NO;
680 :
681 : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
682 2439 : if ((gfc_current_state () == COMP_FUNCTION
683 2439 : || gfc_current_state () == COMP_SUBROUTINE)
684 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
685 : {
686 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
687 1 : return MATCH_ERROR;
688 : }
689 :
690 2438 : set_in_match_data (true);
691 :
692 2632 : for (;;)
693 : {
694 2535 : new_data = gfc_get_data ();
695 2535 : new_data->where = gfc_current_locus;
696 :
697 2535 : m = top_var_list (new_data);
698 2535 : if (m != MATCH_YES)
699 18 : goto cleanup;
700 :
701 2517 : if (new_data->var->iter.var
702 117 : && new_data->var->iter.var->ts.type == BT_INTEGER
703 74 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
704 68 : && new_data->var->list
705 68 : && new_data->var->list->expr
706 55 : && new_data->var->list->expr->ts.type == BT_CHARACTER
707 3 : && new_data->var->list->expr->ref
708 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
709 : {
710 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
711 : "statement", &new_data->var->list->expr->where);
712 1 : goto cleanup;
713 : }
714 :
715 : /* Check for an entity with an allocatable component, which is not
716 : allowed. */
717 2516 : e = new_data->var->expr;
718 2516 : if (e)
719 : {
720 2400 : bool invalid;
721 :
722 2400 : invalid = false;
723 3624 : for (ref = e->ref; ref; ref = ref->next)
724 1224 : if ((ref->type == REF_COMPONENT
725 140 : && ref->u.c.component->attr.allocatable)
726 1222 : || (ref->type == REF_ARRAY
727 1034 : && e->symtree->n.sym->attr.pointer != 1
728 1031 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
729 1224 : invalid = true;
730 :
731 2400 : if (invalid)
732 : {
733 2 : gfc_error ("Allocatable component or deferred-shaped array "
734 : "near %C in DATA statement");
735 2 : goto cleanup;
736 : }
737 :
738 : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
739 : as a data-stmt-object shall not be an object designator in which
740 : a pointer appears other than as the entire rightmost part-ref. */
741 2398 : if (!e->ref && e->ts.type == BT_DERIVED
742 43 : && e->symtree->n.sym->attr.pointer)
743 4 : goto partref;
744 :
745 2394 : ref = e->ref;
746 2394 : if (e->symtree->n.sym->ts.type == BT_DERIVED
747 125 : && e->symtree->n.sym->attr.pointer
748 1 : && ref->type == REF_COMPONENT)
749 1 : goto partref;
750 :
751 3609 : for (; ref; ref = ref->next)
752 1217 : if (ref->type == REF_COMPONENT
753 135 : && ref->u.c.component->attr.pointer
754 27 : && ref->next)
755 1 : goto partref;
756 : }
757 :
758 2508 : m = top_val_list (new_data);
759 2508 : if (m != MATCH_YES)
760 29 : goto cleanup;
761 :
762 2479 : new_data->next = gfc_current_ns->data;
763 2479 : gfc_current_ns->data = new_data;
764 :
765 : /* A BOZ literal constant cannot appear in a structure constructor.
766 : Check for that here for a data statement value. */
767 2479 : if (new_data->value->expr->ts.type == BT_DERIVED
768 37 : && new_data->value->expr->value.constructor)
769 : {
770 35 : gfc_constructor *c;
771 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
772 106 : for (; c; c = gfc_constructor_next (c))
773 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
774 : {
775 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
776 : "structure constructor", &c->expr->where);
777 0 : return MATCH_ERROR;
778 : }
779 : }
780 :
781 2479 : if (gfc_match_eos () == MATCH_YES)
782 : break;
783 :
784 97 : gfc_match_char (','); /* Optional comma */
785 97 : }
786 :
787 2382 : set_in_match_data (false);
788 :
789 2382 : if (gfc_pure (NULL))
790 : {
791 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
792 0 : return MATCH_ERROR;
793 : }
794 2382 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
795 :
796 2382 : return MATCH_YES;
797 :
798 6 : partref:
799 :
800 6 : gfc_error ("part-ref with pointer attribute near %L is not "
801 : "rightmost part-ref of data-stmt-object",
802 : &e->where);
803 :
804 56 : cleanup:
805 56 : set_in_match_data (false);
806 56 : gfc_free_data (new_data);
807 56 : return MATCH_ERROR;
808 : }
809 :
810 :
811 : /************************ Declaration statements *********************/
812 :
813 :
814 : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
815 : list). The difference here is the expression is a list of constants
816 : and is surrounded by '/'.
817 : The typespec ts must match the typespec of the variable which the
818 : clist is initializing.
819 : The arrayspec tells whether this should match a list of constants
820 : corresponding to array elements or a scalar (as == NULL). */
821 :
822 : static match
823 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
824 : {
825 74 : gfc_constructor_base array_head = NULL;
826 74 : gfc_expr *expr = NULL;
827 74 : match m = MATCH_ERROR;
828 74 : locus where;
829 74 : mpz_t repeat, cons_size, as_size;
830 74 : bool scalar;
831 74 : int cmp;
832 :
833 74 : gcc_assert (ts);
834 :
835 : /* We have already matched '/' - now look for a constant list, as with
836 : top_val_list from decl.cc, but append the result to an array. */
837 74 : if (gfc_match ("/") == MATCH_YES)
838 : {
839 1 : gfc_error ("Empty old style initializer list at %C");
840 1 : return MATCH_ERROR;
841 : }
842 :
843 73 : where = gfc_current_locus;
844 73 : scalar = !as || !as->rank;
845 :
846 42 : if (!scalar && !spec_size (as, &as_size))
847 : {
848 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
849 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
850 : /* Nothing to cleanup yet. */
851 1 : return MATCH_ERROR;
852 : }
853 :
854 72 : mpz_init_set_ui (repeat, 0);
855 :
856 143 : for (;;)
857 : {
858 143 : m = match_data_constant (&expr);
859 143 : if (m != MATCH_YES)
860 3 : expr = NULL; /* match_data_constant may set expr to garbage */
861 3 : if (m == MATCH_NO)
862 2 : goto syntax;
863 141 : if (m == MATCH_ERROR)
864 1 : goto cleanup;
865 :
866 : /* Found r in repeat spec r*c; look for the constant to repeat. */
867 140 : if ( gfc_match_char ('*') == MATCH_YES)
868 : {
869 18 : if (scalar)
870 : {
871 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
872 1 : goto cleanup;
873 : }
874 17 : if (expr->ts.type != BT_INTEGER)
875 : {
876 1 : gfc_error ("Repeat spec must be an integer at %C");
877 1 : goto cleanup;
878 : }
879 16 : mpz_set (repeat, expr->value.integer);
880 16 : gfc_free_expr (expr);
881 16 : expr = NULL;
882 :
883 16 : m = match_data_constant (&expr);
884 16 : if (m == MATCH_NO)
885 : {
886 1 : m = MATCH_ERROR;
887 1 : gfc_error ("Expected data constant after repeat spec at %C");
888 : }
889 16 : if (m != MATCH_YES)
890 1 : goto cleanup;
891 : }
892 : /* No repeat spec, we matched the data constant itself. */
893 : else
894 122 : mpz_set_ui (repeat, 1);
895 :
896 137 : if (!scalar)
897 : {
898 : /* Add the constant initializer as many times as repeated. */
899 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
900 : {
901 : /* Make sure types of elements match */
902 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
903 12 : && !gfc_convert_type (expr, ts, 1))
904 0 : goto cleanup;
905 :
906 144 : gfc_constructor_append_expr (&array_head,
907 : gfc_copy_expr (expr), &gfc_current_locus);
908 : }
909 :
910 107 : gfc_free_expr (expr);
911 107 : expr = NULL;
912 : }
913 :
914 : /* For scalar initializers quit after one element. */
915 : else
916 : {
917 30 : if(gfc_match_char ('/') != MATCH_YES)
918 : {
919 1 : gfc_error ("End of scalar initializer expected at %C");
920 1 : goto cleanup;
921 : }
922 : break;
923 : }
924 :
925 107 : if (gfc_match_char ('/') == MATCH_YES)
926 : break;
927 72 : if (gfc_match_char (',') == MATCH_NO)
928 1 : goto syntax;
929 : }
930 :
931 : /* If we break early from here out, we encountered an error. */
932 64 : m = MATCH_ERROR;
933 :
934 : /* Set up expr as an array constructor. */
935 64 : if (!scalar)
936 : {
937 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
938 35 : expr->ts = *ts;
939 35 : expr->value.constructor = array_head;
940 :
941 : /* Validate sizes. We built expr ourselves, so cons_size will be
942 : constant (we fail above for non-constant expressions).
943 : We still need to verify that the sizes match. */
944 35 : gcc_assert (gfc_array_size (expr, &cons_size));
945 35 : cmp = mpz_cmp (cons_size, as_size);
946 35 : if (cmp < 0)
947 2 : gfc_error ("Not enough elements in array initializer at %C");
948 33 : else if (cmp > 0)
949 3 : gfc_error ("Too many elements in array initializer at %C");
950 35 : mpz_clear (cons_size);
951 35 : if (cmp)
952 5 : goto cleanup;
953 :
954 : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
955 30 : expr->rank = as->rank;
956 30 : expr->corank = as->corank;
957 30 : expr->shape = gfc_get_shape (as->rank);
958 66 : for (int i = 0; i < as->rank; ++i)
959 36 : spec_dimen_size (as, i, &expr->shape[i]);
960 : }
961 :
962 : /* Make sure scalar types match. */
963 29 : else if (!gfc_compare_types (&expr->ts, ts)
964 29 : && !gfc_convert_type (expr, ts, 1))
965 2 : goto cleanup;
966 :
967 57 : if (expr->ts.u.cl)
968 1 : expr->ts.u.cl->length_from_typespec = 1;
969 :
970 57 : *result = expr;
971 57 : m = MATCH_YES;
972 57 : goto done;
973 :
974 3 : syntax:
975 3 : m = MATCH_ERROR;
976 3 : gfc_error ("Syntax error in old style initializer list at %C");
977 :
978 15 : cleanup:
979 15 : if (expr)
980 10 : expr->value.constructor = NULL;
981 15 : gfc_free_expr (expr);
982 15 : gfc_constructor_free (array_head);
983 :
984 72 : done:
985 72 : mpz_clear (repeat);
986 72 : if (!scalar)
987 41 : mpz_clear (as_size);
988 : return m;
989 : }
990 :
991 :
992 : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
993 :
994 : static bool
995 114 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
996 : {
997 114 : if ((from->type == AS_ASSUMED_RANK && to->corank)
998 112 : || (to->type == AS_ASSUMED_RANK && from->corank))
999 : {
1000 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
1001 5 : return false;
1002 : }
1003 :
1004 109 : if (to->rank == 0 && from->rank > 0)
1005 : {
1006 48 : to->rank = from->rank;
1007 48 : to->type = from->type;
1008 48 : to->cray_pointee = from->cray_pointee;
1009 48 : to->cp_was_assumed = from->cp_was_assumed;
1010 :
1011 152 : for (int i = to->corank - 1; i >= 0; i--)
1012 : {
1013 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1014 : cleans up elsewhere. */
1015 104 : int j = from->rank + i;
1016 104 : if (j >= GFC_MAX_DIMENSIONS)
1017 : break;
1018 :
1019 104 : to->lower[j] = to->lower[i];
1020 104 : to->upper[j] = to->upper[i];
1021 : }
1022 115 : for (int i = 0; i < from->rank; i++)
1023 : {
1024 67 : if (copy)
1025 : {
1026 43 : to->lower[i] = gfc_copy_expr (from->lower[i]);
1027 43 : to->upper[i] = gfc_copy_expr (from->upper[i]);
1028 : }
1029 : else
1030 : {
1031 24 : to->lower[i] = from->lower[i];
1032 24 : to->upper[i] = from->upper[i];
1033 : }
1034 : }
1035 : }
1036 61 : else if (to->corank == 0 && from->corank > 0)
1037 : {
1038 34 : to->corank = from->corank;
1039 34 : to->cotype = from->cotype;
1040 :
1041 104 : for (int i = 0; i < from->corank; i++)
1042 : {
1043 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1044 : cleans up elsewhere. */
1045 71 : int k = from->rank + i;
1046 71 : int j = to->rank + i;
1047 71 : if (j >= GFC_MAX_DIMENSIONS)
1048 : break;
1049 :
1050 70 : if (copy)
1051 : {
1052 37 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1053 37 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1054 : }
1055 : else
1056 : {
1057 33 : to->lower[j] = from->lower[k];
1058 33 : to->upper[j] = from->upper[k];
1059 : }
1060 : }
1061 : }
1062 :
1063 109 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1064 : {
1065 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1066 : "allowed dimensions of %d",
1067 : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1068 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1069 1 : return false;
1070 : }
1071 : return true;
1072 : }
1073 :
1074 :
1075 : /* Match an intent specification. Since this can only happen after an
1076 : INTENT word, a legal intent-spec must follow. */
1077 :
1078 : static sym_intent
1079 28883 : match_intent_spec (void)
1080 : {
1081 :
1082 28883 : if (gfc_match (" ( in out )") == MATCH_YES)
1083 : return INTENT_INOUT;
1084 25636 : if (gfc_match (" ( in )") == MATCH_YES)
1085 : return INTENT_IN;
1086 3790 : if (gfc_match (" ( out )") == MATCH_YES)
1087 : return INTENT_OUT;
1088 :
1089 2 : gfc_error ("Bad INTENT specification at %C");
1090 2 : return INTENT_UNKNOWN;
1091 : }
1092 :
1093 :
1094 : /* Matches a character length specification, which is either a
1095 : specification expression, '*', or ':'. */
1096 :
1097 : static match
1098 28415 : char_len_param_value (gfc_expr **expr, bool *deferred)
1099 : {
1100 28415 : match m;
1101 28415 : gfc_expr *p;
1102 :
1103 28415 : *expr = NULL;
1104 28415 : *deferred = false;
1105 :
1106 28415 : if (gfc_match_char ('*') == MATCH_YES)
1107 : return MATCH_YES;
1108 :
1109 21805 : if (gfc_match_char (':') == MATCH_YES)
1110 : {
1111 3450 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1112 : return MATCH_ERROR;
1113 :
1114 3448 : *deferred = true;
1115 :
1116 3448 : return MATCH_YES;
1117 : }
1118 :
1119 18355 : m = gfc_match_expr (expr);
1120 :
1121 18355 : if (m == MATCH_NO || m == MATCH_ERROR)
1122 : return m;
1123 :
1124 18350 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1125 : return MATCH_ERROR;
1126 :
1127 : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1128 18344 : p = gfc_copy_expr (*expr);
1129 18344 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1130 15174 : gfc_replace_expr (*expr, p);
1131 : else
1132 3170 : gfc_free_expr (p);
1133 :
1134 18344 : if ((*expr)->expr_type == EXPR_FUNCTION)
1135 : {
1136 1021 : if ((*expr)->ts.type == BT_INTEGER
1137 1020 : || ((*expr)->ts.type == BT_UNKNOWN
1138 1020 : && strcmp((*expr)->symtree->name, "null") != 0))
1139 : return MATCH_YES;
1140 :
1141 2 : goto syntax;
1142 : }
1143 17323 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1144 : {
1145 : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1146 : processor dependent and its value is greater than or equal to zero.
1147 : F2008, 4.4.3.2: If the character length parameter value evaluates
1148 : to a negative value, the length of character entities declared
1149 : is zero. */
1150 :
1151 15072 : if ((*expr)->ts.type == BT_INTEGER)
1152 : {
1153 15054 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1154 4 : mpz_set_si ((*expr)->value.integer, 0);
1155 : }
1156 : else
1157 18 : goto syntax;
1158 : }
1159 2251 : else if ((*expr)->expr_type == EXPR_ARRAY)
1160 8 : goto syntax;
1161 2243 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1162 : {
1163 1582 : bool t;
1164 1582 : gfc_expr *e;
1165 :
1166 1582 : e = gfc_copy_expr (*expr);
1167 :
1168 : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1169 : which causes an ICE if gfc_reduce_init_expr() is called. */
1170 1582 : if (e->ref && e->ref->type == REF_ARRAY
1171 8 : && e->ref->u.ar.type == AR_UNKNOWN
1172 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1173 2 : goto syntax;
1174 :
1175 1580 : t = gfc_reduce_init_expr (e);
1176 :
1177 1580 : if (!t && e->ts.type == BT_UNKNOWN
1178 7 : && e->symtree->n.sym->attr.untyped == 1
1179 7 : && (flag_implicit_none
1180 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1181 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1182 : {
1183 7 : gfc_free_expr (e);
1184 7 : goto syntax;
1185 : }
1186 :
1187 1573 : if ((e->ref && e->ref->type == REF_ARRAY
1188 4 : && e->ref->u.ar.type != AR_ELEMENT)
1189 1572 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1190 : {
1191 2 : gfc_free_expr (e);
1192 2 : goto syntax;
1193 : }
1194 :
1195 1571 : gfc_free_expr (e);
1196 : }
1197 :
1198 17286 : if (gfc_seen_div0)
1199 52 : m = MATCH_ERROR;
1200 :
1201 : return m;
1202 :
1203 39 : syntax:
1204 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1205 39 : return MATCH_ERROR;
1206 : }
1207 :
1208 :
1209 : /* A character length is a '*' followed by a literal integer or a
1210 : char_len_param_value in parenthesis. */
1211 :
1212 : static match
1213 64215 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1214 : {
1215 64215 : int length;
1216 64215 : match m;
1217 :
1218 64215 : *deferred = false;
1219 64215 : m = gfc_match_char ('*');
1220 64215 : if (m != MATCH_YES)
1221 : return m;
1222 :
1223 2641 : m = gfc_match_small_literal_int (&length, NULL);
1224 2641 : if (m == MATCH_ERROR)
1225 : return m;
1226 :
1227 2641 : if (m == MATCH_YES)
1228 : {
1229 2137 : if (obsolescent_check
1230 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1231 : return MATCH_ERROR;
1232 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1233 2137 : return m;
1234 : }
1235 :
1236 504 : if (gfc_match_char ('(') == MATCH_NO)
1237 0 : goto syntax;
1238 :
1239 504 : m = char_len_param_value (expr, deferred);
1240 504 : if (m != MATCH_YES && gfc_matching_function)
1241 : {
1242 0 : gfc_undo_symbols ();
1243 0 : m = MATCH_YES;
1244 : }
1245 :
1246 1 : if (m == MATCH_ERROR)
1247 : return m;
1248 503 : if (m == MATCH_NO)
1249 0 : goto syntax;
1250 :
1251 503 : if (gfc_match_char (')') == MATCH_NO)
1252 : {
1253 0 : gfc_free_expr (*expr);
1254 0 : *expr = NULL;
1255 0 : goto syntax;
1256 : }
1257 :
1258 503 : if (obsolescent_check
1259 503 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1260 0 : return MATCH_ERROR;
1261 :
1262 : return MATCH_YES;
1263 :
1264 0 : syntax:
1265 0 : gfc_error ("Syntax error in character length specification at %C");
1266 0 : return MATCH_ERROR;
1267 : }
1268 :
1269 :
1270 : /* Special subroutine for finding a symbol. Check if the name is found
1271 : in the current name space. If not, and we're compiling a function or
1272 : subroutine and the parent compilation unit is an interface, then check
1273 : to see if the name we've been given is the name of the interface
1274 : (located in another namespace). */
1275 :
1276 : static int
1277 289209 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1278 : {
1279 289209 : gfc_state_data *s;
1280 289209 : gfc_symtree *st;
1281 289209 : int i;
1282 :
1283 289209 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1284 289209 : if (i == 0)
1285 : {
1286 289209 : *result = st ? st->n.sym : NULL;
1287 289209 : goto end;
1288 : }
1289 :
1290 0 : if (gfc_current_state () != COMP_SUBROUTINE
1291 0 : && gfc_current_state () != COMP_FUNCTION)
1292 0 : goto end;
1293 :
1294 0 : s = gfc_state_stack->previous;
1295 0 : if (s == NULL)
1296 0 : goto end;
1297 :
1298 0 : if (s->state != COMP_INTERFACE)
1299 0 : goto end;
1300 0 : if (s->sym == NULL)
1301 0 : goto end; /* Nameless interface. */
1302 :
1303 0 : if (strcmp (name, s->sym->name) == 0)
1304 : {
1305 0 : *result = s->sym;
1306 0 : return 0;
1307 : }
1308 :
1309 0 : end:
1310 : return i;
1311 : }
1312 :
1313 :
1314 : /* Special subroutine for getting a symbol node associated with a
1315 : procedure name, used in SUBROUTINE and FUNCTION statements. The
1316 : symbol is created in the parent using with symtree node in the
1317 : child unit pointing to the symbol. If the current namespace has no
1318 : parent, then the symbol is just created in the current unit. */
1319 :
1320 : static int
1321 65675 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1322 : {
1323 65675 : gfc_symtree *st;
1324 65675 : gfc_symbol *sym;
1325 65675 : int rc = 0;
1326 :
1327 : /* Module functions have to be left in their own namespace because
1328 : they have potentially (almost certainly!) already been referenced.
1329 : In this sense, they are rather like external functions. This is
1330 : fixed up in resolve.cc(resolve_entries), where the symbol name-
1331 : space is set to point to the master function, so that the fake
1332 : result mechanism can work. */
1333 65675 : if (module_fcn_entry)
1334 : {
1335 : /* Present if entry is declared to be a module procedure. */
1336 260 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1337 :
1338 260 : if (*result == NULL)
1339 217 : rc = gfc_get_symbol (name, NULL, result);
1340 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1341 43 : && (*result)->ts.type == BT_UNKNOWN
1342 86 : && sym->attr.flavor == FL_UNKNOWN)
1343 : /* Pick up the typespec for the entry, if declared in the function
1344 : body. Note that this symbol is FL_UNKNOWN because it will
1345 : only have appeared in a type declaration. The local symtree
1346 : is set to point to the module symbol and a unique symtree
1347 : to the local version. This latter ensures a correct clearing
1348 : of the symbols. */
1349 : {
1350 : /* If the ENTRY proceeds its specification, we need to ensure
1351 : that this does not raise a "has no IMPLICIT type" error. */
1352 43 : if (sym->ts.type == BT_UNKNOWN)
1353 23 : sym->attr.untyped = 1;
1354 :
1355 43 : (*result)->ts = sym->ts;
1356 :
1357 : /* Put the symbol in the procedure namespace so that, should
1358 : the ENTRY precede its specification, the specification
1359 : can be applied. */
1360 43 : (*result)->ns = gfc_current_ns;
1361 :
1362 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1363 43 : st->n.sym = *result;
1364 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1365 43 : sym->refs++;
1366 43 : st->n.sym = sym;
1367 : }
1368 : }
1369 : else
1370 65415 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1371 :
1372 65675 : if (rc)
1373 : return rc;
1374 :
1375 65674 : sym = *result;
1376 65674 : if (sym->attr.proc == PROC_ST_FUNCTION)
1377 : return rc;
1378 :
1379 65673 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1380 : {
1381 : /* Create a partially populated interface symbol to carry the
1382 : characteristics of the procedure and the result. */
1383 472 : sym->tlink = gfc_new_symbol (name, sym->ns);
1384 472 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1385 472 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1386 472 : if (sym->attr.dimension)
1387 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1388 :
1389 : /* Ideally, at this point, a copy would be made of the formal
1390 : arguments and their namespace. However, this does not appear
1391 : to be necessary, albeit at the expense of not being able to
1392 : use gfc_compare_interfaces directly. */
1393 :
1394 472 : if (sym->result && sym->result != sym)
1395 : {
1396 105 : sym->tlink->result = sym->result;
1397 105 : sym->result = NULL;
1398 : }
1399 367 : else if (sym->result)
1400 : {
1401 93 : sym->tlink->result = sym->tlink;
1402 : }
1403 : }
1404 65201 : else if (sym && !sym->gfc_new
1405 25189 : && gfc_current_state () != COMP_INTERFACE)
1406 : {
1407 : /* Trap another encompassed procedure with the same name. All
1408 : these conditions are necessary to avoid picking up an entry
1409 : whose name clashes with that of the encompassing procedure;
1410 : this is handled using gsymbols to register unique, globally
1411 : accessible names. */
1412 23848 : if (sym->attr.flavor != 0
1413 21765 : && sym->attr.proc != 0
1414 2422 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1415 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1416 : {
1417 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1418 : name, &sym->declared_at);
1419 7 : return true;
1420 : }
1421 23841 : if (sym->attr.flavor != 0
1422 21758 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1423 : {
1424 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1425 : name, &sym->declared_at);
1426 1 : return true;
1427 : }
1428 :
1429 23840 : if (sym->attr.external && sym->attr.procedure
1430 2 : && gfc_current_state () == COMP_CONTAINS)
1431 : {
1432 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1433 : "procedure defined at %L",
1434 : name, &sym->declared_at);
1435 1 : return true;
1436 : }
1437 :
1438 : /* Trap a procedure with a name the same as interface in the
1439 : encompassing scope. */
1440 23839 : if (sym->attr.generic != 0
1441 60 : && (sym->attr.subroutine || sym->attr.function)
1442 1 : && !sym->attr.mod_proc)
1443 : {
1444 1 : gfc_error_now ("Name %qs at %C is already defined"
1445 : " as a generic interface at %L",
1446 : name, &sym->declared_at);
1447 1 : return true;
1448 : }
1449 :
1450 : /* Trap declarations of attributes in encompassing scope. The
1451 : signature for this is that ts.kind is nonzero for no-CLASS
1452 : entity. For a CLASS entity, ts.kind is zero. */
1453 23838 : if ((sym->ts.kind != 0
1454 23465 : || sym->ts.type == BT_CLASS
1455 23464 : || sym->ts.type == BT_DERIVED)
1456 397 : && !sym->attr.implicit_type
1457 396 : && sym->attr.proc == 0
1458 378 : && gfc_current_ns->parent != NULL
1459 138 : && sym->attr.access == 0
1460 136 : && !module_fcn_entry)
1461 : {
1462 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1463 : "from a previous declaration", name);
1464 5 : return true;
1465 : }
1466 : }
1467 :
1468 : /* F2023: C1247 (R1526) MODULE shall appear only in the function-stmt or
1469 : subroutine-stmt of a module subprogram or of a nonabstract interface
1470 : body that is declared in the scoping unit of a module or submodule. */
1471 65658 : if (sym->attr.external
1472 92 : && (sym->attr.subroutine || sym->attr.function)
1473 91 : && sym->attr.if_source == IFSRC_IFBODY
1474 91 : && !current_attr.module_procedure
1475 3 : && sym->attr.proc == PROC_MODULE
1476 3 : && gfc_state_stack->state == COMP_CONTAINS)
1477 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1478 : "clashes with internal procedure defined at %C",
1479 : name, &sym->declared_at);
1480 :
1481 : /* This is the converse requirement: The separate-module-subprogram for a
1482 : module procedure shall have the MODULE prefix or be declared a MODULE
1483 : PROCEDURE, otherwise it would be ambiguous. */
1484 65658 : if (sym->attr.module_procedure
1485 472 : && (sym->attr.subroutine || sym->attr.function)
1486 472 : && sym->attr.if_source == IFSRC_IFBODY
1487 472 : && !current_attr.module_procedure
1488 4 : && sym->attr.proc == PROC_MODULE
1489 4 : && gfc_state_stack->state == COMP_CONTAINS
1490 2 : && gfc_state_stack->previous
1491 2 : && gfc_state_stack->previous->state == COMP_SUBMODULE)
1492 1 : gfc_error_now ("Procedure %qs at %C requires the MODULE prefix because "
1493 : "it is a module procedure declared in module %qs",
1494 1 : name, sym->module ? sym->module : "");
1495 :
1496 65658 : if (sym && !sym->gfc_new
1497 25646 : && sym->attr.flavor != FL_UNKNOWN
1498 23163 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1499 244 : && gfc_state_stack->state == COMP_CONTAINS
1500 239 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1501 : {
1502 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1503 : name, &sym->declared_at);
1504 1 : return true;
1505 : }
1506 :
1507 65657 : if (gfc_current_ns->parent == NULL || *result == NULL)
1508 : return rc;
1509 :
1510 : /* Module function entries will already have a symtree in
1511 : the current namespace but will need one at module level. */
1512 53300 : if (module_fcn_entry)
1513 : {
1514 : /* Present if entry is declared to be a module procedure. */
1515 258 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1516 258 : if (st == NULL)
1517 217 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1518 : }
1519 : else
1520 53042 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1521 :
1522 53300 : st->n.sym = sym;
1523 53300 : sym->refs++;
1524 :
1525 : /* See if the procedure should be a module procedure. */
1526 :
1527 53300 : if (((sym->ns->proc_name != NULL
1528 53300 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1529 21795 : && sym->attr.proc != PROC_MODULE)
1530 53300 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1531 72230 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1532 : rc = 2;
1533 :
1534 : return rc;
1535 : }
1536 :
1537 :
1538 : /* Verify that the given symbol representing a parameter is C
1539 : interoperable, by checking to see if it was marked as such after
1540 : its declaration. If the given symbol is not interoperable, a
1541 : warning is reported, thus removing the need to return the status to
1542 : the calling function. The standard does not require the user use
1543 : one of the iso_c_binding named constants to declare an
1544 : interoperable parameter, but we can't be sure if the param is C
1545 : interop or not if the user doesn't. For example, integer(4) may be
1546 : legal Fortran, but doesn't have meaning in C. It may interop with
1547 : a number of the C types, which causes a problem because the
1548 : compiler can't know which one. This code is almost certainly not
1549 : portable, and the user will get what they deserve if the C type
1550 : across platforms isn't always interoperable with integer(4). If
1551 : the user had used something like integer(c_int) or integer(c_long),
1552 : the compiler could have automatically handled the varying sizes
1553 : across platforms. */
1554 :
1555 : bool
1556 17324 : gfc_verify_c_interop_param (gfc_symbol *sym)
1557 : {
1558 17324 : int is_c_interop = 0;
1559 17324 : bool retval = true;
1560 :
1561 : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1562 : Don't repeat the checks here. */
1563 17324 : if (sym->attr.implicit_type)
1564 : return true;
1565 :
1566 : /* For subroutines or functions that are passed to a BIND(C) procedure,
1567 : they're interoperable if they're BIND(C) and their params are all
1568 : interoperable. */
1569 17324 : if (sym->attr.flavor == FL_PROCEDURE)
1570 : {
1571 4 : if (sym->attr.is_bind_c == 0)
1572 : {
1573 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1574 : "attribute to be C interoperable", sym->name,
1575 : &(sym->declared_at));
1576 0 : return false;
1577 : }
1578 : else
1579 : {
1580 4 : if (sym->attr.is_c_interop == 1)
1581 : /* We've already checked this procedure; don't check it again. */
1582 : return true;
1583 : else
1584 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1585 4 : sym->common_block);
1586 : }
1587 : }
1588 :
1589 : /* See if we've stored a reference to a procedure that owns sym. */
1590 17320 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1591 : {
1592 17320 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1593 : {
1594 17281 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1595 17281 : bool f2018_added = false;
1596 :
1597 17281 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1598 :
1599 : /* F2018:18.3.6 has the following text:
1600 : "(5) any dummy argument without the VALUE attribute corresponds to
1601 : a formal parameter of the prototype that is of a pointer type, and
1602 : either
1603 : • the dummy argument is interoperable with an entity of the
1604 : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1605 : the formal parameter (this is equivalent to the F2008 text),
1606 : • the dummy argument is a nonallocatable nonpointer variable of
1607 : type CHARACTER with assumed character length and the formal
1608 : parameter is a pointer to CFI_cdesc_t,
1609 : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1610 : or a pointer without the CONTIGUOUS attribute, and the formal
1611 : parameter is a pointer to CFI_cdesc_t, or
1612 : • the dummy argument is assumed-type and not allocatable,
1613 : assumed-shape, assumed-rank, or a pointer, and the formal
1614 : parameter is a pointer to void," */
1615 3731 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1616 : {
1617 2364 : bool as_ar = (sym->as
1618 2364 : && (sym->as->type == AS_ASSUMED_SHAPE
1619 2117 : || sym->as->type == AS_ASSUMED_RANK));
1620 4728 : bool cond1 = (sym->ts.type == BT_CHARACTER
1621 1565 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1622 905 : && !sym->attr.allocatable
1623 3251 : && !sym->attr.pointer);
1624 4728 : bool cond2 = (sym->attr.allocatable
1625 2267 : || as_ar
1626 3389 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1627 4728 : bool cond3 = (sym->ts.type == BT_ASSUMED
1628 0 : && !sym->attr.allocatable
1629 0 : && !sym->attr.pointer
1630 2364 : && !as_ar);
1631 2364 : f2018_added = cond1 || cond2 || cond3;
1632 : }
1633 :
1634 17281 : if (is_c_interop != 1 && !f2018_added)
1635 : {
1636 : /* Make personalized messages to give better feedback. */
1637 1837 : if (sym->ts.type == BT_DERIVED)
1638 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1639 : "BIND(C) procedure %qs but is not C interoperable "
1640 : "because derived type %qs is not C interoperable",
1641 : sym->name, &(sym->declared_at),
1642 1 : sym->ns->proc_name->name,
1643 1 : sym->ts.u.derived->name);
1644 1836 : else if (sym->ts.type == BT_CLASS)
1645 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1646 : "BIND(C) procedure %qs but is not C interoperable "
1647 : "because it is polymorphic",
1648 : sym->name, &(sym->declared_at),
1649 6 : sym->ns->proc_name->name);
1650 1830 : else if (warn_c_binding_type)
1651 39 : gfc_warning (OPT_Wc_binding_type,
1652 : "Variable %qs at %L is a dummy argument of the "
1653 : "BIND(C) procedure %qs but may not be C "
1654 : "interoperable",
1655 : sym->name, &(sym->declared_at),
1656 39 : sym->ns->proc_name->name);
1657 : }
1658 :
1659 : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1660 17281 : if (sym->attr.pointer && sym->attr.contiguous)
1661 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1662 : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1663 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1664 :
1665 : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1666 : procedure that are default-initialized are not permitted. */
1667 16641 : if ((sym->attr.pointer || sym->attr.allocatable)
1668 1041 : && sym->ts.type == BT_DERIVED
1669 17659 : && gfc_has_default_initializer (sym->ts.u.derived))
1670 : {
1671 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1672 : "attribute at %L is not permitted in BIND(C) "
1673 : "procedure %qs", sym->name,
1674 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1675 4 : &sym->declared_at, sym->ns->proc_name->name);
1676 4 : retval = false;
1677 : }
1678 :
1679 : /* Character strings are only C interoperable if they have a
1680 : length of 1. However, as an argument they are also interoperable
1681 : when passed as descriptor (which requires len=: or len=*). */
1682 17281 : if (sym->ts.type == BT_CHARACTER)
1683 : {
1684 2350 : gfc_charlen *cl = sym->ts.u.cl;
1685 :
1686 2350 : if (sym->attr.allocatable || sym->attr.pointer)
1687 : {
1688 : /* F2018, 18.3.6 (6). */
1689 195 : if (!sym->ts.deferred)
1690 : {
1691 64 : if (sym->attr.allocatable)
1692 32 : gfc_error ("Allocatable character dummy argument %qs "
1693 : "at %L must have deferred length as "
1694 : "procedure %qs is BIND(C)", sym->name,
1695 32 : &sym->declared_at, sym->ns->proc_name->name);
1696 : else
1697 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1698 : "must have deferred length as procedure %qs "
1699 : "is BIND(C)", sym->name, &sym->declared_at,
1700 32 : sym->ns->proc_name->name);
1701 : retval = false;
1702 : }
1703 131 : else if (!gfc_notify_std (GFC_STD_F2018,
1704 : "Deferred-length character dummy "
1705 : "argument %qs at %L of procedure "
1706 : "%qs with BIND(C) attribute",
1707 : sym->name, &sym->declared_at,
1708 131 : sym->ns->proc_name->name))
1709 17281 : retval = false;
1710 : }
1711 2155 : else if (sym->attr.value
1712 360 : && (!cl || !cl->length
1713 360 : || cl->length->expr_type != EXPR_CONSTANT
1714 360 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1715 : {
1716 1 : gfc_error ("Character dummy argument %qs at %L must be "
1717 : "of length 1 as it has the VALUE attribute",
1718 : sym->name, &sym->declared_at);
1719 1 : retval = false;
1720 : }
1721 2154 : else if (!cl || !cl->length)
1722 : {
1723 : /* Assumed length; F2018, 18.3.6 (5)(2).
1724 : Uses the CFI array descriptor - also for scalars and
1725 : explicit-size/assumed-size arrays. */
1726 959 : if (!gfc_notify_std (GFC_STD_F2018,
1727 : "Assumed-length character dummy argument "
1728 : "%qs at %L of procedure %qs with BIND(C) "
1729 : "attribute", sym->name, &sym->declared_at,
1730 959 : sym->ns->proc_name->name))
1731 17281 : retval = false;
1732 : }
1733 1195 : else if (cl->length->expr_type != EXPR_CONSTANT
1734 881 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1735 : {
1736 : /* F2018, 18.3.6, (5), item 4. */
1737 653 : if (!sym->attr.dimension
1738 645 : || sym->as->type == AS_ASSUMED_SIZE
1739 639 : || sym->as->type == AS_EXPLICIT)
1740 : {
1741 20 : gfc_error ("Character dummy argument %qs at %L must be "
1742 : "of constant length of one or assumed length, "
1743 : "unless it has assumed shape or assumed rank, "
1744 : "as procedure %qs has the BIND(C) attribute",
1745 : sym->name, &sym->declared_at,
1746 20 : sym->ns->proc_name->name);
1747 20 : retval = false;
1748 : }
1749 : /* else: valid only since F2018 - and an assumed-shape/rank
1750 : array; however, gfc_notify_std is already called when
1751 : those array types are used. Thus, silently accept F200x. */
1752 : }
1753 : }
1754 :
1755 : /* We have to make sure that any param to a bind(c) routine does
1756 : not have the allocatable, pointer, or optional attributes,
1757 : according to J3/04-007, section 5.1. */
1758 17281 : if (sym->attr.allocatable == 1
1759 17682 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1760 : "ALLOCATABLE attribute in procedure %qs "
1761 : "with BIND(C)", sym->name,
1762 : &(sym->declared_at),
1763 401 : sym->ns->proc_name->name))
1764 : retval = false;
1765 :
1766 17281 : if (sym->attr.pointer == 1
1767 17921 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1768 : "POINTER attribute in procedure %qs "
1769 : "with BIND(C)", sym->name,
1770 : &(sym->declared_at),
1771 640 : sym->ns->proc_name->name))
1772 : retval = false;
1773 :
1774 17281 : if (sym->attr.optional == 1 && sym->attr.value)
1775 : {
1776 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1777 : "and the VALUE attribute because procedure %qs "
1778 : "is BIND(C)", sym->name, &(sym->declared_at),
1779 9 : sym->ns->proc_name->name);
1780 9 : retval = false;
1781 : }
1782 17272 : else if (sym->attr.optional == 1
1783 18226 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1784 : "at %L with OPTIONAL attribute in "
1785 : "procedure %qs which is BIND(C)",
1786 : sym->name, &(sym->declared_at),
1787 954 : sym->ns->proc_name->name))
1788 : retval = false;
1789 :
1790 : /* Make sure that if it has the dimension attribute, that it is
1791 : either assumed size or explicit shape. Deferred shape is already
1792 : covered by the pointer/allocatable attribute. */
1793 5553 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1794 18615 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1795 : "at %L as dummy argument to the BIND(C) "
1796 : "procedure %qs at %L", sym->name,
1797 : &(sym->declared_at),
1798 : sym->ns->proc_name->name,
1799 1334 : &(sym->ns->proc_name->declared_at)))
1800 : retval = false;
1801 : }
1802 : }
1803 :
1804 : return retval;
1805 : }
1806 :
1807 :
1808 :
1809 : /* Function called by variable_decl() that adds a name to the symbol table. */
1810 :
1811 : static bool
1812 267431 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1813 : gfc_array_spec **as, locus *var_locus)
1814 : {
1815 267431 : symbol_attribute attr;
1816 267431 : gfc_symbol *sym;
1817 267431 : int upper;
1818 267431 : gfc_symtree *st, *host_st = NULL;
1819 :
1820 : /* Symbols in a submodule are host associated from the parent module or
1821 : submodules. Therefore, they can be overridden by declarations in the
1822 : submodule scope. Deal with this by attaching the existing symbol to
1823 : a new symtree and recycling the old symtree with a new symbol... */
1824 267431 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1825 267431 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1826 3 : && gfc_current_ns->parent)
1827 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1828 :
1829 267431 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1830 12 : && st->n.sym != NULL
1831 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1832 : {
1833 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1834 12 : s->n.sym = st->n.sym;
1835 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1836 :
1837 12 : st->n.sym = sym;
1838 12 : sym->refs++;
1839 12 : gfc_set_sym_referenced (sym);
1840 12 : }
1841 : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1842 : current scope are not violated by local redeclarations. Note that there is
1843 : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1844 : only set for these standards. */
1845 267419 : else if (host_st && host_st->n.sym
1846 2 : && host_st->n.sym != gfc_current_ns->proc_name
1847 2 : && !(st && st->n.sym
1848 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1849 : {
1850 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1851 : "statement and must not be re-declared", name, var_locus,
1852 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1853 2 : return false;
1854 : }
1855 : /* ...Otherwise generate a new symtree and new symbol. */
1856 267417 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1857 : return false;
1858 :
1859 : /* Check if the name has already been defined as a type. The
1860 : first letter of the symtree will be in upper case then. Of
1861 : course, this is only necessary if the upper case letter is
1862 : actually different. */
1863 :
1864 267429 : upper = TOUPPER(name[0]);
1865 267429 : if (upper != name[0])
1866 : {
1867 266679 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1868 266679 : gfc_symtree *st;
1869 :
1870 266679 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1871 266679 : strcpy (u_name, name);
1872 266679 : u_name[0] = upper;
1873 :
1874 266679 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1875 :
1876 : /* STRUCTURE types can alias symbol names */
1877 266679 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1878 : {
1879 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1880 : &st->n.sym->declared_at);
1881 1 : return false;
1882 : }
1883 : }
1884 :
1885 : /* Start updating the symbol table. Add basic type attribute if present. */
1886 267428 : if (current_ts.type != BT_UNKNOWN
1887 267428 : && (sym->attr.implicit_type == 0
1888 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1889 534674 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1890 : {
1891 : /* Duplicate-type rejection can leave a fresh CHARACTER length node on
1892 : the namespace list before it is attached to any surviving symbol.
1893 : Drop only that unattached node; shared constant charlen nodes are
1894 : already reachable from earlier declarations. PR82721. */
1895 27 : if (current_ts.type == BT_CHARACTER && cl && elem == 1)
1896 : {
1897 1 : discard_pending_charlen (cl);
1898 1 : gfc_clear_ts (¤t_ts);
1899 : }
1900 26 : else if (current_ts.type == BT_CHARACTER && cl && cl != current_ts.u.cl)
1901 0 : discard_pending_charlen (cl);
1902 : return false;
1903 : }
1904 :
1905 267401 : if (sym->ts.type == BT_CHARACTER)
1906 : {
1907 29512 : if (elem > 1)
1908 4166 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1909 : else
1910 : sym->ts.u.cl = cl;
1911 29512 : sym->ts.deferred = cl_deferred;
1912 : }
1913 :
1914 : /* Add dimension attribute if present. */
1915 267401 : if (!gfc_set_array_spec (sym, *as, var_locus))
1916 : return false;
1917 267399 : *as = NULL;
1918 :
1919 : /* Add attribute to symbol. The copy is so that we can reset the
1920 : dimension attribute. */
1921 267399 : attr = current_attr;
1922 267399 : attr.dimension = 0;
1923 267399 : attr.codimension = 0;
1924 :
1925 267399 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1926 : return false;
1927 :
1928 : /* Finish any work that may need to be done for the binding label,
1929 : if it's a bind(c). The bind(c) attr is found before the symbol
1930 : is made, and before the symbol name (for data decls), so the
1931 : current_ts is holding the binding label, or nothing if the
1932 : name= attr wasn't given. Therefore, test here if we're dealing
1933 : with a bind(c) and make sure the binding label is set correctly. */
1934 267387 : if (sym->attr.is_bind_c == 1)
1935 : {
1936 1788 : if (!sym->binding_label)
1937 : {
1938 : /* Set the binding label and verify that if a NAME= was specified
1939 : then only one identifier was in the entity-decl-list. */
1940 137 : if (!set_binding_label (&sym->binding_label, sym->name,
1941 : num_idents_on_line))
1942 : return false;
1943 : }
1944 : }
1945 :
1946 : /* See if we know we're in a common block, and if it's a bind(c)
1947 : common then we need to make sure we're an interoperable type. */
1948 267385 : if (sym->attr.in_common == 1)
1949 : {
1950 : /* Test the common block object. */
1951 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1952 6 : && sym->ts.is_c_interop != 1)
1953 : {
1954 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1955 : "must be declared with a C interoperable "
1956 : "kind since common block %qs is BIND(C)",
1957 : sym->name, sym->common_block->name,
1958 0 : sym->common_block->name);
1959 0 : gfc_clear_error ();
1960 : }
1961 : }
1962 :
1963 267385 : sym->attr.implied_index = 0;
1964 :
1965 : /* Use the parameter expressions for a parameterized derived type. */
1966 267385 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1967 38270 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1968 1404 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1969 :
1970 267385 : if (sym->ts.type == BT_CLASS)
1971 11489 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1972 :
1973 : return true;
1974 : }
1975 :
1976 :
1977 : /* Set character constant to the given length. The constant will be padded or
1978 : truncated. If we're inside an array constructor without a typespec, we
1979 : additionally check that all elements have the same length; check_len -1
1980 : means no checking. */
1981 :
1982 : void
1983 14655 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1984 : gfc_charlen_t check_len)
1985 : {
1986 14655 : gfc_char_t *s;
1987 14655 : gfc_charlen_t slen;
1988 :
1989 14655 : if (expr->ts.type != BT_CHARACTER)
1990 : return;
1991 :
1992 14653 : if (expr->expr_type != EXPR_CONSTANT)
1993 : {
1994 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1995 1 : return;
1996 : }
1997 :
1998 14652 : slen = expr->value.character.length;
1999 14652 : if (len != slen)
2000 : {
2001 2178 : s = gfc_get_wide_string (len + 1);
2002 2178 : memcpy (s, expr->value.character.string,
2003 2178 : MIN (len, slen) * sizeof (gfc_char_t));
2004 2178 : if (len > slen)
2005 1887 : gfc_wide_memset (&s[slen], ' ', len - slen);
2006 :
2007 2178 : if (warn_character_truncation && slen > len)
2008 1 : gfc_warning_now (OPT_Wcharacter_truncation,
2009 : "CHARACTER expression at %L is being truncated "
2010 : "(%ld/%ld)", &expr->where,
2011 : (long) slen, (long) len);
2012 :
2013 : /* Apply the standard by 'hand' otherwise it gets cleared for
2014 : initializers. */
2015 2178 : if (check_len != -1 && slen != check_len)
2016 : {
2017 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
2018 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
2019 : "at %L must have the same length (%ld/%ld)",
2020 : &expr->where, (long) slen,
2021 : (long) check_len);
2022 : else
2023 3 : gfc_notify_std (GFC_STD_LEGACY,
2024 : "The CHARACTER elements of the array constructor "
2025 : "at %L must have the same length (%ld/%ld)",
2026 : &expr->where, (long) slen,
2027 : (long) check_len);
2028 : }
2029 :
2030 2178 : s[len] = '\0';
2031 2178 : free (expr->value.character.string);
2032 2178 : expr->value.character.string = s;
2033 2178 : expr->value.character.length = len;
2034 : /* If explicit representation was given, clear it
2035 : as it is no longer needed after padding. */
2036 2178 : if (expr->representation.length)
2037 : {
2038 45 : expr->representation.length = 0;
2039 45 : free (expr->representation.string);
2040 45 : expr->representation.string = NULL;
2041 : }
2042 : }
2043 : }
2044 :
2045 :
2046 : /* Function to create and update the enumerator history
2047 : using the information passed as arguments.
2048 : Pointer "max_enum" is also updated, to point to
2049 : enum history node containing largest initializer.
2050 :
2051 : SYM points to the symbol node of enumerator.
2052 : INIT points to its enumerator value. */
2053 :
2054 : static void
2055 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
2056 : {
2057 543 : enumerator_history *new_enum_history;
2058 543 : gcc_assert (sym != NULL && init != NULL);
2059 :
2060 543 : new_enum_history = XCNEW (enumerator_history);
2061 :
2062 543 : new_enum_history->sym = sym;
2063 543 : new_enum_history->initializer = init;
2064 543 : new_enum_history->next = NULL;
2065 :
2066 543 : if (enum_history == NULL)
2067 : {
2068 160 : enum_history = new_enum_history;
2069 160 : max_enum = enum_history;
2070 : }
2071 : else
2072 : {
2073 383 : new_enum_history->next = enum_history;
2074 383 : enum_history = new_enum_history;
2075 :
2076 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2077 383 : new_enum_history->initializer->value.integer) < 0)
2078 381 : max_enum = new_enum_history;
2079 : }
2080 543 : }
2081 :
2082 :
2083 : /* Function to free enum kind history. */
2084 :
2085 : void
2086 175 : gfc_free_enum_history (void)
2087 : {
2088 175 : enumerator_history *current = enum_history;
2089 175 : enumerator_history *next;
2090 :
2091 718 : while (current != NULL)
2092 : {
2093 543 : next = current->next;
2094 543 : free (current);
2095 543 : current = next;
2096 : }
2097 175 : max_enum = NULL;
2098 175 : enum_history = NULL;
2099 175 : }
2100 :
2101 :
2102 : /* Function to fix initializer character length if the length of the
2103 : symbol or component is constant. */
2104 :
2105 : static bool
2106 2819 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2107 : {
2108 2819 : if (!gfc_specification_expr (ts->u.cl->length))
2109 : return false;
2110 :
2111 2819 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2112 :
2113 : /* resolve_charlen will complain later on if the length
2114 : is too large. Just skip the initialization in that case. */
2115 2819 : if (mpz_cmp (ts->u.cl->length->value.integer,
2116 2819 : gfc_integer_kinds[k].huge) <= 0)
2117 : {
2118 2818 : HOST_WIDE_INT len
2119 2818 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2120 :
2121 2818 : if (init->expr_type == EXPR_CONSTANT)
2122 2030 : gfc_set_constant_character_len (len, init, -1);
2123 788 : else if (init->expr_type == EXPR_ARRAY)
2124 : {
2125 769 : gfc_constructor *cons;
2126 :
2127 : /* Build a new charlen to prevent simplification from
2128 : deleting the length before it is resolved. */
2129 769 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2130 769 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2131 769 : cons = gfc_constructor_first (init->value.constructor);
2132 5175 : for (; cons; cons = gfc_constructor_next (cons))
2133 3637 : gfc_set_constant_character_len (len, cons->expr, -1);
2134 : }
2135 : }
2136 :
2137 : return true;
2138 : }
2139 :
2140 :
2141 : /* Function called by variable_decl() that adds an initialization
2142 : expression to a symbol. */
2143 :
2144 : static bool
2145 275782 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus,
2146 : gfc_charlen *saved_cl_list)
2147 : {
2148 275782 : symbol_attribute attr;
2149 275782 : gfc_symbol *sym;
2150 275782 : gfc_expr *init;
2151 :
2152 275782 : init = *initp;
2153 275782 : if (find_special (name, &sym, false))
2154 : return false;
2155 :
2156 275782 : attr = sym->attr;
2157 :
2158 : /* If this symbol is confirming an implicit parameter type,
2159 : then an initialization expression is not allowed. */
2160 275782 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2161 : {
2162 1 : if (*initp != NULL)
2163 : {
2164 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2165 : sym->name);
2166 0 : return false;
2167 : }
2168 : else
2169 : return true;
2170 : }
2171 :
2172 275781 : if (init == NULL)
2173 : {
2174 : /* An initializer is required for PARAMETER declarations. */
2175 241985 : if (attr.flavor == FL_PARAMETER)
2176 : {
2177 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2178 1 : return false;
2179 : }
2180 : }
2181 : else
2182 : {
2183 : /* If a variable appears in a DATA block, it cannot have an
2184 : initializer. */
2185 33796 : if (sym->attr.data)
2186 : {
2187 0 : gfc_error ("Variable %qs at %C with an initializer already "
2188 : "appears in a DATA statement", sym->name);
2189 0 : return false;
2190 : }
2191 :
2192 : /* Check if the assignment can happen. This has to be put off
2193 : until later for derived type variables and procedure pointers. */
2194 32603 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2195 32580 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2196 32530 : && !sym->attr.proc_pointer
2197 66217 : && !gfc_check_assign_symbol (sym, NULL, init))
2198 : return false;
2199 :
2200 33765 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2201 3542 : && init->ts.type == BT_CHARACTER)
2202 : {
2203 : /* Update symbol character length according initializer. */
2204 3378 : if (!gfc_check_assign_symbol (sym, NULL, init))
2205 : return false;
2206 :
2207 3378 : if (sym->ts.u.cl->length == NULL)
2208 : {
2209 887 : gfc_charlen_t clen;
2210 : /* If there are multiple CHARACTER variables declared on the
2211 : same line, we don't want them to share the same length. */
2212 887 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2213 :
2214 887 : if (sym->attr.flavor == FL_PARAMETER)
2215 : {
2216 854 : if (init->expr_type == EXPR_CONSTANT)
2217 : {
2218 563 : clen = init->value.character.length;
2219 563 : sym->ts.u.cl->length
2220 563 : = gfc_get_int_expr (gfc_charlen_int_kind,
2221 : NULL, clen);
2222 : }
2223 291 : else if (init->expr_type == EXPR_ARRAY)
2224 : {
2225 291 : if (init->ts.u.cl && init->ts.u.cl->length)
2226 : {
2227 279 : const gfc_expr *length = init->ts.u.cl->length;
2228 279 : if (length->expr_type != EXPR_CONSTANT)
2229 : {
2230 3 : gfc_error ("Cannot initialize parameter array "
2231 : "at %L "
2232 : "with variable length elements",
2233 : &sym->declared_at);
2234 :
2235 : /* This rejection path can leave several
2236 : declaration-local charlens on cl_list,
2237 : including the replacement symbol charlen and
2238 : the array-constructor typespec charlen.
2239 : Clear the surviving owners first, then drop
2240 : only the nodes created by this declaration. */
2241 3 : sym->ts.u.cl = NULL;
2242 3 : init->ts.u.cl = NULL;
2243 3 : discard_pending_charlens (saved_cl_list);
2244 3 : return false;
2245 : }
2246 276 : clen = mpz_get_si (length->value.integer);
2247 276 : }
2248 12 : else if (init->value.constructor)
2249 : {
2250 12 : gfc_constructor *c;
2251 12 : c = gfc_constructor_first (init->value.constructor);
2252 12 : clen = c->expr->value.character.length;
2253 : }
2254 : else
2255 0 : gcc_unreachable ();
2256 288 : sym->ts.u.cl->length
2257 288 : = gfc_get_int_expr (gfc_charlen_int_kind,
2258 : NULL, clen);
2259 : }
2260 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2261 0 : sym->ts.u.cl->length =
2262 0 : gfc_copy_expr (init->ts.u.cl->length);
2263 : }
2264 : }
2265 : /* Update initializer character length according to symbol. */
2266 2491 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2267 2491 : && !fix_initializer_charlen (&sym->ts, init))
2268 : return false;
2269 : }
2270 :
2271 33762 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2272 3814 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2273 : {
2274 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2275 : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2276 3 : return false;
2277 : }
2278 :
2279 : /* If sym is implied-shape, set its upper bounds from init. */
2280 33759 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2281 3811 : && sym->as && sym->as->type == AS_IMPLIED_SHAPE)
2282 : {
2283 1041 : int dim;
2284 :
2285 1041 : if (init->rank == 0)
2286 : {
2287 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2288 : " with scalar", &sym->declared_at);
2289 1 : return false;
2290 : }
2291 :
2292 : /* The shape may be NULL for EXPR_ARRAY, set it. */
2293 1040 : if (init->shape == NULL)
2294 : {
2295 5 : if (init->expr_type != EXPR_ARRAY)
2296 : {
2297 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2298 2 : return false;
2299 : }
2300 :
2301 3 : init->shape = gfc_get_shape (1);
2302 3 : if (!gfc_array_size (init, &init->shape[0]))
2303 : {
2304 1 : gfc_error ("Cannot determine shape of initializer at %L",
2305 : &init->where);
2306 1 : free (init->shape);
2307 1 : init->shape = NULL;
2308 1 : return false;
2309 : }
2310 : }
2311 :
2312 2175 : for (dim = 0; dim < sym->as->rank; ++dim)
2313 : {
2314 1139 : int k;
2315 1139 : gfc_expr *e, *lower;
2316 :
2317 1139 : lower = sym->as->lower[dim];
2318 :
2319 : /* If the lower bound is an array element from another
2320 : parameterized array, then it is marked with EXPR_VARIABLE and
2321 : is an initialization expression. Try to reduce it. */
2322 1139 : if (lower->expr_type == EXPR_VARIABLE)
2323 7 : gfc_reduce_init_expr (lower);
2324 :
2325 1139 : if (lower->expr_type == EXPR_CONSTANT)
2326 : {
2327 : /* All dimensions must be without upper bound. */
2328 1138 : gcc_assert (!sym->as->upper[dim]);
2329 :
2330 1138 : k = lower->ts.kind;
2331 1138 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2332 1138 : mpz_add (e->value.integer, lower->value.integer,
2333 1138 : init->shape[dim]);
2334 1138 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2335 1138 : sym->as->upper[dim] = e;
2336 : }
2337 : else
2338 : {
2339 1 : gfc_error ("Non-constant lower bound in implied-shape"
2340 : " declaration at %L", &lower->where);
2341 1 : return false;
2342 : }
2343 : }
2344 :
2345 1036 : sym->as->type = AS_EXPLICIT;
2346 : }
2347 :
2348 : /* Ensure that explicit bounds are simplified. */
2349 33754 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2350 3806 : && sym->as && sym->as->type == AS_EXPLICIT)
2351 : {
2352 8446 : for (int dim = 0; dim < sym->as->rank; ++dim)
2353 : {
2354 4652 : gfc_expr *e;
2355 :
2356 4652 : e = sym->as->lower[dim];
2357 4652 : if (e->expr_type != EXPR_CONSTANT)
2358 12 : gfc_reduce_init_expr (e);
2359 :
2360 4652 : e = sym->as->upper[dim];
2361 4652 : if (e->expr_type != EXPR_CONSTANT)
2362 106 : gfc_reduce_init_expr (e);
2363 : }
2364 : }
2365 :
2366 : /* Need to check if the expression we initialized this
2367 : to was one of the iso_c_binding named constants. If so,
2368 : and we're a parameter (constant), let it be iso_c.
2369 : For example:
2370 : integer(c_int), parameter :: my_int = c_int
2371 : integer(my_int) :: my_int_2
2372 : If we mark my_int as iso_c (since we can see it's value
2373 : is equal to one of the named constants), then my_int_2
2374 : will be considered C interoperable. */
2375 33754 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2376 : {
2377 29025 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2378 29025 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2379 : /* attr bits needed for module files. */
2380 29025 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2381 29025 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2382 29025 : if (init->ts.is_iso_c)
2383 118 : sym->ts.f90_type = init->ts.f90_type;
2384 : }
2385 :
2386 : /* Catch the case: type(t), parameter :: x = z'1'. */
2387 33754 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2388 : {
2389 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2390 : "literal constant", name, &sym->declared_at);
2391 1 : return false;
2392 : }
2393 :
2394 : /* Add initializer. Make sure we keep the ranks sane. */
2395 33753 : if (sym->attr.dimension && init->rank == 0)
2396 : {
2397 1313 : mpz_t size;
2398 1313 : gfc_expr *array;
2399 1313 : int n;
2400 1313 : if (sym->attr.flavor == FL_PARAMETER
2401 468 : && gfc_is_constant_expr (init)
2402 467 : && (init->expr_type == EXPR_CONSTANT
2403 48 : || init->expr_type == EXPR_STRUCTURE)
2404 1780 : && spec_size (sym->as, &size))
2405 : {
2406 463 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2407 : &init->where);
2408 463 : if (init->ts.type == BT_DERIVED)
2409 48 : array->ts.u.derived = init->ts.u.derived;
2410 67619 : for (n = 0; n < (int)mpz_get_si (size); n++)
2411 133990 : gfc_constructor_append_expr (&array->value.constructor,
2412 : n == 0
2413 : ? init
2414 66834 : : gfc_copy_expr (init),
2415 : &init->where);
2416 :
2417 463 : array->shape = gfc_get_shape (sym->as->rank);
2418 1052 : for (n = 0; n < sym->as->rank; n++)
2419 589 : spec_dimen_size (sym->as, n, &array->shape[n]);
2420 :
2421 463 : init = array;
2422 463 : mpz_clear (size);
2423 : }
2424 1313 : init->rank = sym->as->rank;
2425 1313 : init->corank = sym->as->corank;
2426 : }
2427 :
2428 33753 : sym->value = init;
2429 33753 : if (sym->attr.save == SAVE_NONE)
2430 29003 : sym->attr.save = SAVE_IMPLICIT;
2431 33753 : *initp = NULL;
2432 : }
2433 :
2434 : return true;
2435 : }
2436 :
2437 :
2438 : /* Function called by variable_decl() that adds a name to a structure
2439 : being built. */
2440 :
2441 : static bool
2442 19449 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2443 : gfc_array_spec **as)
2444 : {
2445 19449 : gfc_state_data *s;
2446 19449 : gfc_component *c;
2447 :
2448 : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2449 : constructing, it must have the pointer attribute. */
2450 19449 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2451 3634 : && current_ts.u.derived == gfc_current_block ()
2452 297 : && current_attr.pointer == 0)
2453 : {
2454 136 : if (current_attr.allocatable
2455 136 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2456 : "must have the POINTER attribute"))
2457 : {
2458 : return false;
2459 : }
2460 135 : else if (current_attr.allocatable == 0)
2461 : {
2462 0 : gfc_error ("Component at %C must have the POINTER attribute");
2463 0 : return false;
2464 : }
2465 : }
2466 :
2467 : /* F03:C437. */
2468 19448 : if (current_ts.type == BT_CLASS
2469 923 : && !(current_attr.pointer || current_attr.allocatable))
2470 : {
2471 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2472 : "or pointer", name);
2473 5 : return false;
2474 : }
2475 :
2476 19443 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2477 : {
2478 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2479 : {
2480 0 : gfc_error ("Array component of structure at %C must have explicit "
2481 : "or deferred shape");
2482 0 : return false;
2483 : }
2484 : }
2485 :
2486 : /* If we are in a nested union/map definition, gfc_add_component will not
2487 : properly find repeated components because:
2488 : (i) gfc_add_component does a flat search, where components of unions
2489 : and maps are implicity chained so nested components may conflict.
2490 : (ii) Unions and maps are not linked as components of their parent
2491 : structures until after they are parsed.
2492 : For (i) we use gfc_find_component which searches recursively, and for (ii)
2493 : we search each block directly from the parse stack until we find the top
2494 : level structure. */
2495 :
2496 19443 : s = gfc_state_stack;
2497 19443 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2498 : {
2499 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2500 : {
2501 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2502 1434 : if (c != NULL)
2503 : {
2504 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2505 : name, &c->loc);
2506 0 : return false;
2507 : }
2508 : /* Break after we've searched the entire chain. */
2509 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2510 : break;
2511 1000 : s = s->previous;
2512 : }
2513 : }
2514 :
2515 19443 : if (!gfc_add_component (gfc_current_block(), name, &c))
2516 : return false;
2517 :
2518 19437 : c->ts = current_ts;
2519 19437 : if (c->ts.type == BT_CHARACTER)
2520 : {
2521 2078 : c->ts.u.cl = cl;
2522 : /* The component struct is not tracked by the symbol undo mechanism,
2523 : so free the charlen here to prevent a double-free. */
2524 2078 : gfc_remove_saved_charlen (cl);
2525 : }
2526 :
2527 19437 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2528 15809 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2529 2390 : && saved_kind_expr != NULL)
2530 392 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2531 :
2532 19437 : c->attr = current_attr;
2533 :
2534 19437 : c->initializer = *init;
2535 19437 : *init = NULL;
2536 :
2537 : /* Update initializer character length according to component. */
2538 2078 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2539 1665 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2540 1534 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2541 19768 : && !fix_initializer_charlen (&c->ts, c->initializer))
2542 : return false;
2543 :
2544 19437 : c->as = *as;
2545 19437 : if (c->as != NULL)
2546 : {
2547 5227 : if (c->as->corank)
2548 113 : c->attr.codimension = 1;
2549 5227 : if (c->as->rank)
2550 5146 : c->attr.dimension = 1;
2551 : }
2552 19437 : *as = NULL;
2553 :
2554 19437 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2555 :
2556 : /* Convert a class, PDT component of a non-derived type to a specific instance
2557 : before gfc_build_class_symbol gets to work on it. */
2558 19437 : if (c->ts.type == BT_CLASS
2559 918 : && !(gfc_current_block ()->attr.pdt_template
2560 918 : || gfc_current_block ()->attr.pdt_type)
2561 918 : && c->ts.u.derived->attr.pdt_template)
2562 : {
2563 12 : match m = gfc_get_pdt_instance (decl_type_param_list, &c->ts.u.derived, NULL);
2564 12 : if (m != MATCH_YES)
2565 : {
2566 0 : if (!gfc_error_check ())
2567 0 : gfc_error ("Parameterized component of a non-parameterized "
2568 : "derived type at %C could not be converted to a valid "
2569 : "instance");
2570 : return false;
2571 : }
2572 : }
2573 :
2574 : /* Check array components. */
2575 19437 : if (!c->attr.dimension)
2576 14291 : goto scalar;
2577 :
2578 5146 : if (c->attr.pointer)
2579 : {
2580 744 : if (c->as->type != AS_DEFERRED)
2581 : {
2582 5 : gfc_error ("Pointer array component of structure at %C must have a "
2583 : "deferred shape");
2584 5 : return false;
2585 : }
2586 : }
2587 4402 : else if (c->attr.allocatable)
2588 : {
2589 2520 : const char *err = G_("Allocatable component of structure at %C must have "
2590 : "a deferred shape");
2591 2520 : if (c->as->type != AS_DEFERRED)
2592 : {
2593 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2594 : {
2595 : /* Issue an immediate error and allow this component to pass for
2596 : the sake of clean error recovery. Set the error flag for the
2597 : containing derived type so that finalizers are not built. */
2598 4 : gfc_error_now (err);
2599 4 : s->sym->error = 1;
2600 4 : c->as->type = AS_DEFERRED;
2601 : }
2602 : else
2603 : {
2604 10 : gfc_error (err);
2605 10 : return false;
2606 : }
2607 : }
2608 : }
2609 : else
2610 : {
2611 1882 : if (c->as->type != AS_EXPLICIT)
2612 : {
2613 7 : gfc_error ("Array component of structure at %C must have an "
2614 : "explicit shape");
2615 7 : return false;
2616 : }
2617 : }
2618 :
2619 1875 : scalar:
2620 19415 : if (c->ts.type == BT_CLASS)
2621 915 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2622 :
2623 18500 : if (c->attr.pdt_kind || c->attr.pdt_len)
2624 : {
2625 826 : gfc_symbol *sym;
2626 826 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2627 : 0, &sym);
2628 826 : if (sym == NULL)
2629 : {
2630 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2631 : "in the type parameter name list at %L",
2632 0 : c->name, &gfc_current_block ()->declared_at);
2633 0 : return false;
2634 : }
2635 826 : sym->ts = c->ts;
2636 826 : sym->attr.pdt_kind = c->attr.pdt_kind;
2637 826 : sym->attr.pdt_len = c->attr.pdt_len;
2638 826 : if (c->initializer)
2639 390 : sym->value = gfc_copy_expr (c->initializer);
2640 826 : sym->attr.flavor = FL_VARIABLE;
2641 : }
2642 :
2643 18500 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2644 2710 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2645 136 : && decl_type_param_list)
2646 136 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2647 :
2648 : return true;
2649 : }
2650 :
2651 :
2652 : /* Match a 'NULL()', and possibly take care of some side effects. */
2653 :
2654 : match
2655 1812 : gfc_match_null (gfc_expr **result)
2656 : {
2657 1812 : gfc_symbol *sym;
2658 1812 : match m, m2 = MATCH_NO;
2659 :
2660 1812 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2661 : return MATCH_ERROR;
2662 :
2663 1812 : if (m == MATCH_NO)
2664 : {
2665 565 : locus old_loc;
2666 565 : char name[GFC_MAX_SYMBOL_LEN + 1];
2667 :
2668 565 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2669 559 : return m2;
2670 :
2671 6 : old_loc = gfc_current_locus;
2672 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2673 : return MATCH_ERROR;
2674 6 : if (m2 != MATCH_YES
2675 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2676 : return MATCH_ERROR;
2677 6 : if (m2 == MATCH_NO)
2678 : {
2679 0 : gfc_current_locus = old_loc;
2680 0 : return MATCH_NO;
2681 : }
2682 : }
2683 :
2684 : /* The NULL symbol now has to be/become an intrinsic function. */
2685 1253 : if (gfc_get_symbol ("null", NULL, &sym))
2686 : {
2687 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2688 0 : return MATCH_ERROR;
2689 : }
2690 :
2691 1253 : gfc_intrinsic_symbol (sym);
2692 :
2693 1253 : if (sym->attr.proc != PROC_INTRINSIC
2694 883 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2695 2135 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2696 882 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2697 : return MATCH_ERROR;
2698 :
2699 1253 : *result = gfc_get_null_expr (&gfc_current_locus);
2700 :
2701 : /* Invalid per F2008, C512. */
2702 1253 : if (m2 == MATCH_YES)
2703 : {
2704 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2705 6 : return MATCH_ERROR;
2706 : }
2707 :
2708 : return MATCH_YES;
2709 : }
2710 :
2711 :
2712 : /* Match the initialization expr for a data pointer or procedure pointer. */
2713 :
2714 : static match
2715 1458 : match_pointer_init (gfc_expr **init, int procptr)
2716 : {
2717 1458 : match m;
2718 :
2719 1458 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2720 : {
2721 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2722 : "a PURE procedure");
2723 1 : return MATCH_ERROR;
2724 : }
2725 1457 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2726 :
2727 : /* Match NULL() initialization. */
2728 1457 : m = gfc_match_null (init);
2729 1457 : if (m != MATCH_NO)
2730 : return m;
2731 :
2732 : /* Match non-NULL initialization. */
2733 212 : gfc_matching_ptr_assignment = !procptr;
2734 212 : gfc_matching_procptr_assignment = procptr;
2735 212 : m = gfc_match_rvalue (init);
2736 212 : gfc_matching_ptr_assignment = 0;
2737 212 : gfc_matching_procptr_assignment = 0;
2738 212 : if (m == MATCH_ERROR)
2739 : return MATCH_ERROR;
2740 211 : else if (m == MATCH_NO)
2741 : {
2742 2 : gfc_error ("Error in pointer initialization at %C");
2743 2 : return MATCH_ERROR;
2744 : }
2745 :
2746 209 : if (!procptr && !gfc_resolve_expr (*init))
2747 : return MATCH_ERROR;
2748 :
2749 208 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2750 : "initialization at %C"))
2751 0 : return MATCH_ERROR;
2752 :
2753 : return MATCH_YES;
2754 : }
2755 :
2756 :
2757 : static bool
2758 296801 : check_function_name (char *name)
2759 : {
2760 : /* In functions that have a RESULT variable defined, the function name always
2761 : refers to function calls. Therefore, the name is not allowed to appear in
2762 : specification statements. When checking this, be careful about
2763 : 'hidden' procedure pointer results ('ppr@'). */
2764 :
2765 296801 : if (gfc_current_state () == COMP_FUNCTION)
2766 : {
2767 48555 : gfc_symbol *block = gfc_current_block ();
2768 48555 : if (block && block->result && block->result != block
2769 15797 : && strcmp (block->result->name, "ppr@") != 0
2770 15738 : && strcmp (block->name, name) == 0)
2771 : {
2772 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2773 : "from appearing in a specification statement",
2774 : block->result->name, &block->result->declared_at, name);
2775 9 : return false;
2776 : }
2777 : }
2778 :
2779 : return true;
2780 : }
2781 :
2782 :
2783 : /* Match a variable name with an optional initializer. When this
2784 : subroutine is called, a variable is expected to be parsed next.
2785 : Depending on what is happening at the moment, updates either the
2786 : symbol table or the current interface. */
2787 :
2788 : static match
2789 286567 : variable_decl (int elem)
2790 : {
2791 286567 : char name[GFC_MAX_SYMBOL_LEN + 1];
2792 286567 : static unsigned int fill_id = 0;
2793 286567 : gfc_expr *initializer, *char_len;
2794 286567 : gfc_array_spec *as;
2795 286567 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2796 286567 : gfc_charlen *cl;
2797 286567 : gfc_charlen *saved_cl_list;
2798 286567 : bool cl_deferred;
2799 286567 : locus var_locus;
2800 286567 : match m;
2801 286567 : bool t;
2802 286567 : gfc_symbol *sym;
2803 286567 : char c;
2804 :
2805 286567 : initializer = NULL;
2806 286567 : as = NULL;
2807 286567 : cp_as = NULL;
2808 286567 : saved_cl_list = gfc_current_ns->cl_list;
2809 :
2810 : /* When we get here, we've just matched a list of attributes and
2811 : maybe a type and a double colon. The next thing we expect to see
2812 : is the name of the symbol. */
2813 :
2814 : /* If we are parsing a structure with legacy support, we allow the symbol
2815 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2816 286567 : m = MATCH_NO;
2817 286567 : gfc_gobble_whitespace ();
2818 286567 : var_locus = gfc_current_locus;
2819 286567 : c = gfc_peek_ascii_char ();
2820 286567 : if (c == '%')
2821 : {
2822 12 : gfc_next_ascii_char (); /* Burn % character. */
2823 12 : m = gfc_match ("fill");
2824 12 : if (m == MATCH_YES)
2825 : {
2826 11 : if (gfc_current_state () != COMP_STRUCTURE)
2827 : {
2828 2 : if (flag_dec_structure)
2829 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2830 : else
2831 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2832 : "%<-fdec-structure%>", "%FILL");
2833 2 : m = MATCH_ERROR;
2834 2 : goto cleanup;
2835 : }
2836 :
2837 9 : if (attr_seen)
2838 : {
2839 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2840 1 : m = MATCH_ERROR;
2841 1 : goto cleanup;
2842 : }
2843 :
2844 : /* %FILL components are given invalid fortran names. */
2845 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2846 : }
2847 : else
2848 : {
2849 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2850 1 : return MATCH_ERROR;
2851 : }
2852 : }
2853 : else
2854 : {
2855 286555 : m = gfc_match_name (name);
2856 286554 : if (m != MATCH_YES)
2857 10 : goto cleanup;
2858 : }
2859 :
2860 : /* Now we could see the optional array spec. or character length. */
2861 286552 : m = gfc_match_array_spec (&as, true, true);
2862 286551 : if (m == MATCH_ERROR)
2863 57 : goto cleanup;
2864 :
2865 286494 : if (m == MATCH_NO)
2866 223430 : as = gfc_copy_array_spec (current_as);
2867 63064 : else if (current_as
2868 63064 : && !merge_array_spec (current_as, as, true))
2869 : {
2870 4 : m = MATCH_ERROR;
2871 4 : goto cleanup;
2872 : }
2873 :
2874 286490 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2875 : &gfc_current_locus);
2876 286490 : if (flag_cray_pointer)
2877 3063 : cp_as = gfc_copy_array_spec (as);
2878 :
2879 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2880 : determine (and check) whether it can be implied-shape. If it
2881 : was parsed as assumed-size, change it because PARAMETERs cannot
2882 : be assumed-size.
2883 :
2884 : An explicit-shape-array cannot appear under several conditions.
2885 : That check is done here as well. */
2886 286490 : if (as)
2887 : {
2888 85769 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2889 : {
2890 2 : m = MATCH_ERROR;
2891 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2892 : name, &var_locus);
2893 2 : goto cleanup;
2894 : }
2895 :
2896 85767 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2897 6528 : && current_attr.flavor == FL_PARAMETER)
2898 993 : as->type = AS_IMPLIED_SHAPE;
2899 :
2900 85767 : if (as->type == AS_IMPLIED_SHAPE
2901 85767 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2902 : &var_locus))
2903 : {
2904 1 : m = MATCH_ERROR;
2905 1 : goto cleanup;
2906 : }
2907 :
2908 85766 : gfc_seen_div0 = false;
2909 :
2910 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2911 : constant expressions shall appear only in a subprogram, derived
2912 : type definition, BLOCK construct, or interface body. */
2913 85766 : if (as->type == AS_EXPLICIT
2914 42754 : && gfc_current_state () != COMP_BLOCK
2915 : && gfc_current_state () != COMP_DERIVED
2916 : && gfc_current_state () != COMP_FUNCTION
2917 : && gfc_current_state () != COMP_INTERFACE
2918 : && gfc_current_state () != COMP_SUBROUTINE)
2919 : {
2920 : gfc_expr *e;
2921 50673 : bool not_constant = false;
2922 :
2923 50673 : for (int i = 0; i < as->rank; i++)
2924 : {
2925 28823 : e = gfc_copy_expr (as->lower[i]);
2926 28823 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2927 : {
2928 0 : m = MATCH_ERROR;
2929 0 : goto cleanup;
2930 : }
2931 :
2932 28823 : gfc_simplify_expr (e, 0);
2933 28823 : if (e && (e->expr_type != EXPR_CONSTANT))
2934 : {
2935 : not_constant = true;
2936 : break;
2937 : }
2938 28823 : gfc_free_expr (e);
2939 :
2940 28823 : e = gfc_copy_expr (as->upper[i]);
2941 28823 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2942 : {
2943 4 : m = MATCH_ERROR;
2944 4 : goto cleanup;
2945 : }
2946 :
2947 28819 : gfc_simplify_expr (e, 0);
2948 28819 : if (e && (e->expr_type != EXPR_CONSTANT))
2949 : {
2950 : not_constant = true;
2951 : break;
2952 : }
2953 28806 : gfc_free_expr (e);
2954 : }
2955 :
2956 21863 : if (not_constant && e->ts.type != BT_INTEGER)
2957 : {
2958 4 : gfc_error ("Explicit array shape at %C must be constant of "
2959 : "INTEGER type and not %s type",
2960 : gfc_basic_typename (e->ts.type));
2961 4 : m = MATCH_ERROR;
2962 4 : goto cleanup;
2963 : }
2964 9 : if (not_constant)
2965 : {
2966 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2967 9 : m = MATCH_ERROR;
2968 9 : goto cleanup;
2969 : }
2970 : }
2971 85749 : if (as->type == AS_EXPLICIT)
2972 : {
2973 102064 : for (int i = 0; i < as->rank; i++)
2974 : {
2975 59327 : gfc_expr *e, *n;
2976 59327 : e = as->lower[i];
2977 59327 : if (e->expr_type != EXPR_CONSTANT)
2978 : {
2979 458 : n = gfc_copy_expr (e);
2980 458 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2981 : {
2982 0 : m = MATCH_ERROR;
2983 0 : goto cleanup;
2984 : }
2985 :
2986 458 : if (n->expr_type == EXPR_CONSTANT)
2987 22 : gfc_replace_expr (e, n);
2988 : else
2989 436 : gfc_free_expr (n);
2990 : }
2991 59327 : e = as->upper[i];
2992 59327 : if (e->expr_type != EXPR_CONSTANT)
2993 : {
2994 6939 : n = gfc_copy_expr (e);
2995 6939 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2996 : {
2997 0 : m = MATCH_ERROR;
2998 0 : goto cleanup;
2999 : }
3000 :
3001 6939 : if (n->expr_type == EXPR_CONSTANT)
3002 45 : gfc_replace_expr (e, n);
3003 : else
3004 6894 : gfc_free_expr (n);
3005 : }
3006 : /* For an explicit-shape spec with constant bounds, ensure
3007 : that the effective upper bound is not lower than the
3008 : respective lower bound minus one. Otherwise adjust it so
3009 : that the extent is trivially derived to be zero. */
3010 59327 : if (as->lower[i]->expr_type == EXPR_CONSTANT
3011 58891 : && as->upper[i]->expr_type == EXPR_CONSTANT
3012 52421 : && as->lower[i]->ts.type == BT_INTEGER
3013 52421 : && as->upper[i]->ts.type == BT_INTEGER
3014 52416 : && mpz_cmp (as->upper[i]->value.integer,
3015 52416 : as->lower[i]->value.integer) < 0)
3016 1218 : mpz_sub_ui (as->upper[i]->value.integer,
3017 : as->lower[i]->value.integer, 1);
3018 : }
3019 : }
3020 : }
3021 :
3022 286470 : char_len = NULL;
3023 286470 : cl = NULL;
3024 286470 : cl_deferred = false;
3025 :
3026 286470 : if (current_ts.type == BT_CHARACTER)
3027 : {
3028 31631 : switch (match_char_length (&char_len, &cl_deferred, false))
3029 : {
3030 435 : case MATCH_YES:
3031 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3032 :
3033 435 : cl->length = char_len;
3034 435 : break;
3035 :
3036 : /* Non-constant lengths need to be copied after the first
3037 : element. Also copy assumed lengths. */
3038 31195 : case MATCH_NO:
3039 31195 : if (elem > 1
3040 3935 : && (current_ts.u.cl->length == NULL
3041 2709 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
3042 : {
3043 1281 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3044 1281 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
3045 : }
3046 : else
3047 29914 : cl = current_ts.u.cl;
3048 :
3049 31195 : cl_deferred = current_ts.deferred;
3050 :
3051 31195 : break;
3052 :
3053 1 : case MATCH_ERROR:
3054 1 : goto cleanup;
3055 : }
3056 : }
3057 :
3058 : /* The dummy arguments and result of the abbreviated form of MODULE
3059 : PROCEDUREs, used in SUBMODULES should not be redefined. */
3060 286469 : if (gfc_current_ns->proc_name
3061 281977 : && gfc_current_ns->proc_name->abr_modproc_decl)
3062 : {
3063 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
3064 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
3065 : {
3066 2 : m = MATCH_ERROR;
3067 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
3068 : "in the corresponding interface for MODULE "
3069 : "PROCEDURE %qs", sym->name, &var_locus,
3070 2 : gfc_current_ns->proc_name->name);
3071 2 : goto cleanup;
3072 : }
3073 : }
3074 :
3075 : /* %FILL components may not have initializers. */
3076 286467 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
3077 : {
3078 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
3079 : &var_locus);
3080 1 : m = MATCH_ERROR;
3081 1 : goto cleanup;
3082 : }
3083 :
3084 : /* If this symbol has already shown up in a Cray Pointer declaration,
3085 : and this is not a component declaration,
3086 : then we want to set the type & bail out. */
3087 286466 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
3088 : {
3089 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3090 2959 : if (sym != NULL && sym->attr.cray_pointee)
3091 : {
3092 101 : m = MATCH_YES;
3093 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
3094 : {
3095 1 : m = MATCH_ERROR;
3096 1 : goto cleanup;
3097 : }
3098 :
3099 : /* Check to see if we have an array specification. */
3100 100 : if (cp_as != NULL)
3101 : {
3102 49 : if (sym->as != NULL)
3103 : {
3104 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3105 1 : gfc_free_array_spec (cp_as);
3106 1 : m = MATCH_ERROR;
3107 1 : goto cleanup;
3108 : }
3109 : else
3110 : {
3111 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3112 0 : gfc_internal_error ("Cannot set pointee array spec.");
3113 :
3114 : /* Fix the array spec. */
3115 48 : m = gfc_mod_pointee_as (sym->as);
3116 48 : if (m == MATCH_ERROR)
3117 0 : goto cleanup;
3118 : }
3119 : }
3120 99 : goto cleanup;
3121 : }
3122 : else
3123 : {
3124 2858 : gfc_free_array_spec (cp_as);
3125 : }
3126 : }
3127 : else
3128 : {
3129 : /* Check to see if this is the declaration of the type and/or attributes
3130 : of an implicit function result, emanating from a module function
3131 : interface declared within the parent module or submodule of a
3132 : containing submodule. */
3133 283507 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3134 283507 : if (gfc_current_state () == COMP_FUNCTION
3135 47073 : && sym == gfc_current_block ()
3136 8278 : && sym->attr.if_source == IFSRC_DECL
3137 4952 : && sym->attr.used_in_submodule
3138 4 : && sym == sym->result
3139 4 : && sym->ts.type != BT_UNKNOWN)
3140 : {
3141 4 : m = MATCH_YES;
3142 4 : goto cleanup;
3143 : }
3144 283503 : sym = NULL;
3145 : }
3146 :
3147 : /* Procedure pointer as function result. */
3148 286361 : if (gfc_current_state () == COMP_FUNCTION
3149 47183 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3150 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3151 7 : strcpy (name, "ppr@");
3152 :
3153 286361 : if (gfc_current_state () == COMP_FUNCTION
3154 47183 : && strcmp (name, gfc_current_block ()->name) == 0
3155 8294 : && gfc_current_block ()->result
3156 8294 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3157 16 : strcpy (name, "ppr@");
3158 :
3159 : /* OK, we've successfully matched the declaration. Now put the
3160 : symbol in the current namespace, because it might be used in the
3161 : optional initialization expression for this symbol, e.g. this is
3162 : perfectly legal:
3163 :
3164 : integer, parameter :: i = huge(i)
3165 :
3166 : This is only true for parameters or variables of a basic type.
3167 : For components of derived types, it is not true, so we don't
3168 : create a symbol for those yet. If we fail to create the symbol,
3169 : bail out. */
3170 286361 : if (!gfc_comp_struct (gfc_current_state ())
3171 266883 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3172 : {
3173 46 : m = MATCH_ERROR;
3174 46 : goto cleanup;
3175 : }
3176 :
3177 286315 : if (!check_function_name (name))
3178 : {
3179 0 : m = MATCH_ERROR;
3180 0 : goto cleanup;
3181 : }
3182 :
3183 : /* We allow old-style initializations of the form
3184 : integer i /2/, j(4) /3*3, 1/
3185 : (if no colon has been seen). These are different from data
3186 : statements in that initializers are only allowed to apply to the
3187 : variable immediately preceding, i.e.
3188 : integer i, j /1, 2/
3189 : is not allowed. Therefore we have to do some work manually, that
3190 : could otherwise be left to the matchers for DATA statements. */
3191 :
3192 286315 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3193 : {
3194 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3195 : "initialization at %C"))
3196 : return MATCH_ERROR;
3197 :
3198 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3199 : but not components of derived types. */
3200 146 : else if (gfc_current_state () == COMP_DERIVED)
3201 : {
3202 2 : gfc_error ("Invalid old style initialization for derived type "
3203 : "component at %C");
3204 2 : m = MATCH_ERROR;
3205 2 : goto cleanup;
3206 : }
3207 :
3208 : /* For structure components, read the initializer as a special
3209 : expression and let the rest of this function apply the initializer
3210 : as usual. */
3211 144 : else if (gfc_comp_struct (gfc_current_state ()))
3212 : {
3213 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3214 74 : if (m == MATCH_NO)
3215 : gfc_error ("Syntax error in old style initialization of %s at %C",
3216 : name);
3217 74 : if (m != MATCH_YES)
3218 14 : goto cleanup;
3219 : }
3220 :
3221 : /* Otherwise we treat the old style initialization just like a
3222 : DATA declaration for the current variable. */
3223 : else
3224 70 : return match_old_style_init (name);
3225 : }
3226 :
3227 : /* The double colon must be present in order to have initializers.
3228 : Otherwise the statement is ambiguous with an assignment statement. */
3229 286229 : if (colon_seen)
3230 : {
3231 239974 : if (gfc_match (" =>") == MATCH_YES)
3232 : {
3233 1263 : if (!current_attr.pointer)
3234 : {
3235 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3236 0 : m = MATCH_ERROR;
3237 0 : goto cleanup;
3238 : }
3239 :
3240 1263 : m = match_pointer_init (&initializer, 0);
3241 1263 : if (m != MATCH_YES)
3242 10 : goto cleanup;
3243 :
3244 : /* The target of a pointer initialization must have the SAVE
3245 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3246 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3247 1253 : if (initializer->expr_type == EXPR_VARIABLE
3248 164 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3249 25 : && (gfc_current_state () == COMP_PROGRAM
3250 : || gfc_current_state () == COMP_MODULE
3251 25 : || gfc_current_state () == COMP_SUBMODULE))
3252 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3253 : }
3254 238711 : else if (gfc_match_char ('=') == MATCH_YES)
3255 : {
3256 26884 : if (current_attr.pointer)
3257 : {
3258 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3259 : "not %<=%>");
3260 0 : m = MATCH_ERROR;
3261 0 : goto cleanup;
3262 : }
3263 :
3264 26884 : if (gfc_comp_struct (gfc_current_state ())
3265 2761 : && gfc_current_block ()->attr.pdt_template)
3266 : {
3267 443 : m = gfc_match_expr (&initializer);
3268 443 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3269 139 : initializer->ts = current_ts;
3270 : }
3271 : else
3272 26441 : m = gfc_match_init_expr (&initializer);
3273 :
3274 26884 : if (m == MATCH_NO)
3275 : {
3276 1 : gfc_error ("Expected an initialization expression at %C");
3277 1 : m = MATCH_ERROR;
3278 : }
3279 :
3280 10672 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3281 26886 : && !gfc_comp_struct (gfc_state_stack->state))
3282 : {
3283 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3284 : "a PURE procedure");
3285 1 : m = MATCH_ERROR;
3286 : }
3287 :
3288 26884 : if (current_attr.flavor != FL_PARAMETER
3289 10672 : && !gfc_comp_struct (gfc_state_stack->state))
3290 7911 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3291 :
3292 26884 : if (m != MATCH_YES)
3293 160 : goto cleanup;
3294 : }
3295 : }
3296 :
3297 286059 : if (initializer != NULL && current_attr.allocatable
3298 3 : && gfc_comp_struct (gfc_current_state ()))
3299 : {
3300 2 : gfc_error ("Initialization of allocatable component at %C is not "
3301 : "allowed");
3302 2 : m = MATCH_ERROR;
3303 2 : goto cleanup;
3304 : }
3305 :
3306 286057 : if (gfc_current_state () == COMP_DERIVED
3307 18436 : && initializer && initializer->ts.type == BT_HOLLERITH)
3308 : {
3309 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3310 : "constant at %L is not allowed", &initializer->where);
3311 1 : m = MATCH_ERROR;
3312 1 : goto cleanup;
3313 : }
3314 :
3315 286056 : if (gfc_current_state () == COMP_DERIVED
3316 18435 : && gfc_current_block ()->attr.pdt_template)
3317 : {
3318 1704 : gfc_symbol *param;
3319 1704 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3320 : 0, ¶m);
3321 1704 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3322 : {
3323 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3324 : "not appear in the type parameter list at %L",
3325 1 : &gfc_current_block ()->declared_at);
3326 1 : m = MATCH_ERROR;
3327 4 : goto cleanup;
3328 : }
3329 1703 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3330 : {
3331 1 : gfc_error ("The component at %C that appears in the type parameter "
3332 : "list at %L has neither the KIND nor LEN attribute",
3333 1 : &gfc_current_block ()->declared_at);
3334 1 : m = MATCH_ERROR;
3335 1 : goto cleanup;
3336 : }
3337 1702 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3338 : {
3339 1 : gfc_error ("The component at %C which is a type parameter must be "
3340 : "a scalar");
3341 1 : m = MATCH_ERROR;
3342 1 : goto cleanup;
3343 : }
3344 1701 : else if (param && initializer)
3345 : {
3346 391 : if (initializer->ts.type == BT_BOZ)
3347 : {
3348 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3349 : "initializer", &initializer->where);
3350 1 : m = MATCH_ERROR;
3351 1 : goto cleanup;
3352 : }
3353 390 : param->value = gfc_copy_expr (initializer);
3354 : }
3355 : }
3356 :
3357 : /* Before adding a possible initializer, do a simple check for compatibility
3358 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3359 : good thing. */
3360 29468 : if (current_ts.type == BT_DERIVED && initializer
3361 287521 : && (gfc_numeric_ts (&initializer->ts)
3362 1467 : || initializer->ts.type == BT_LOGICAL
3363 1467 : || initializer->ts.type == BT_CHARACTER))
3364 : {
3365 2 : gfc_error ("Incompatible initialization between a derived type "
3366 : "entity and an entity with %qs type at %C",
3367 : gfc_typename (initializer));
3368 2 : m = MATCH_ERROR;
3369 2 : goto cleanup;
3370 : }
3371 :
3372 :
3373 : /* Add the initializer. Note that it is fine if initializer is
3374 : NULL here, because we sometimes also need to check if a
3375 : declaration *must* have an initialization expression. */
3376 286050 : if (!gfc_comp_struct (gfc_current_state ()))
3377 266601 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
3378 : saved_cl_list);
3379 : else
3380 : {
3381 19449 : if (current_ts.type == BT_DERIVED
3382 2710 : && !current_attr.pointer && !initializer)
3383 2145 : initializer = gfc_default_initializer (¤t_ts);
3384 19449 : t = build_struct (name, cl, &initializer, &as);
3385 :
3386 : /* If we match a nested structure definition we expect to see the
3387 : * body even if the variable declarations blow up, so we need to keep
3388 : * the structure declaration around. */
3389 19449 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3390 34 : gfc_commit_symbol (gfc_new_block);
3391 : }
3392 :
3393 286050 : m = (t) ? MATCH_YES : MATCH_ERROR;
3394 :
3395 286494 : cleanup:
3396 : /* Free stuff up and return. */
3397 286494 : gfc_seen_div0 = false;
3398 286494 : gfc_free_expr (initializer);
3399 286494 : gfc_free_array_spec (as);
3400 :
3401 286494 : return m;
3402 : }
3403 :
3404 :
3405 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3406 : This assumes that the byte size is equal to the kind number for
3407 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3408 :
3409 : static match
3410 110078 : gfc_match_old_kind_spec (gfc_typespec *ts)
3411 : {
3412 110078 : match m;
3413 110078 : int original_kind;
3414 :
3415 110078 : if (gfc_match_char ('*') != MATCH_YES)
3416 : return MATCH_NO;
3417 :
3418 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3419 1150 : if (m != MATCH_YES)
3420 : return MATCH_ERROR;
3421 :
3422 1150 : original_kind = ts->kind;
3423 :
3424 : /* Massage the kind numbers for complex types. */
3425 1150 : if (ts->type == BT_COMPLEX)
3426 : {
3427 79 : if (ts->kind % 2)
3428 : {
3429 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3430 : gfc_basic_typename (ts->type), original_kind);
3431 0 : return MATCH_ERROR;
3432 : }
3433 79 : ts->kind /= 2;
3434 :
3435 : }
3436 :
3437 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3438 0 : ts->kind = 8;
3439 :
3440 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3441 : {
3442 858 : if (ts->kind == 4)
3443 : {
3444 224 : if (flag_real4_kind == 8)
3445 24 : ts->kind = 8;
3446 224 : if (flag_real4_kind == 10)
3447 24 : ts->kind = 10;
3448 224 : if (flag_real4_kind == 16)
3449 24 : ts->kind = 16;
3450 : }
3451 634 : else if (ts->kind == 8)
3452 : {
3453 629 : if (flag_real8_kind == 4)
3454 24 : ts->kind = 4;
3455 629 : if (flag_real8_kind == 10)
3456 24 : ts->kind = 10;
3457 629 : if (flag_real8_kind == 16)
3458 24 : ts->kind = 16;
3459 : }
3460 : }
3461 :
3462 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3463 : {
3464 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3465 : gfc_basic_typename (ts->type), original_kind);
3466 8 : return MATCH_ERROR;
3467 : }
3468 :
3469 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3470 : "Nonstandard type declaration %s*%d at %C",
3471 : gfc_basic_typename(ts->type), original_kind))
3472 0 : return MATCH_ERROR;
3473 :
3474 : return MATCH_YES;
3475 : }
3476 :
3477 :
3478 : /* Match a kind specification. Since kinds are generally optional, we
3479 : usually return MATCH_NO if something goes wrong. If a "kind="
3480 : string is found, then we know we have an error. */
3481 :
3482 : match
3483 163766 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3484 : {
3485 163766 : locus where, loc;
3486 163766 : gfc_expr *e;
3487 163766 : match m, n;
3488 163766 : char c;
3489 :
3490 163766 : m = MATCH_NO;
3491 163766 : n = MATCH_YES;
3492 163766 : e = NULL;
3493 163766 : saved_kind_expr = NULL;
3494 :
3495 163766 : where = loc = gfc_current_locus;
3496 :
3497 163766 : if (kind_expr_only)
3498 0 : goto kind_expr;
3499 :
3500 163766 : if (gfc_match_char ('(') == MATCH_NO)
3501 : return MATCH_NO;
3502 :
3503 : /* Also gobbles optional text. */
3504 52054 : if (gfc_match (" kind = ") == MATCH_YES)
3505 52054 : m = MATCH_ERROR;
3506 :
3507 52054 : loc = gfc_current_locus;
3508 :
3509 52054 : kind_expr:
3510 :
3511 52054 : n = gfc_match_init_expr (&e);
3512 :
3513 52054 : if (gfc_derived_parameter_expr (e))
3514 : {
3515 292 : ts->kind = 0;
3516 292 : saved_kind_expr = gfc_copy_expr (e);
3517 292 : goto close_brackets;
3518 : }
3519 :
3520 51762 : if (n != MATCH_YES)
3521 : {
3522 465 : if (gfc_matching_function)
3523 : {
3524 : /* The function kind expression might include use associated or
3525 : imported parameters and try again after the specification
3526 : expressions..... */
3527 437 : if (gfc_match_char (')') != MATCH_YES)
3528 : {
3529 1 : gfc_error ("Missing right parenthesis at %C");
3530 1 : m = MATCH_ERROR;
3531 1 : goto no_match;
3532 : }
3533 :
3534 436 : gfc_free_expr (e);
3535 436 : gfc_undo_symbols ();
3536 436 : return MATCH_YES;
3537 : }
3538 : else
3539 : {
3540 : /* ....or else, the match is real. */
3541 28 : if (n == MATCH_NO)
3542 0 : gfc_error ("Expected initialization expression at %C");
3543 : if (n != MATCH_YES)
3544 : return MATCH_ERROR;
3545 : }
3546 : }
3547 :
3548 51297 : if (e->rank != 0)
3549 : {
3550 0 : gfc_error ("Expected scalar initialization expression at %C");
3551 0 : m = MATCH_ERROR;
3552 0 : goto no_match;
3553 : }
3554 :
3555 51297 : if (gfc_extract_int (e, &ts->kind, 1))
3556 : {
3557 0 : m = MATCH_ERROR;
3558 0 : goto no_match;
3559 : }
3560 :
3561 : /* Before throwing away the expression, let's see if we had a
3562 : C interoperable kind (and store the fact). */
3563 51297 : if (e->ts.is_c_interop == 1)
3564 : {
3565 : /* Mark this as C interoperable if being declared with one
3566 : of the named constants from iso_c_binding. */
3567 18880 : ts->is_c_interop = e->ts.is_iso_c;
3568 18880 : ts->f90_type = e->ts.f90_type;
3569 18880 : if (e->symtree)
3570 18879 : ts->interop_kind = e->symtree->n.sym;
3571 : }
3572 :
3573 51297 : gfc_free_expr (e);
3574 51297 : e = NULL;
3575 :
3576 : /* Ignore errors to this point, if we've gotten here. This means
3577 : we ignore the m=MATCH_ERROR from above. */
3578 51297 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3579 : {
3580 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3581 : gfc_basic_typename (ts->type));
3582 7 : gfc_current_locus = where;
3583 7 : return MATCH_ERROR;
3584 : }
3585 :
3586 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3587 : if, e.g., c_double is used for COMPLEX as the standard
3588 : explicitly says that the kind type parameter for complex and real
3589 : variable is the same, i.e. c_float == c_float_complex. */
3590 51290 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3591 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3592 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3593 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3594 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3595 : gfc_basic_typename (ts->type));
3596 :
3597 51277 : close_brackets:
3598 :
3599 51582 : gfc_gobble_whitespace ();
3600 51582 : if ((c = gfc_next_ascii_char ()) != ')'
3601 51582 : && (ts->type != BT_CHARACTER || c != ','))
3602 : {
3603 0 : if (ts->type == BT_CHARACTER)
3604 0 : gfc_error ("Missing right parenthesis or comma at %C");
3605 : else
3606 0 : gfc_error ("Missing right parenthesis at %C");
3607 0 : m = MATCH_ERROR;
3608 0 : goto no_match;
3609 : }
3610 : else
3611 : /* All tests passed. */
3612 51582 : m = MATCH_YES;
3613 :
3614 51582 : if(m == MATCH_ERROR)
3615 : gfc_current_locus = where;
3616 :
3617 51582 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3618 0 : ts->kind = 8;
3619 :
3620 51582 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3621 : {
3622 14630 : if (ts->kind == 4)
3623 : {
3624 4618 : if (flag_real4_kind == 8)
3625 54 : ts->kind = 8;
3626 4618 : if (flag_real4_kind == 10)
3627 54 : ts->kind = 10;
3628 4618 : if (flag_real4_kind == 16)
3629 54 : ts->kind = 16;
3630 : }
3631 10012 : else if (ts->kind == 8)
3632 : {
3633 6782 : if (flag_real8_kind == 4)
3634 48 : ts->kind = 4;
3635 6782 : if (flag_real8_kind == 10)
3636 48 : ts->kind = 10;
3637 6782 : if (flag_real8_kind == 16)
3638 48 : ts->kind = 16;
3639 : }
3640 : }
3641 :
3642 : /* Return what we know from the test(s). */
3643 : return m;
3644 :
3645 1 : no_match:
3646 1 : gfc_free_expr (e);
3647 1 : gfc_current_locus = where;
3648 1 : return m;
3649 : }
3650 :
3651 :
3652 : static match
3653 5056 : match_char_kind (int * kind, int * is_iso_c)
3654 : {
3655 5056 : locus where;
3656 5056 : gfc_expr *e;
3657 5056 : match m, n;
3658 5056 : bool fail;
3659 :
3660 5056 : m = MATCH_NO;
3661 5056 : e = NULL;
3662 5056 : where = gfc_current_locus;
3663 :
3664 5056 : n = gfc_match_init_expr (&e);
3665 :
3666 5056 : if (n != MATCH_YES && gfc_matching_function)
3667 : {
3668 : /* The expression might include use-associated or imported
3669 : parameters and try again after the specification
3670 : expressions. */
3671 7 : gfc_free_expr (e);
3672 7 : gfc_undo_symbols ();
3673 7 : return MATCH_YES;
3674 : }
3675 :
3676 7 : if (n == MATCH_NO)
3677 2 : gfc_error ("Expected initialization expression at %C");
3678 5049 : if (n != MATCH_YES)
3679 : return MATCH_ERROR;
3680 :
3681 5042 : if (e->rank != 0)
3682 : {
3683 0 : gfc_error ("Expected scalar initialization expression at %C");
3684 0 : m = MATCH_ERROR;
3685 0 : goto no_match;
3686 : }
3687 :
3688 5042 : if (gfc_derived_parameter_expr (e))
3689 : {
3690 80 : saved_kind_expr = e;
3691 80 : *kind = 0;
3692 80 : return MATCH_YES;
3693 : }
3694 :
3695 4962 : fail = gfc_extract_int (e, kind, 1);
3696 4962 : *is_iso_c = e->ts.is_iso_c;
3697 4962 : if (fail)
3698 : {
3699 0 : m = MATCH_ERROR;
3700 0 : goto no_match;
3701 : }
3702 :
3703 4962 : gfc_free_expr (e);
3704 :
3705 : /* Ignore errors to this point, if we've gotten here. This means
3706 : we ignore the m=MATCH_ERROR from above. */
3707 4962 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3708 : {
3709 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3710 14 : m = MATCH_ERROR;
3711 : }
3712 : else
3713 : /* All tests passed. */
3714 : m = MATCH_YES;
3715 :
3716 14 : if (m == MATCH_ERROR)
3717 14 : gfc_current_locus = where;
3718 :
3719 : /* Return what we know from the test(s). */
3720 : return m;
3721 :
3722 0 : no_match:
3723 0 : gfc_free_expr (e);
3724 0 : gfc_current_locus = where;
3725 0 : return m;
3726 : }
3727 :
3728 :
3729 : /* Match the various kind/length specifications in a CHARACTER
3730 : declaration. We don't return MATCH_NO. */
3731 :
3732 : match
3733 32584 : gfc_match_char_spec (gfc_typespec *ts)
3734 : {
3735 32584 : int kind, seen_length, is_iso_c;
3736 32584 : gfc_charlen *cl;
3737 32584 : gfc_expr *len;
3738 32584 : match m;
3739 32584 : bool deferred;
3740 :
3741 32584 : len = NULL;
3742 32584 : seen_length = 0;
3743 32584 : kind = 0;
3744 32584 : is_iso_c = 0;
3745 32584 : deferred = false;
3746 :
3747 : /* Try the old-style specification first. */
3748 32584 : old_char_selector = 0;
3749 :
3750 32584 : m = match_char_length (&len, &deferred, true);
3751 32584 : if (m != MATCH_NO)
3752 : {
3753 2205 : if (m == MATCH_YES)
3754 2205 : old_char_selector = 1;
3755 2205 : seen_length = 1;
3756 2205 : goto done;
3757 : }
3758 :
3759 30379 : m = gfc_match_char ('(');
3760 30379 : if (m != MATCH_YES)
3761 : {
3762 1916 : m = MATCH_YES; /* Character without length is a single char. */
3763 1916 : goto done;
3764 : }
3765 :
3766 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3767 28463 : if (gfc_match (" kind =") == MATCH_YES)
3768 : {
3769 3571 : m = match_char_kind (&kind, &is_iso_c);
3770 :
3771 3571 : if (m == MATCH_ERROR)
3772 16 : goto done;
3773 3555 : if (m == MATCH_NO)
3774 : goto syntax;
3775 :
3776 3555 : if (gfc_match (" , len =") == MATCH_NO)
3777 536 : goto rparen;
3778 :
3779 3019 : m = char_len_param_value (&len, &deferred);
3780 3019 : if (m == MATCH_NO)
3781 0 : goto syntax;
3782 3019 : if (m == MATCH_ERROR)
3783 2 : goto done;
3784 3017 : seen_length = 1;
3785 :
3786 3017 : goto rparen;
3787 : }
3788 :
3789 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3790 24892 : if (gfc_match (" len =") == MATCH_YES)
3791 : {
3792 14152 : m = char_len_param_value (&len, &deferred);
3793 14152 : if (m == MATCH_NO)
3794 2 : goto syntax;
3795 14150 : if (m == MATCH_ERROR)
3796 8 : goto done;
3797 14142 : seen_length = 1;
3798 :
3799 14142 : if (gfc_match_char (')') == MATCH_YES)
3800 12837 : goto done;
3801 :
3802 1305 : if (gfc_match (" , kind =") != MATCH_YES)
3803 0 : goto syntax;
3804 :
3805 1305 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3806 2 : goto done;
3807 :
3808 1303 : goto rparen;
3809 : }
3810 :
3811 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3812 10740 : m = char_len_param_value (&len, &deferred);
3813 10740 : if (m == MATCH_NO)
3814 0 : goto syntax;
3815 10740 : if (m == MATCH_ERROR)
3816 44 : goto done;
3817 10696 : seen_length = 1;
3818 :
3819 10696 : m = gfc_match_char (')');
3820 10696 : if (m == MATCH_YES)
3821 10514 : goto done;
3822 :
3823 182 : if (gfc_match_char (',') != MATCH_YES)
3824 2 : goto syntax;
3825 :
3826 180 : gfc_match (" kind ="); /* Gobble optional text. */
3827 :
3828 180 : m = match_char_kind (&kind, &is_iso_c);
3829 180 : if (m == MATCH_ERROR)
3830 3 : goto done;
3831 : if (m == MATCH_NO)
3832 : goto syntax;
3833 :
3834 5033 : rparen:
3835 : /* Require a right-paren at this point. */
3836 5033 : m = gfc_match_char (')');
3837 5033 : if (m == MATCH_YES)
3838 5033 : goto done;
3839 :
3840 0 : syntax:
3841 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3842 4 : m = MATCH_ERROR;
3843 4 : gfc_free_expr (len);
3844 4 : return m;
3845 :
3846 32580 : done:
3847 : /* Deal with character functions after USE and IMPORT statements. */
3848 32580 : if (gfc_matching_function)
3849 : {
3850 1431 : gfc_free_expr (len);
3851 1431 : gfc_undo_symbols ();
3852 1431 : return MATCH_YES;
3853 : }
3854 :
3855 31149 : if (m != MATCH_YES)
3856 : {
3857 65 : gfc_free_expr (len);
3858 65 : return m;
3859 : }
3860 :
3861 : /* Do some final massaging of the length values. */
3862 31084 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3863 :
3864 31084 : if (seen_length == 0)
3865 2400 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3866 : else
3867 : {
3868 : /* If gfortran ends up here, then len may be reducible to a constant.
3869 : Try to do that here. If it does not reduce, simply assign len to
3870 : charlen. A complication occurs with user-defined generic functions,
3871 : which are not resolved. Use a private namespace to deal with
3872 : generic functions. */
3873 :
3874 28684 : if (len && len->expr_type != EXPR_CONSTANT)
3875 : {
3876 3213 : gfc_namespace *old_ns;
3877 3213 : gfc_expr *e;
3878 :
3879 3213 : old_ns = gfc_current_ns;
3880 3213 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3881 :
3882 3213 : e = gfc_copy_expr (len);
3883 3213 : gfc_push_suppress_errors ();
3884 3213 : gfc_reduce_init_expr (e);
3885 3213 : gfc_pop_suppress_errors ();
3886 3213 : if (e->expr_type == EXPR_CONSTANT)
3887 : {
3888 318 : gfc_replace_expr (len, e);
3889 318 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3890 7 : mpz_set_ui (len->value.integer, 0);
3891 : }
3892 : else
3893 2895 : gfc_free_expr (e);
3894 :
3895 3213 : gfc_free_namespace (gfc_current_ns);
3896 3213 : gfc_current_ns = old_ns;
3897 : }
3898 :
3899 28684 : cl->length = len;
3900 : }
3901 :
3902 31084 : ts->u.cl = cl;
3903 31084 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3904 31084 : ts->deferred = deferred;
3905 :
3906 : /* We have to know if it was a C interoperable kind so we can
3907 : do accurate type checking of bind(c) procs, etc. */
3908 31084 : if (kind != 0)
3909 : /* Mark this as C interoperable if being declared with one
3910 : of the named constants from iso_c_binding. */
3911 4873 : ts->is_c_interop = is_iso_c;
3912 26211 : else if (len != NULL)
3913 : /* Here, we might have parsed something such as: character(c_char)
3914 : In this case, the parsing code above grabs the c_char when
3915 : looking for the length (line 1690, roughly). it's the last
3916 : testcase for parsing the kind params of a character variable.
3917 : However, it's not actually the length. this seems like it
3918 : could be an error.
3919 : To see if the user used a C interop kind, test the expr
3920 : of the so called length, and see if it's C interoperable. */
3921 16914 : ts->is_c_interop = len->ts.is_iso_c;
3922 :
3923 : return MATCH_YES;
3924 : }
3925 :
3926 :
3927 : /* Matches a RECORD declaration. */
3928 :
3929 : static match
3930 985035 : match_record_decl (char *name)
3931 : {
3932 985035 : locus old_loc;
3933 985035 : old_loc = gfc_current_locus;
3934 985035 : match m;
3935 :
3936 985035 : m = gfc_match (" record /");
3937 985035 : if (m == MATCH_YES)
3938 : {
3939 353 : if (!flag_dec_structure)
3940 : {
3941 6 : gfc_current_locus = old_loc;
3942 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3943 : "%<-fdec-structure%>");
3944 6 : return MATCH_ERROR;
3945 : }
3946 347 : m = gfc_match (" %n/", name);
3947 347 : if (m == MATCH_YES)
3948 : return MATCH_YES;
3949 : }
3950 :
3951 984685 : gfc_current_locus = old_loc;
3952 984685 : if (flag_dec_structure
3953 984685 : && (gfc_match (" record% ") == MATCH_YES
3954 8026 : || gfc_match (" record%t") == MATCH_YES))
3955 6 : gfc_error ("Structure name expected after RECORD at %C");
3956 984685 : if (m == MATCH_NO)
3957 984685 : return MATCH_NO;
3958 :
3959 : return MATCH_ERROR;
3960 : }
3961 :
3962 :
3963 : /* In parsing a PDT, it is possible that one of the type parameters has the
3964 : same name as a previously declared symbol that is not a type parameter.
3965 : Intercept this now by looking for the symtree in f2k_derived. */
3966 :
3967 : static bool
3968 1351 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3969 : {
3970 1351 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3971 : return false;
3972 :
3973 1035 : if (!(e->symtree->n.sym->attr.pdt_len
3974 242 : || e->symtree->n.sym->attr.pdt_kind))
3975 : {
3976 158 : gfc_symtree *st;
3977 158 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3978 : e->symtree->n.sym->name);
3979 158 : if (st && st->n.sym
3980 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3981 : {
3982 30 : gfc_expr *new_expr;
3983 30 : gfc_set_sym_referenced (st->n.sym);
3984 30 : new_expr = gfc_get_expr ();
3985 30 : new_expr->ts = st->n.sym->ts;
3986 30 : new_expr->expr_type = EXPR_VARIABLE;
3987 30 : new_expr->symtree = st;
3988 30 : new_expr->where = e->where;
3989 30 : gfc_replace_expr (e, new_expr);
3990 : }
3991 : }
3992 :
3993 : return false;
3994 : }
3995 :
3996 :
3997 : void
3998 1053 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3999 : {
4000 1053 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
4001 : return;
4002 860 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
4003 : }
4004 :
4005 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
4006 : of expressions to substitute into the possibly parameterized expression
4007 : 'e'. Using a list is inefficient but should not be too bad since the
4008 : number of type parameters is not likely to be large. */
4009 : static bool
4010 5173 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4011 : int* f)
4012 : {
4013 5173 : gfc_actual_arglist *param;
4014 5173 : gfc_expr *copy;
4015 :
4016 5173 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
4017 : return false;
4018 :
4019 2287 : gcc_assert (e->symtree);
4020 2287 : if (e->symtree->n.sym->attr.pdt_kind
4021 1590 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
4022 819 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
4023 : {
4024 2476 : for (param = type_param_spec_list; param; param = param->next)
4025 2326 : if (!strcmp (e->symtree->n.sym->name, param->name))
4026 : break;
4027 :
4028 1617 : if (param && param->expr)
4029 : {
4030 1466 : copy = gfc_copy_expr (param->expr);
4031 1466 : gfc_replace_expr (e, copy);
4032 : /* Catch variables declared without a value expression. */
4033 1466 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
4034 21 : e->ts = e->symtree->n.sym->ts;
4035 : }
4036 : }
4037 :
4038 : return false;
4039 : }
4040 :
4041 :
4042 : static bool
4043 1499 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
4044 : {
4045 1499 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
4046 : }
4047 :
4048 :
4049 : bool
4050 2703 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
4051 : {
4052 2703 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
4053 2703 : type_param_spec_list = param_list;
4054 2703 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
4055 2703 : type_param_spec_list = old_param_spec_list;
4056 2703 : return res;
4057 : }
4058 :
4059 : /* Determines the instance of a parameterized derived type to be used by
4060 : matching determining the values of the kind parameters and using them
4061 : in the name of the instance. If the instance exists, it is used, otherwise
4062 : a new derived type is created. */
4063 : match
4064 3557 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
4065 : gfc_actual_arglist **ext_param_list)
4066 : {
4067 : /* The PDT template symbol. */
4068 3557 : gfc_symbol *pdt = *sym;
4069 : /* The symbol for the parameter in the template f2k_namespace. */
4070 3557 : gfc_symbol *param;
4071 : /* The hoped for instance of the PDT. */
4072 3557 : gfc_symbol *instance = NULL;
4073 : /* The list of parameters appearing in the PDT declaration. */
4074 3557 : gfc_formal_arglist *type_param_name_list;
4075 : /* Used to store the parameter specification list during recursive calls. */
4076 3557 : gfc_actual_arglist *old_param_spec_list;
4077 : /* Pointers to the parameter specification being used. */
4078 3557 : gfc_actual_arglist *actual_param;
4079 3557 : gfc_actual_arglist *tail = NULL;
4080 : /* Used to build up the name of the PDT instance. */
4081 3557 : char *name;
4082 3557 : bool name_seen = (param_list == NULL);
4083 3557 : bool assumed_seen = false;
4084 3557 : bool deferred_seen = false;
4085 3557 : bool spec_error = false;
4086 3557 : bool alloc_seen = false;
4087 3557 : bool ptr_seen = false;
4088 3557 : int i;
4089 3557 : gfc_expr *kind_expr;
4090 3557 : gfc_component *c1, *c2;
4091 3557 : match m;
4092 3557 : gfc_symtree *s = NULL;
4093 :
4094 3557 : type_param_spec_list = NULL;
4095 :
4096 3557 : type_param_name_list = pdt->formal;
4097 3557 : actual_param = param_list;
4098 :
4099 : /* Prevent a PDT component of the same type as the template from being
4100 : converted into an instance. Doing this results in the component being
4101 : lost. */
4102 3557 : if (gfc_current_state () == COMP_DERIVED
4103 113 : && !(gfc_state_stack->previous
4104 113 : && gfc_state_stack->previous->state == COMP_DERIVED)
4105 113 : && gfc_current_block ()->attr.pdt_template)
4106 : {
4107 100 : if (ext_param_list)
4108 100 : *ext_param_list = gfc_copy_actual_arglist (param_list);
4109 : return MATCH_YES;
4110 : }
4111 :
4112 3457 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
4113 :
4114 : /* Run through the parameter name list and pick up the actual
4115 : parameter values or use the default values in the PDT declaration. */
4116 11744 : for (; type_param_name_list;
4117 4830 : type_param_name_list = type_param_name_list->next)
4118 : {
4119 4898 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4120 : {
4121 4448 : if (actual_param->spec_type == SPEC_ASSUMED)
4122 : spec_error = deferred_seen;
4123 : else
4124 4448 : spec_error = assumed_seen;
4125 :
4126 4448 : if (spec_error)
4127 : {
4128 : gfc_error ("The type parameter spec list at %C cannot contain "
4129 : "both ASSUMED and DEFERRED parameters");
4130 : goto error_return;
4131 : }
4132 : }
4133 :
4134 4448 : if (actual_param && actual_param->name)
4135 4898 : name_seen = true;
4136 4898 : param = type_param_name_list->sym;
4137 :
4138 4898 : if (!param || !param->name)
4139 2 : continue;
4140 :
4141 4896 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4142 : /* An error should already have been thrown in resolve.cc
4143 : (resolve_fl_derived0). */
4144 4896 : if (!pdt->attr.use_assoc && !c1)
4145 8 : goto error_return;
4146 :
4147 : /* Resolution PDT class components of derived types are handled here.
4148 : They can arrive without a parameter list and no KIND parameters. */
4149 4888 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4150 20 : continue;
4151 :
4152 4868 : kind_expr = NULL;
4153 4868 : if (!name_seen)
4154 : {
4155 2956 : if (!actual_param && !(c1 && c1->initializer))
4156 : {
4157 2 : gfc_error ("The type parameter spec list at %C does not contain "
4158 : "enough parameter expressions");
4159 2 : goto error_return;
4160 : }
4161 2954 : else if (!actual_param && c1 && c1->initializer)
4162 5 : kind_expr = gfc_copy_expr (c1->initializer);
4163 2949 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4164 2604 : kind_expr = gfc_copy_expr (actual_param->expr);
4165 : }
4166 : else
4167 : {
4168 : actual_param = param_list;
4169 2846 : for (;actual_param; actual_param = actual_param->next)
4170 2408 : if (actual_param->name
4171 2388 : && strcmp (actual_param->name, param->name) == 0)
4172 : break;
4173 1912 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4174 1295 : kind_expr = gfc_copy_expr (actual_param->expr);
4175 : else
4176 : {
4177 617 : if (c1->initializer)
4178 553 : kind_expr = gfc_copy_expr (c1->initializer);
4179 64 : else if (!(actual_param && param->attr.pdt_len))
4180 : {
4181 9 : gfc_error ("The derived parameter %qs at %C does not "
4182 : "have a default value", param->name);
4183 9 : goto error_return;
4184 : }
4185 : }
4186 : }
4187 :
4188 4457 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4189 342 : && kind_expr->ts.type != BT_INTEGER
4190 136 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4191 : {
4192 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4193 : "type and not %s", &kind_expr->where,
4194 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4195 12 : goto error_return;
4196 : }
4197 :
4198 : /* Store the current parameter expressions in a temporary actual
4199 : arglist 'list' so that they can be substituted in the corresponding
4200 : expressions in the PDT instance. */
4201 4845 : if (type_param_spec_list == NULL)
4202 : {
4203 3414 : type_param_spec_list = gfc_get_actual_arglist ();
4204 3414 : tail = type_param_spec_list;
4205 : }
4206 : else
4207 : {
4208 1431 : tail->next = gfc_get_actual_arglist ();
4209 1431 : tail = tail->next;
4210 : }
4211 4845 : tail->name = param->name;
4212 :
4213 4845 : if (kind_expr)
4214 : {
4215 : /* Try simplification even for LEN expressions. */
4216 4445 : bool ok;
4217 4445 : gfc_resolve_expr (kind_expr);
4218 :
4219 4445 : if (c1->attr.pdt_kind
4220 2306 : && kind_expr->expr_type != EXPR_CONSTANT
4221 28 : && type_param_spec_list)
4222 28 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4223 :
4224 4445 : ok = gfc_simplify_expr (kind_expr, 1);
4225 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4226 : initializer so allow for this. */
4227 4445 : if (kind_expr->ts.type != BT_INTEGER
4228 153 : && kind_expr->ts.type != BT_PROCEDURE)
4229 : {
4230 29 : gfc_error ("The parameter expression at %C must be of "
4231 : "INTEGER type and not %s type",
4232 : gfc_basic_typename (kind_expr->ts.type));
4233 29 : goto error_return;
4234 : }
4235 4416 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4236 : {
4237 4 : gfc_error ("The parameter expression at %C does not "
4238 : "simplify to an INTEGER constant");
4239 4 : goto error_return;
4240 : }
4241 :
4242 4412 : tail->expr = gfc_copy_expr (kind_expr);
4243 : }
4244 :
4245 4812 : if (actual_param)
4246 4376 : tail->spec_type = actual_param->spec_type;
4247 :
4248 4812 : if (!param->attr.pdt_kind)
4249 : {
4250 2531 : if (!name_seen && actual_param)
4251 1708 : actual_param = actual_param->next;
4252 2531 : if (kind_expr)
4253 : {
4254 2133 : gfc_free_expr (kind_expr);
4255 2133 : kind_expr = NULL;
4256 : }
4257 2531 : continue;
4258 : }
4259 :
4260 2281 : if (actual_param
4261 1889 : && (actual_param->spec_type == SPEC_ASSUMED
4262 1889 : || actual_param->spec_type == SPEC_DEFERRED))
4263 : {
4264 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4265 : "ASSUMED or DEFERRED", param->name);
4266 2 : goto error_return;
4267 : }
4268 :
4269 2279 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4270 : {
4271 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4272 : "reduce to a constant expression", param->name);
4273 2 : goto error_return;
4274 : }
4275 :
4276 : /* This can come about during the parsing of nested pdt_templates. An
4277 : error arises because the KIND parameter expression has not been
4278 : provided. Use the template instead of an incorrect instance. */
4279 2277 : if (kind_expr->expr_type != EXPR_CONSTANT
4280 2277 : || kind_expr->ts.type != BT_INTEGER)
4281 : {
4282 0 : gfc_free_actual_arglist (type_param_spec_list);
4283 0 : free (name);
4284 0 : return MATCH_YES;
4285 : }
4286 :
4287 2277 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4288 2277 : char *old_name = name;
4289 2277 : name = xasprintf ("%s_%s", old_name, kind_value);
4290 2277 : free (old_name);
4291 2277 : free (kind_value);
4292 :
4293 2277 : if (!name_seen && actual_param)
4294 1192 : actual_param = actual_param->next;
4295 2277 : gfc_free_expr (kind_expr);
4296 : }
4297 :
4298 3389 : if (!name_seen && actual_param)
4299 : {
4300 2 : gfc_error ("The type parameter spec list at %C contains too many "
4301 : "parameter expressions");
4302 2 : goto error_return;
4303 : }
4304 :
4305 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4306 : build it, using 'pdt' as a template. */
4307 3387 : if (gfc_get_symbol (name, pdt->ns, &instance))
4308 : {
4309 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4310 0 : goto error_return;
4311 : }
4312 :
4313 : /* If we are in an interface body, the instance will not have been imported.
4314 : Make sure that it is imported implicitly. */
4315 3387 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4316 3387 : if (gfc_current_ns->proc_name
4317 3340 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4318 99 : && s && s->import_only && pdt->attr.imported)
4319 : {
4320 8 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4321 8 : if (!s)
4322 : {
4323 7 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4324 : &gfc_current_locus);
4325 7 : s->n.sym = instance;
4326 7 : instance->refs++;
4327 : }
4328 8 : s->n.sym->attr.imported = 1;
4329 8 : s->import_only = 1;
4330 : }
4331 :
4332 3387 : m = MATCH_YES;
4333 :
4334 3387 : if (instance->attr.flavor == FL_DERIVED
4335 2638 : && instance->attr.pdt_type
4336 2638 : && instance->components)
4337 : {
4338 2638 : instance->refs++;
4339 2638 : if (ext_param_list)
4340 1254 : *ext_param_list = type_param_spec_list;
4341 2638 : *sym = instance;
4342 2638 : gfc_commit_symbols ();
4343 2638 : free (name);
4344 2638 : return m;
4345 : }
4346 :
4347 : /* Start building the new instance of the parameterized type. */
4348 749 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4349 749 : if (pdt->attr.use_assoc)
4350 162 : instance->module = pdt->module;
4351 749 : instance->attr.pdt_template = 0;
4352 749 : instance->attr.pdt_type = 1;
4353 749 : instance->declared_at = gfc_current_locus;
4354 :
4355 : /* In resolution, the finalizers are copied, according to the type of the
4356 : argument, to the instance finalizers. However, they are retained by the
4357 : template and procedures are freed there. */
4358 749 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4359 : {
4360 36 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4361 36 : instance->template_sym = pdt;
4362 36 : *instance->f2k_derived = *pdt->f2k_derived;
4363 : }
4364 :
4365 : /* Add the components, replacing the parameters in all expressions
4366 : with the expressions for their values in 'type_param_spec_list'. */
4367 749 : c1 = pdt->components;
4368 749 : tail = type_param_spec_list;
4369 2884 : for (; c1; c1 = c1->next)
4370 : {
4371 2137 : gfc_add_component (instance, c1->name, &c2);
4372 :
4373 2137 : c2->ts = c1->ts;
4374 2137 : c2->attr = c1->attr;
4375 2137 : if (c1->tb)
4376 : {
4377 12 : c2->tb = gfc_get_tbp ();
4378 12 : *c2->tb = *c1->tb;
4379 : }
4380 :
4381 : /* The order of declaration of the type_specs might not be the
4382 : same as that of the components. */
4383 2137 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4384 : {
4385 1490 : for (tail = type_param_spec_list; tail; tail = tail->next)
4386 1486 : if (strcmp (c1->name, tail->name) == 0)
4387 : break;
4388 : }
4389 :
4390 : /* Deal with type extension by recursively calling this function
4391 : to obtain the instance of the extended type. */
4392 2137 : if (gfc_current_state () != COMP_DERIVED
4393 2123 : && c1 == pdt->components
4394 736 : && c1->ts.type == BT_DERIVED
4395 96 : && c1->ts.u.derived
4396 2233 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4397 : {
4398 96 : if (c1->ts.u.derived->attr.pdt_template)
4399 : {
4400 83 : gfc_formal_arglist *f;
4401 :
4402 83 : old_param_spec_list = type_param_spec_list;
4403 :
4404 : /* Obtain a spec list appropriate to the extended type..*/
4405 83 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4406 83 : type_param_spec_list = actual_param;
4407 163 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4408 80 : actual_param = actual_param->next;
4409 83 : if (actual_param)
4410 : {
4411 83 : gfc_free_actual_arglist (actual_param->next);
4412 83 : actual_param->next = NULL;
4413 : }
4414 :
4415 : /* Now obtain the PDT instance for the extended type. */
4416 83 : c2->param_list = type_param_spec_list;
4417 83 : m = gfc_get_pdt_instance (type_param_spec_list,
4418 : &c2->ts.u.derived,
4419 : &c2->param_list);
4420 83 : type_param_spec_list = old_param_spec_list;
4421 : }
4422 : else
4423 13 : c2->ts = c1->ts;
4424 :
4425 96 : c2->ts.u.derived->refs++;
4426 96 : gfc_set_sym_referenced (c2->ts.u.derived);
4427 :
4428 : /* If the component is allocatable or the parent has allocatable
4429 : components, make sure that the new instance also is marked as
4430 : having allocatable components. */
4431 96 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4432 6 : instance->attr.alloc_comp = 1;
4433 :
4434 : /* Set extension level. */
4435 96 : if (c2->ts.u.derived->attr.extension == 255)
4436 : {
4437 : /* Since the extension field is 8 bit wide, we can only have
4438 : up to 255 extension levels. */
4439 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4440 : c2->ts.u.derived->name,
4441 : &c2->ts.u.derived->declared_at);
4442 0 : goto error_return;
4443 : }
4444 96 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4445 :
4446 : /* Add the parent initializer. */
4447 96 : if (!IS_PDT (c2) && !c2->ts.u.derived->attr.alloc_comp)
4448 7 : c2->initializer = gfc_generate_initializer (&c2->ts, false);
4449 96 : continue;
4450 96 : }
4451 :
4452 : /* Addressing PR82943, this will fix the issue where a function or
4453 : subroutine is declared as not a member of the PDT instance.
4454 : The reason for this is because the PDT instance did not have access
4455 : to its template's f2k_derived namespace in order to find the
4456 : typebound procedures.
4457 :
4458 : The number of references to the PDT template's f2k_derived will
4459 : ensure that f2k_derived is properly freed later on. */
4460 :
4461 2041 : if (!instance->f2k_derived && pdt->f2k_derived)
4462 : {
4463 706 : instance->f2k_derived = pdt->f2k_derived;
4464 706 : instance->f2k_derived->refs++;
4465 : }
4466 :
4467 : /* Set the component kind using the parameterized expression. */
4468 2041 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4469 735 : && c1->kind_expr != NULL)
4470 : {
4471 500 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4472 500 : gfc_insert_kind_parameter_exprs (e);
4473 500 : gfc_simplify_expr (e, 1);
4474 500 : gfc_extract_int (e, &c2->ts.kind);
4475 500 : gfc_free_expr (e);
4476 500 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4477 : {
4478 2 : gfc_error ("Kind %d not supported for type %s at %C",
4479 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4480 2 : goto error_return;
4481 : }
4482 498 : if (c2->attr.proc_pointer && c2->attr.function
4483 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4484 : {
4485 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4486 0 : c2->ts.interface->result = c2->ts.interface;
4487 0 : c2->ts.interface->ts = c2->ts;
4488 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4489 0 : c2->ts.interface->attr.function = 1;
4490 0 : c2->attr.function = 1;
4491 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4492 : }
4493 : }
4494 :
4495 : /* Set up either the KIND/LEN initializer, if constant,
4496 : or the parameterized expression. Use the template
4497 : initializer if one is not already set in this instance. */
4498 2039 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4499 : {
4500 994 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4501 788 : c2->initializer = gfc_copy_expr (tail->expr);
4502 206 : else if (tail && tail->expr)
4503 : {
4504 34 : c2->param_list = gfc_get_actual_arglist ();
4505 34 : c2->param_list->name = tail->name;
4506 34 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4507 34 : c2->param_list->next = NULL;
4508 : }
4509 :
4510 : /* Initializer expressions in PDT templates, such as character_kinds(1),
4511 : can end up being mutilated when use associated. Simplify now. */
4512 994 : if (c1->initializer && c1->initializer->expr_type != EXPR_CONSTANT)
4513 154 : gfc_simplify_expr (c1->initializer, 1);
4514 :
4515 994 : if (!c2->initializer && c1->initializer)
4516 78 : c2->initializer = gfc_copy_expr (c1->initializer);
4517 :
4518 994 : if (c2->initializer)
4519 866 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4520 : }
4521 :
4522 : /* Copy the array spec. */
4523 2039 : c2->as = gfc_copy_array_spec (c1->as);
4524 2039 : if (c1->ts.type == BT_CLASS)
4525 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4526 :
4527 2039 : if (c1->attr.allocatable)
4528 94 : alloc_seen = true;
4529 :
4530 2039 : if (c1->attr.pointer)
4531 20 : ptr_seen = true;
4532 :
4533 : /* Determine if an array spec is parameterized. If so, substitute
4534 : in the parameter expressions for the bounds and set the pdt_array
4535 : attribute. Notice that this attribute must be unconditionally set
4536 : if this is an array of parameterized character length. */
4537 2039 : if (c1->as && c1->as->type == AS_EXPLICIT)
4538 : {
4539 : bool pdt_array = false;
4540 910 : bool all_constant = true;
4541 :
4542 : /* Are the bounds of the array parameterized? */
4543 910 : for (i = 0; i < c1->as->rank; i++)
4544 : {
4545 503 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4546 12 : pdt_array = true;
4547 503 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4548 411 : pdt_array = true;
4549 : }
4550 :
4551 : /* If they are, free the expressions for the bounds and
4552 : replace them with the template expressions with substitute
4553 : values. */
4554 824 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4555 : {
4556 417 : gfc_expr *e;
4557 417 : e = gfc_copy_expr (c1->as->lower[i]);
4558 417 : gfc_insert_kind_parameter_exprs (e);
4559 417 : if (gfc_simplify_expr (e, 1))
4560 417 : gfc_replace_expr (c2->as->lower[i], e);
4561 : else
4562 0 : gfc_free_expr (e);
4563 417 : if (c2->as->lower[i]->expr_type != EXPR_CONSTANT)
4564 12 : all_constant = false;
4565 417 : e = gfc_copy_expr (c1->as->upper[i]);
4566 417 : gfc_insert_kind_parameter_exprs (e);
4567 417 : if (gfc_simplify_expr (e, 1))
4568 417 : gfc_replace_expr (c2->as->upper[i], e);
4569 : else
4570 0 : gfc_free_expr (e);
4571 417 : if (c2->as->upper[i]->expr_type != EXPR_CONSTANT)
4572 409 : all_constant = false;
4573 : }
4574 :
4575 407 : c2->attr.pdt_array = all_constant ? 0 : 1;
4576 407 : if (c1->initializer)
4577 : {
4578 13 : c2->initializer = gfc_copy_expr (c1->initializer);
4579 13 : gfc_insert_kind_parameter_exprs (c2->initializer);
4580 13 : gfc_simplify_expr (c2->initializer, 1);
4581 : }
4582 : }
4583 :
4584 : /* Similarly, set the string length if parameterized. */
4585 2039 : if (c1->ts.type == BT_CHARACTER
4586 189 : && c1->ts.u.cl->length
4587 2227 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4588 : {
4589 152 : gfc_expr *e;
4590 152 : e = gfc_copy_expr (c1->ts.u.cl->length);
4591 152 : gfc_insert_kind_parameter_exprs (e);
4592 152 : if (gfc_simplify_expr (e, 1))
4593 152 : gfc_replace_expr (c2->ts.u.cl->length, e);
4594 : else
4595 0 : gfc_free_expr (e);
4596 152 : if (c2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4597 149 : c2->attr.pdt_string = 1;
4598 152 : if (c1->as && c1->as->type == AS_EXPLICIT)
4599 48 : c2->attr.pdt_array = 1;
4600 104 : else if (c1->attr.allocatable)
4601 6 : c2->ts.deferred = 1;
4602 : }
4603 :
4604 : /* Recurse into this function for PDT components. */
4605 2039 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4606 143 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4607 : {
4608 129 : gfc_actual_arglist *params;
4609 : /* The component in the template has a list of specification
4610 : expressions derived from its declaration. */
4611 129 : params = gfc_copy_actual_arglist (c1->param_list);
4612 129 : actual_param = params;
4613 : /* Substitute the template parameters with the expressions
4614 : from the specification list. */
4615 402 : for (;actual_param; actual_param = actual_param->next)
4616 : {
4617 144 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4618 144 : gfc_insert_parameter_exprs (actual_param->expr,
4619 : type_param_spec_list);
4620 : }
4621 :
4622 : /* Now obtain the PDT instance for the component. */
4623 129 : old_param_spec_list = type_param_spec_list;
4624 258 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4625 129 : &c2->param_list);
4626 129 : type_param_spec_list = old_param_spec_list;
4627 :
4628 129 : if (!(c2->attr.pointer || c2->attr.allocatable))
4629 : {
4630 83 : if (!c1->initializer
4631 58 : || c1->initializer->expr_type != EXPR_FUNCTION)
4632 82 : c2->initializer = gfc_default_initializer (&c2->ts);
4633 : else
4634 : {
4635 1 : gfc_symtree *s;
4636 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4637 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4638 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4639 1 : if (s)
4640 0 : c2->initializer->symtree = s;
4641 1 : c2->initializer->ts = c2->ts;
4642 1 : if (!s)
4643 1 : gfc_insert_parameter_exprs (c2->initializer,
4644 : type_param_spec_list);
4645 1 : gfc_simplify_expr (c2->initializer, 1);
4646 : }
4647 : }
4648 :
4649 129 : if (c2->attr.allocatable
4650 91 : || (c2->ts.type == BT_DERIVED && c2->ts.u.derived
4651 91 : && c2->ts.u.derived->attr.alloc_comp && !c2->attr.pointer))
4652 67 : instance->attr.alloc_comp = 1;
4653 : }
4654 1910 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4655 767 : || c2->attr.pdt_array) && c1->initializer)
4656 : {
4657 74 : c2->initializer = gfc_copy_expr (c1->initializer);
4658 74 : if (c2->initializer->ts.type == BT_UNKNOWN)
4659 18 : c2->initializer->ts = c2->ts;
4660 74 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4661 : /* The template initializers are parsed using gfc_match_expr rather
4662 : than gfc_match_init_expr. Apply the missing reduction to the
4663 : PDT instance initializers. */
4664 74 : if (!gfc_reduce_init_expr (c2->initializer))
4665 : {
4666 0 : gfc_free_expr (c2->initializer);
4667 0 : goto error_return;
4668 : }
4669 74 : gfc_simplify_expr (c2->initializer, 1);
4670 : }
4671 :
4672 : /* Pick up any remaining initializers that could be simplified. */
4673 2039 : if (c1->initializer)
4674 : {
4675 655 : if (!c2->initializer)
4676 31 : c2->initializer = gfc_copy_expr (c1->initializer);
4677 655 : if (gfc_derived_parameter_expr (c2->initializer))
4678 0 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4679 655 : c2->initializer->ts = c2->ts;
4680 655 : if (!gfc_is_constant_expr (c2->initializer))
4681 19 : gfc_simplify_expr (c2->initializer, 1);
4682 : }
4683 : }
4684 :
4685 747 : if (alloc_seen)
4686 91 : instance->attr.alloc_comp = 1;
4687 747 : if (ptr_seen)
4688 20 : instance->attr.pointer_comp = 1;
4689 :
4690 747 : gfc_set_sym_referenced (instance);
4691 747 : gfc_commit_symbol (instance);
4692 :
4693 747 : if (ext_param_list)
4694 486 : *ext_param_list = type_param_spec_list;
4695 747 : *sym = instance;
4696 747 : free (name);
4697 747 : return m;
4698 :
4699 72 : error_return:
4700 72 : gfc_free_actual_arglist (type_param_spec_list);
4701 72 : free (name);
4702 72 : return MATCH_ERROR;
4703 : }
4704 :
4705 :
4706 : /* Match a legacy nonstandard BYTE type-spec. */
4707 :
4708 : static match
4709 1211978 : match_byte_typespec (gfc_typespec *ts)
4710 : {
4711 1211978 : if (gfc_match (" byte") == MATCH_YES)
4712 : {
4713 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4714 : return MATCH_ERROR;
4715 :
4716 31 : if (gfc_current_form == FORM_FREE)
4717 : {
4718 19 : char c = gfc_peek_ascii_char ();
4719 19 : if (!gfc_is_whitespace (c) && c != ',')
4720 : return MATCH_NO;
4721 : }
4722 :
4723 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4724 : {
4725 0 : gfc_error ("BYTE type used at %C "
4726 : "is not available on the target machine");
4727 0 : return MATCH_ERROR;
4728 : }
4729 :
4730 29 : ts->type = BT_INTEGER;
4731 29 : ts->kind = 1;
4732 29 : return MATCH_YES;
4733 : }
4734 : return MATCH_NO;
4735 : }
4736 :
4737 :
4738 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4739 : structure to the matched specification. This is necessary for FUNCTION and
4740 : IMPLICIT statements.
4741 :
4742 : If implicit_flag is nonzero, then we don't check for the optional
4743 : kind specification. Not doing so is needed for matching an IMPLICIT
4744 : statement correctly. */
4745 :
4746 : match
4747 1211978 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4748 : {
4749 : /* Provide sufficient space to hold "pdtsymbol". */
4750 1211978 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4751 1211978 : gfc_symbol *sym, *dt_sym;
4752 1211978 : match m;
4753 1211978 : char c;
4754 1211978 : bool seen_deferred_kind, matched_type;
4755 1211978 : const char *dt_name;
4756 :
4757 1211978 : decl_type_param_list = NULL;
4758 :
4759 : /* A belt and braces check that the typespec is correctly being treated
4760 : as a deferred characteristic association. */
4761 2423956 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4762 85340 : && (gfc_current_block ()->result->ts.kind == -1)
4763 1224018 : && (ts->kind == -1);
4764 1211978 : gfc_clear_ts (ts);
4765 1211978 : if (seen_deferred_kind)
4766 9805 : ts->kind = -1;
4767 :
4768 : /* Clear the current binding label, in case one is given. */
4769 1211978 : curr_binding_label = NULL;
4770 :
4771 : /* Match BYTE type-spec. */
4772 1211978 : m = match_byte_typespec (ts);
4773 1211978 : if (m != MATCH_NO)
4774 : return m;
4775 :
4776 1211947 : m = gfc_match (" type (");
4777 1211947 : matched_type = (m == MATCH_YES);
4778 1211947 : if (matched_type)
4779 : {
4780 32412 : gfc_gobble_whitespace ();
4781 32412 : if (gfc_peek_ascii_char () == '*')
4782 : {
4783 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4784 : return m;
4785 5617 : if (gfc_comp_struct (gfc_current_state ()))
4786 : {
4787 2 : gfc_error ("Assumed type at %C is not allowed for components");
4788 2 : return MATCH_ERROR;
4789 : }
4790 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4791 : return MATCH_ERROR;
4792 5613 : ts->type = BT_ASSUMED;
4793 5613 : return MATCH_YES;
4794 : }
4795 :
4796 26795 : m = gfc_match ("%n", name);
4797 26795 : matched_type = (m == MATCH_YES);
4798 : }
4799 :
4800 26795 : if ((matched_type && strcmp ("integer", name) == 0)
4801 1206330 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4802 : {
4803 114439 : ts->type = BT_INTEGER;
4804 114439 : ts->kind = gfc_default_integer_kind;
4805 114439 : goto get_kind;
4806 : }
4807 :
4808 1091891 : if (flag_unsigned)
4809 : {
4810 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4811 22510 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4812 : {
4813 1036 : ts->type = BT_UNSIGNED;
4814 1036 : ts->kind = gfc_default_integer_kind;
4815 1036 : goto get_kind;
4816 : }
4817 : }
4818 :
4819 26789 : if ((matched_type && strcmp ("character", name) == 0)
4820 1090855 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4821 : {
4822 29586 : if (matched_type
4823 29586 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4824 : "intrinsic-type-spec at %C"))
4825 : return MATCH_ERROR;
4826 :
4827 29585 : ts->type = BT_CHARACTER;
4828 29585 : if (implicit_flag == 0)
4829 29479 : m = gfc_match_char_spec (ts);
4830 : else
4831 : m = MATCH_YES;
4832 :
4833 29585 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4834 : {
4835 1 : gfc_error ("Malformed type-spec at %C");
4836 1 : return MATCH_ERROR;
4837 : }
4838 :
4839 : return m;
4840 : }
4841 :
4842 26785 : if ((matched_type && strcmp ("real", name) == 0)
4843 1061269 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4844 : {
4845 30809 : ts->type = BT_REAL;
4846 30809 : ts->kind = gfc_default_real_kind;
4847 30809 : goto get_kind;
4848 : }
4849 :
4850 1030460 : if ((matched_type
4851 26782 : && (strcmp ("doubleprecision", name) == 0
4852 26781 : || (strcmp ("double", name) == 0
4853 5 : && gfc_match (" precision") == MATCH_YES)))
4854 1030460 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4855 : {
4856 2614 : if (matched_type
4857 2614 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4858 : "intrinsic-type-spec at %C"))
4859 : return MATCH_ERROR;
4860 :
4861 2613 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4862 : {
4863 2 : gfc_error ("Malformed type-spec at %C");
4864 2 : return MATCH_ERROR;
4865 : }
4866 :
4867 2611 : ts->type = BT_REAL;
4868 2611 : ts->kind = gfc_default_double_kind;
4869 2611 : return MATCH_YES;
4870 : }
4871 :
4872 26778 : if ((matched_type && strcmp ("complex", name) == 0)
4873 1027846 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4874 : {
4875 4165 : ts->type = BT_COMPLEX;
4876 4165 : ts->kind = gfc_default_complex_kind;
4877 4165 : goto get_kind;
4878 : }
4879 :
4880 1023681 : if ((matched_type
4881 26778 : && (strcmp ("doublecomplex", name) == 0
4882 26777 : || (strcmp ("double", name) == 0
4883 2 : && gfc_match (" complex") == MATCH_YES)))
4884 1023681 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4885 : {
4886 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4887 : return MATCH_ERROR;
4888 :
4889 203 : if (matched_type
4890 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4891 : "intrinsic-type-spec at %C"))
4892 : return MATCH_ERROR;
4893 :
4894 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4895 : {
4896 2 : gfc_error ("Malformed type-spec at %C");
4897 2 : return MATCH_ERROR;
4898 : }
4899 :
4900 201 : ts->type = BT_COMPLEX;
4901 201 : ts->kind = gfc_default_double_kind;
4902 201 : return MATCH_YES;
4903 : }
4904 :
4905 26775 : if ((matched_type && strcmp ("logical", name) == 0)
4906 1023477 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4907 : {
4908 11670 : ts->type = BT_LOGICAL;
4909 11670 : ts->kind = gfc_default_logical_kind;
4910 11670 : goto get_kind;
4911 : }
4912 :
4913 1011807 : if (matched_type)
4914 : {
4915 26772 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4916 26772 : if (m == MATCH_ERROR)
4917 : return m;
4918 :
4919 26772 : gfc_gobble_whitespace ();
4920 26772 : if (gfc_peek_ascii_char () != ')')
4921 : {
4922 1 : gfc_error ("Malformed type-spec at %C");
4923 1 : return MATCH_ERROR;
4924 : }
4925 26771 : m = gfc_match_char (')'); /* Burn closing ')'. */
4926 : }
4927 :
4928 1011806 : if (m != MATCH_YES)
4929 985035 : m = match_record_decl (name);
4930 :
4931 1011806 : if (matched_type || m == MATCH_YES)
4932 : {
4933 27115 : ts->type = BT_DERIVED;
4934 : /* We accept record/s/ or type(s) where s is a structure, but we
4935 : * don't need all the extra derived-type stuff for structures. */
4936 27115 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4937 : {
4938 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4939 1 : return MATCH_ERROR;
4940 : }
4941 :
4942 27114 : if (sym && sym->attr.flavor == FL_DERIVED
4943 25964 : && sym->attr.pdt_template
4944 1300 : && gfc_current_state () != COMP_DERIVED)
4945 : {
4946 1179 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4947 1179 : if (m != MATCH_YES)
4948 : return m;
4949 1164 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4950 1164 : ts->u.derived = sym;
4951 1164 : const char* lower = gfc_dt_lower_string (sym->name);
4952 1164 : size_t len = strlen (lower);
4953 : /* Reallocate with sufficient size. */
4954 1164 : if (len > GFC_MAX_SYMBOL_LEN)
4955 2 : name = XALLOCAVEC (char, len + 1);
4956 1164 : memcpy (name, lower, len);
4957 1164 : name[len] = '\0';
4958 : }
4959 :
4960 27099 : if (sym && sym->attr.flavor == FL_STRUCT)
4961 : {
4962 361 : ts->u.derived = sym;
4963 361 : return MATCH_YES;
4964 : }
4965 : /* Actually a derived type. */
4966 : }
4967 :
4968 : else
4969 : {
4970 : /* Match nested STRUCTURE declarations; only valid within another
4971 : structure declaration. */
4972 984691 : if (flag_dec_structure
4973 8032 : && (gfc_current_state () == COMP_STRUCTURE
4974 7570 : || gfc_current_state () == COMP_MAP))
4975 : {
4976 732 : m = gfc_match (" structure");
4977 732 : if (m == MATCH_YES)
4978 : {
4979 27 : m = gfc_match_structure_decl ();
4980 27 : if (m == MATCH_YES)
4981 : {
4982 : /* gfc_new_block is updated by match_structure_decl. */
4983 26 : ts->type = BT_DERIVED;
4984 26 : ts->u.derived = gfc_new_block;
4985 26 : return MATCH_YES;
4986 : }
4987 : }
4988 706 : if (m == MATCH_ERROR)
4989 : return MATCH_ERROR;
4990 : }
4991 :
4992 : /* Match CLASS declarations. */
4993 984664 : m = gfc_match (" class ( * )");
4994 984664 : if (m == MATCH_ERROR)
4995 : return MATCH_ERROR;
4996 984664 : else if (m == MATCH_YES)
4997 : {
4998 2081 : gfc_symbol *upe;
4999 2081 : gfc_symtree *st;
5000 2081 : ts->type = BT_CLASS;
5001 2081 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
5002 2081 : if (upe == NULL)
5003 : {
5004 1255 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
5005 1255 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
5006 1255 : st->n.sym = upe;
5007 1255 : gfc_set_sym_referenced (upe);
5008 1255 : upe->refs++;
5009 1255 : upe->ts.type = BT_VOID;
5010 1255 : upe->attr.unlimited_polymorphic = 1;
5011 : /* This is essential to force the construction of
5012 : unlimited polymorphic component class containers. */
5013 1255 : upe->attr.zero_comp = 1;
5014 1255 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
5015 : &gfc_current_locus))
5016 : return MATCH_ERROR;
5017 : }
5018 : else
5019 : {
5020 826 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
5021 826 : st->n.sym = upe;
5022 826 : upe->refs++;
5023 : }
5024 2081 : ts->u.derived = upe;
5025 2081 : return m;
5026 : }
5027 :
5028 982583 : m = gfc_match (" class (");
5029 :
5030 982583 : if (m == MATCH_YES)
5031 9292 : m = gfc_match ("%n", name);
5032 : else
5033 : return m;
5034 :
5035 9292 : if (m != MATCH_YES)
5036 : return m;
5037 9292 : ts->type = BT_CLASS;
5038 :
5039 9292 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
5040 : return MATCH_ERROR;
5041 :
5042 9291 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
5043 9291 : if (m == MATCH_ERROR)
5044 : return m;
5045 :
5046 9291 : m = gfc_match_char (')');
5047 9291 : if (m != MATCH_YES)
5048 : return m;
5049 : }
5050 :
5051 : /* This picks up function declarations with a PDT typespec. Since a
5052 : pdt_type has been generated, there is no more to do. Within the
5053 : function body, this type must be used for the typespec so that
5054 : the "being used before it is defined warning" does not arise. */
5055 36029 : if (ts->type == BT_DERIVED
5056 26738 : && sym && sym->attr.pdt_type
5057 37193 : && (gfc_current_state () == COMP_CONTAINS
5058 1148 : || (gfc_current_state () == COMP_FUNCTION
5059 292 : && gfc_current_block ()->ts.type == BT_DERIVED
5060 60 : && gfc_current_block ()->ts.u.derived == sym
5061 30 : && !gfc_find_symtree (gfc_current_ns->sym_root,
5062 : sym->name))))
5063 : {
5064 42 : if (gfc_current_state () == COMP_FUNCTION)
5065 : {
5066 26 : gfc_symtree *pdt_st;
5067 26 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
5068 : sym->name);
5069 26 : pdt_st->n.sym = sym;
5070 26 : sym->refs++;
5071 : }
5072 42 : ts->u.derived = sym;
5073 42 : return MATCH_YES;
5074 : }
5075 :
5076 : /* Defer association of the derived type until the end of the
5077 : specification block. However, if the derived type can be
5078 : found, add it to the typespec. */
5079 35987 : if (gfc_matching_function)
5080 : {
5081 1044 : ts->u.derived = NULL;
5082 1044 : if (gfc_current_state () != COMP_INTERFACE
5083 1044 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
5084 : {
5085 513 : sym = gfc_find_dt_in_generic (sym);
5086 513 : ts->u.derived = sym;
5087 : }
5088 : return MATCH_YES;
5089 : }
5090 :
5091 : /* Search for the name but allow the components to be defined later. If
5092 : type = -1, this typespec has been seen in a function declaration but
5093 : the type could not be accessed at that point. The actual derived type is
5094 : stored in a symtree with the first letter of the name capitalized; the
5095 : symtree with the all lower-case name contains the associated
5096 : generic function. */
5097 34943 : dt_name = gfc_dt_upper_string (name);
5098 34943 : sym = NULL;
5099 34943 : dt_sym = NULL;
5100 34943 : if (ts->kind != -1)
5101 : {
5102 33730 : gfc_get_ha_symbol (name, &sym);
5103 33730 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
5104 : {
5105 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5106 0 : return MATCH_ERROR;
5107 : }
5108 33730 : if (sym->generic && !dt_sym)
5109 14660 : dt_sym = gfc_find_dt_in_generic (sym);
5110 :
5111 : /* Host associated PDTs can get confused with their constructors
5112 : because they are instantiated in the template's namespace. */
5113 33730 : if (!dt_sym)
5114 : {
5115 1226 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5116 : {
5117 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5118 0 : return MATCH_ERROR;
5119 : }
5120 1226 : if (dt_sym && !dt_sym->attr.pdt_type)
5121 0 : dt_sym = NULL;
5122 : }
5123 : }
5124 1213 : else if (ts->kind == -1)
5125 : {
5126 2426 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
5127 1213 : || gfc_current_ns->has_import_set;
5128 1213 : gfc_find_symbol (name, NULL, iface, &sym);
5129 1213 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5130 : {
5131 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5132 0 : return MATCH_ERROR;
5133 : }
5134 1213 : if (sym && sym->generic && !dt_sym)
5135 2 : dt_sym = gfc_find_dt_in_generic (sym);
5136 :
5137 1213 : ts->kind = 0;
5138 1213 : if (sym == NULL)
5139 : return MATCH_NO;
5140 : }
5141 :
5142 34926 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
5143 33964 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
5144 34924 : || sym->attr.subroutine)
5145 : {
5146 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
5147 : "entity at %L, which has the same name", name,
5148 : &sym->declared_at);
5149 2 : return MATCH_ERROR;
5150 : }
5151 :
5152 34924 : if (dt_sym && decl_type_param_list
5153 1198 : && dt_sym->attr.flavor == FL_DERIVED
5154 1198 : && !dt_sym->attr.pdt_type
5155 262 : && !dt_sym->attr.pdt_template)
5156 : {
5157 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5158 : "list at %C may not appear", dt_sym->name);
5159 1 : return MATCH_ERROR;
5160 : }
5161 :
5162 34923 : if (sym && sym->attr.flavor == FL_DERIVED
5163 : && sym->attr.pdt_template
5164 : && gfc_current_state () != COMP_DERIVED)
5165 : {
5166 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5167 : if (m != MATCH_YES)
5168 : return m;
5169 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5170 : ts->u.derived = sym;
5171 : strcpy (name, gfc_dt_lower_string (sym->name));
5172 : }
5173 :
5174 34923 : gfc_save_symbol_data (sym);
5175 34923 : gfc_set_sym_referenced (sym);
5176 34923 : if (!sym->attr.generic
5177 34923 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5178 : return MATCH_ERROR;
5179 :
5180 34923 : if (!sym->attr.function
5181 34923 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5182 : return MATCH_ERROR;
5183 :
5184 34923 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5185 34791 : && dt_sym->attr.pdt_template
5186 272 : && gfc_current_state () != COMP_DERIVED)
5187 : {
5188 139 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5189 139 : if (m != MATCH_YES)
5190 : return m;
5191 139 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5192 : }
5193 :
5194 34923 : if (!dt_sym)
5195 : {
5196 132 : gfc_interface *intr, *head;
5197 :
5198 : /* Use upper case to save the actual derived-type symbol. */
5199 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5200 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5201 132 : head = sym->generic;
5202 132 : intr = gfc_get_interface ();
5203 132 : intr->sym = dt_sym;
5204 132 : intr->where = gfc_current_locus;
5205 132 : intr->next = head;
5206 132 : sym->generic = intr;
5207 132 : sym->attr.if_source = IFSRC_DECL;
5208 : }
5209 : else
5210 34791 : gfc_save_symbol_data (dt_sym);
5211 :
5212 34923 : gfc_set_sym_referenced (dt_sym);
5213 :
5214 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5215 35055 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5216 : return MATCH_ERROR;
5217 :
5218 34923 : ts->u.derived = dt_sym;
5219 :
5220 34923 : return MATCH_YES;
5221 :
5222 162119 : get_kind:
5223 162119 : if (matched_type
5224 162119 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5225 : "intrinsic-type-spec at %C"))
5226 : return MATCH_ERROR;
5227 :
5228 : /* For all types except double, derived and character, look for an
5229 : optional kind specifier. MATCH_NO is actually OK at this point. */
5230 162116 : if (implicit_flag == 1)
5231 : {
5232 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5233 : return MATCH_ERROR;
5234 :
5235 : return MATCH_YES;
5236 : }
5237 :
5238 161893 : if (gfc_current_form == FORM_FREE)
5239 : {
5240 146678 : c = gfc_peek_ascii_char ();
5241 146678 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5242 72545 : && c != ':' && c != ',')
5243 : {
5244 167 : if (matched_type && c == ')')
5245 : {
5246 3 : gfc_next_ascii_char ();
5247 3 : return MATCH_YES;
5248 : }
5249 164 : gfc_error ("Malformed type-spec at %C");
5250 164 : return MATCH_NO;
5251 : }
5252 : }
5253 :
5254 161726 : m = gfc_match_kind_spec (ts, false);
5255 161726 : if (m == MATCH_ERROR)
5256 : return MATCH_ERROR;
5257 :
5258 161690 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5259 : {
5260 110038 : m = gfc_match_old_kind_spec (ts);
5261 110038 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5262 : return MATCH_ERROR;
5263 : }
5264 :
5265 161682 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5266 : {
5267 0 : gfc_error ("Malformed type-spec at %C");
5268 0 : return MATCH_ERROR;
5269 : }
5270 :
5271 : /* Defer association of the KIND expression of function results
5272 : until after USE and IMPORT statements. */
5273 4454 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5274 166109 : || gfc_matching_function)
5275 : return MATCH_YES;
5276 :
5277 154310 : if (m == MATCH_NO)
5278 155705 : m = MATCH_YES; /* No kind specifier found. */
5279 :
5280 : return m;
5281 : }
5282 :
5283 :
5284 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5285 : already matched in parse.cc, or we would not end up here in the
5286 : first place. So the only thing we need to check, is if there is
5287 : trailing garbage. If not, the match is successful. */
5288 :
5289 : match
5290 24611 : gfc_match_implicit_none (void)
5291 : {
5292 24611 : char c;
5293 24611 : match m;
5294 24611 : char name[GFC_MAX_SYMBOL_LEN + 1];
5295 24611 : bool type = false;
5296 24611 : bool external = false;
5297 24611 : locus cur_loc = gfc_current_locus;
5298 :
5299 24611 : if (gfc_current_ns->seen_implicit_none
5300 24609 : || gfc_current_ns->has_implicit_none_export)
5301 : {
5302 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5303 4 : return MATCH_ERROR;
5304 : }
5305 :
5306 24607 : gfc_gobble_whitespace ();
5307 24607 : c = gfc_peek_ascii_char ();
5308 24607 : if (c == '(')
5309 : {
5310 1109 : (void) gfc_next_ascii_char ();
5311 1109 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5312 : return MATCH_ERROR;
5313 :
5314 1108 : gfc_gobble_whitespace ();
5315 1108 : if (gfc_peek_ascii_char () == ')')
5316 : {
5317 1 : (void) gfc_next_ascii_char ();
5318 1 : type = true;
5319 : }
5320 : else
5321 3297 : for(;;)
5322 : {
5323 2202 : m = gfc_match (" %n", name);
5324 2202 : if (m != MATCH_YES)
5325 : return MATCH_ERROR;
5326 :
5327 2202 : if (strcmp (name, "type") == 0)
5328 : type = true;
5329 1107 : else if (strcmp (name, "external") == 0)
5330 : external = true;
5331 : else
5332 : return MATCH_ERROR;
5333 :
5334 2202 : gfc_gobble_whitespace ();
5335 2202 : c = gfc_next_ascii_char ();
5336 2202 : if (c == ',')
5337 1095 : continue;
5338 1107 : if (c == ')')
5339 : break;
5340 : return MATCH_ERROR;
5341 : }
5342 : }
5343 : else
5344 : type = true;
5345 :
5346 24606 : if (gfc_match_eos () != MATCH_YES)
5347 : return MATCH_ERROR;
5348 :
5349 24606 : gfc_set_implicit_none (type, external, &cur_loc);
5350 :
5351 24606 : return MATCH_YES;
5352 : }
5353 :
5354 :
5355 : /* Match the letter range(s) of an IMPLICIT statement. */
5356 :
5357 : static match
5358 600 : match_implicit_range (void)
5359 : {
5360 600 : char c, c1, c2;
5361 600 : int inner;
5362 600 : locus cur_loc;
5363 :
5364 600 : cur_loc = gfc_current_locus;
5365 :
5366 600 : gfc_gobble_whitespace ();
5367 600 : c = gfc_next_ascii_char ();
5368 600 : if (c != '(')
5369 : {
5370 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5371 59 : goto bad;
5372 : }
5373 :
5374 : inner = 1;
5375 1195 : while (inner)
5376 : {
5377 722 : gfc_gobble_whitespace ();
5378 722 : c1 = gfc_next_ascii_char ();
5379 722 : if (!ISALPHA (c1))
5380 33 : goto bad;
5381 :
5382 689 : gfc_gobble_whitespace ();
5383 689 : c = gfc_next_ascii_char ();
5384 :
5385 689 : switch (c)
5386 : {
5387 201 : case ')':
5388 201 : inner = 0; /* Fall through. */
5389 :
5390 : case ',':
5391 : c2 = c1;
5392 : break;
5393 :
5394 439 : case '-':
5395 439 : gfc_gobble_whitespace ();
5396 439 : c2 = gfc_next_ascii_char ();
5397 439 : if (!ISALPHA (c2))
5398 0 : goto bad;
5399 :
5400 439 : gfc_gobble_whitespace ();
5401 439 : c = gfc_next_ascii_char ();
5402 :
5403 439 : if ((c != ',') && (c != ')'))
5404 0 : goto bad;
5405 439 : if (c == ')')
5406 272 : inner = 0;
5407 :
5408 : break;
5409 :
5410 35 : default:
5411 35 : goto bad;
5412 : }
5413 :
5414 654 : if (c1 > c2)
5415 : {
5416 0 : gfc_error ("Letters must be in alphabetic order in "
5417 : "IMPLICIT statement at %C");
5418 0 : goto bad;
5419 : }
5420 :
5421 : /* See if we can add the newly matched range to the pending
5422 : implicits from this IMPLICIT statement. We do not check for
5423 : conflicts with whatever earlier IMPLICIT statements may have
5424 : set. This is done when we've successfully finished matching
5425 : the current one. */
5426 654 : if (!gfc_add_new_implicit_range (c1, c2))
5427 0 : goto bad;
5428 : }
5429 :
5430 : return MATCH_YES;
5431 :
5432 127 : bad:
5433 127 : gfc_syntax_error (ST_IMPLICIT);
5434 :
5435 127 : gfc_current_locus = cur_loc;
5436 127 : return MATCH_ERROR;
5437 : }
5438 :
5439 :
5440 : /* Match an IMPLICIT statement, storing the types for
5441 : gfc_set_implicit() if the statement is accepted by the parser.
5442 : There is a strange looking, but legal syntactic construction
5443 : possible. It looks like:
5444 :
5445 : IMPLICIT INTEGER (a-b) (c-d)
5446 :
5447 : This is legal if "a-b" is a constant expression that happens to
5448 : equal one of the legal kinds for integers. The real problem
5449 : happens with an implicit specification that looks like:
5450 :
5451 : IMPLICIT INTEGER (a-b)
5452 :
5453 : In this case, a typespec matcher that is "greedy" (as most of the
5454 : matchers are) gobbles the character range as a kindspec, leaving
5455 : nothing left. We therefore have to go a bit more slowly in the
5456 : matching process by inhibiting the kindspec checking during
5457 : typespec matching and checking for a kind later. */
5458 :
5459 : match
5460 25037 : gfc_match_implicit (void)
5461 : {
5462 25037 : gfc_typespec ts;
5463 25037 : locus cur_loc;
5464 25037 : char c;
5465 25037 : match m;
5466 :
5467 25037 : if (gfc_current_ns->seen_implicit_none)
5468 : {
5469 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5470 : "statement");
5471 4 : return MATCH_ERROR;
5472 : }
5473 :
5474 25033 : gfc_clear_ts (&ts);
5475 :
5476 : /* We don't allow empty implicit statements. */
5477 25033 : if (gfc_match_eos () == MATCH_YES)
5478 : {
5479 0 : gfc_error ("Empty IMPLICIT statement at %C");
5480 0 : return MATCH_ERROR;
5481 : }
5482 :
5483 25062 : do
5484 : {
5485 : /* First cleanup. */
5486 25062 : gfc_clear_new_implicit ();
5487 :
5488 : /* A basic type is mandatory here. */
5489 25062 : m = gfc_match_decl_type_spec (&ts, 1);
5490 25062 : if (m == MATCH_ERROR)
5491 0 : goto error;
5492 25062 : if (m == MATCH_NO)
5493 24609 : goto syntax;
5494 :
5495 453 : cur_loc = gfc_current_locus;
5496 453 : m = match_implicit_range ();
5497 :
5498 453 : if (m == MATCH_YES)
5499 : {
5500 : /* We may have <TYPE> (<RANGE>). */
5501 326 : gfc_gobble_whitespace ();
5502 326 : c = gfc_peek_ascii_char ();
5503 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5504 : {
5505 : /* Check for CHARACTER with no length parameter. */
5506 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5507 : {
5508 32 : ts.kind = gfc_default_character_kind;
5509 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5510 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5511 : NULL, 1);
5512 : }
5513 :
5514 : /* Record the Successful match. */
5515 299 : if (!gfc_merge_new_implicit (&ts))
5516 : return MATCH_ERROR;
5517 297 : if (c == ',')
5518 28 : c = gfc_next_ascii_char ();
5519 269 : else if (gfc_match_eos () == MATCH_ERROR)
5520 0 : goto error;
5521 297 : continue;
5522 : }
5523 :
5524 27 : gfc_current_locus = cur_loc;
5525 : }
5526 :
5527 : /* Discard the (incorrectly) matched range. */
5528 154 : gfc_clear_new_implicit ();
5529 :
5530 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5531 154 : if (ts.type == BT_CHARACTER)
5532 74 : m = gfc_match_char_spec (&ts);
5533 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5534 : {
5535 76 : m = gfc_match_kind_spec (&ts, false);
5536 76 : if (m == MATCH_NO)
5537 : {
5538 40 : m = gfc_match_old_kind_spec (&ts);
5539 40 : if (m == MATCH_ERROR)
5540 0 : goto error;
5541 40 : if (m == MATCH_NO)
5542 0 : goto syntax;
5543 : }
5544 : }
5545 154 : if (m == MATCH_ERROR)
5546 7 : goto error;
5547 :
5548 147 : m = match_implicit_range ();
5549 147 : if (m == MATCH_ERROR)
5550 0 : goto error;
5551 147 : if (m == MATCH_NO)
5552 : goto syntax;
5553 :
5554 147 : gfc_gobble_whitespace ();
5555 147 : c = gfc_next_ascii_char ();
5556 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5557 0 : goto syntax;
5558 :
5559 147 : if (!gfc_merge_new_implicit (&ts))
5560 : return MATCH_ERROR;
5561 : }
5562 444 : while (c == ',');
5563 :
5564 : return MATCH_YES;
5565 :
5566 24609 : syntax:
5567 24609 : gfc_syntax_error (ST_IMPLICIT);
5568 :
5569 25037 : error:
5570 : return MATCH_ERROR;
5571 : }
5572 :
5573 :
5574 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5575 :
5576 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5577 :
5578 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5579 :
5580 : C1211 (R1209) Each import-name shall be the name of an entity in the
5581 : host scoping unit.
5582 :
5583 : under the description of an interface block. Under F2008, IMPORT was
5584 : split out of the interface block description to 12.4.3.3 and C1210
5585 : became
5586 :
5587 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5588 : that is not a module procedure interface body.
5589 :
5590 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5591 :
5592 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5593 : or IMPORT, ONLY : import-name-list
5594 : or IMPORT, NONE
5595 : or IMPORT, ALL
5596 :
5597 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5598 : a main-program, external-subprogram, module, or block-data.
5599 :
5600 : C897 (R867) Each import-name shall be the name of an entity in the host
5601 : scoping unit.
5602 :
5603 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5604 : all IMPORT statements in that scoping unit shall have an ONLY
5605 : specifier.
5606 :
5607 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5608 :
5609 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5610 : unit, no other IMPORT statement shall appear in that scoping unit.
5611 :
5612 : C8101 Within an interface body, an entity that is accessed by host
5613 : association shall be accessible by host or use association within
5614 : the host scoping unit, or explicitly declared prior to the interface
5615 : body.
5616 :
5617 : C8102 An entity whose name appears as an import-name or which is made
5618 : accessible by an IMPORT, ALL statement shall not appear in any
5619 : context described in 19.5.1.4 that would cause the host entity
5620 : of that name to be inaccessible. */
5621 :
5622 : match
5623 4044 : gfc_match_import (void)
5624 : {
5625 4044 : char name[GFC_MAX_SYMBOL_LEN + 1];
5626 4044 : match m;
5627 4044 : gfc_symbol *sym;
5628 4044 : gfc_symtree *st;
5629 4044 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5630 4044 : importstate current_import_state = gfc_current_ns->import_state;
5631 :
5632 4044 : if (!f2018_allowed
5633 13 : && (gfc_current_ns->proc_name == NULL
5634 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5635 : {
5636 3 : gfc_error ("IMPORT statement at %C only permitted in "
5637 : "an INTERFACE body");
5638 3 : return MATCH_ERROR;
5639 : }
5640 : else if (f2018_allowed
5641 4031 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5642 4 : goto C897;
5643 :
5644 4027 : if (f2018_allowed
5645 4027 : && (current_import_state == IMPORT_ALL
5646 4027 : || current_import_state == IMPORT_NONE))
5647 2 : goto C8100;
5648 :
5649 4035 : if (gfc_current_ns->proc_name
5650 4034 : && gfc_current_ns->proc_name->attr.module_procedure)
5651 : {
5652 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5653 : "in a module procedure interface body");
5654 1 : return MATCH_ERROR;
5655 : }
5656 :
5657 4034 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5658 : return MATCH_ERROR;
5659 :
5660 4030 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5661 4030 : if (f2018_allowed)
5662 : {
5663 4024 : if (gfc_match (" , none") == MATCH_YES)
5664 : {
5665 8 : if (current_import_state == IMPORT_ONLY)
5666 0 : goto C898;
5667 8 : if (gfc_current_state () == COMP_SUBMODULE)
5668 0 : goto C899;
5669 8 : gfc_current_ns->import_state = IMPORT_NONE;
5670 : }
5671 4016 : else if (gfc_match (" , only :") == MATCH_YES)
5672 : {
5673 19 : if (current_import_state != IMPORT_NOT_SET
5674 19 : && current_import_state != IMPORT_ONLY)
5675 0 : goto C898;
5676 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5677 : }
5678 3997 : else if (gfc_match (" , all") == MATCH_YES)
5679 : {
5680 1 : if (current_import_state == IMPORT_ONLY)
5681 0 : goto C898;
5682 1 : gfc_current_ns->import_state = IMPORT_ALL;
5683 : }
5684 :
5685 4024 : if (current_import_state != IMPORT_NOT_SET
5686 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5687 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5688 0 : goto C8100;
5689 : }
5690 :
5691 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5692 4030 : if (gfc_match_eos () == MATCH_YES)
5693 : {
5694 : /* This is the F2008 variant. */
5695 340 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5696 : {
5697 331 : if (current_import_state == IMPORT_ONLY)
5698 0 : goto C898;
5699 331 : gfc_current_ns->import_state = IMPORT_F2008;
5700 : }
5701 :
5702 : /* Host variables should be imported. */
5703 340 : if (gfc_current_ns->import_state != IMPORT_NONE)
5704 332 : gfc_current_ns->has_import_set = 1;
5705 : return MATCH_YES;
5706 : }
5707 :
5708 3690 : if (gfc_match (" ::") == MATCH_YES
5709 3690 : && gfc_current_ns->import_state != IMPORT_ONLY)
5710 : {
5711 1182 : if (gfc_match_eos () == MATCH_YES)
5712 1 : goto expecting_list;
5713 1181 : gfc_current_ns->import_state = IMPORT_F2008;
5714 : }
5715 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5716 : {
5717 19 : if (gfc_match_eos () == MATCH_YES)
5718 0 : goto expecting_list;
5719 : }
5720 :
5721 4384 : for(;;)
5722 : {
5723 4384 : sym = NULL;
5724 4384 : m = gfc_match (" %n", name);
5725 4384 : switch (m)
5726 : {
5727 4384 : case MATCH_YES:
5728 : /* Before checking if the symbol is available from host
5729 : association into a SUBROUTINE or FUNCTION within an
5730 : INTERFACE, check if it is already in local scope. */
5731 4384 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5732 4384 : if (sym
5733 25 : && gfc_state_stack->previous
5734 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5735 : {
5736 2 : gfc_error ("import-name %qs at %C is in the "
5737 : "local scope", name);
5738 2 : return MATCH_ERROR;
5739 : }
5740 :
5741 4382 : if (gfc_current_ns->parent != NULL
5742 4382 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5743 : {
5744 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5745 0 : return MATCH_ERROR;
5746 : }
5747 4382 : else if (!sym
5748 5 : && gfc_current_ns->proc_name
5749 4 : && gfc_current_ns->proc_name->ns->parent
5750 4383 : && gfc_find_symbol (name,
5751 : gfc_current_ns->proc_name->ns->parent,
5752 : 1, &sym))
5753 : {
5754 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5755 0 : return MATCH_ERROR;
5756 : }
5757 :
5758 4382 : if (sym == NULL)
5759 : {
5760 5 : if (gfc_current_ns->proc_name
5761 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5762 : {
5763 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5764 : "at %C - does not exist.", name);
5765 1 : return MATCH_ERROR;
5766 : }
5767 : else
5768 : {
5769 : /* This might be a procedure that has not yet been parsed. If
5770 : so gfc_fixup_sibling_symbols will replace this symbol with
5771 : that of the procedure. */
5772 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5773 : &gfc_current_locus);
5774 4 : st->n.sym->refs++;
5775 4 : st->n.sym->attr.imported = 1;
5776 4 : st->import_only = 1;
5777 4 : goto next_item;
5778 : }
5779 : }
5780 :
5781 4377 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5782 4377 : if (st && st->n.sym && st->n.sym->attr.imported)
5783 : {
5784 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5785 : "at %C", name);
5786 0 : goto next_item;
5787 : }
5788 :
5789 4377 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5790 4377 : st->n.sym = sym;
5791 4377 : sym->refs++;
5792 4377 : sym->attr.imported = 1;
5793 4377 : st->import_only = 1;
5794 :
5795 4377 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5796 : {
5797 : /* The actual derived type is stored in a symtree with the first
5798 : letter of the name capitalized; the symtree with the all
5799 : lower-case name contains the associated generic function. */
5800 605 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5801 : gfc_dt_upper_string (name));
5802 605 : st->n.sym = sym;
5803 605 : sym->refs++;
5804 605 : sym->attr.imported = 1;
5805 605 : st->import_only = 1;
5806 : }
5807 :
5808 4377 : goto next_item;
5809 :
5810 : case MATCH_NO:
5811 : break;
5812 :
5813 : case MATCH_ERROR:
5814 : return MATCH_ERROR;
5815 : }
5816 :
5817 4381 : next_item:
5818 4381 : if (gfc_match_eos () == MATCH_YES)
5819 : break;
5820 695 : if (gfc_match_char (',') != MATCH_YES)
5821 0 : goto syntax;
5822 : }
5823 :
5824 : return MATCH_YES;
5825 :
5826 0 : syntax:
5827 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5828 0 : return MATCH_ERROR;
5829 :
5830 4 : C897:
5831 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5832 : "program, an external subprogram, a module or block data");
5833 4 : return MATCH_ERROR;
5834 :
5835 0 : C898:
5836 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5837 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5838 : "with an ONLY specifier");
5839 0 : return MATCH_ERROR;
5840 :
5841 0 : C899:
5842 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5843 : " of a submodule as at %C");
5844 0 : return MATCH_ERROR;
5845 :
5846 2 : C8100:
5847 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5848 : "%s has already been declared, which must be unique in the "
5849 : "scoping unit",
5850 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5851 : "IMPORT, NONE");
5852 2 : return MATCH_ERROR;
5853 :
5854 1 : expecting_list:
5855 1 : gfc_error ("Expecting list of named entities at %C");
5856 1 : return MATCH_ERROR;
5857 : }
5858 :
5859 :
5860 : /* A minimal implementation of gfc_match without whitespace, escape
5861 : characters or variable arguments. Returns true if the next
5862 : characters match the TARGET template exactly. */
5863 :
5864 : static bool
5865 150365 : match_string_p (const char *target)
5866 : {
5867 150365 : const char *p;
5868 :
5869 942594 : for (p = target; *p; p++)
5870 792230 : if ((char) gfc_next_ascii_char () != *p)
5871 : return false;
5872 : return true;
5873 : }
5874 :
5875 : /* Matches an attribute specification including array specs. If
5876 : successful, leaves the variables current_attr and current_as
5877 : holding the specification. Also sets the colon_seen variable for
5878 : later use by matchers associated with initializations.
5879 :
5880 : This subroutine is a little tricky in the sense that we don't know
5881 : if we really have an attr-spec until we hit the double colon.
5882 : Until that time, we can only return MATCH_NO. This forces us to
5883 : check for duplicate specification at this level. */
5884 :
5885 : static match
5886 222051 : match_attr_spec (void)
5887 : {
5888 : /* Modifiers that can exist in a type statement. */
5889 222051 : enum
5890 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5891 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5892 : DECL_DIMENSION, DECL_EXTERNAL,
5893 : DECL_INTRINSIC, DECL_OPTIONAL,
5894 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5895 : DECL_STATIC, DECL_AUTOMATIC,
5896 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5897 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5898 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5899 : };
5900 :
5901 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5902 : #define NUM_DECL GFC_DECL_END
5903 :
5904 : /* Make sure that values from sym_intent are safe to be used here. */
5905 222051 : gcc_assert (INTENT_IN > 0);
5906 :
5907 222051 : locus start, seen_at[NUM_DECL];
5908 222051 : int seen[NUM_DECL];
5909 222051 : unsigned int d;
5910 222051 : const char *attr;
5911 222051 : match m;
5912 222051 : bool t;
5913 :
5914 222051 : gfc_clear_attr (¤t_attr);
5915 222051 : start = gfc_current_locus;
5916 :
5917 222051 : current_as = NULL;
5918 222051 : colon_seen = 0;
5919 222051 : attr_seen = 0;
5920 :
5921 : /* See if we get all of the keywords up to the final double colon. */
5922 5995377 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5923 5773326 : seen[d] = 0;
5924 :
5925 343885 : for (;;)
5926 : {
5927 343885 : char ch;
5928 :
5929 343885 : d = DECL_NONE;
5930 343885 : gfc_gobble_whitespace ();
5931 :
5932 343885 : ch = gfc_next_ascii_char ();
5933 343885 : if (ch == ':')
5934 : {
5935 : /* This is the successful exit condition for the loop. */
5936 188196 : if (gfc_next_ascii_char () == ':')
5937 : break;
5938 : }
5939 155689 : else if (ch == ',')
5940 : {
5941 121846 : gfc_gobble_whitespace ();
5942 121846 : switch (gfc_peek_ascii_char ())
5943 : {
5944 18982 : case 'a':
5945 18982 : gfc_next_ascii_char ();
5946 18982 : switch (gfc_next_ascii_char ())
5947 : {
5948 18911 : case 'l':
5949 18911 : if (match_string_p ("locatable"))
5950 : {
5951 : /* Matched "allocatable". */
5952 : d = DECL_ALLOCATABLE;
5953 : }
5954 : break;
5955 :
5956 30 : case 's':
5957 30 : if (match_string_p ("ynchronous"))
5958 : {
5959 : /* Matched "asynchronous". */
5960 : d = DECL_ASYNCHRONOUS;
5961 : }
5962 : break;
5963 :
5964 41 : case 'u':
5965 41 : if (match_string_p ("tomatic"))
5966 : {
5967 : /* Matched "automatic". */
5968 : d = DECL_AUTOMATIC;
5969 : }
5970 : break;
5971 : }
5972 : break;
5973 :
5974 164 : case 'b':
5975 : /* Try and match the bind(c). */
5976 164 : m = gfc_match_bind_c (NULL, true);
5977 164 : if (m == MATCH_YES)
5978 : d = DECL_IS_BIND_C;
5979 0 : else if (m == MATCH_ERROR)
5980 0 : goto cleanup;
5981 : break;
5982 :
5983 2177 : case 'c':
5984 2177 : gfc_next_ascii_char ();
5985 2177 : if ('o' != gfc_next_ascii_char ())
5986 : break;
5987 2176 : switch (gfc_next_ascii_char ())
5988 : {
5989 68 : case 'd':
5990 68 : if (match_string_p ("imension"))
5991 : {
5992 : d = DECL_CODIMENSION;
5993 : break;
5994 : }
5995 : /* FALLTHRU */
5996 2108 : case 'n':
5997 2108 : if (match_string_p ("tiguous"))
5998 : {
5999 : d = DECL_CONTIGUOUS;
6000 : break;
6001 : }
6002 : }
6003 : break;
6004 :
6005 19760 : case 'd':
6006 19760 : if (match_string_p ("dimension"))
6007 : d = DECL_DIMENSION;
6008 : break;
6009 :
6010 177 : case 'e':
6011 177 : if (match_string_p ("external"))
6012 : d = DECL_EXTERNAL;
6013 : break;
6014 :
6015 28684 : case 'i':
6016 28684 : if (match_string_p ("int"))
6017 : {
6018 28684 : ch = gfc_next_ascii_char ();
6019 28684 : if (ch == 'e')
6020 : {
6021 28678 : if (match_string_p ("nt"))
6022 : {
6023 : /* Matched "intent". */
6024 28677 : d = match_intent_spec ();
6025 28677 : if (d == INTENT_UNKNOWN)
6026 : {
6027 2 : m = MATCH_ERROR;
6028 2 : goto cleanup;
6029 : }
6030 : }
6031 : }
6032 6 : else if (ch == 'r')
6033 : {
6034 6 : if (match_string_p ("insic"))
6035 : {
6036 : /* Matched "intrinsic". */
6037 : d = DECL_INTRINSIC;
6038 : }
6039 : }
6040 : }
6041 : break;
6042 :
6043 383 : case 'k':
6044 383 : if (match_string_p ("kind"))
6045 : d = DECL_KIND;
6046 : break;
6047 :
6048 427 : case 'l':
6049 427 : if (match_string_p ("len"))
6050 : d = DECL_LEN;
6051 : break;
6052 :
6053 5223 : case 'o':
6054 5223 : if (match_string_p ("optional"))
6055 : d = DECL_OPTIONAL;
6056 : break;
6057 :
6058 27589 : case 'p':
6059 27589 : gfc_next_ascii_char ();
6060 27589 : switch (gfc_next_ascii_char ())
6061 : {
6062 14464 : case 'a':
6063 14464 : if (match_string_p ("rameter"))
6064 : {
6065 : /* Matched "parameter". */
6066 : d = DECL_PARAMETER;
6067 : }
6068 : break;
6069 :
6070 12604 : case 'o':
6071 12604 : if (match_string_p ("inter"))
6072 : {
6073 : /* Matched "pointer". */
6074 : d = DECL_POINTER;
6075 : }
6076 : break;
6077 :
6078 268 : case 'r':
6079 268 : ch = gfc_next_ascii_char ();
6080 268 : if (ch == 'i')
6081 : {
6082 217 : if (match_string_p ("vate"))
6083 : {
6084 : /* Matched "private". */
6085 : d = DECL_PRIVATE;
6086 : }
6087 : }
6088 51 : else if (ch == 'o')
6089 : {
6090 51 : if (match_string_p ("tected"))
6091 : {
6092 : /* Matched "protected". */
6093 : d = DECL_PROTECTED;
6094 : }
6095 : }
6096 : break;
6097 :
6098 253 : case 'u':
6099 253 : if (match_string_p ("blic"))
6100 : {
6101 : /* Matched "public". */
6102 : d = DECL_PUBLIC;
6103 : }
6104 : break;
6105 : }
6106 : break;
6107 :
6108 1223 : case 's':
6109 1223 : gfc_next_ascii_char ();
6110 1223 : switch (gfc_next_ascii_char ())
6111 : {
6112 1210 : case 'a':
6113 1210 : if (match_string_p ("ve"))
6114 : {
6115 : /* Matched "save". */
6116 : d = DECL_SAVE;
6117 : }
6118 : break;
6119 :
6120 13 : case 't':
6121 13 : if (match_string_p ("atic"))
6122 : {
6123 : /* Matched "static". */
6124 : d = DECL_STATIC;
6125 : }
6126 : break;
6127 : }
6128 : break;
6129 :
6130 5731 : case 't':
6131 5731 : if (match_string_p ("target"))
6132 : d = DECL_TARGET;
6133 : break;
6134 :
6135 11326 : case 'v':
6136 11326 : gfc_next_ascii_char ();
6137 11326 : ch = gfc_next_ascii_char ();
6138 11326 : if (ch == 'a')
6139 : {
6140 10805 : if (match_string_p ("lue"))
6141 : {
6142 : /* Matched "value". */
6143 : d = DECL_VALUE;
6144 : }
6145 : }
6146 521 : else if (ch == 'o')
6147 : {
6148 521 : if (match_string_p ("latile"))
6149 : {
6150 : /* Matched "volatile". */
6151 : d = DECL_VOLATILE;
6152 : }
6153 : }
6154 : break;
6155 : }
6156 : }
6157 :
6158 : /* No double colon and no recognizable decl_type, so assume that
6159 : we've been looking at something else the whole time. */
6160 : if (d == DECL_NONE)
6161 : {
6162 33846 : m = MATCH_NO;
6163 33846 : goto cleanup;
6164 : }
6165 :
6166 : /* Check to make sure any parens are paired up correctly. */
6167 121842 : if (gfc_match_parens () == MATCH_ERROR)
6168 : {
6169 1 : m = MATCH_ERROR;
6170 1 : goto cleanup;
6171 : }
6172 :
6173 121841 : seen[d]++;
6174 121841 : seen_at[d] = gfc_current_locus;
6175 :
6176 121841 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6177 : {
6178 19827 : gfc_array_spec *as = NULL;
6179 :
6180 19827 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6181 : d == DECL_CODIMENSION);
6182 :
6183 19827 : if (current_as == NULL)
6184 19802 : current_as = as;
6185 25 : else if (m == MATCH_YES)
6186 : {
6187 25 : if (!merge_array_spec (as, current_as, false))
6188 2 : m = MATCH_ERROR;
6189 25 : free (as);
6190 : }
6191 :
6192 19827 : if (m == MATCH_NO)
6193 : {
6194 0 : if (d == DECL_CODIMENSION)
6195 0 : gfc_error ("Missing codimension specification at %C");
6196 : else
6197 0 : gfc_error ("Missing dimension specification at %C");
6198 : m = MATCH_ERROR;
6199 : }
6200 :
6201 19827 : if (m == MATCH_ERROR)
6202 7 : goto cleanup;
6203 : }
6204 : }
6205 :
6206 : /* Since we've seen a double colon, we have to be looking at an
6207 : attr-spec. This means that we can now issue errors. */
6208 5081244 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6209 4893051 : if (seen[d] > 1)
6210 : {
6211 2 : switch (d)
6212 : {
6213 : case DECL_ALLOCATABLE:
6214 : attr = "ALLOCATABLE";
6215 : break;
6216 0 : case DECL_ASYNCHRONOUS:
6217 0 : attr = "ASYNCHRONOUS";
6218 0 : break;
6219 0 : case DECL_CODIMENSION:
6220 0 : attr = "CODIMENSION";
6221 0 : break;
6222 0 : case DECL_CONTIGUOUS:
6223 0 : attr = "CONTIGUOUS";
6224 0 : break;
6225 0 : case DECL_DIMENSION:
6226 0 : attr = "DIMENSION";
6227 0 : break;
6228 0 : case DECL_EXTERNAL:
6229 0 : attr = "EXTERNAL";
6230 0 : break;
6231 0 : case DECL_IN:
6232 0 : attr = "INTENT (IN)";
6233 0 : break;
6234 0 : case DECL_OUT:
6235 0 : attr = "INTENT (OUT)";
6236 0 : break;
6237 0 : case DECL_INOUT:
6238 0 : attr = "INTENT (IN OUT)";
6239 0 : break;
6240 0 : case DECL_INTRINSIC:
6241 0 : attr = "INTRINSIC";
6242 0 : break;
6243 0 : case DECL_OPTIONAL:
6244 0 : attr = "OPTIONAL";
6245 0 : break;
6246 0 : case DECL_KIND:
6247 0 : attr = "KIND";
6248 0 : break;
6249 0 : case DECL_LEN:
6250 0 : attr = "LEN";
6251 0 : break;
6252 0 : case DECL_PARAMETER:
6253 0 : attr = "PARAMETER";
6254 0 : break;
6255 0 : case DECL_POINTER:
6256 0 : attr = "POINTER";
6257 0 : break;
6258 0 : case DECL_PROTECTED:
6259 0 : attr = "PROTECTED";
6260 0 : break;
6261 0 : case DECL_PRIVATE:
6262 0 : attr = "PRIVATE";
6263 0 : break;
6264 0 : case DECL_PUBLIC:
6265 0 : attr = "PUBLIC";
6266 0 : break;
6267 0 : case DECL_SAVE:
6268 0 : attr = "SAVE";
6269 0 : break;
6270 0 : case DECL_STATIC:
6271 0 : attr = "STATIC";
6272 0 : break;
6273 1 : case DECL_AUTOMATIC:
6274 1 : attr = "AUTOMATIC";
6275 1 : break;
6276 0 : case DECL_TARGET:
6277 0 : attr = "TARGET";
6278 0 : break;
6279 0 : case DECL_IS_BIND_C:
6280 0 : attr = "IS_BIND_C";
6281 0 : break;
6282 0 : case DECL_VALUE:
6283 0 : attr = "VALUE";
6284 0 : break;
6285 1 : case DECL_VOLATILE:
6286 1 : attr = "VOLATILE";
6287 1 : break;
6288 0 : default:
6289 0 : attr = NULL; /* This shouldn't happen. */
6290 : }
6291 :
6292 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6293 2 : m = MATCH_ERROR;
6294 2 : goto cleanup;
6295 : }
6296 :
6297 : /* Now that we've dealt with duplicate attributes, add the attributes
6298 : to the current attribute. */
6299 5080424 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6300 : {
6301 4892304 : if (seen[d] == 0)
6302 4770479 : continue;
6303 : else
6304 121825 : attr_seen = 1;
6305 :
6306 121825 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6307 52 : && !flag_dec_static)
6308 : {
6309 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6310 : "%<-fdec-static%>",
6311 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6312 2 : m = MATCH_ERROR;
6313 2 : goto cleanup;
6314 : }
6315 : /* Allow SAVE with STATIC, but don't complain. */
6316 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6317 0 : continue;
6318 :
6319 121823 : if (gfc_comp_struct (gfc_current_state ())
6320 7279 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6321 6315 : && d != DECL_POINTER && d != DECL_PRIVATE
6322 4601 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6323 : {
6324 4544 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6325 4544 : if (d == DECL_ALLOCATABLE)
6326 : {
6327 3721 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6328 : ? G_("ALLOCATABLE attribute at %C in a "
6329 : "TYPE definition")
6330 : : G_("ALLOCATABLE attribute at %C in a "
6331 : "STRUCTURE definition")))
6332 : {
6333 2 : m = MATCH_ERROR;
6334 2 : goto cleanup;
6335 : }
6336 : }
6337 823 : else if (d == DECL_KIND)
6338 : {
6339 381 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6340 : ? G_("KIND attribute at %C in a "
6341 : "TYPE definition")
6342 : : G_("KIND attribute at %C in a "
6343 : "STRUCTURE definition")))
6344 : {
6345 1 : m = MATCH_ERROR;
6346 1 : goto cleanup;
6347 : }
6348 380 : if (current_ts.type != BT_INTEGER)
6349 : {
6350 2 : gfc_error ("Component with KIND attribute at %C must be "
6351 : "INTEGER");
6352 2 : m = MATCH_ERROR;
6353 2 : goto cleanup;
6354 : }
6355 : }
6356 442 : else if (d == DECL_LEN)
6357 : {
6358 426 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6359 : ? G_("LEN attribute at %C in a "
6360 : "TYPE definition")
6361 : : G_("LEN attribute at %C in a "
6362 : "STRUCTURE definition")))
6363 : {
6364 0 : m = MATCH_ERROR;
6365 0 : goto cleanup;
6366 : }
6367 426 : if (current_ts.type != BT_INTEGER)
6368 : {
6369 1 : gfc_error ("Component with LEN attribute at %C must be "
6370 : "INTEGER");
6371 1 : m = MATCH_ERROR;
6372 1 : goto cleanup;
6373 : }
6374 : }
6375 : else
6376 : {
6377 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6378 : "TYPE definition")
6379 : : G_("Attribute at %L is not allowed in a "
6380 : "STRUCTURE definition"), &seen_at[d]);
6381 16 : m = MATCH_ERROR;
6382 16 : goto cleanup;
6383 : }
6384 : }
6385 :
6386 121801 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6387 470 : && gfc_current_state () != COMP_MODULE)
6388 : {
6389 147 : if (d == DECL_PRIVATE)
6390 : attr = "PRIVATE";
6391 : else
6392 43 : attr = "PUBLIC";
6393 147 : if (gfc_current_state () == COMP_DERIVED
6394 141 : && gfc_state_stack->previous
6395 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6396 : {
6397 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6398 : "at %L in a TYPE definition", attr,
6399 : &seen_at[d]))
6400 : {
6401 2 : m = MATCH_ERROR;
6402 2 : goto cleanup;
6403 : }
6404 : }
6405 : else
6406 : {
6407 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6408 : "specification part of a module", attr, &seen_at[d]);
6409 9 : m = MATCH_ERROR;
6410 9 : goto cleanup;
6411 : }
6412 : }
6413 :
6414 121790 : if (gfc_current_state () != COMP_DERIVED
6415 114542 : && (d == DECL_KIND || d == DECL_LEN))
6416 : {
6417 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6418 : "definition", &seen_at[d]);
6419 3 : m = MATCH_ERROR;
6420 3 : goto cleanup;
6421 : }
6422 :
6423 121787 : switch (d)
6424 : {
6425 18909 : case DECL_ALLOCATABLE:
6426 18909 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6427 18909 : break;
6428 :
6429 29 : case DECL_ASYNCHRONOUS:
6430 29 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6431 : t = false;
6432 : else
6433 29 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6434 : break;
6435 :
6436 66 : case DECL_CODIMENSION:
6437 66 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6438 66 : break;
6439 :
6440 2108 : case DECL_CONTIGUOUS:
6441 2108 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6442 : t = false;
6443 : else
6444 2107 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6445 : break;
6446 :
6447 19752 : case DECL_DIMENSION:
6448 19752 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6449 19752 : break;
6450 :
6451 176 : case DECL_EXTERNAL:
6452 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6453 176 : break;
6454 :
6455 21674 : case DECL_IN:
6456 21674 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6457 21674 : break;
6458 :
6459 3784 : case DECL_OUT:
6460 3784 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6461 3784 : break;
6462 :
6463 3213 : case DECL_INOUT:
6464 3213 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6465 3213 : break;
6466 :
6467 5 : case DECL_INTRINSIC:
6468 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6469 5 : break;
6470 :
6471 5222 : case DECL_OPTIONAL:
6472 5222 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6473 5222 : break;
6474 :
6475 378 : case DECL_KIND:
6476 378 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6477 378 : break;
6478 :
6479 425 : case DECL_LEN:
6480 425 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6481 425 : break;
6482 :
6483 14463 : case DECL_PARAMETER:
6484 14463 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6485 14463 : break;
6486 :
6487 12603 : case DECL_POINTER:
6488 12603 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6489 12603 : break;
6490 :
6491 50 : case DECL_PROTECTED:
6492 50 : if (gfc_current_state () != COMP_MODULE
6493 48 : || (gfc_current_ns->proc_name
6494 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6495 : {
6496 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6497 : "part of a module");
6498 2 : t = false;
6499 2 : break;
6500 : }
6501 :
6502 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6503 : t = false;
6504 : else
6505 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6506 : break;
6507 :
6508 214 : case DECL_PRIVATE:
6509 214 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6510 : &seen_at[d]);
6511 214 : break;
6512 :
6513 245 : case DECL_PUBLIC:
6514 245 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6515 : &seen_at[d]);
6516 245 : break;
6517 :
6518 1220 : case DECL_STATIC:
6519 1220 : case DECL_SAVE:
6520 1220 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6521 1220 : break;
6522 :
6523 37 : case DECL_AUTOMATIC:
6524 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6525 37 : break;
6526 :
6527 5729 : case DECL_TARGET:
6528 5729 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6529 5729 : break;
6530 :
6531 163 : case DECL_IS_BIND_C:
6532 163 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6533 163 : break;
6534 :
6535 10804 : case DECL_VALUE:
6536 10804 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6537 : t = false;
6538 : else
6539 10804 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6540 : break;
6541 :
6542 518 : case DECL_VOLATILE:
6543 518 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6544 : t = false;
6545 : else
6546 517 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6547 : break;
6548 :
6549 0 : default:
6550 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6551 : }
6552 :
6553 121781 : if (!t)
6554 : {
6555 35 : m = MATCH_ERROR;
6556 35 : goto cleanup;
6557 : }
6558 : }
6559 :
6560 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6561 188120 : if ((gfc_current_state () == COMP_MODULE
6562 188120 : || gfc_current_state () == COMP_SUBMODULE)
6563 6018 : && !current_attr.save
6564 5836 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6565 5744 : current_attr.save = SAVE_IMPLICIT;
6566 :
6567 188120 : colon_seen = 1;
6568 188120 : return MATCH_YES;
6569 :
6570 33931 : cleanup:
6571 33931 : gfc_current_locus = start;
6572 33931 : gfc_free_array_spec (current_as);
6573 33931 : current_as = NULL;
6574 33931 : attr_seen = 0;
6575 33931 : return m;
6576 : }
6577 :
6578 :
6579 : /* Set the binding label, dest_label, either with the binding label
6580 : stored in the given gfc_typespec, ts, or if none was provided, it
6581 : will be the symbol name in all lower case, as required by the draft
6582 : (J3/04-007, section 15.4.1). If a binding label was given and
6583 : there is more than one argument (num_idents), it is an error. */
6584 :
6585 : static bool
6586 347 : set_binding_label (const char **dest_label, const char *sym_name,
6587 : int num_idents)
6588 : {
6589 347 : if (num_idents > 1 && has_name_equals)
6590 : {
6591 4 : gfc_error ("Multiple identifiers provided with "
6592 : "single NAME= specifier at %C");
6593 4 : return false;
6594 : }
6595 :
6596 343 : if (curr_binding_label)
6597 : /* Binding label given; store in temp holder till have sym. */
6598 108 : *dest_label = curr_binding_label;
6599 : else
6600 : {
6601 : /* No binding label given, and the NAME= specifier did not exist,
6602 : which means there was no NAME="". */
6603 235 : if (sym_name != NULL && has_name_equals == 0)
6604 205 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6605 : }
6606 :
6607 : return true;
6608 : }
6609 :
6610 :
6611 : /* Set the status of the given common block as being BIND(C) or not,
6612 : depending on the given parameter, is_bind_c. */
6613 :
6614 : static void
6615 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6616 : {
6617 76 : com_block->is_bind_c = is_bind_c;
6618 76 : return;
6619 : }
6620 :
6621 :
6622 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6623 :
6624 : bool
6625 21433 : gfc_verify_c_interop (gfc_typespec *ts)
6626 : {
6627 21433 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6628 4320 : return ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c;
6629 17113 : else if (ts->type == BT_CLASS)
6630 : return false;
6631 17105 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6632 3983 : return false;
6633 :
6634 : return true;
6635 : }
6636 :
6637 :
6638 : /* Verify that the variables of a given common block, which has been
6639 : defined with the attribute specifier bind(c), to be of a C
6640 : interoperable type. Errors will be reported here, if
6641 : encountered. */
6642 :
6643 : bool
6644 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6645 : {
6646 1 : gfc_symbol *curr_sym = NULL;
6647 1 : bool retval = true;
6648 :
6649 1 : curr_sym = com_block->head;
6650 :
6651 : /* Make sure we have at least one symbol. */
6652 1 : if (curr_sym == NULL)
6653 : return retval;
6654 :
6655 : /* Here we know we have a symbol, so we'll execute this loop
6656 : at least once. */
6657 1 : do
6658 : {
6659 : /* The second to last param, 1, says this is in a common block. */
6660 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6661 1 : curr_sym = curr_sym->common_next;
6662 1 : } while (curr_sym != NULL);
6663 :
6664 : return retval;
6665 : }
6666 :
6667 :
6668 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6669 : an appropriate error message is reported. */
6670 :
6671 : bool
6672 7407 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6673 : int is_in_common, gfc_common_head *com_block)
6674 : {
6675 7407 : bool bind_c_function = false;
6676 7407 : bool retval = true;
6677 :
6678 7407 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6679 7407 : bind_c_function = true;
6680 :
6681 7407 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6682 : {
6683 3156 : tmp_sym = tmp_sym->result;
6684 : /* Make sure it wasn't an implicitly typed result. */
6685 3156 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6686 : {
6687 1 : gfc_warning (OPT_Wc_binding_type,
6688 : "Implicitly declared BIND(C) function %qs at "
6689 : "%L may not be C interoperable", tmp_sym->name,
6690 : &tmp_sym->declared_at);
6691 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6692 : /* Mark it as C interoperable to prevent duplicate warnings. */
6693 1 : tmp_sym->ts.is_c_interop = 1;
6694 1 : tmp_sym->attr.is_c_interop = 1;
6695 : }
6696 : }
6697 :
6698 : /* Here, we know we have the bind(c) attribute, so if we have
6699 : enough type info, then verify that it's a C interop kind.
6700 : The info could be in the symbol already, or possibly still in
6701 : the given ts (current_ts), so look in both. */
6702 7407 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6703 : {
6704 3315 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6705 : {
6706 : /* See if we're dealing with a sym in a common block or not. */
6707 237 : if (is_in_common == 1 && warn_c_binding_type)
6708 : {
6709 0 : gfc_warning (OPT_Wc_binding_type,
6710 : "Variable %qs in common block %qs at %L "
6711 : "may not be a C interoperable "
6712 : "kind though common block %qs is BIND(C)",
6713 : tmp_sym->name, com_block->name,
6714 0 : &(tmp_sym->declared_at), com_block->name);
6715 : }
6716 : else
6717 : {
6718 237 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6719 235 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6720 : {
6721 3 : gfc_error ("Type declaration %qs at %L is not C "
6722 : "interoperable but it is BIND(C)",
6723 : tmp_sym->name, &(tmp_sym->declared_at));
6724 3 : retval = false;
6725 : }
6726 234 : else if (warn_c_binding_type)
6727 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6728 : "may not be a C interoperable "
6729 : "kind but it is BIND(C)",
6730 : tmp_sym->name, &(tmp_sym->declared_at));
6731 : }
6732 : }
6733 :
6734 : /* Variables declared w/in a common block can't be bind(c)
6735 : since there's no way for C to see these variables, so there's
6736 : semantically no reason for the attribute. */
6737 3315 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6738 : {
6739 1 : gfc_error ("Variable %qs in common block %qs at "
6740 : "%L cannot be declared with BIND(C) "
6741 : "since it is not a global",
6742 1 : tmp_sym->name, com_block->name,
6743 : &(tmp_sym->declared_at));
6744 1 : retval = false;
6745 : }
6746 :
6747 : /* Scalar variables that are bind(c) cannot have the pointer
6748 : or allocatable attributes. */
6749 3315 : if (tmp_sym->attr.is_bind_c == 1)
6750 : {
6751 2771 : if (tmp_sym->attr.pointer == 1)
6752 : {
6753 1 : gfc_error ("Variable %qs at %L cannot have both the "
6754 : "POINTER and BIND(C) attributes",
6755 : tmp_sym->name, &(tmp_sym->declared_at));
6756 1 : retval = false;
6757 : }
6758 :
6759 2771 : if (tmp_sym->attr.allocatable == 1)
6760 : {
6761 0 : gfc_error ("Variable %qs at %L cannot have both the "
6762 : "ALLOCATABLE and BIND(C) attributes",
6763 : tmp_sym->name, &(tmp_sym->declared_at));
6764 0 : retval = false;
6765 : }
6766 :
6767 : }
6768 :
6769 : /* If it is a BIND(C) function, make sure the return value is a
6770 : scalar value. The previous tests in this function made sure
6771 : the type is interoperable. */
6772 3315 : if (bind_c_function && tmp_sym->as != NULL)
6773 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6774 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6775 :
6776 : /* BIND(C) functions cannot return a character string. */
6777 3156 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6778 116 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6779 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6780 : "type at %L must have length 1", tmp_sym->name,
6781 : &(tmp_sym->declared_at));
6782 : }
6783 :
6784 : /* See if the symbol has been marked as private. If it has, warn if
6785 : there is a binding label with default binding name. */
6786 7407 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6787 11 : && tmp_sym->binding_label
6788 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6789 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6790 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6791 4 : gfc_warning (OPT_Wsurprising,
6792 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6793 : "via its default binding name %qs", tmp_sym->name,
6794 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6795 :
6796 7407 : return retval;
6797 : }
6798 :
6799 :
6800 : /* Set the appropriate fields for a symbol that's been declared as
6801 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6802 : the type is C interoperable. Errors are reported by the functions
6803 : used to set/test these fields. */
6804 :
6805 : static bool
6806 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6807 : {
6808 47 : bool retval = true;
6809 :
6810 : /* TODO: Do we need to make sure the vars aren't marked private? */
6811 :
6812 : /* Set the is_bind_c bit in symbol_attribute. */
6813 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6814 :
6815 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6816 : return false;
6817 :
6818 : return retval;
6819 : }
6820 :
6821 :
6822 : /* Set the fields marking the given common block as BIND(C), including
6823 : a binding label, and report any errors encountered. */
6824 :
6825 : static bool
6826 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6827 : {
6828 76 : bool retval = true;
6829 :
6830 : /* destLabel, common name, typespec (which may have binding label). */
6831 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6832 : num_idents))
6833 : return false;
6834 :
6835 : /* Set the given common block (com_block) to being bind(c) (1). */
6836 76 : set_com_block_bind_c (com_block, 1);
6837 :
6838 76 : return retval;
6839 : }
6840 :
6841 :
6842 : /* Retrieve the list of one or more identifiers that the given bind(c)
6843 : attribute applies to. */
6844 :
6845 : static bool
6846 102 : get_bind_c_idents (void)
6847 : {
6848 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6849 102 : int num_idents = 0;
6850 102 : gfc_symbol *tmp_sym = NULL;
6851 102 : match found_id;
6852 102 : gfc_common_head *com_block = NULL;
6853 :
6854 102 : if (gfc_match_name (name) == MATCH_YES)
6855 : {
6856 38 : found_id = MATCH_YES;
6857 38 : gfc_get_ha_symbol (name, &tmp_sym);
6858 : }
6859 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6860 : {
6861 64 : found_id = MATCH_YES;
6862 64 : com_block = gfc_get_common (name, 0);
6863 : }
6864 : else
6865 : {
6866 0 : gfc_error ("Need either entity or common block name for "
6867 : "attribute specification statement at %C");
6868 0 : return false;
6869 : }
6870 :
6871 : /* Save the current identifier and look for more. */
6872 123 : do
6873 : {
6874 : /* Increment the number of identifiers found for this spec stmt. */
6875 123 : num_idents++;
6876 :
6877 : /* Make sure we have a sym or com block, and verify that it can
6878 : be bind(c). Set the appropriate field(s) and look for more
6879 : identifiers. */
6880 123 : if (tmp_sym != NULL || com_block != NULL)
6881 : {
6882 123 : if (tmp_sym != NULL)
6883 : {
6884 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6885 : return false;
6886 : }
6887 : else
6888 : {
6889 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6890 : return false;
6891 : }
6892 :
6893 : /* Look to see if we have another identifier. */
6894 122 : tmp_sym = NULL;
6895 122 : if (gfc_match_eos () == MATCH_YES)
6896 : found_id = MATCH_NO;
6897 21 : else if (gfc_match_char (',') != MATCH_YES)
6898 : found_id = MATCH_NO;
6899 21 : else if (gfc_match_name (name) == MATCH_YES)
6900 : {
6901 9 : found_id = MATCH_YES;
6902 9 : gfc_get_ha_symbol (name, &tmp_sym);
6903 : }
6904 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6905 : {
6906 12 : found_id = MATCH_YES;
6907 12 : com_block = gfc_get_common (name, 0);
6908 : }
6909 : else
6910 : {
6911 0 : gfc_error ("Missing entity or common block name for "
6912 : "attribute specification statement at %C");
6913 0 : return false;
6914 : }
6915 : }
6916 : else
6917 : {
6918 0 : gfc_internal_error ("Missing symbol");
6919 : }
6920 122 : } while (found_id == MATCH_YES);
6921 :
6922 : /* if we get here we were successful */
6923 : return true;
6924 : }
6925 :
6926 :
6927 : /* Try and match a BIND(C) attribute specification statement. */
6928 :
6929 : match
6930 140 : gfc_match_bind_c_stmt (void)
6931 : {
6932 140 : match found_match = MATCH_NO;
6933 140 : gfc_typespec *ts;
6934 :
6935 140 : ts = ¤t_ts;
6936 :
6937 : /* This may not be necessary. */
6938 140 : gfc_clear_ts (ts);
6939 : /* Clear the temporary binding label holder. */
6940 140 : curr_binding_label = NULL;
6941 :
6942 : /* Look for the bind(c). */
6943 140 : found_match = gfc_match_bind_c (NULL, true);
6944 :
6945 140 : if (found_match == MATCH_YES)
6946 : {
6947 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6948 : return MATCH_ERROR;
6949 :
6950 : /* Look for the :: now, but it is not required. */
6951 102 : gfc_match (" :: ");
6952 :
6953 : /* Get the identifier(s) that needs to be updated. This may need to
6954 : change to hand the flag(s) for the attr specified so all identifiers
6955 : found can have all appropriate parts updated (assuming that the same
6956 : spec stmt can have multiple attrs, such as both bind(c) and
6957 : allocatable...). */
6958 102 : if (!get_bind_c_idents ())
6959 : /* Error message should have printed already. */
6960 1 : return MATCH_ERROR;
6961 : }
6962 :
6963 : return found_match;
6964 : }
6965 :
6966 :
6967 : /* Match a data declaration statement. */
6968 :
6969 : match
6970 1046474 : gfc_match_data_decl (void)
6971 : {
6972 1046474 : gfc_symbol *sym;
6973 1046474 : match m;
6974 1046474 : int elem;
6975 1046474 : gfc_component *comp_tail = NULL;
6976 :
6977 1046474 : type_param_spec_list = NULL;
6978 1046474 : decl_type_param_list = NULL;
6979 :
6980 1046474 : num_idents_on_line = 0;
6981 :
6982 : /* Record the last component before we start, so that we can roll back
6983 : any components added during this statement on error. PR106946.
6984 : Must be set before any 'goto cleanup' with m == MATCH_ERROR. */
6985 1046474 : if (gfc_comp_struct (gfc_current_state ()))
6986 : {
6987 33606 : gfc_symbol *block = gfc_current_block ();
6988 33606 : if (block)
6989 : {
6990 33606 : comp_tail = block->components;
6991 33606 : if (comp_tail)
6992 35734 : while (comp_tail->next)
6993 : comp_tail = comp_tail->next;
6994 : }
6995 : }
6996 :
6997 1046474 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6998 1046474 : if (m != MATCH_YES)
6999 : return m;
7000 :
7001 220874 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
7002 36318 : && !gfc_comp_struct (gfc_current_state ()))
7003 : {
7004 32765 : sym = gfc_use_derived (current_ts.u.derived);
7005 :
7006 32765 : if (sym == NULL)
7007 : {
7008 22 : m = MATCH_ERROR;
7009 22 : goto cleanup;
7010 : }
7011 :
7012 32743 : current_ts.u.derived = sym;
7013 : }
7014 :
7015 220852 : m = match_attr_spec ();
7016 220852 : if (m == MATCH_ERROR)
7017 : {
7018 84 : m = MATCH_NO;
7019 84 : goto cleanup;
7020 : }
7021 :
7022 : /* F2018:C708. */
7023 220768 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
7024 : {
7025 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
7026 6 : m = MATCH_ERROR;
7027 6 : goto cleanup;
7028 : }
7029 :
7030 220762 : if (current_ts.type == BT_CLASS
7031 11299 : && current_ts.u.derived->attr.unlimited_polymorphic)
7032 2053 : goto ok;
7033 :
7034 218709 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
7035 34236 : && current_ts.u.derived->components == NULL
7036 2885 : && !current_ts.u.derived->attr.zero_comp)
7037 : {
7038 :
7039 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
7040 136 : goto ok;
7041 :
7042 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
7043 47 : goto ok;
7044 :
7045 27 : gfc_find_symbol (current_ts.u.derived->name,
7046 27 : current_ts.u.derived->ns, 1, &sym);
7047 :
7048 : /* Any symbol that we find had better be a type definition
7049 : which has its components defined, or be a structure definition
7050 : actively being parsed. */
7051 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
7052 26 : && (current_ts.u.derived->components != NULL
7053 26 : || current_ts.u.derived->attr.zero_comp
7054 26 : || current_ts.u.derived == gfc_new_block))
7055 26 : goto ok;
7056 :
7057 1 : gfc_error ("Derived type at %C has not been previously defined "
7058 : "and so cannot appear in a derived type definition");
7059 1 : m = MATCH_ERROR;
7060 1 : goto cleanup;
7061 : }
7062 :
7063 218499 : ok:
7064 : /* If we have an old-style character declaration, and no new-style
7065 : attribute specifications, then there a comma is optional between
7066 : the type specification and the variable list. */
7067 220761 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
7068 1407 : gfc_match_char (',');
7069 :
7070 : /* Give the types/attributes to symbols that follow. Give the element
7071 : a number so that repeat character length expressions can be copied. */
7072 220761 : elem = 1;
7073 286567 : for (;;)
7074 : {
7075 286567 : num_idents_on_line++;
7076 286567 : m = variable_decl (elem++);
7077 286565 : if (m == MATCH_ERROR)
7078 413 : goto cleanup;
7079 286152 : if (m == MATCH_NO)
7080 : break;
7081 :
7082 286141 : if (gfc_match_eos () == MATCH_YES)
7083 220311 : goto cleanup;
7084 65830 : if (gfc_match_char (',') != MATCH_YES)
7085 : break;
7086 : }
7087 :
7088 35 : if (!gfc_error_flag_test ())
7089 : {
7090 : /* An anonymous structure declaration is unambiguous; if we matched one
7091 : according to gfc_match_structure_decl, we need to return MATCH_YES
7092 : here to avoid confusing the remaining matchers, even if there was an
7093 : error during variable_decl. We must flush any such errors. Note this
7094 : causes the parser to gracefully continue parsing the remaining input
7095 : as a structure body, which likely follows. */
7096 11 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
7097 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
7098 : {
7099 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
7100 : " at %C");
7101 : /* Skip the bad variable_decl and line up for the start of the
7102 : structure body. */
7103 1 : gfc_error_recovery ();
7104 1 : m = MATCH_YES;
7105 1 : goto cleanup;
7106 : }
7107 :
7108 10 : gfc_error ("Syntax error in data declaration at %C");
7109 : }
7110 :
7111 34 : m = MATCH_ERROR;
7112 :
7113 34 : gfc_free_data_all (gfc_current_ns);
7114 :
7115 220872 : cleanup:
7116 : /* If we failed inside a derived type definition, remove any CLASS
7117 : components that were added during this failed statement. For CLASS
7118 : components, gfc_build_class_symbol creates an extra container symbol in
7119 : the namespace outside the normal undo machinery. When reject_statement
7120 : later calls gfc_undo_symbols, the declaration state is rolled back but
7121 : that helper symbol survives and leaves the component dangling. Ordinary
7122 : components do not create that extra helper symbol, so leave them in
7123 : place for the usual follow-up diagnostics. PR106946.
7124 :
7125 : CLASS containers are shared between components of the same class type
7126 : and attributes (gfc_build_class_symbol reuses existing containers).
7127 : We must not free a container that is still referenced by a previously
7128 : committed component. Unlink and free the components first, then clean
7129 : up only orphaned containers. PR124482. */
7130 220872 : if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
7131 : {
7132 86 : gfc_symbol *block = gfc_current_block ();
7133 86 : if (block)
7134 : {
7135 86 : gfc_component **prev;
7136 86 : if (comp_tail)
7137 43 : prev = &comp_tail->next;
7138 : else
7139 43 : prev = &block->components;
7140 :
7141 : /* Record the CLASS container from the removed components.
7142 : Normally all components in one declaration share a single
7143 : container, but per-variable array specs can produce
7144 : additional ones; any beyond the first are harmlessly
7145 : leaked until namespace destruction. */
7146 86 : gfc_symbol *fclass_container = NULL;
7147 :
7148 120 : while (*prev)
7149 : {
7150 34 : gfc_component *c = *prev;
7151 34 : if (c->ts.type == BT_CLASS && c->ts.u.derived
7152 6 : && c->ts.u.derived->attr.is_class)
7153 : {
7154 3 : *prev = c->next;
7155 3 : if (!fclass_container)
7156 3 : fclass_container = c->ts.u.derived;
7157 3 : c->ts.u.derived = NULL;
7158 3 : gfc_free_component (c);
7159 : }
7160 : else
7161 31 : prev = &c->next;
7162 : }
7163 :
7164 : /* Free the container only if no remaining component still
7165 : references it. CLASS containers are shared between
7166 : components of the same class type and attributes
7167 : (gfc_build_class_symbol reuses existing ones). */
7168 86 : if (fclass_container)
7169 : {
7170 3 : bool shared = false;
7171 3 : for (gfc_component *q = block->components; q; q = q->next)
7172 1 : if (q->ts.type == BT_CLASS
7173 1 : && q->ts.u.derived == fclass_container)
7174 : {
7175 : shared = true;
7176 : break;
7177 : }
7178 3 : if (!shared)
7179 : {
7180 2 : if (gfc_find_symtree (fclass_container->ns->sym_root,
7181 : fclass_container->name))
7182 2 : gfc_delete_symtree (&fclass_container->ns->sym_root,
7183 : fclass_container->name);
7184 2 : gfc_release_symbol (fclass_container);
7185 : }
7186 : }
7187 : }
7188 : }
7189 :
7190 220872 : if (saved_kind_expr)
7191 372 : gfc_free_expr (saved_kind_expr);
7192 220872 : if (type_param_spec_list)
7193 1249 : gfc_free_actual_arglist (type_param_spec_list);
7194 220872 : if (decl_type_param_list)
7195 1200 : gfc_free_actual_arglist (decl_type_param_list);
7196 220872 : saved_kind_expr = NULL;
7197 220872 : gfc_free_array_spec (current_as);
7198 220872 : current_as = NULL;
7199 220872 : return m;
7200 : }
7201 :
7202 : static bool
7203 25145 : in_module_or_interface(void)
7204 : {
7205 25145 : if (gfc_current_state () == COMP_MODULE
7206 25145 : || gfc_current_state () == COMP_SUBMODULE
7207 25145 : || gfc_current_state () == COMP_INTERFACE)
7208 : return true;
7209 :
7210 21126 : if (gfc_state_stack->state == COMP_CONTAINS
7211 20244 : || gfc_state_stack->state == COMP_FUNCTION
7212 20138 : || gfc_state_stack->state == COMP_SUBROUTINE)
7213 : {
7214 988 : gfc_state_data *p;
7215 1032 : for (p = gfc_state_stack->previous; p ; p = p->previous)
7216 : {
7217 1028 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
7218 118 : || p->state == COMP_INTERFACE)
7219 : return true;
7220 : }
7221 : }
7222 : return false;
7223 : }
7224 :
7225 : /* Match a prefix associated with a function or subroutine
7226 : declaration. If the typespec pointer is nonnull, then a typespec
7227 : can be matched. Note that if nothing matches, MATCH_YES is
7228 : returned (the null string was matched). */
7229 :
7230 : match
7231 248037 : gfc_match_prefix (gfc_typespec *ts)
7232 : {
7233 248037 : bool seen_type;
7234 248037 : bool seen_impure;
7235 248037 : bool found_prefix;
7236 :
7237 248037 : gfc_clear_attr (¤t_attr);
7238 248037 : seen_type = false;
7239 248037 : seen_impure = false;
7240 :
7241 248037 : gcc_assert (!gfc_matching_prefix);
7242 248037 : gfc_matching_prefix = true;
7243 :
7244 257702 : do
7245 : {
7246 278144 : found_prefix = false;
7247 :
7248 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7249 : corresponding attribute seems natural and distinguishes these
7250 : procedures from procedure types of PROC_MODULE, which these are
7251 : as well. */
7252 278144 : if (gfc_match ("module% ") == MATCH_YES)
7253 : {
7254 25420 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7255 275 : goto error;
7256 :
7257 25145 : if (!in_module_or_interface ())
7258 : {
7259 20142 : gfc_error ("MODULE prefix at %C found outside of a module, "
7260 : "submodule, or interface");
7261 20142 : goto error;
7262 : }
7263 :
7264 5003 : current_attr.module_procedure = 1;
7265 5003 : found_prefix = true;
7266 : }
7267 :
7268 257727 : if (!seen_type && ts != NULL)
7269 : {
7270 138799 : match m;
7271 138799 : m = gfc_match_decl_type_spec (ts, 0);
7272 138799 : if (m == MATCH_ERROR)
7273 15 : goto error;
7274 138784 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7275 : {
7276 : seen_type = true;
7277 : found_prefix = true;
7278 : }
7279 : }
7280 :
7281 257712 : if (gfc_match ("elemental% ") == MATCH_YES)
7282 : {
7283 5383 : if (!gfc_add_elemental (¤t_attr, NULL))
7284 2 : goto error;
7285 :
7286 : found_prefix = true;
7287 : }
7288 :
7289 257710 : if (gfc_match ("pure% ") == MATCH_YES)
7290 : {
7291 2490 : if (!gfc_add_pure (¤t_attr, NULL))
7292 2 : goto error;
7293 :
7294 : found_prefix = true;
7295 : }
7296 :
7297 257708 : if (gfc_match ("recursive% ") == MATCH_YES)
7298 : {
7299 469 : if (!gfc_add_recursive (¤t_attr, NULL))
7300 2 : goto error;
7301 :
7302 : found_prefix = true;
7303 : }
7304 :
7305 : /* IMPURE is a somewhat special case, as it needs not set an actual
7306 : attribute but rather only prevents ELEMENTAL routines from being
7307 : automatically PURE. */
7308 257706 : if (gfc_match ("impure% ") == MATCH_YES)
7309 : {
7310 729 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7311 4 : goto error;
7312 :
7313 : seen_impure = true;
7314 : found_prefix = true;
7315 : }
7316 : }
7317 : while (found_prefix);
7318 :
7319 : /* IMPURE and PURE must not both appear, of course. */
7320 227595 : if (seen_impure && current_attr.pure)
7321 : {
7322 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7323 4 : goto error;
7324 : }
7325 :
7326 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7327 226870 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7328 : {
7329 4688 : if (!gfc_add_pure (¤t_attr, NULL))
7330 0 : goto error;
7331 : }
7332 :
7333 : /* At this point, the next item is not a prefix. */
7334 227591 : gcc_assert (gfc_matching_prefix);
7335 :
7336 227591 : gfc_matching_prefix = false;
7337 227591 : return MATCH_YES;
7338 :
7339 20446 : error:
7340 20446 : gcc_assert (gfc_matching_prefix);
7341 20446 : gfc_matching_prefix = false;
7342 20446 : return MATCH_ERROR;
7343 : }
7344 :
7345 :
7346 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7347 :
7348 : static bool
7349 64552 : copy_prefix (symbol_attribute *dest, locus *where)
7350 : {
7351 64552 : if (dest->module_procedure)
7352 : {
7353 732 : if (current_attr.elemental)
7354 13 : dest->elemental = 1;
7355 :
7356 732 : if (current_attr.pure)
7357 61 : dest->pure = 1;
7358 :
7359 732 : if (current_attr.recursive)
7360 8 : dest->recursive = 1;
7361 :
7362 : /* Module procedures are unusual in that the 'dest' is copied from
7363 : the interface declaration. However, this is an opportunity to
7364 : check that the submodule declaration is compliant with the
7365 : interface. */
7366 732 : if (dest->elemental && !current_attr.elemental)
7367 : {
7368 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7369 : "missing at %L", where);
7370 1 : return false;
7371 : }
7372 :
7373 731 : if (dest->pure && !current_attr.pure)
7374 : {
7375 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7376 : "missing at %L", where);
7377 1 : return false;
7378 : }
7379 :
7380 730 : if (dest->recursive && !current_attr.recursive)
7381 : {
7382 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7383 : "missing at %L", where);
7384 1 : return false;
7385 : }
7386 :
7387 : return true;
7388 : }
7389 :
7390 63820 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7391 : return false;
7392 :
7393 63818 : if (current_attr.pure && !gfc_add_pure (dest, where))
7394 : return false;
7395 :
7396 63818 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7397 : return false;
7398 :
7399 : return true;
7400 : }
7401 :
7402 :
7403 : /* Match a formal argument list or, if typeparam is true, a
7404 : type_param_name_list. */
7405 :
7406 : match
7407 498581 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7408 : int null_flag, bool typeparam)
7409 : {
7410 498581 : gfc_formal_arglist *head, *tail, *p, *q;
7411 498581 : char name[GFC_MAX_SYMBOL_LEN + 1];
7412 498581 : gfc_symbol *sym;
7413 498581 : match m;
7414 498581 : gfc_formal_arglist *formal = NULL;
7415 :
7416 498581 : head = tail = NULL;
7417 :
7418 : /* Keep the interface formal argument list and null it so that the
7419 : matching for the new declaration can be done. The numbers and
7420 : names of the arguments are checked here. The interface formal
7421 : arguments are retained in formal_arglist and the characteristics
7422 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7423 : in get_proc_name about the eventual need to copy the formal_arglist
7424 : and populate the formal namespace of the interface symbol. */
7425 498581 : if (progname->attr.module_procedure
7426 736 : && progname->attr.host_assoc)
7427 : {
7428 196 : formal = progname->formal;
7429 196 : progname->formal = NULL;
7430 : }
7431 :
7432 498581 : if (gfc_match_char ('(') != MATCH_YES)
7433 : {
7434 294659 : if (null_flag)
7435 6806 : goto ok;
7436 : return MATCH_NO;
7437 : }
7438 :
7439 203922 : if (gfc_match_char (')') == MATCH_YES)
7440 : {
7441 10652 : if (typeparam)
7442 : {
7443 1 : gfc_error_now ("A type parameter list is required at %C");
7444 1 : m = MATCH_ERROR;
7445 1 : goto cleanup;
7446 : }
7447 : else
7448 10651 : goto ok;
7449 : }
7450 :
7451 256092 : for (;;)
7452 : {
7453 256092 : gfc_gobble_whitespace ();
7454 256092 : if (gfc_match_char ('*') == MATCH_YES)
7455 : {
7456 10509 : sym = NULL;
7457 10509 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7458 : "Alternate-return argument at %C"))
7459 : {
7460 1 : m = MATCH_ERROR;
7461 1 : goto cleanup;
7462 : }
7463 10508 : else if (typeparam)
7464 2 : gfc_error_now ("A parameter name is required at %C");
7465 : }
7466 : else
7467 : {
7468 245583 : locus loc = gfc_current_locus;
7469 245583 : m = gfc_match_name (name);
7470 245583 : if (m != MATCH_YES)
7471 : {
7472 16948 : if(typeparam)
7473 1 : gfc_error_now ("A parameter name is required at %C");
7474 16964 : goto cleanup;
7475 : }
7476 228635 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7477 :
7478 228635 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7479 16 : goto cleanup;
7480 228619 : else if (typeparam
7481 228619 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7482 0 : goto cleanup;
7483 : }
7484 :
7485 239127 : p = gfc_get_formal_arglist ();
7486 :
7487 239127 : if (head == NULL)
7488 : head = tail = p;
7489 : else
7490 : {
7491 62119 : tail->next = p;
7492 62119 : tail = p;
7493 : }
7494 :
7495 239127 : tail->sym = sym;
7496 :
7497 : /* We don't add the VARIABLE flavor because the name could be a
7498 : dummy procedure. We don't apply these attributes to formal
7499 : arguments of statement functions. */
7500 228619 : if (sym != NULL && !st_flag
7501 341799 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7502 102672 : || !gfc_missing_attr (&sym->attr, NULL)))
7503 : {
7504 0 : m = MATCH_ERROR;
7505 0 : goto cleanup;
7506 : }
7507 :
7508 : /* The name of a program unit can be in a different namespace,
7509 : so check for it explicitly. After the statement is accepted,
7510 : the name is checked for especially in gfc_get_symbol(). */
7511 239127 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7512 101186 : && strcmp (sym->name, gfc_new_block->name) == 0)
7513 : {
7514 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7515 : sym->name);
7516 0 : m = MATCH_ERROR;
7517 0 : goto cleanup;
7518 : }
7519 :
7520 239127 : if (gfc_match_char (')') == MATCH_YES)
7521 126936 : goto ok;
7522 :
7523 112191 : m = gfc_match_char (',');
7524 112191 : if (m != MATCH_YES)
7525 : {
7526 49369 : if (typeparam)
7527 1 : gfc_error_now ("Expected parameter list in type declaration "
7528 : "at %C");
7529 : else
7530 49368 : gfc_error ("Unexpected junk in formal argument list at %C");
7531 49369 : goto cleanup;
7532 : }
7533 : }
7534 :
7535 144393 : ok:
7536 : /* Check for duplicate symbols in the formal argument list. */
7537 144393 : if (head != NULL)
7538 : {
7539 187414 : for (p = head; p->next; p = p->next)
7540 : {
7541 60526 : if (p->sym == NULL)
7542 338 : continue;
7543 :
7544 238047 : for (q = p->next; q; q = q->next)
7545 177907 : if (p->sym == q->sym)
7546 : {
7547 48 : if (typeparam)
7548 1 : gfc_error_now ("Duplicate name %qs in parameter "
7549 : "list at %C", p->sym->name);
7550 : else
7551 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7552 : "list at %C", p->sym->name);
7553 :
7554 48 : m = MATCH_ERROR;
7555 48 : goto cleanup;
7556 : }
7557 : }
7558 : }
7559 :
7560 144345 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7561 : {
7562 0 : m = MATCH_ERROR;
7563 0 : goto cleanup;
7564 : }
7565 :
7566 : /* gfc_error_now used in following and return with MATCH_YES because
7567 : doing otherwise results in a cascade of extraneous errors and in
7568 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7569 144345 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7570 : {
7571 195 : bool arg_count_mismatch = false;
7572 :
7573 195 : if (!formal && head)
7574 : arg_count_mismatch = true;
7575 :
7576 : /* Abbreviated module procedure declaration is not meant to have any
7577 : formal arguments! */
7578 195 : if (!progname->abr_modproc_decl && formal && !head)
7579 195 : arg_count_mismatch = true;
7580 :
7581 377 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7582 : {
7583 182 : if ((p->next != NULL && q->next == NULL)
7584 181 : || (p->next == NULL && q->next != NULL))
7585 : arg_count_mismatch = true;
7586 180 : else if ((p->sym == NULL && q->sym == NULL)
7587 180 : || (p->sym && q->sym
7588 178 : && strcmp (p->sym->name, q->sym->name) == 0))
7589 176 : continue;
7590 : else
7591 : {
7592 4 : if (q->sym == NULL)
7593 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7594 : "conflicts with alternate return at %C",
7595 : p->sym->name);
7596 3 : else if (p->sym == NULL)
7597 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7598 : "alternate return and conflicts with "
7599 : "%qs in the separate declaration at %C",
7600 : q->sym->name);
7601 : else
7602 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7603 : "argument names (%s/%s) at %C",
7604 : p->sym->name, q->sym->name);
7605 : }
7606 : }
7607 :
7608 195 : if (arg_count_mismatch)
7609 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7610 : "formal arguments at %C");
7611 : }
7612 :
7613 : return MATCH_YES;
7614 :
7615 66383 : cleanup:
7616 66383 : gfc_free_formal_arglist (head);
7617 66383 : return m;
7618 : }
7619 :
7620 :
7621 : /* Match a RESULT specification following a function declaration or
7622 : ENTRY statement. Also matches the end-of-statement. */
7623 :
7624 : static match
7625 8794 : match_result (gfc_symbol *function, gfc_symbol **result)
7626 : {
7627 8794 : char name[GFC_MAX_SYMBOL_LEN + 1];
7628 8794 : gfc_symbol *r;
7629 8794 : match m;
7630 :
7631 8794 : if (gfc_match (" result (") != MATCH_YES)
7632 : return MATCH_NO;
7633 :
7634 6238 : m = gfc_match_name (name);
7635 6238 : if (m != MATCH_YES)
7636 : return m;
7637 :
7638 : /* Get the right paren, and that's it because there could be the
7639 : bind(c) attribute after the result clause. */
7640 6238 : if (gfc_match_char (')') != MATCH_YES)
7641 : {
7642 : /* TODO: should report the missing right paren here. */
7643 : return MATCH_ERROR;
7644 : }
7645 :
7646 6238 : if (strcmp (function->name, name) == 0)
7647 : {
7648 1 : gfc_error ("RESULT variable at %C must be different than function name");
7649 1 : return MATCH_ERROR;
7650 : }
7651 :
7652 6237 : if (gfc_get_symbol (name, NULL, &r))
7653 : return MATCH_ERROR;
7654 :
7655 6237 : if (!gfc_add_result (&r->attr, r->name, NULL))
7656 : return MATCH_ERROR;
7657 :
7658 6237 : *result = r;
7659 :
7660 6237 : return MATCH_YES;
7661 : }
7662 :
7663 :
7664 : /* Match a function suffix, which could be a combination of a result
7665 : clause and BIND(C), either one, or neither. The draft does not
7666 : require them to come in a specific order. */
7667 :
7668 : static match
7669 8798 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7670 : {
7671 8798 : match is_bind_c; /* Found bind(c). */
7672 8798 : match is_result; /* Found result clause. */
7673 8798 : match found_match; /* Status of whether we've found a good match. */
7674 8798 : char peek_char; /* Character we're going to peek at. */
7675 8798 : bool allow_binding_name;
7676 :
7677 : /* Initialize to having found nothing. */
7678 8798 : found_match = MATCH_NO;
7679 8798 : is_bind_c = MATCH_NO;
7680 8798 : is_result = MATCH_NO;
7681 :
7682 : /* Get the next char to narrow between result and bind(c). */
7683 8798 : gfc_gobble_whitespace ();
7684 8798 : peek_char = gfc_peek_ascii_char ();
7685 :
7686 : /* C binding names are not allowed for internal procedures. */
7687 8798 : if (gfc_current_state () == COMP_CONTAINS
7688 4959 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7689 : allow_binding_name = false;
7690 : else
7691 7070 : allow_binding_name = true;
7692 :
7693 8798 : switch (peek_char)
7694 : {
7695 5861 : case 'r':
7696 : /* Look for result clause. */
7697 5861 : is_result = match_result (sym, result);
7698 5861 : if (is_result == MATCH_YES)
7699 : {
7700 : /* Now see if there is a bind(c) after it. */
7701 5860 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7702 : /* We've found the result clause and possibly bind(c). */
7703 5860 : found_match = MATCH_YES;
7704 : }
7705 : else
7706 : /* This should only be MATCH_ERROR. */
7707 : found_match = is_result;
7708 : break;
7709 2937 : case 'b':
7710 : /* Look for bind(c) first. */
7711 2937 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7712 2937 : if (is_bind_c == MATCH_YES)
7713 : {
7714 : /* Now see if a result clause followed it. */
7715 2933 : is_result = match_result (sym, result);
7716 2933 : found_match = MATCH_YES;
7717 : }
7718 : else
7719 : {
7720 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7721 : found_match = MATCH_ERROR;
7722 : }
7723 : break;
7724 0 : default:
7725 0 : gfc_error ("Unexpected junk after function declaration at %C");
7726 0 : found_match = MATCH_ERROR;
7727 0 : break;
7728 : }
7729 :
7730 8793 : if (is_bind_c == MATCH_YES)
7731 : {
7732 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7733 3100 : if (gfc_current_state () == COMP_CONTAINS
7734 423 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7735 3118 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7736 : "at %L may not be specified for an internal "
7737 : "procedure", &gfc_current_locus))
7738 : return MATCH_ERROR;
7739 :
7740 3097 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7741 0 : return MATCH_ERROR;
7742 : }
7743 :
7744 : return found_match;
7745 : }
7746 :
7747 :
7748 : /* Procedure pointer return value without RESULT statement:
7749 : Add "hidden" result variable named "ppr@". */
7750 :
7751 : static bool
7752 76234 : add_hidden_procptr_result (gfc_symbol *sym)
7753 : {
7754 76234 : bool case1,case2;
7755 :
7756 76234 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7757 : return false;
7758 :
7759 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7760 1539 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7761 1539 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7762 76633 : && sym->attr.external;
7763 : /* Second usage case: INTERFACE statements. */
7764 14920 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7765 14920 : && gfc_state_stack->previous->state == COMP_FUNCTION
7766 76281 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7767 :
7768 76050 : if (case1 || case2)
7769 : {
7770 125 : gfc_symtree *stree;
7771 125 : if (case1)
7772 95 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7773 : else
7774 : {
7775 30 : gfc_symtree *st2;
7776 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7777 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7778 30 : st2->n.sym = stree->n.sym;
7779 30 : stree->n.sym->refs++;
7780 : }
7781 125 : sym->result = stree->n.sym;
7782 :
7783 125 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7784 125 : sym->result->attr.pointer = sym->attr.pointer;
7785 125 : sym->result->attr.external = sym->attr.external;
7786 125 : sym->result->attr.referenced = sym->attr.referenced;
7787 125 : sym->result->ts = sym->ts;
7788 125 : sym->attr.proc_pointer = 0;
7789 125 : sym->attr.pointer = 0;
7790 125 : sym->attr.external = 0;
7791 125 : if (sym->result->attr.external && sym->result->attr.pointer)
7792 : {
7793 4 : sym->result->attr.pointer = 0;
7794 4 : sym->result->attr.proc_pointer = 1;
7795 : }
7796 :
7797 125 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7798 : }
7799 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7800 75955 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7801 411 : && sym->result && sym->result != sym && sym->result->attr.external
7802 28 : && sym == gfc_current_ns->proc_name
7803 28 : && sym == sym->result->ns->proc_name
7804 28 : && strcmp ("ppr@", sym->result->name) == 0)
7805 : {
7806 28 : sym->result->attr.proc_pointer = 1;
7807 28 : sym->attr.pointer = 0;
7808 28 : return true;
7809 : }
7810 : else
7811 : return false;
7812 : }
7813 :
7814 :
7815 : /* Match the interface for a PROCEDURE declaration,
7816 : including brackets (R1212). */
7817 :
7818 : static match
7819 1644 : match_procedure_interface (gfc_symbol **proc_if)
7820 : {
7821 1644 : match m;
7822 1644 : gfc_symtree *st;
7823 1644 : locus old_loc, entry_loc;
7824 1644 : gfc_namespace *old_ns = gfc_current_ns;
7825 1644 : char name[GFC_MAX_SYMBOL_LEN + 1];
7826 :
7827 1644 : old_loc = entry_loc = gfc_current_locus;
7828 1644 : gfc_clear_ts (¤t_ts);
7829 :
7830 1644 : if (gfc_match (" (") != MATCH_YES)
7831 : {
7832 1 : gfc_current_locus = entry_loc;
7833 1 : return MATCH_NO;
7834 : }
7835 :
7836 : /* Get the type spec. for the procedure interface. */
7837 1643 : old_loc = gfc_current_locus;
7838 1643 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7839 1643 : gfc_gobble_whitespace ();
7840 1643 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7841 395 : goto got_ts;
7842 :
7843 1248 : if (m == MATCH_ERROR)
7844 : return m;
7845 :
7846 : /* Procedure interface is itself a procedure. */
7847 1248 : gfc_current_locus = old_loc;
7848 1248 : m = gfc_match_name (name);
7849 :
7850 : /* First look to see if it is already accessible in the current
7851 : namespace because it is use associated or contained. */
7852 1248 : st = NULL;
7853 1248 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7854 : return MATCH_ERROR;
7855 :
7856 : /* If it is still not found, then try the parent namespace, if it
7857 : exists and create the symbol there if it is still not found. */
7858 1248 : if (gfc_current_ns->parent)
7859 435 : gfc_current_ns = gfc_current_ns->parent;
7860 1248 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7861 : return MATCH_ERROR;
7862 :
7863 1248 : gfc_current_ns = old_ns;
7864 1248 : *proc_if = st->n.sym;
7865 :
7866 1248 : if (*proc_if)
7867 : {
7868 1248 : (*proc_if)->refs++;
7869 : /* Resolve interface if possible. That way, attr.procedure is only set
7870 : if it is declared by a later procedure-declaration-stmt, which is
7871 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7872 1248 : while ((*proc_if)->ts.interface
7873 1255 : && *proc_if != (*proc_if)->ts.interface)
7874 7 : *proc_if = (*proc_if)->ts.interface;
7875 :
7876 1248 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7877 395 : && (*proc_if)->ts.type == BT_UNKNOWN
7878 1643 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7879 : (*proc_if)->name, NULL))
7880 : return MATCH_ERROR;
7881 : }
7882 :
7883 0 : got_ts:
7884 1643 : if (gfc_match (" )") != MATCH_YES)
7885 : {
7886 0 : gfc_current_locus = entry_loc;
7887 0 : return MATCH_NO;
7888 : }
7889 :
7890 : return MATCH_YES;
7891 : }
7892 :
7893 :
7894 : /* Match a PROCEDURE declaration (R1211). */
7895 :
7896 : static match
7897 1199 : match_procedure_decl (void)
7898 : {
7899 1199 : match m;
7900 1199 : gfc_symbol *sym, *proc_if = NULL;
7901 1199 : int num;
7902 1199 : gfc_expr *initializer = NULL;
7903 :
7904 : /* Parse interface (with brackets). */
7905 1199 : m = match_procedure_interface (&proc_if);
7906 1199 : if (m != MATCH_YES)
7907 : return m;
7908 :
7909 : /* Parse attributes (with colons). */
7910 1199 : m = match_attr_spec();
7911 1199 : if (m == MATCH_ERROR)
7912 : return MATCH_ERROR;
7913 :
7914 1198 : if (current_attr.allocatable)
7915 : {
7916 2 : current_attr.procedure = 1;
7917 2 : gfc_check_conflict (¤t_attr, NULL, &gfc_current_locus);
7918 2 : return MATCH_ERROR;
7919 : }
7920 :
7921 1196 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7922 : {
7923 53 : current_attr.is_bind_c = 1;
7924 53 : has_name_equals = 0;
7925 53 : curr_binding_label = NULL;
7926 : }
7927 :
7928 : /* Get procedure symbols. */
7929 1196 : for(num=1;;num++)
7930 : {
7931 1275 : m = gfc_match_symbol (&sym, 0);
7932 1275 : if (m == MATCH_NO)
7933 1 : goto syntax;
7934 1274 : else if (m == MATCH_ERROR)
7935 : return m;
7936 :
7937 : /* Add current_attr to the symbol attributes. */
7938 1274 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7939 : return MATCH_ERROR;
7940 :
7941 1272 : if (sym->attr.is_bind_c)
7942 : {
7943 : /* Check for C1218. */
7944 90 : if (!proc_if || !proc_if->attr.is_bind_c)
7945 : {
7946 1 : gfc_error ("BIND(C) attribute at %C requires "
7947 : "an interface with BIND(C)");
7948 1 : return MATCH_ERROR;
7949 : }
7950 : /* Check for C1217. */
7951 89 : if (has_name_equals && sym->attr.pointer)
7952 : {
7953 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7954 : "POINTER attribute at %C");
7955 1 : return MATCH_ERROR;
7956 : }
7957 88 : if (has_name_equals && sym->attr.dummy)
7958 : {
7959 1 : gfc_error ("Dummy procedure at %C may not have "
7960 : "BIND(C) attribute with NAME");
7961 1 : return MATCH_ERROR;
7962 : }
7963 : /* Set binding label for BIND(C). */
7964 87 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7965 : return MATCH_ERROR;
7966 : }
7967 :
7968 1268 : if (!gfc_add_external (&sym->attr, NULL))
7969 : return MATCH_ERROR;
7970 :
7971 1264 : if (add_hidden_procptr_result (sym))
7972 68 : sym = sym->result;
7973 :
7974 1264 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7975 : return MATCH_ERROR;
7976 :
7977 : /* Set interface. */
7978 1264 : if (proc_if != NULL)
7979 : {
7980 921 : if (sym->ts.type != BT_UNKNOWN)
7981 : {
7982 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7983 : sym->name, &gfc_current_locus,
7984 : gfc_basic_typename (sym->ts.type));
7985 1 : return MATCH_ERROR;
7986 : }
7987 920 : sym->ts.interface = proc_if;
7988 920 : sym->attr.untyped = 1;
7989 920 : sym->attr.if_source = IFSRC_IFBODY;
7990 : }
7991 343 : else if (current_ts.type != BT_UNKNOWN)
7992 : {
7993 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7994 : return MATCH_ERROR;
7995 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7996 198 : sym->ts.interface->ts = current_ts;
7997 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7998 198 : sym->ts.interface->attr.function = 1;
7999 198 : sym->attr.function = 1;
8000 198 : sym->attr.if_source = IFSRC_UNKNOWN;
8001 : }
8002 :
8003 1262 : if (gfc_match (" =>") == MATCH_YES)
8004 : {
8005 110 : if (!current_attr.pointer)
8006 : {
8007 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
8008 0 : m = MATCH_ERROR;
8009 0 : goto cleanup;
8010 : }
8011 :
8012 110 : m = match_pointer_init (&initializer, 1);
8013 110 : if (m != MATCH_YES)
8014 1 : goto cleanup;
8015 :
8016 109 : if (!add_init_expr_to_sym (sym->name, &initializer,
8017 : &gfc_current_locus,
8018 : gfc_current_ns->cl_list))
8019 0 : goto cleanup;
8020 :
8021 : }
8022 :
8023 1261 : if (gfc_match_eos () == MATCH_YES)
8024 : return MATCH_YES;
8025 79 : if (gfc_match_char (',') != MATCH_YES)
8026 0 : goto syntax;
8027 : }
8028 :
8029 1 : syntax:
8030 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8031 1 : return MATCH_ERROR;
8032 :
8033 1 : cleanup:
8034 : /* Free stuff up and return. */
8035 1 : gfc_free_expr (initializer);
8036 1 : return m;
8037 : }
8038 :
8039 :
8040 : static match
8041 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
8042 :
8043 :
8044 : /* Match a procedure pointer component declaration (R445). */
8045 :
8046 : static match
8047 445 : match_ppc_decl (void)
8048 : {
8049 445 : match m;
8050 445 : gfc_symbol *proc_if = NULL;
8051 445 : gfc_typespec ts;
8052 445 : int num;
8053 445 : gfc_component *c;
8054 445 : gfc_expr *initializer = NULL;
8055 445 : gfc_typebound_proc* tb;
8056 445 : char name[GFC_MAX_SYMBOL_LEN + 1];
8057 :
8058 : /* Parse interface (with brackets). */
8059 445 : m = match_procedure_interface (&proc_if);
8060 445 : if (m != MATCH_YES)
8061 1 : goto syntax;
8062 :
8063 : /* Parse attributes. */
8064 444 : tb = XCNEW (gfc_typebound_proc);
8065 444 : tb->where = gfc_current_locus;
8066 444 : m = match_binding_attributes (tb, false, true);
8067 444 : if (m == MATCH_ERROR)
8068 : return m;
8069 :
8070 441 : gfc_clear_attr (¤t_attr);
8071 441 : current_attr.procedure = 1;
8072 441 : current_attr.proc_pointer = 1;
8073 441 : current_attr.access = tb->access;
8074 441 : current_attr.flavor = FL_PROCEDURE;
8075 :
8076 : /* Match the colons (required). */
8077 441 : if (gfc_match (" ::") != MATCH_YES)
8078 : {
8079 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
8080 1 : return MATCH_ERROR;
8081 : }
8082 :
8083 : /* Check for C450. */
8084 440 : if (!tb->nopass && proc_if == NULL)
8085 : {
8086 2 : gfc_error("NOPASS or explicit interface required at %C");
8087 2 : return MATCH_ERROR;
8088 : }
8089 :
8090 438 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
8091 : return MATCH_ERROR;
8092 :
8093 : /* Match PPC names. */
8094 437 : ts = current_ts;
8095 437 : for(num=1;;num++)
8096 : {
8097 438 : m = gfc_match_name (name);
8098 438 : if (m == MATCH_NO)
8099 0 : goto syntax;
8100 438 : else if (m == MATCH_ERROR)
8101 : return m;
8102 :
8103 438 : if (!gfc_add_component (gfc_current_block(), name, &c))
8104 : return MATCH_ERROR;
8105 :
8106 : /* Add current_attr to the symbol attributes. */
8107 438 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
8108 : return MATCH_ERROR;
8109 :
8110 438 : if (!gfc_add_external (&c->attr, NULL))
8111 : return MATCH_ERROR;
8112 :
8113 438 : if (!gfc_add_proc (&c->attr, name, NULL))
8114 : return MATCH_ERROR;
8115 :
8116 438 : if (num == 1)
8117 437 : c->tb = tb;
8118 : else
8119 : {
8120 1 : c->tb = XCNEW (gfc_typebound_proc);
8121 1 : c->tb->where = gfc_current_locus;
8122 1 : *c->tb = *tb;
8123 : }
8124 :
8125 438 : if (saved_kind_expr)
8126 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
8127 :
8128 : /* Set interface. */
8129 438 : if (proc_if != NULL)
8130 : {
8131 371 : c->ts.interface = proc_if;
8132 371 : c->attr.untyped = 1;
8133 371 : c->attr.if_source = IFSRC_IFBODY;
8134 : }
8135 67 : else if (ts.type != BT_UNKNOWN)
8136 : {
8137 29 : c->ts = ts;
8138 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
8139 29 : c->ts.interface->result = c->ts.interface;
8140 29 : c->ts.interface->ts = ts;
8141 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
8142 29 : c->ts.interface->attr.function = 1;
8143 29 : c->attr.function = 1;
8144 29 : c->attr.if_source = IFSRC_UNKNOWN;
8145 : }
8146 :
8147 438 : if (gfc_match (" =>") == MATCH_YES)
8148 : {
8149 85 : m = match_pointer_init (&initializer, 1);
8150 85 : if (m != MATCH_YES)
8151 : {
8152 0 : gfc_free_expr (initializer);
8153 0 : return m;
8154 : }
8155 85 : c->initializer = initializer;
8156 : }
8157 :
8158 438 : if (gfc_match_eos () == MATCH_YES)
8159 : return MATCH_YES;
8160 1 : if (gfc_match_char (',') != MATCH_YES)
8161 0 : goto syntax;
8162 : }
8163 :
8164 1 : syntax:
8165 1 : gfc_error ("Syntax error in procedure pointer component at %C");
8166 1 : return MATCH_ERROR;
8167 : }
8168 :
8169 :
8170 : /* Match a PROCEDURE declaration inside an interface (R1206). */
8171 :
8172 : static match
8173 1561 : match_procedure_in_interface (void)
8174 : {
8175 1561 : match m;
8176 1561 : gfc_symbol *sym;
8177 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
8178 1561 : locus old_locus;
8179 :
8180 1561 : if (current_interface.type == INTERFACE_NAMELESS
8181 1561 : || current_interface.type == INTERFACE_ABSTRACT)
8182 : {
8183 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
8184 1 : return MATCH_ERROR;
8185 : }
8186 :
8187 : /* Check if the F2008 optional double colon appears. */
8188 1560 : gfc_gobble_whitespace ();
8189 1560 : old_locus = gfc_current_locus;
8190 1560 : if (gfc_match ("::") == MATCH_YES)
8191 : {
8192 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8193 : "MODULE PROCEDURE statement at %L", &old_locus))
8194 : return MATCH_ERROR;
8195 : }
8196 : else
8197 685 : gfc_current_locus = old_locus;
8198 :
8199 2214 : for(;;)
8200 : {
8201 2214 : m = gfc_match_name (name);
8202 2214 : if (m == MATCH_NO)
8203 0 : goto syntax;
8204 2214 : else if (m == MATCH_ERROR)
8205 : return m;
8206 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
8207 : return MATCH_ERROR;
8208 :
8209 2214 : if (!gfc_add_interface (sym))
8210 : return MATCH_ERROR;
8211 :
8212 2213 : if (gfc_match_eos () == MATCH_YES)
8213 : break;
8214 655 : if (gfc_match_char (',') != MATCH_YES)
8215 0 : goto syntax;
8216 : }
8217 :
8218 : return MATCH_YES;
8219 :
8220 0 : syntax:
8221 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8222 0 : return MATCH_ERROR;
8223 : }
8224 :
8225 :
8226 : /* General matcher for PROCEDURE declarations. */
8227 :
8228 : static match match_procedure_in_type (void);
8229 :
8230 : match
8231 6459 : gfc_match_procedure (void)
8232 : {
8233 6459 : match m;
8234 :
8235 6459 : switch (gfc_current_state ())
8236 : {
8237 1199 : case COMP_NONE:
8238 1199 : case COMP_PROGRAM:
8239 1199 : case COMP_MODULE:
8240 1199 : case COMP_SUBMODULE:
8241 1199 : case COMP_SUBROUTINE:
8242 1199 : case COMP_FUNCTION:
8243 1199 : case COMP_BLOCK:
8244 1199 : m = match_procedure_decl ();
8245 1199 : break;
8246 1561 : case COMP_INTERFACE:
8247 1561 : m = match_procedure_in_interface ();
8248 1561 : break;
8249 445 : case COMP_DERIVED:
8250 445 : m = match_ppc_decl ();
8251 445 : break;
8252 3254 : case COMP_DERIVED_CONTAINS:
8253 3254 : m = match_procedure_in_type ();
8254 3254 : break;
8255 : default:
8256 : return MATCH_NO;
8257 : }
8258 :
8259 6459 : if (m != MATCH_YES)
8260 : return m;
8261 :
8262 6402 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8263 4 : return MATCH_ERROR;
8264 :
8265 : return m;
8266 : }
8267 :
8268 :
8269 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8270 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8271 : parser-state-stack to find out whether we're in a module. */
8272 :
8273 : static void
8274 64549 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8275 : {
8276 64549 : bool in_module;
8277 :
8278 129098 : in_module = (gfc_state_stack->previous
8279 64549 : && (gfc_state_stack->previous->state == COMP_MODULE
8280 52740 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8281 :
8282 64549 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8283 64549 : }
8284 :
8285 :
8286 : /* Match a function declaration. */
8287 :
8288 : match
8289 132152 : gfc_match_function_decl (void)
8290 : {
8291 132152 : char name[GFC_MAX_SYMBOL_LEN + 1];
8292 132152 : gfc_symbol *sym, *result;
8293 132152 : locus old_loc;
8294 132152 : match m;
8295 132152 : match suffix_match;
8296 132152 : match found_match; /* Status returned by match func. */
8297 :
8298 132152 : if (gfc_current_state () != COMP_NONE
8299 83385 : && gfc_current_state () != COMP_INTERFACE
8300 53872 : && gfc_current_state () != COMP_CONTAINS)
8301 : return MATCH_NO;
8302 :
8303 132152 : gfc_clear_ts (¤t_ts);
8304 :
8305 132152 : old_loc = gfc_current_locus;
8306 :
8307 132152 : m = gfc_match_prefix (¤t_ts);
8308 132152 : if (m != MATCH_YES)
8309 : {
8310 10225 : gfc_current_locus = old_loc;
8311 10225 : return m;
8312 : }
8313 :
8314 121927 : if (gfc_match ("function% %n", name) != MATCH_YES)
8315 : {
8316 101500 : gfc_current_locus = old_loc;
8317 101500 : return MATCH_NO;
8318 : }
8319 :
8320 20427 : if (get_proc_name (name, &sym, false))
8321 : return MATCH_ERROR;
8322 :
8323 20422 : if (add_hidden_procptr_result (sym))
8324 20 : sym = sym->result;
8325 :
8326 20422 : if (current_attr.module_procedure)
8327 : {
8328 304 : sym->attr.module_procedure = 1;
8329 304 : if (gfc_current_state () == COMP_INTERFACE)
8330 215 : gfc_current_ns->has_import_set = 1;
8331 : }
8332 :
8333 20422 : gfc_new_block = sym;
8334 :
8335 20422 : m = gfc_match_formal_arglist (sym, 0, 0);
8336 20422 : if (m == MATCH_NO)
8337 : {
8338 6 : gfc_error ("Expected formal argument list in function "
8339 : "definition at %C");
8340 6 : m = MATCH_ERROR;
8341 6 : goto cleanup;
8342 : }
8343 20416 : else if (m == MATCH_ERROR)
8344 0 : goto cleanup;
8345 :
8346 20416 : result = NULL;
8347 :
8348 : /* According to the draft, the bind(c) and result clause can
8349 : come in either order after the formal_arg_list (i.e., either
8350 : can be first, both can exist together or by themselves or neither
8351 : one). Therefore, the match_result can't match the end of the
8352 : string, and check for the bind(c) or result clause in either order. */
8353 20416 : found_match = gfc_match_eos ();
8354 :
8355 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8356 : must have been marked BIND(C) with a BIND(C) attribute and that is
8357 : not allowed for procedures. */
8358 20416 : if (sym->attr.is_bind_c == 1)
8359 : {
8360 3 : sym->attr.is_bind_c = 0;
8361 :
8362 3 : if (gfc_state_stack->previous
8363 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8364 : {
8365 1 : locus loc;
8366 1 : loc = sym->old_symbol != NULL
8367 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8368 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8369 : "variables or common blocks", &loc);
8370 : }
8371 : }
8372 :
8373 20416 : if (found_match != MATCH_YES)
8374 : {
8375 : /* If we haven't found the end-of-statement, look for a suffix. */
8376 8549 : suffix_match = gfc_match_suffix (sym, &result);
8377 8549 : if (suffix_match == MATCH_YES)
8378 : /* Need to get the eos now. */
8379 8541 : found_match = gfc_match_eos ();
8380 : else
8381 : found_match = suffix_match;
8382 : }
8383 :
8384 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8385 : subprogram and a binding label is specified, it shall be the
8386 : same as the binding label specified in the corresponding module
8387 : procedure interface body. */
8388 20416 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8389 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8390 3 : && sym->binding_label && sym->old_symbol->binding_label
8391 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8392 : {
8393 1 : const char *null = "NULL", *s1, *s2;
8394 1 : s1 = sym->binding_label;
8395 1 : if (!s1) s1 = null;
8396 1 : s2 = sym->old_symbol->binding_label;
8397 1 : if (!s2) s2 = null;
8398 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8399 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8400 1 : return MATCH_ERROR;
8401 : }
8402 :
8403 20415 : if(found_match != MATCH_YES)
8404 : m = MATCH_ERROR;
8405 : else
8406 : {
8407 : /* Make changes to the symbol. */
8408 20407 : m = MATCH_ERROR;
8409 :
8410 20407 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8411 0 : goto cleanup;
8412 :
8413 20407 : if (!gfc_missing_attr (&sym->attr, NULL))
8414 0 : goto cleanup;
8415 :
8416 20407 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8417 : {
8418 1 : if(!sym->attr.module_procedure)
8419 1 : goto cleanup;
8420 : else
8421 0 : gfc_error_check ();
8422 : }
8423 :
8424 : /* Delay matching the function characteristics until after the
8425 : specification block by signalling kind=-1. */
8426 20406 : sym->declared_at = old_loc;
8427 20406 : if (current_ts.type != BT_UNKNOWN)
8428 : current_ts.kind = -1;
8429 : else
8430 13334 : current_ts.kind = 0;
8431 :
8432 20406 : if (result == NULL)
8433 : {
8434 14381 : if (current_ts.type != BT_UNKNOWN
8435 14381 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8436 1 : goto cleanup;
8437 14380 : sym->result = sym;
8438 : }
8439 : else
8440 : {
8441 6025 : if (current_ts.type != BT_UNKNOWN
8442 6025 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8443 0 : goto cleanup;
8444 6025 : sym->result = result;
8445 : }
8446 :
8447 : /* Warn if this procedure has the same name as an intrinsic. */
8448 20405 : do_warn_intrinsic_shadow (sym, true);
8449 :
8450 20405 : return MATCH_YES;
8451 : }
8452 :
8453 16 : cleanup:
8454 16 : gfc_current_locus = old_loc;
8455 16 : return m;
8456 : }
8457 :
8458 :
8459 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8460 : pass the name of the entry, rather than the gfc_current_block name, and
8461 : to return false upon finding an existing global entry. */
8462 :
8463 : static bool
8464 539 : add_global_entry (const char *name, const char *binding_label, bool sub,
8465 : locus *where)
8466 : {
8467 539 : gfc_gsymbol *s;
8468 539 : enum gfc_symbol_type type;
8469 :
8470 539 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8471 :
8472 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8473 : name is a global identifier. */
8474 539 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8475 : {
8476 516 : s = gfc_get_gsymbol (name, false);
8477 :
8478 516 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8479 : {
8480 2 : gfc_global_used (s, where);
8481 2 : return false;
8482 : }
8483 : else
8484 : {
8485 514 : s->type = type;
8486 514 : s->sym_name = name;
8487 514 : s->where = *where;
8488 514 : s->defined = 1;
8489 514 : s->ns = gfc_current_ns;
8490 : }
8491 : }
8492 :
8493 : /* Don't add the symbol multiple times. */
8494 537 : if (binding_label
8495 537 : && (!gfc_notification_std (GFC_STD_F2008)
8496 0 : || strcmp (name, binding_label) != 0))
8497 : {
8498 23 : s = gfc_get_gsymbol (binding_label, true);
8499 :
8500 23 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8501 : {
8502 1 : gfc_global_used (s, where);
8503 1 : return false;
8504 : }
8505 : else
8506 : {
8507 22 : s->type = type;
8508 22 : s->sym_name = gfc_get_string ("%s", name);
8509 22 : s->binding_label = binding_label;
8510 22 : s->where = *where;
8511 22 : s->defined = 1;
8512 22 : s->ns = gfc_current_ns;
8513 : }
8514 : }
8515 :
8516 : return true;
8517 : }
8518 :
8519 :
8520 : /* Match an ENTRY statement. */
8521 :
8522 : match
8523 805 : gfc_match_entry (void)
8524 : {
8525 805 : gfc_symbol *proc;
8526 805 : gfc_symbol *result;
8527 805 : gfc_symbol *entry;
8528 805 : char name[GFC_MAX_SYMBOL_LEN + 1];
8529 805 : gfc_compile_state state;
8530 805 : match m;
8531 805 : gfc_entry_list *el;
8532 805 : locus old_loc;
8533 805 : bool module_procedure;
8534 805 : char peek_char;
8535 805 : match is_bind_c;
8536 :
8537 805 : m = gfc_match_name (name);
8538 805 : if (m != MATCH_YES)
8539 : return m;
8540 :
8541 805 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8542 : return MATCH_ERROR;
8543 :
8544 805 : state = gfc_current_state ();
8545 805 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8546 : {
8547 3 : switch (state)
8548 : {
8549 0 : case COMP_PROGRAM:
8550 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8551 0 : break;
8552 0 : case COMP_MODULE:
8553 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8554 0 : break;
8555 0 : case COMP_SUBMODULE:
8556 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8557 0 : break;
8558 0 : case COMP_BLOCK_DATA:
8559 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8560 : "a BLOCK DATA");
8561 0 : break;
8562 0 : case COMP_INTERFACE:
8563 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8564 : "an INTERFACE");
8565 0 : break;
8566 1 : case COMP_STRUCTURE:
8567 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8568 : "a STRUCTURE block");
8569 1 : break;
8570 0 : case COMP_DERIVED:
8571 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8572 : "a DERIVED TYPE block");
8573 0 : break;
8574 0 : case COMP_IF:
8575 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8576 : "an IF-THEN block");
8577 0 : break;
8578 0 : case COMP_DO:
8579 0 : case COMP_DO_CONCURRENT:
8580 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8581 : "a DO block");
8582 0 : break;
8583 0 : case COMP_SELECT:
8584 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8585 : "a SELECT block");
8586 0 : break;
8587 0 : case COMP_FORALL:
8588 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8589 : "a FORALL block");
8590 0 : break;
8591 0 : case COMP_WHERE:
8592 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8593 : "a WHERE block");
8594 0 : break;
8595 0 : case COMP_CONTAINS:
8596 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8597 : "a contained subprogram");
8598 0 : break;
8599 2 : default:
8600 2 : gfc_error ("Unexpected ENTRY statement at %C");
8601 : }
8602 : return MATCH_ERROR;
8603 : }
8604 :
8605 802 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8606 802 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8607 : {
8608 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8609 1 : return MATCH_ERROR;
8610 : }
8611 :
8612 1602 : module_procedure = gfc_current_ns->parent != NULL
8613 260 : && gfc_current_ns->parent->proc_name
8614 801 : && gfc_current_ns->parent->proc_name->attr.flavor
8615 260 : == FL_MODULE;
8616 :
8617 801 : if (gfc_current_ns->parent != NULL
8618 260 : && gfc_current_ns->parent->proc_name
8619 260 : && !module_procedure)
8620 : {
8621 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8622 : "contained procedure");
8623 0 : return MATCH_ERROR;
8624 : }
8625 :
8626 : /* Module function entries need special care in get_proc_name
8627 : because previous references within the function will have
8628 : created symbols attached to the current namespace. */
8629 1342 : if (get_proc_name (name, &entry,
8630 : gfc_current_ns->parent != NULL
8631 : && module_procedure))
8632 : return MATCH_ERROR;
8633 :
8634 799 : proc = gfc_current_block ();
8635 :
8636 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8637 : must have been marked BIND(C) with a BIND(C) attribute and that is
8638 : not allowed for procedures. */
8639 799 : if (entry->attr.is_bind_c == 1)
8640 : {
8641 0 : locus loc;
8642 :
8643 0 : entry->attr.is_bind_c = 0;
8644 :
8645 0 : loc = entry->old_symbol != NULL
8646 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8647 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8648 : "variables or common blocks", &loc);
8649 : }
8650 :
8651 : /* Check what next non-whitespace character is so we can tell if there
8652 : is the required parens if we have a BIND(C). */
8653 799 : old_loc = gfc_current_locus;
8654 799 : gfc_gobble_whitespace ();
8655 799 : peek_char = gfc_peek_ascii_char ();
8656 :
8657 799 : if (state == COMP_SUBROUTINE)
8658 : {
8659 138 : m = gfc_match_formal_arglist (entry, 0, 1);
8660 138 : if (m != MATCH_YES)
8661 : return MATCH_ERROR;
8662 :
8663 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8664 : never be an internal procedure. */
8665 138 : is_bind_c = gfc_match_bind_c (entry, true);
8666 138 : if (is_bind_c == MATCH_ERROR)
8667 : return MATCH_ERROR;
8668 138 : if (is_bind_c == MATCH_YES)
8669 : {
8670 22 : if (peek_char != '(')
8671 : {
8672 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8673 0 : return MATCH_ERROR;
8674 : }
8675 :
8676 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8677 22 : &(entry->declared_at), 1))
8678 : return MATCH_ERROR;
8679 :
8680 : }
8681 :
8682 138 : if (!gfc_current_ns->parent
8683 138 : && !add_global_entry (name, entry->binding_label, true,
8684 : &old_loc))
8685 : return MATCH_ERROR;
8686 :
8687 : /* An entry in a subroutine. */
8688 135 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8689 135 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8690 : return MATCH_ERROR;
8691 : }
8692 : else
8693 : {
8694 : /* An entry in a function.
8695 : We need to take special care because writing
8696 : ENTRY f()
8697 : as
8698 : ENTRY f
8699 : is allowed, whereas
8700 : ENTRY f() RESULT (r)
8701 : can't be written as
8702 : ENTRY f RESULT (r). */
8703 661 : if (gfc_match_eos () == MATCH_YES)
8704 : {
8705 24 : gfc_current_locus = old_loc;
8706 : /* Match the empty argument list, and add the interface to
8707 : the symbol. */
8708 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8709 : }
8710 : else
8711 637 : m = gfc_match_formal_arglist (entry, 0, 0);
8712 :
8713 661 : if (m != MATCH_YES)
8714 : return MATCH_ERROR;
8715 :
8716 660 : result = NULL;
8717 :
8718 660 : if (gfc_match_eos () == MATCH_YES)
8719 : {
8720 411 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8721 411 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8722 : return MATCH_ERROR;
8723 :
8724 409 : entry->result = entry;
8725 : }
8726 : else
8727 : {
8728 249 : m = gfc_match_suffix (entry, &result);
8729 249 : if (m == MATCH_NO)
8730 0 : gfc_syntax_error (ST_ENTRY);
8731 249 : if (m != MATCH_YES)
8732 : return MATCH_ERROR;
8733 :
8734 249 : if (result)
8735 : {
8736 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8737 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8738 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8739 : return MATCH_ERROR;
8740 212 : entry->result = result;
8741 : }
8742 : else
8743 : {
8744 37 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8745 37 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8746 : return MATCH_ERROR;
8747 37 : entry->result = entry;
8748 : }
8749 : }
8750 :
8751 658 : if (!gfc_current_ns->parent
8752 658 : && !add_global_entry (name, entry->binding_label, false,
8753 : &old_loc))
8754 : return MATCH_ERROR;
8755 : }
8756 :
8757 790 : if (gfc_match_eos () != MATCH_YES)
8758 : {
8759 0 : gfc_syntax_error (ST_ENTRY);
8760 0 : return MATCH_ERROR;
8761 : }
8762 :
8763 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8764 790 : if (proc->attr.elemental && entry->attr.is_bind_c)
8765 : {
8766 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8767 : "elemental procedure", &entry->declared_at);
8768 2 : return MATCH_ERROR;
8769 : }
8770 :
8771 788 : entry->attr.recursive = proc->attr.recursive;
8772 788 : entry->attr.elemental = proc->attr.elemental;
8773 788 : entry->attr.pure = proc->attr.pure;
8774 :
8775 788 : el = gfc_get_entry_list ();
8776 788 : el->sym = entry;
8777 788 : el->next = gfc_current_ns->entries;
8778 788 : gfc_current_ns->entries = el;
8779 788 : if (el->next)
8780 85 : el->id = el->next->id + 1;
8781 : else
8782 : el->id = 1;
8783 :
8784 788 : new_st.op = EXEC_ENTRY;
8785 788 : new_st.ext.entry = el;
8786 :
8787 788 : return MATCH_YES;
8788 : }
8789 :
8790 :
8791 : /* Match a subroutine statement, including optional prefixes. */
8792 :
8793 : match
8794 824624 : gfc_match_subroutine (void)
8795 : {
8796 824624 : char name[GFC_MAX_SYMBOL_LEN + 1];
8797 824624 : gfc_symbol *sym;
8798 824624 : match m;
8799 824624 : match is_bind_c;
8800 824624 : char peek_char;
8801 824624 : bool allow_binding_name;
8802 824624 : locus loc;
8803 :
8804 824624 : if (gfc_current_state () != COMP_NONE
8805 781767 : && gfc_current_state () != COMP_INTERFACE
8806 758866 : && gfc_current_state () != COMP_CONTAINS)
8807 : return MATCH_NO;
8808 :
8809 108815 : m = gfc_match_prefix (NULL);
8810 108815 : if (m != MATCH_YES)
8811 : return m;
8812 :
8813 98600 : loc = gfc_current_locus;
8814 98600 : m = gfc_match ("subroutine% %n", name);
8815 98600 : if (m != MATCH_YES)
8816 : return m;
8817 :
8818 44180 : if (get_proc_name (name, &sym, false))
8819 : return MATCH_ERROR;
8820 :
8821 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8822 : the symbol existed before. */
8823 44169 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8824 : &gfc_current_locus);
8825 :
8826 44169 : if (current_attr.module_procedure)
8827 : {
8828 429 : sym->attr.module_procedure = 1;
8829 429 : if (gfc_current_state () == COMP_INTERFACE)
8830 302 : gfc_current_ns->has_import_set = 1;
8831 : }
8832 :
8833 44169 : if (add_hidden_procptr_result (sym))
8834 9 : sym = sym->result;
8835 :
8836 44169 : gfc_new_block = sym;
8837 :
8838 : /* Check what next non-whitespace character is so we can tell if there
8839 : is the required parens if we have a BIND(C). */
8840 44169 : gfc_gobble_whitespace ();
8841 44169 : peek_char = gfc_peek_ascii_char ();
8842 :
8843 44169 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8844 : return MATCH_ERROR;
8845 :
8846 44166 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8847 : return MATCH_ERROR;
8848 :
8849 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8850 : must have been marked BIND(C) with a BIND(C) attribute and that is
8851 : not allowed for procedures. */
8852 44166 : if (sym->attr.is_bind_c == 1)
8853 : {
8854 4 : sym->attr.is_bind_c = 0;
8855 :
8856 4 : if (gfc_state_stack->previous
8857 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8858 : {
8859 2 : locus loc;
8860 2 : loc = sym->old_symbol != NULL
8861 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8862 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8863 : "variables or common blocks", &loc);
8864 : }
8865 : }
8866 :
8867 : /* C binding names are not allowed for internal procedures. */
8868 44166 : if (gfc_current_state () == COMP_CONTAINS
8869 27032 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8870 : allow_binding_name = false;
8871 : else
8872 28763 : allow_binding_name = true;
8873 :
8874 : /* Here, we are just checking if it has the bind(c) attribute, and if
8875 : so, then we need to make sure it's all correct. If it doesn't,
8876 : we still need to continue matching the rest of the subroutine line. */
8877 44166 : gfc_gobble_whitespace ();
8878 44166 : loc = gfc_current_locus;
8879 44166 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8880 44166 : if (is_bind_c == MATCH_ERROR)
8881 : {
8882 : /* There was an attempt at the bind(c), but it was wrong. An
8883 : error message should have been printed w/in the gfc_match_bind_c
8884 : so here we'll just return the MATCH_ERROR. */
8885 : return MATCH_ERROR;
8886 : }
8887 :
8888 44153 : if (is_bind_c == MATCH_YES)
8889 : {
8890 4055 : gfc_formal_arglist *arg;
8891 :
8892 : /* The following is allowed in the Fortran 2008 draft. */
8893 4055 : if (gfc_current_state () == COMP_CONTAINS
8894 1301 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8895 4466 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8896 : "at %L may not be specified for an internal "
8897 : "procedure", &gfc_current_locus))
8898 : return MATCH_ERROR;
8899 :
8900 4052 : if (peek_char != '(')
8901 : {
8902 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8903 1 : return MATCH_ERROR;
8904 : }
8905 :
8906 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8907 : subprogram and a binding label is specified, it shall be the
8908 : same as the binding label specified in the corresponding module
8909 : procedure interface body. */
8910 4051 : if (sym->attr.module_procedure && sym->old_symbol
8911 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8912 3 : && sym->binding_label && sym->old_symbol->binding_label
8913 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8914 : {
8915 1 : const char *null = "NULL", *s1, *s2;
8916 1 : s1 = sym->binding_label;
8917 1 : if (!s1) s1 = null;
8918 1 : s2 = sym->old_symbol->binding_label;
8919 1 : if (!s2) s2 = null;
8920 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8921 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8922 1 : return MATCH_ERROR;
8923 : }
8924 :
8925 : /* Scan the dummy arguments for an alternate return. */
8926 12539 : for (arg = sym->formal; arg; arg = arg->next)
8927 8490 : if (!arg->sym)
8928 : {
8929 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8930 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8931 1 : return MATCH_ERROR;
8932 : }
8933 :
8934 4049 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8935 : return MATCH_ERROR;
8936 : }
8937 :
8938 44146 : if (gfc_match_eos () != MATCH_YES)
8939 : {
8940 1 : gfc_syntax_error (ST_SUBROUTINE);
8941 1 : return MATCH_ERROR;
8942 : }
8943 :
8944 44145 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8945 : {
8946 4 : if(!sym->attr.module_procedure)
8947 : return MATCH_ERROR;
8948 : else
8949 3 : gfc_error_check ();
8950 : }
8951 :
8952 : /* Warn if it has the same name as an intrinsic. */
8953 44144 : do_warn_intrinsic_shadow (sym, false);
8954 :
8955 44144 : return MATCH_YES;
8956 : }
8957 :
8958 :
8959 : /* Check that the NAME identifier in a BIND attribute or statement
8960 : is conform to C identifier rules. */
8961 :
8962 : match
8963 1193 : check_bind_name_identifier (char **name)
8964 : {
8965 1193 : char *n = *name, *p;
8966 :
8967 : /* Remove leading spaces. */
8968 1219 : while (*n == ' ')
8969 26 : n++;
8970 :
8971 : /* On an empty string, free memory and set name to NULL. */
8972 1193 : if (*n == '\0')
8973 : {
8974 42 : free (*name);
8975 42 : *name = NULL;
8976 42 : return MATCH_YES;
8977 : }
8978 :
8979 : /* Remove trailing spaces. */
8980 1151 : p = n + strlen(n) - 1;
8981 1167 : while (*p == ' ')
8982 16 : *(p--) = '\0';
8983 :
8984 : /* Insert the identifier into the symbol table. */
8985 1151 : p = xstrdup (n);
8986 1151 : free (*name);
8987 1151 : *name = p;
8988 :
8989 : /* Now check that identifier is valid under C rules. */
8990 1151 : if (ISDIGIT (*p))
8991 : {
8992 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8993 2 : return MATCH_ERROR;
8994 : }
8995 :
8996 12572 : for (; *p; p++)
8997 11426 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8998 : {
8999 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
9000 3 : return MATCH_ERROR;
9001 : }
9002 :
9003 : return MATCH_YES;
9004 : }
9005 :
9006 :
9007 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
9008 : given, and set the binding label in either the given symbol (if not
9009 : NULL), or in the current_ts. The symbol may be NULL because we may
9010 : encounter the BIND(C) before the declaration itself. Return
9011 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
9012 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
9013 : or MATCH_YES if the specifier was correct and the binding label and
9014 : bind(c) fields were set correctly for the given symbol or the
9015 : current_ts. If allow_binding_name is false, no binding name may be
9016 : given. */
9017 :
9018 : match
9019 53405 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
9020 : {
9021 53405 : char *binding_label = NULL;
9022 53405 : gfc_expr *e = NULL;
9023 :
9024 : /* Initialize the flag that specifies whether we encountered a NAME=
9025 : specifier or not. */
9026 53405 : has_name_equals = 0;
9027 :
9028 : /* This much we have to be able to match, in this order, if
9029 : there is a bind(c) label. */
9030 53405 : if (gfc_match (" bind ( c ") != MATCH_YES)
9031 : return MATCH_NO;
9032 :
9033 : /* Now see if there is a binding label, or if we've reached the
9034 : end of the bind(c) attribute without one. */
9035 7466 : if (gfc_match_char (',') == MATCH_YES)
9036 : {
9037 1200 : if (gfc_match (" name = ") != MATCH_YES)
9038 : {
9039 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
9040 : "at %C");
9041 : /* should give an error message here */
9042 1 : return MATCH_ERROR;
9043 : }
9044 :
9045 1199 : has_name_equals = 1;
9046 :
9047 1199 : if (gfc_match_init_expr (&e) != MATCH_YES)
9048 : {
9049 2 : gfc_free_expr (e);
9050 2 : return MATCH_ERROR;
9051 : }
9052 :
9053 1197 : if (!gfc_simplify_expr(e, 0))
9054 : {
9055 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
9056 0 : gfc_free_expr (e);
9057 0 : return MATCH_ERROR;
9058 : }
9059 :
9060 1197 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
9061 1194 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
9062 : {
9063 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
9064 : "default character kind");
9065 4 : gfc_free_expr(e);
9066 4 : return MATCH_ERROR;
9067 : }
9068 :
9069 : // Get a C string from the Fortran string constant
9070 2386 : binding_label = gfc_widechar_to_char (e->value.character.string,
9071 1193 : e->value.character.length);
9072 1193 : gfc_free_expr(e);
9073 :
9074 : // Check that it is valid (old gfc_match_name_C)
9075 1193 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
9076 : return MATCH_ERROR;
9077 : }
9078 :
9079 : /* Get the required right paren. */
9080 7454 : if (gfc_match_char (')') != MATCH_YES)
9081 : {
9082 1 : gfc_error ("Missing closing paren for binding label at %C");
9083 1 : return MATCH_ERROR;
9084 : }
9085 :
9086 7453 : if (has_name_equals && !allow_binding_name)
9087 : {
9088 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
9089 6 : return MATCH_ERROR;
9090 : }
9091 :
9092 7447 : if (has_name_equals && sym != NULL && sym->attr.dummy)
9093 : {
9094 2 : gfc_error ("For dummy procedure %s, no binding name is "
9095 : "allowed in BIND(C) at %C", sym->name);
9096 2 : return MATCH_ERROR;
9097 : }
9098 :
9099 :
9100 : /* Save the binding label to the symbol. If sym is null, we're
9101 : probably matching the typespec attributes of a declaration and
9102 : haven't gotten the name yet, and therefore, no symbol yet. */
9103 7445 : if (binding_label)
9104 : {
9105 1139 : if (sym != NULL)
9106 1029 : sym->binding_label = binding_label;
9107 : else
9108 110 : curr_binding_label = binding_label;
9109 : }
9110 6306 : else if (allow_binding_name)
9111 : {
9112 : /* No binding label, but if symbol isn't null, we
9113 : can set the label for it here.
9114 : If name="" or allow_binding_name is false, no C binding name is
9115 : created. */
9116 5877 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
9117 5710 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
9118 : }
9119 :
9120 7445 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
9121 747 : && current_interface.type == INTERFACE_ABSTRACT)
9122 : {
9123 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
9124 1 : return MATCH_ERROR;
9125 : }
9126 :
9127 : return MATCH_YES;
9128 : }
9129 :
9130 :
9131 : /* Return nonzero if we're currently compiling a contained procedure. */
9132 :
9133 : static int
9134 64876 : contained_procedure (void)
9135 : {
9136 64876 : gfc_state_data *s = gfc_state_stack;
9137 :
9138 64876 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
9139 63889 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
9140 37755 : return 1;
9141 :
9142 : return 0;
9143 : }
9144 :
9145 : /* Set the kind of each enumerator. The kind is selected such that it is
9146 : interoperable with the corresponding C enumeration type, making
9147 : sure that -fshort-enums is honored. */
9148 :
9149 : static void
9150 158 : set_enum_kind(void)
9151 : {
9152 158 : enumerator_history *current_history = NULL;
9153 158 : int kind;
9154 158 : int i;
9155 :
9156 158 : if (max_enum == NULL || enum_history == NULL)
9157 : return;
9158 :
9159 150 : if (!flag_short_enums)
9160 : return;
9161 :
9162 : i = 0;
9163 48 : do
9164 : {
9165 48 : kind = gfc_integer_kinds[i++].kind;
9166 : }
9167 48 : while (kind < gfc_c_int_kind
9168 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
9169 : kind) != ARITH_OK);
9170 :
9171 24 : current_history = enum_history;
9172 96 : while (current_history != NULL)
9173 : {
9174 72 : current_history->sym->ts.kind = kind;
9175 72 : current_history = current_history->next;
9176 : }
9177 : }
9178 :
9179 :
9180 : /* Match any of the various end-block statements. Returns the type of
9181 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
9182 : and END BLOCK statements cannot be replaced by a single END statement. */
9183 :
9184 : match
9185 190691 : gfc_match_end (gfc_statement *st)
9186 : {
9187 190691 : char name[GFC_MAX_SYMBOL_LEN + 1];
9188 190691 : gfc_compile_state state;
9189 190691 : locus old_loc;
9190 190691 : const char *block_name;
9191 190691 : const char *target;
9192 190691 : int eos_ok;
9193 190691 : match m;
9194 190691 : gfc_namespace *parent_ns, *ns, *prev_ns;
9195 190691 : gfc_namespace **nsp;
9196 190691 : bool abbreviated_modproc_decl = false;
9197 190691 : bool got_matching_end = false;
9198 :
9199 190691 : old_loc = gfc_current_locus;
9200 190691 : if (gfc_match ("end") != MATCH_YES)
9201 : return MATCH_NO;
9202 :
9203 185544 : state = gfc_current_state ();
9204 101976 : block_name = gfc_current_block () == NULL
9205 185544 : ? NULL : gfc_current_block ()->name;
9206 :
9207 185544 : switch (state)
9208 : {
9209 3332 : case COMP_ASSOCIATE:
9210 3332 : case COMP_BLOCK:
9211 3332 : case COMP_CHANGE_TEAM:
9212 3332 : if (startswith (block_name, "block@"))
9213 : block_name = NULL;
9214 : break;
9215 :
9216 18070 : case COMP_CONTAINS:
9217 18070 : case COMP_DERIVED_CONTAINS:
9218 18070 : case COMP_OMP_BEGIN_METADIRECTIVE:
9219 18070 : state = gfc_state_stack->previous->state;
9220 16498 : block_name = gfc_state_stack->previous->sym == NULL
9221 18070 : ? NULL : gfc_state_stack->previous->sym->name;
9222 18070 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
9223 18070 : && gfc_state_stack->previous->sym->abr_modproc_decl;
9224 : break;
9225 :
9226 : case COMP_OMP_METADIRECTIVE:
9227 : {
9228 : /* Metadirectives can be nested, so we need to drill down to the
9229 : first state that is not COMP_OMP_METADIRECTIVE. */
9230 : gfc_state_data *state_data = gfc_state_stack;
9231 :
9232 93 : do
9233 : {
9234 93 : state_data = state_data->previous;
9235 93 : state = state_data->state;
9236 81 : block_name = (state_data->sym == NULL
9237 93 : ? NULL : state_data->sym->name);
9238 186 : abbreviated_modproc_decl = (state_data->sym
9239 93 : && state_data->sym->abr_modproc_decl);
9240 : }
9241 93 : while (state == COMP_OMP_METADIRECTIVE);
9242 :
9243 87 : if (block_name && startswith (block_name, "block@"))
9244 : block_name = NULL;
9245 : }
9246 : break;
9247 :
9248 : default:
9249 : break;
9250 : }
9251 :
9252 87 : if (!abbreviated_modproc_decl)
9253 185543 : abbreviated_modproc_decl = gfc_current_block ()
9254 185543 : && gfc_current_block ()->abr_modproc_decl;
9255 :
9256 185544 : switch (state)
9257 : {
9258 28663 : case COMP_NONE:
9259 28663 : case COMP_PROGRAM:
9260 28663 : *st = ST_END_PROGRAM;
9261 28663 : target = " program";
9262 28663 : eos_ok = 1;
9263 28663 : break;
9264 :
9265 44337 : case COMP_SUBROUTINE:
9266 44337 : *st = ST_END_SUBROUTINE;
9267 44337 : if (!abbreviated_modproc_decl)
9268 : target = " subroutine";
9269 : else
9270 148 : target = " procedure";
9271 44337 : eos_ok = !contained_procedure ();
9272 44337 : break;
9273 :
9274 20539 : case COMP_FUNCTION:
9275 20539 : *st = ST_END_FUNCTION;
9276 20539 : if (!abbreviated_modproc_decl)
9277 : target = " function";
9278 : else
9279 117 : target = " procedure";
9280 20539 : eos_ok = !contained_procedure ();
9281 20539 : break;
9282 :
9283 87 : case COMP_BLOCK_DATA:
9284 87 : *st = ST_END_BLOCK_DATA;
9285 87 : target = " block data";
9286 87 : eos_ok = 1;
9287 87 : break;
9288 :
9289 10207 : case COMP_MODULE:
9290 10207 : *st = ST_END_MODULE;
9291 10207 : target = " module";
9292 10207 : eos_ok = 1;
9293 10207 : break;
9294 :
9295 268 : case COMP_SUBMODULE:
9296 268 : *st = ST_END_SUBMODULE;
9297 268 : target = " submodule";
9298 268 : eos_ok = 1;
9299 268 : break;
9300 :
9301 11393 : case COMP_INTERFACE:
9302 11393 : *st = ST_END_INTERFACE;
9303 11393 : target = " interface";
9304 11393 : eos_ok = 0;
9305 11393 : break;
9306 :
9307 257 : case COMP_MAP:
9308 257 : *st = ST_END_MAP;
9309 257 : target = " map";
9310 257 : eos_ok = 0;
9311 257 : break;
9312 :
9313 132 : case COMP_UNION:
9314 132 : *st = ST_END_UNION;
9315 132 : target = " union";
9316 132 : eos_ok = 0;
9317 132 : break;
9318 :
9319 313 : case COMP_STRUCTURE:
9320 313 : *st = ST_END_STRUCTURE;
9321 313 : target = " structure";
9322 313 : eos_ok = 0;
9323 313 : break;
9324 :
9325 13707 : case COMP_DERIVED:
9326 13707 : case COMP_DERIVED_CONTAINS:
9327 13707 : *st = ST_END_TYPE;
9328 13707 : target = " type";
9329 13707 : eos_ok = 0;
9330 13707 : break;
9331 :
9332 1684 : case COMP_ASSOCIATE:
9333 1684 : *st = ST_END_ASSOCIATE;
9334 1684 : target = " associate";
9335 1684 : eos_ok = 0;
9336 1684 : break;
9337 :
9338 1546 : case COMP_BLOCK:
9339 1546 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9340 1546 : *st = ST_END_BLOCK;
9341 1546 : target = " block";
9342 1546 : eos_ok = 0;
9343 1546 : break;
9344 :
9345 15072 : case COMP_IF:
9346 15072 : *st = ST_ENDIF;
9347 15072 : target = " if";
9348 15072 : eos_ok = 0;
9349 15072 : break;
9350 :
9351 31283 : case COMP_DO:
9352 31283 : case COMP_DO_CONCURRENT:
9353 31283 : *st = ST_ENDDO;
9354 31283 : target = " do";
9355 31283 : eos_ok = 0;
9356 31283 : break;
9357 :
9358 54 : case COMP_CRITICAL:
9359 54 : *st = ST_END_CRITICAL;
9360 54 : target = " critical";
9361 54 : eos_ok = 0;
9362 54 : break;
9363 :
9364 4821 : case COMP_SELECT:
9365 4821 : case COMP_SELECT_TYPE:
9366 4821 : case COMP_SELECT_RANK:
9367 4821 : *st = ST_END_SELECT;
9368 4821 : target = " select";
9369 4821 : eos_ok = 0;
9370 4821 : break;
9371 :
9372 509 : case COMP_FORALL:
9373 509 : *st = ST_END_FORALL;
9374 509 : target = " forall";
9375 509 : eos_ok = 0;
9376 509 : break;
9377 :
9378 373 : case COMP_WHERE:
9379 373 : *st = ST_END_WHERE;
9380 373 : target = " where";
9381 373 : eos_ok = 0;
9382 373 : break;
9383 :
9384 158 : case COMP_ENUM:
9385 158 : *st = ST_END_ENUM;
9386 158 : target = " enum";
9387 158 : eos_ok = 0;
9388 158 : last_initializer = NULL;
9389 158 : set_enum_kind ();
9390 158 : gfc_free_enum_history ();
9391 158 : break;
9392 :
9393 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9394 0 : *st = ST_OMP_END_METADIRECTIVE;
9395 0 : target = " metadirective";
9396 0 : eos_ok = 0;
9397 0 : break;
9398 :
9399 132 : case COMP_CHANGE_TEAM:
9400 132 : *st = ST_END_TEAM;
9401 132 : target = " team";
9402 132 : eos_ok = 0;
9403 132 : break;
9404 :
9405 9 : default:
9406 9 : gfc_error ("Unexpected END statement at %C");
9407 9 : goto cleanup;
9408 : }
9409 :
9410 185535 : old_loc = gfc_current_locus;
9411 185535 : if (gfc_match_eos () == MATCH_YES)
9412 : {
9413 20950 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9414 : {
9415 8305 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9416 : "instead of %s statement at %L",
9417 : abbreviated_modproc_decl ? "END PROCEDURE"
9418 4140 : : gfc_ascii_statement(*st), &old_loc))
9419 4 : goto cleanup;
9420 : }
9421 9 : else if (!eos_ok)
9422 : {
9423 : /* We would have required END [something]. */
9424 9 : gfc_error ("%s statement expected at %L",
9425 : gfc_ascii_statement (*st), &old_loc);
9426 9 : goto cleanup;
9427 : }
9428 :
9429 : return MATCH_YES;
9430 : }
9431 :
9432 : /* Verify that we've got the sort of end-block that we're expecting. */
9433 164585 : if (gfc_match (target) != MATCH_YES)
9434 : {
9435 331 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9436 165 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9437 166 : goto cleanup;
9438 : }
9439 : else
9440 164419 : got_matching_end = true;
9441 :
9442 164419 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9443 : /* Emit errors of stat and errmsg parsing now to finish the block and
9444 : continue analysis of compilation unit. */
9445 2 : gfc_error_check ();
9446 :
9447 164419 : old_loc = gfc_current_locus;
9448 : /* If we're at the end, make sure a block name wasn't required. */
9449 164419 : if (gfc_match_eos () == MATCH_YES)
9450 : {
9451 108978 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9452 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9453 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9454 : && *st != ST_END_TEAM)
9455 : return MATCH_YES;
9456 :
9457 54975 : if (!block_name)
9458 : return MATCH_YES;
9459 :
9460 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9461 : block_name, gfc_ascii_statement (*st), &old_loc);
9462 :
9463 8 : return MATCH_ERROR;
9464 : }
9465 :
9466 : /* END INTERFACE has a special handler for its several possible endings. */
9467 55441 : if (*st == ST_END_INTERFACE)
9468 696 : return gfc_match_end_interface ();
9469 :
9470 : /* We haven't hit the end of statement, so what is left must be an
9471 : end-name. */
9472 54745 : m = gfc_match_space ();
9473 54745 : if (m == MATCH_YES)
9474 54745 : m = gfc_match_name (name);
9475 :
9476 54745 : if (m == MATCH_NO)
9477 0 : gfc_error ("Expected terminating name at %C");
9478 54745 : if (m != MATCH_YES)
9479 0 : goto cleanup;
9480 :
9481 54745 : if (block_name == NULL)
9482 15 : goto syntax;
9483 :
9484 : /* We have to pick out the declared submodule name from the composite
9485 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9486 54730 : if (state == COMP_SUBMODULE)
9487 137 : block_name = strchr (block_name, '.') + 1;
9488 :
9489 54730 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9490 : {
9491 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9492 : gfc_ascii_statement (*st));
9493 8 : goto cleanup;
9494 : }
9495 : /* Procedure pointer as function result. */
9496 54722 : else if (strcmp (block_name, "ppr@") == 0
9497 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9498 : {
9499 0 : gfc_error ("Expected label %qs for %s statement at %C",
9500 0 : gfc_current_block ()->ns->proc_name->name,
9501 : gfc_ascii_statement (*st));
9502 0 : goto cleanup;
9503 : }
9504 :
9505 54722 : if (gfc_match_eos () == MATCH_YES)
9506 : return MATCH_YES;
9507 :
9508 0 : syntax:
9509 15 : gfc_syntax_error (*st);
9510 :
9511 211 : cleanup:
9512 211 : gfc_current_locus = old_loc;
9513 :
9514 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9515 : Remove it from the parent namespace's sibling list. */
9516 :
9517 211 : if (state == COMP_BLOCK && !got_matching_end)
9518 : {
9519 7 : parent_ns = gfc_current_ns->parent;
9520 :
9521 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9522 :
9523 7 : prev_ns = NULL;
9524 7 : ns = *nsp;
9525 14 : while (ns)
9526 : {
9527 7 : if (ns == gfc_current_ns)
9528 : {
9529 7 : if (prev_ns == NULL)
9530 7 : *nsp = NULL;
9531 : else
9532 0 : prev_ns->sibling = ns->sibling;
9533 : }
9534 7 : prev_ns = ns;
9535 7 : ns = ns->sibling;
9536 : }
9537 :
9538 : /* The namespace can still be referenced by parser state and code nodes;
9539 : let normal block unwinding/freeing own its lifetime. */
9540 7 : gfc_current_ns = parent_ns;
9541 7 : gfc_state_stack = gfc_state_stack->previous;
9542 7 : state = gfc_current_state ();
9543 : }
9544 :
9545 : return MATCH_ERROR;
9546 : }
9547 :
9548 :
9549 :
9550 : /***************** Attribute declaration statements ****************/
9551 :
9552 : /* Set the attribute of a single variable. */
9553 :
9554 : static match
9555 10428 : attr_decl1 (void)
9556 : {
9557 10428 : char name[GFC_MAX_SYMBOL_LEN + 1];
9558 10428 : gfc_array_spec *as;
9559 :
9560 : /* Workaround -Wmaybe-uninitialized false positive during
9561 : profiledbootstrap by initializing them. */
9562 10428 : gfc_symbol *sym = NULL;
9563 10428 : locus var_locus;
9564 10428 : match m;
9565 :
9566 10428 : as = NULL;
9567 :
9568 10428 : m = gfc_match_name (name);
9569 10428 : if (m != MATCH_YES)
9570 0 : goto cleanup;
9571 :
9572 10428 : if (find_special (name, &sym, false))
9573 : return MATCH_ERROR;
9574 :
9575 10428 : if (!check_function_name (name))
9576 : {
9577 7 : m = MATCH_ERROR;
9578 7 : goto cleanup;
9579 : }
9580 :
9581 10421 : var_locus = gfc_current_locus;
9582 :
9583 : /* Deal with possible array specification for certain attributes. */
9584 10421 : if (current_attr.dimension
9585 8842 : || current_attr.codimension
9586 8820 : || current_attr.allocatable
9587 8396 : || current_attr.pointer
9588 7673 : || current_attr.target)
9589 : {
9590 6174 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9591 : !current_attr.dimension
9592 1395 : && !current_attr.pointer
9593 : && !current_attr.target);
9594 2974 : if (m == MATCH_ERROR)
9595 2 : goto cleanup;
9596 :
9597 2972 : if (current_attr.dimension && m == MATCH_NO)
9598 : {
9599 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9600 : "statement", &var_locus);
9601 0 : m = MATCH_ERROR;
9602 0 : goto cleanup;
9603 : }
9604 :
9605 2972 : if (current_attr.dimension && sym->value)
9606 : {
9607 1 : gfc_error ("Dimensions specified for %s at %L after its "
9608 : "initialization", sym->name, &var_locus);
9609 1 : m = MATCH_ERROR;
9610 1 : goto cleanup;
9611 : }
9612 :
9613 2971 : if (current_attr.codimension && m == MATCH_NO)
9614 : {
9615 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9616 : "statement", &var_locus);
9617 0 : m = MATCH_ERROR;
9618 0 : goto cleanup;
9619 : }
9620 :
9621 2971 : if ((current_attr.allocatable || current_attr.pointer)
9622 1147 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9623 : {
9624 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9625 0 : m = MATCH_ERROR;
9626 0 : goto cleanup;
9627 : }
9628 : }
9629 :
9630 10418 : if (sym->ts.type == BT_CLASS
9631 200 : && sym->ts.u.derived
9632 200 : && sym->ts.u.derived->attr.is_class)
9633 : {
9634 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9635 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9636 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9637 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9638 177 : if (CLASS_DATA (sym)->as)
9639 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9640 : }
9641 8841 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9642 19238 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9643 : {
9644 22 : m = MATCH_ERROR;
9645 22 : goto cleanup;
9646 : }
9647 10396 : if (!gfc_set_array_spec (sym, as, &var_locus))
9648 : {
9649 17 : m = MATCH_ERROR;
9650 17 : goto cleanup;
9651 : }
9652 :
9653 10379 : if (sym->attr.cray_pointee && sym->as != NULL)
9654 : {
9655 : /* Fix the array spec. */
9656 2 : m = gfc_mod_pointee_as (sym->as);
9657 2 : if (m == MATCH_ERROR)
9658 0 : goto cleanup;
9659 : }
9660 :
9661 10379 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9662 : {
9663 0 : m = MATCH_ERROR;
9664 0 : goto cleanup;
9665 : }
9666 :
9667 5741 : if ((current_attr.external || current_attr.intrinsic)
9668 6290 : && sym->attr.flavor != FL_PROCEDURE
9669 16637 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9670 : {
9671 0 : m = MATCH_ERROR;
9672 0 : goto cleanup;
9673 : }
9674 :
9675 10379 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9676 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9677 136 : && !current_attr.external)
9678 : {
9679 136 : sym->attr.pointer = 0;
9680 136 : sym->attr.allocatable = 0;
9681 136 : sym->attr.dimension = 0;
9682 136 : sym->attr.codimension = 0;
9683 136 : gfc_free_array_spec (sym->as);
9684 136 : sym->as = NULL;
9685 : }
9686 10243 : else if (sym->ts.type == BT_CLASS
9687 10243 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9688 : {
9689 0 : m = MATCH_ERROR;
9690 0 : goto cleanup;
9691 : }
9692 :
9693 10379 : add_hidden_procptr_result (sym);
9694 :
9695 10379 : return MATCH_YES;
9696 :
9697 49 : cleanup:
9698 49 : gfc_free_array_spec (as);
9699 49 : return m;
9700 : }
9701 :
9702 :
9703 : /* Generic attribute declaration subroutine. Used for attributes that
9704 : just have a list of names. */
9705 :
9706 : static match
9707 6713 : attr_decl (void)
9708 : {
9709 6713 : match m;
9710 :
9711 : /* Gobble the optional double colon, by simply ignoring the result
9712 : of gfc_match(). */
9713 6713 : gfc_match (" ::");
9714 :
9715 10428 : for (;;)
9716 : {
9717 10428 : m = attr_decl1 ();
9718 10428 : if (m != MATCH_YES)
9719 : break;
9720 :
9721 10379 : if (gfc_match_eos () == MATCH_YES)
9722 : {
9723 : m = MATCH_YES;
9724 : break;
9725 : }
9726 :
9727 3715 : if (gfc_match_char (',') != MATCH_YES)
9728 : {
9729 0 : gfc_error ("Unexpected character in variable list at %C");
9730 0 : m = MATCH_ERROR;
9731 0 : break;
9732 : }
9733 : }
9734 :
9735 6713 : return m;
9736 : }
9737 :
9738 :
9739 : /* This routine matches Cray Pointer declarations of the form:
9740 : pointer ( <pointer>, <pointee> )
9741 : or
9742 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9743 : The pointer, if already declared, should be an integer. Otherwise, we
9744 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9745 : be either a scalar, or an array declaration. No space is allocated for
9746 : the pointee. For the statement
9747 : pointer (ipt, ar(10))
9748 : any subsequent uses of ar will be translated (in C-notation) as
9749 : ar(i) => ((<type> *) ipt)(i)
9750 : After gimplification, pointee variable will disappear in the code. */
9751 :
9752 : static match
9753 334 : cray_pointer_decl (void)
9754 : {
9755 334 : match m;
9756 334 : gfc_array_spec *as = NULL;
9757 334 : gfc_symbol *cptr; /* Pointer symbol. */
9758 334 : gfc_symbol *cpte; /* Pointee symbol. */
9759 334 : locus var_locus;
9760 334 : bool done = false;
9761 :
9762 334 : while (!done)
9763 : {
9764 347 : if (gfc_match_char ('(') != MATCH_YES)
9765 : {
9766 1 : gfc_error ("Expected %<(%> at %C");
9767 1 : return MATCH_ERROR;
9768 : }
9769 :
9770 : /* Match pointer. */
9771 346 : var_locus = gfc_current_locus;
9772 346 : gfc_clear_attr (¤t_attr);
9773 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9774 346 : current_ts.type = BT_INTEGER;
9775 346 : current_ts.kind = gfc_index_integer_kind;
9776 :
9777 346 : m = gfc_match_symbol (&cptr, 0);
9778 346 : if (m != MATCH_YES)
9779 : {
9780 2 : gfc_error ("Expected variable name at %C");
9781 2 : return m;
9782 : }
9783 :
9784 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9785 : return MATCH_ERROR;
9786 :
9787 341 : gfc_set_sym_referenced (cptr);
9788 :
9789 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9790 : {
9791 327 : cptr->ts.type = BT_INTEGER;
9792 327 : cptr->ts.kind = gfc_index_integer_kind;
9793 : }
9794 14 : else if (cptr->ts.type != BT_INTEGER)
9795 : {
9796 1 : gfc_error ("Cray pointer at %C must be an integer");
9797 1 : return MATCH_ERROR;
9798 : }
9799 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9800 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9801 : " memory addresses require %d bytes",
9802 : cptr->ts.kind, gfc_index_integer_kind);
9803 :
9804 340 : if (gfc_match_char (',') != MATCH_YES)
9805 : {
9806 2 : gfc_error ("Expected \",\" at %C");
9807 2 : return MATCH_ERROR;
9808 : }
9809 :
9810 : /* Match Pointee. */
9811 338 : var_locus = gfc_current_locus;
9812 338 : gfc_clear_attr (¤t_attr);
9813 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9814 338 : current_ts.type = BT_UNKNOWN;
9815 338 : current_ts.kind = 0;
9816 :
9817 338 : m = gfc_match_symbol (&cpte, 0);
9818 338 : if (m != MATCH_YES)
9819 : {
9820 2 : gfc_error ("Expected variable name at %C");
9821 2 : return m;
9822 : }
9823 :
9824 : /* Check for an optional array spec. */
9825 336 : m = gfc_match_array_spec (&as, true, false);
9826 336 : if (m == MATCH_ERROR)
9827 : {
9828 0 : gfc_free_array_spec (as);
9829 0 : return m;
9830 : }
9831 336 : else if (m == MATCH_NO)
9832 : {
9833 226 : gfc_free_array_spec (as);
9834 226 : as = NULL;
9835 : }
9836 :
9837 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9838 : return MATCH_ERROR;
9839 :
9840 329 : gfc_set_sym_referenced (cpte);
9841 :
9842 329 : if (cpte->as == NULL)
9843 : {
9844 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9845 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9846 : }
9847 82 : else if (as != NULL)
9848 : {
9849 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9850 1 : gfc_free_array_spec (as);
9851 1 : return MATCH_ERROR;
9852 : }
9853 :
9854 328 : as = NULL;
9855 :
9856 328 : if (cpte->as != NULL)
9857 : {
9858 : /* Fix array spec. */
9859 190 : m = gfc_mod_pointee_as (cpte->as);
9860 190 : if (m == MATCH_ERROR)
9861 : return m;
9862 : }
9863 :
9864 : /* Point the Pointee at the Pointer. */
9865 328 : cpte->cp_pointer = cptr;
9866 :
9867 328 : if (gfc_match_char (')') != MATCH_YES)
9868 : {
9869 2 : gfc_error ("Expected \")\" at %C");
9870 2 : return MATCH_ERROR;
9871 : }
9872 326 : m = gfc_match_char (',');
9873 326 : if (m != MATCH_YES)
9874 : done = true; /* Stop searching for more declarations. */
9875 :
9876 : }
9877 :
9878 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9879 313 : || gfc_match_eos () != MATCH_YES)
9880 : {
9881 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9882 0 : return MATCH_ERROR;
9883 : }
9884 : return MATCH_YES;
9885 : }
9886 :
9887 :
9888 : match
9889 3216 : gfc_match_external (void)
9890 : {
9891 :
9892 3216 : gfc_clear_attr (¤t_attr);
9893 3216 : current_attr.external = 1;
9894 :
9895 3216 : return attr_decl ();
9896 : }
9897 :
9898 :
9899 : match
9900 208 : gfc_match_intent (void)
9901 : {
9902 208 : sym_intent intent;
9903 :
9904 : /* This is not allowed within a BLOCK construct! */
9905 208 : if (gfc_current_state () == COMP_BLOCK)
9906 : {
9907 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9908 2 : return MATCH_ERROR;
9909 : }
9910 :
9911 206 : intent = match_intent_spec ();
9912 206 : if (intent == INTENT_UNKNOWN)
9913 : return MATCH_ERROR;
9914 :
9915 206 : gfc_clear_attr (¤t_attr);
9916 206 : current_attr.intent = intent;
9917 :
9918 206 : return attr_decl ();
9919 : }
9920 :
9921 :
9922 : match
9923 1482 : gfc_match_intrinsic (void)
9924 : {
9925 :
9926 1482 : gfc_clear_attr (¤t_attr);
9927 1482 : current_attr.intrinsic = 1;
9928 :
9929 1482 : return attr_decl ();
9930 : }
9931 :
9932 :
9933 : match
9934 220 : gfc_match_optional (void)
9935 : {
9936 : /* This is not allowed within a BLOCK construct! */
9937 220 : if (gfc_current_state () == COMP_BLOCK)
9938 : {
9939 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9940 2 : return MATCH_ERROR;
9941 : }
9942 :
9943 218 : gfc_clear_attr (¤t_attr);
9944 218 : current_attr.optional = 1;
9945 :
9946 218 : return attr_decl ();
9947 : }
9948 :
9949 :
9950 : match
9951 915 : gfc_match_pointer (void)
9952 : {
9953 915 : gfc_gobble_whitespace ();
9954 915 : if (gfc_peek_ascii_char () == '(')
9955 : {
9956 335 : if (!flag_cray_pointer)
9957 : {
9958 1 : gfc_error ("Cray pointer declaration at %C requires "
9959 : "%<-fcray-pointer%> flag");
9960 1 : return MATCH_ERROR;
9961 : }
9962 334 : return cray_pointer_decl ();
9963 : }
9964 : else
9965 : {
9966 580 : gfc_clear_attr (¤t_attr);
9967 580 : current_attr.pointer = 1;
9968 :
9969 580 : return attr_decl ();
9970 : }
9971 : }
9972 :
9973 :
9974 : match
9975 162 : gfc_match_allocatable (void)
9976 : {
9977 162 : gfc_clear_attr (¤t_attr);
9978 162 : current_attr.allocatable = 1;
9979 :
9980 162 : return attr_decl ();
9981 : }
9982 :
9983 :
9984 : match
9985 23 : gfc_match_codimension (void)
9986 : {
9987 23 : gfc_clear_attr (¤t_attr);
9988 23 : current_attr.codimension = 1;
9989 :
9990 23 : return attr_decl ();
9991 : }
9992 :
9993 :
9994 : match
9995 80 : gfc_match_contiguous (void)
9996 : {
9997 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9998 : return MATCH_ERROR;
9999 :
10000 79 : gfc_clear_attr (¤t_attr);
10001 79 : current_attr.contiguous = 1;
10002 :
10003 79 : return attr_decl ();
10004 : }
10005 :
10006 :
10007 : match
10008 648 : gfc_match_dimension (void)
10009 : {
10010 648 : gfc_clear_attr (¤t_attr);
10011 648 : current_attr.dimension = 1;
10012 :
10013 648 : return attr_decl ();
10014 : }
10015 :
10016 :
10017 : match
10018 99 : gfc_match_target (void)
10019 : {
10020 99 : gfc_clear_attr (¤t_attr);
10021 99 : current_attr.target = 1;
10022 :
10023 99 : return attr_decl ();
10024 : }
10025 :
10026 :
10027 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
10028 : statement. */
10029 :
10030 : static match
10031 1766 : access_attr_decl (gfc_statement st)
10032 : {
10033 1766 : char name[GFC_MAX_SYMBOL_LEN + 1];
10034 1766 : interface_type type;
10035 1766 : gfc_user_op *uop;
10036 1766 : gfc_symbol *sym, *dt_sym;
10037 1766 : gfc_intrinsic_op op;
10038 1766 : match m;
10039 1766 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
10040 :
10041 1766 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10042 0 : goto done;
10043 :
10044 2916 : for (;;)
10045 : {
10046 2916 : m = gfc_match_generic_spec (&type, name, &op);
10047 2916 : if (m == MATCH_NO)
10048 0 : goto syntax;
10049 2916 : if (m == MATCH_ERROR)
10050 0 : goto done;
10051 :
10052 2916 : switch (type)
10053 : {
10054 0 : case INTERFACE_NAMELESS:
10055 0 : case INTERFACE_ABSTRACT:
10056 0 : goto syntax;
10057 :
10058 2839 : case INTERFACE_GENERIC:
10059 2839 : case INTERFACE_DTIO:
10060 :
10061 2839 : if (gfc_get_symbol (name, NULL, &sym))
10062 0 : goto done;
10063 :
10064 2839 : if (type == INTERFACE_DTIO
10065 26 : && gfc_current_ns->proc_name
10066 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
10067 26 : && sym->attr.flavor == FL_UNKNOWN)
10068 2 : sym->attr.flavor = FL_PROCEDURE;
10069 :
10070 2839 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
10071 4 : goto done;
10072 :
10073 330 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
10074 2892 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
10075 0 : goto done;
10076 :
10077 : break;
10078 :
10079 72 : case INTERFACE_INTRINSIC_OP:
10080 72 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
10081 : {
10082 72 : gfc_intrinsic_op other_op;
10083 :
10084 72 : gfc_current_ns->operator_access[op] = access;
10085 :
10086 : /* Handle the case if there is another op with the same
10087 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
10088 72 : other_op = gfc_equivalent_op (op);
10089 :
10090 72 : if (other_op != INTRINSIC_NONE)
10091 21 : gfc_current_ns->operator_access[other_op] = access;
10092 : }
10093 : else
10094 : {
10095 0 : gfc_error ("Access specification of the %s operator at %C has "
10096 : "already been specified", gfc_op2string (op));
10097 0 : goto done;
10098 : }
10099 :
10100 : break;
10101 :
10102 5 : case INTERFACE_USER_OP:
10103 5 : uop = gfc_get_uop (name);
10104 :
10105 5 : if (uop->access == ACCESS_UNKNOWN)
10106 : {
10107 4 : uop->access = access;
10108 : }
10109 : else
10110 : {
10111 1 : gfc_error ("Access specification of the .%s. operator at %C "
10112 : "has already been specified", uop->name);
10113 1 : goto done;
10114 : }
10115 :
10116 4 : break;
10117 : }
10118 :
10119 2911 : if (gfc_match_char (',') == MATCH_NO)
10120 : break;
10121 : }
10122 :
10123 1761 : if (gfc_match_eos () != MATCH_YES)
10124 0 : goto syntax;
10125 : return MATCH_YES;
10126 :
10127 0 : syntax:
10128 0 : gfc_syntax_error (st);
10129 :
10130 1766 : done:
10131 : return MATCH_ERROR;
10132 : }
10133 :
10134 :
10135 : match
10136 23 : gfc_match_protected (void)
10137 : {
10138 23 : gfc_symbol *sym;
10139 23 : match m;
10140 23 : char c;
10141 :
10142 : /* PROTECTED has already been seen, but must be followed by whitespace
10143 : or ::. */
10144 23 : c = gfc_peek_ascii_char ();
10145 23 : if (!gfc_is_whitespace (c) && c != ':')
10146 : return MATCH_NO;
10147 :
10148 22 : if (!gfc_current_ns->proc_name
10149 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
10150 : {
10151 3 : gfc_error ("PROTECTED at %C only allowed in specification "
10152 : "part of a module");
10153 3 : return MATCH_ERROR;
10154 :
10155 : }
10156 :
10157 19 : gfc_match (" ::");
10158 :
10159 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
10160 : return MATCH_ERROR;
10161 :
10162 : /* PROTECTED has an entity-list. */
10163 18 : if (gfc_match_eos () == MATCH_YES)
10164 0 : goto syntax;
10165 :
10166 26 : for(;;)
10167 : {
10168 26 : m = gfc_match_symbol (&sym, 0);
10169 26 : switch (m)
10170 : {
10171 26 : case MATCH_YES:
10172 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
10173 : return MATCH_ERROR;
10174 25 : goto next_item;
10175 :
10176 : case MATCH_NO:
10177 : break;
10178 :
10179 : case MATCH_ERROR:
10180 : return MATCH_ERROR;
10181 : }
10182 :
10183 25 : next_item:
10184 25 : if (gfc_match_eos () == MATCH_YES)
10185 : break;
10186 8 : if (gfc_match_char (',') != MATCH_YES)
10187 0 : goto syntax;
10188 : }
10189 :
10190 : return MATCH_YES;
10191 :
10192 0 : syntax:
10193 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
10194 0 : return MATCH_ERROR;
10195 : }
10196 :
10197 :
10198 : /* The PRIVATE statement is a bit weird in that it can be an attribute
10199 : declaration, but also works as a standalone statement inside of a
10200 : type declaration or a module. */
10201 :
10202 : match
10203 29797 : gfc_match_private (gfc_statement *st)
10204 : {
10205 29797 : gfc_state_data *prev;
10206 :
10207 29797 : if (gfc_match ("private") != MATCH_YES)
10208 : return MATCH_NO;
10209 :
10210 : /* Try matching PRIVATE without an access-list. */
10211 1635 : if (gfc_match_eos () == MATCH_YES)
10212 : {
10213 1348 : prev = gfc_state_stack->previous;
10214 1348 : if (gfc_current_state () != COMP_MODULE
10215 367 : && !(gfc_current_state () == COMP_DERIVED
10216 334 : && prev && prev->state == COMP_MODULE)
10217 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10218 32 : && prev->previous && prev->previous->state == COMP_MODULE))
10219 : {
10220 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10221 : "specification part of a module");
10222 2 : return MATCH_ERROR;
10223 : }
10224 :
10225 1346 : *st = ST_PRIVATE;
10226 1346 : return MATCH_YES;
10227 : }
10228 :
10229 : /* At this point in free-form source code, PRIVATE must be followed
10230 : by whitespace or ::. */
10231 287 : if (gfc_current_form == FORM_FREE)
10232 : {
10233 285 : char c = gfc_peek_ascii_char ();
10234 285 : if (!gfc_is_whitespace (c) && c != ':')
10235 : return MATCH_NO;
10236 : }
10237 :
10238 286 : prev = gfc_state_stack->previous;
10239 286 : if (gfc_current_state () != COMP_MODULE
10240 1 : && !(gfc_current_state () == COMP_DERIVED
10241 0 : && prev && prev->state == COMP_MODULE)
10242 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10243 0 : && prev->previous && prev->previous->state == COMP_MODULE))
10244 : {
10245 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10246 : "specification part of a module");
10247 1 : return MATCH_ERROR;
10248 : }
10249 :
10250 285 : *st = ST_ATTR_DECL;
10251 285 : return access_attr_decl (ST_PRIVATE);
10252 : }
10253 :
10254 :
10255 : match
10256 1882 : gfc_match_public (gfc_statement *st)
10257 : {
10258 1882 : if (gfc_match ("public") != MATCH_YES)
10259 : return MATCH_NO;
10260 :
10261 : /* Try matching PUBLIC without an access-list. */
10262 1528 : if (gfc_match_eos () == MATCH_YES)
10263 : {
10264 45 : if (gfc_current_state () != COMP_MODULE)
10265 : {
10266 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10267 : "specification part of a module");
10268 2 : return MATCH_ERROR;
10269 : }
10270 :
10271 43 : *st = ST_PUBLIC;
10272 43 : return MATCH_YES;
10273 : }
10274 :
10275 : /* At this point in free-form source code, PUBLIC must be followed
10276 : by whitespace or ::. */
10277 1483 : if (gfc_current_form == FORM_FREE)
10278 : {
10279 1481 : char c = gfc_peek_ascii_char ();
10280 1481 : if (!gfc_is_whitespace (c) && c != ':')
10281 : return MATCH_NO;
10282 : }
10283 :
10284 1482 : if (gfc_current_state () != COMP_MODULE)
10285 : {
10286 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10287 : "specification part of a module");
10288 1 : return MATCH_ERROR;
10289 : }
10290 :
10291 1481 : *st = ST_ATTR_DECL;
10292 1481 : return access_attr_decl (ST_PUBLIC);
10293 : }
10294 :
10295 :
10296 : /* Workhorse for gfc_match_parameter. */
10297 :
10298 : static match
10299 8533 : do_parm (void)
10300 : {
10301 8533 : gfc_symbol *sym;
10302 8533 : gfc_expr *init;
10303 8533 : gfc_charlen *saved_cl_list;
10304 8533 : match m;
10305 8533 : bool t;
10306 :
10307 8533 : saved_cl_list = gfc_current_ns->cl_list;
10308 :
10309 8533 : m = gfc_match_symbol (&sym, 0);
10310 8533 : if (m == MATCH_NO)
10311 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10312 :
10313 8533 : if (m != MATCH_YES)
10314 : return m;
10315 :
10316 8533 : if (gfc_match_char ('=') == MATCH_NO)
10317 : {
10318 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10319 0 : return MATCH_ERROR;
10320 : }
10321 :
10322 8533 : m = gfc_match_init_expr (&init);
10323 8533 : if (m == MATCH_NO)
10324 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10325 8533 : if (m != MATCH_YES)
10326 : return m;
10327 :
10328 8532 : if (sym->ts.type == BT_UNKNOWN
10329 8532 : && !gfc_set_default_type (sym, 1, NULL))
10330 : {
10331 1 : m = MATCH_ERROR;
10332 1 : goto cleanup;
10333 : }
10334 :
10335 8531 : if (!gfc_check_assign_symbol (sym, NULL, init)
10336 8531 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10337 : {
10338 1 : m = MATCH_ERROR;
10339 1 : goto cleanup;
10340 : }
10341 :
10342 8530 : if (sym->value)
10343 : {
10344 1 : gfc_error ("Initializing already initialized variable at %C");
10345 1 : m = MATCH_ERROR;
10346 1 : goto cleanup;
10347 : }
10348 :
10349 8529 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus,
10350 : saved_cl_list);
10351 8529 : return (t) ? MATCH_YES : MATCH_ERROR;
10352 :
10353 3 : cleanup:
10354 3 : gfc_free_expr (init);
10355 3 : return m;
10356 : }
10357 :
10358 :
10359 : /* Match a parameter statement, with the weird syntax that these have. */
10360 :
10361 : match
10362 7820 : gfc_match_parameter (void)
10363 : {
10364 7820 : const char *term = " )%t";
10365 7820 : match m;
10366 :
10367 7820 : if (gfc_match_char ('(') == MATCH_NO)
10368 : {
10369 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10370 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10371 : return MATCH_NO;
10372 7819 : term = " %t";
10373 : }
10374 :
10375 8533 : for (;;)
10376 : {
10377 8533 : m = do_parm ();
10378 8533 : if (m != MATCH_YES)
10379 : break;
10380 :
10381 8529 : if (gfc_match (term) == MATCH_YES)
10382 : break;
10383 :
10384 714 : if (gfc_match_char (',') != MATCH_YES)
10385 : {
10386 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10387 0 : m = MATCH_ERROR;
10388 0 : break;
10389 : }
10390 : }
10391 :
10392 : return m;
10393 : }
10394 :
10395 :
10396 : match
10397 8 : gfc_match_automatic (void)
10398 : {
10399 8 : gfc_symbol *sym;
10400 8 : match m;
10401 8 : bool seen_symbol = false;
10402 :
10403 8 : if (!flag_dec_static)
10404 : {
10405 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10406 : "%<-fdec-static%>",
10407 : "AUTOMATIC"
10408 : );
10409 2 : return MATCH_ERROR;
10410 : }
10411 :
10412 6 : gfc_match (" ::");
10413 :
10414 6 : for (;;)
10415 : {
10416 6 : m = gfc_match_symbol (&sym, 0);
10417 6 : switch (m)
10418 : {
10419 : case MATCH_NO:
10420 : break;
10421 :
10422 : case MATCH_ERROR:
10423 : return MATCH_ERROR;
10424 :
10425 4 : case MATCH_YES:
10426 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10427 : return MATCH_ERROR;
10428 : seen_symbol = true;
10429 : break;
10430 : }
10431 :
10432 4 : if (gfc_match_eos () == MATCH_YES)
10433 : break;
10434 0 : if (gfc_match_char (',') != MATCH_YES)
10435 0 : goto syntax;
10436 : }
10437 :
10438 4 : if (!seen_symbol)
10439 : {
10440 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10441 2 : return MATCH_ERROR;
10442 : }
10443 :
10444 : return MATCH_YES;
10445 :
10446 0 : syntax:
10447 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10448 0 : return MATCH_ERROR;
10449 : }
10450 :
10451 :
10452 : match
10453 7 : gfc_match_static (void)
10454 : {
10455 7 : gfc_symbol *sym;
10456 7 : match m;
10457 7 : bool seen_symbol = false;
10458 :
10459 7 : if (!flag_dec_static)
10460 : {
10461 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10462 : "%<-fdec-static%>",
10463 : "STATIC");
10464 2 : return MATCH_ERROR;
10465 : }
10466 :
10467 5 : gfc_match (" ::");
10468 :
10469 5 : for (;;)
10470 : {
10471 5 : m = gfc_match_symbol (&sym, 0);
10472 5 : switch (m)
10473 : {
10474 : case MATCH_NO:
10475 : break;
10476 :
10477 : case MATCH_ERROR:
10478 : return MATCH_ERROR;
10479 :
10480 3 : case MATCH_YES:
10481 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10482 : &gfc_current_locus))
10483 : return MATCH_ERROR;
10484 : seen_symbol = true;
10485 : break;
10486 : }
10487 :
10488 3 : if (gfc_match_eos () == MATCH_YES)
10489 : break;
10490 0 : if (gfc_match_char (',') != MATCH_YES)
10491 0 : goto syntax;
10492 : }
10493 :
10494 3 : if (!seen_symbol)
10495 : {
10496 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10497 2 : return MATCH_ERROR;
10498 : }
10499 :
10500 : return MATCH_YES;
10501 :
10502 0 : syntax:
10503 0 : gfc_error ("Syntax error in STATIC statement at %C");
10504 0 : return MATCH_ERROR;
10505 : }
10506 :
10507 :
10508 : /* Save statements have a special syntax. */
10509 :
10510 : match
10511 272 : gfc_match_save (void)
10512 : {
10513 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10514 272 : gfc_common_head *c;
10515 272 : gfc_symbol *sym;
10516 272 : match m;
10517 :
10518 272 : if (gfc_match_eos () == MATCH_YES)
10519 : {
10520 150 : if (gfc_current_ns->seen_save)
10521 : {
10522 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10523 : "follows previous SAVE statement"))
10524 : return MATCH_ERROR;
10525 : }
10526 :
10527 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10528 149 : return MATCH_YES;
10529 : }
10530 :
10531 122 : if (gfc_current_ns->save_all)
10532 : {
10533 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10534 : "blanket SAVE statement"))
10535 : return MATCH_ERROR;
10536 : }
10537 :
10538 121 : gfc_match (" ::");
10539 :
10540 183 : for (;;)
10541 : {
10542 183 : m = gfc_match_symbol (&sym, 0);
10543 183 : switch (m)
10544 : {
10545 181 : case MATCH_YES:
10546 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10547 : &gfc_current_locus))
10548 : return MATCH_ERROR;
10549 179 : goto next_item;
10550 :
10551 : case MATCH_NO:
10552 : break;
10553 :
10554 : case MATCH_ERROR:
10555 : return MATCH_ERROR;
10556 : }
10557 :
10558 2 : m = gfc_match (" / %n /", &n);
10559 2 : if (m == MATCH_ERROR)
10560 : return MATCH_ERROR;
10561 2 : if (m == MATCH_NO)
10562 0 : goto syntax;
10563 :
10564 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10565 : saved-entity-list that does not specify a common-block-name. */
10566 2 : if (gfc_current_state () == COMP_BLOCK)
10567 : {
10568 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10569 : "in a BLOCK construct", n);
10570 1 : return MATCH_ERROR;
10571 : }
10572 :
10573 1 : c = gfc_get_common (n, 0);
10574 1 : c->saved = 1;
10575 :
10576 1 : gfc_current_ns->seen_save = 1;
10577 :
10578 180 : next_item:
10579 180 : if (gfc_match_eos () == MATCH_YES)
10580 : break;
10581 62 : if (gfc_match_char (',') != MATCH_YES)
10582 0 : goto syntax;
10583 : }
10584 :
10585 : return MATCH_YES;
10586 :
10587 0 : syntax:
10588 0 : if (gfc_current_ns->seen_save)
10589 : {
10590 0 : gfc_error ("Syntax error in SAVE statement at %C");
10591 0 : return MATCH_ERROR;
10592 : }
10593 : else
10594 : return MATCH_NO;
10595 : }
10596 :
10597 :
10598 : match
10599 93 : gfc_match_value (void)
10600 : {
10601 93 : gfc_symbol *sym;
10602 93 : match m;
10603 :
10604 : /* This is not allowed within a BLOCK construct! */
10605 93 : if (gfc_current_state () == COMP_BLOCK)
10606 : {
10607 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10608 2 : return MATCH_ERROR;
10609 : }
10610 :
10611 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10612 : return MATCH_ERROR;
10613 :
10614 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10615 : {
10616 : return MATCH_ERROR;
10617 : }
10618 :
10619 90 : if (gfc_match_eos () == MATCH_YES)
10620 0 : goto syntax;
10621 :
10622 116 : for(;;)
10623 : {
10624 116 : m = gfc_match_symbol (&sym, 0);
10625 116 : switch (m)
10626 : {
10627 116 : case MATCH_YES:
10628 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10629 : return MATCH_ERROR;
10630 110 : goto next_item;
10631 :
10632 : case MATCH_NO:
10633 : break;
10634 :
10635 : case MATCH_ERROR:
10636 : return MATCH_ERROR;
10637 : }
10638 :
10639 110 : next_item:
10640 110 : if (gfc_match_eos () == MATCH_YES)
10641 : break;
10642 26 : if (gfc_match_char (',') != MATCH_YES)
10643 0 : goto syntax;
10644 : }
10645 :
10646 : return MATCH_YES;
10647 :
10648 0 : syntax:
10649 0 : gfc_error ("Syntax error in VALUE statement at %C");
10650 0 : return MATCH_ERROR;
10651 : }
10652 :
10653 :
10654 : match
10655 45 : gfc_match_volatile (void)
10656 : {
10657 45 : gfc_symbol *sym;
10658 45 : char *name;
10659 45 : match m;
10660 :
10661 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10662 : return MATCH_ERROR;
10663 :
10664 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10665 : {
10666 : return MATCH_ERROR;
10667 : }
10668 :
10669 44 : if (gfc_match_eos () == MATCH_YES)
10670 1 : goto syntax;
10671 :
10672 48 : for(;;)
10673 : {
10674 : /* VOLATILE is special because it can be added to host-associated
10675 : symbols locally. Except for coarrays. */
10676 48 : m = gfc_match_symbol (&sym, 1);
10677 48 : switch (m)
10678 : {
10679 48 : case MATCH_YES:
10680 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10681 48 : strcpy (name, sym->name);
10682 48 : if (!check_function_name (name))
10683 : return MATCH_ERROR;
10684 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10685 : for variable in a BLOCK which is defined outside of the BLOCK. */
10686 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10687 : {
10688 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10689 : "%C, which is use-/host-associated", sym->name);
10690 2 : return MATCH_ERROR;
10691 : }
10692 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10693 : return MATCH_ERROR;
10694 42 : goto next_item;
10695 :
10696 : case MATCH_NO:
10697 : break;
10698 :
10699 : case MATCH_ERROR:
10700 : return MATCH_ERROR;
10701 : }
10702 :
10703 42 : next_item:
10704 42 : if (gfc_match_eos () == MATCH_YES)
10705 : break;
10706 5 : if (gfc_match_char (',') != MATCH_YES)
10707 0 : goto syntax;
10708 : }
10709 :
10710 : return MATCH_YES;
10711 :
10712 1 : syntax:
10713 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10714 1 : return MATCH_ERROR;
10715 : }
10716 :
10717 :
10718 : match
10719 11 : gfc_match_asynchronous (void)
10720 : {
10721 11 : gfc_symbol *sym;
10722 11 : char *name;
10723 11 : match m;
10724 :
10725 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10726 : return MATCH_ERROR;
10727 :
10728 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10729 : {
10730 : return MATCH_ERROR;
10731 : }
10732 :
10733 10 : if (gfc_match_eos () == MATCH_YES)
10734 0 : goto syntax;
10735 :
10736 10 : for(;;)
10737 : {
10738 : /* ASYNCHRONOUS is special because it can be added to host-associated
10739 : symbols locally. */
10740 10 : m = gfc_match_symbol (&sym, 1);
10741 10 : switch (m)
10742 : {
10743 10 : case MATCH_YES:
10744 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10745 10 : strcpy (name, sym->name);
10746 10 : if (!check_function_name (name))
10747 : return MATCH_ERROR;
10748 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10749 : return MATCH_ERROR;
10750 7 : goto next_item;
10751 :
10752 : case MATCH_NO:
10753 : break;
10754 :
10755 : case MATCH_ERROR:
10756 : return MATCH_ERROR;
10757 : }
10758 :
10759 7 : next_item:
10760 7 : if (gfc_match_eos () == MATCH_YES)
10761 : break;
10762 0 : if (gfc_match_char (',') != MATCH_YES)
10763 0 : goto syntax;
10764 : }
10765 :
10766 : return MATCH_YES;
10767 :
10768 0 : syntax:
10769 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10770 0 : return MATCH_ERROR;
10771 : }
10772 :
10773 :
10774 : /* Match a module procedure statement in a submodule. */
10775 :
10776 : match
10777 780480 : gfc_match_submod_proc (void)
10778 : {
10779 780480 : char name[GFC_MAX_SYMBOL_LEN + 1];
10780 780480 : gfc_symbol *sym, *fsym;
10781 780480 : match m;
10782 780480 : gfc_formal_arglist *formal, *head, *tail;
10783 :
10784 780480 : if (gfc_current_state () != COMP_CONTAINS
10785 16040 : || !(gfc_state_stack->previous
10786 16040 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10787 16040 : || gfc_state_stack->previous->state == COMP_MODULE)))
10788 : return MATCH_NO;
10789 :
10790 7998 : m = gfc_match (" module% procedure% %n", name);
10791 7998 : if (m != MATCH_YES)
10792 : return m;
10793 :
10794 267 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10795 : "at %C"))
10796 : return MATCH_ERROR;
10797 :
10798 267 : if (get_proc_name (name, &sym, false))
10799 : return MATCH_ERROR;
10800 :
10801 : /* Make sure that the result field is appropriately filled. */
10802 267 : if (sym->tlink && sym->tlink->attr.function)
10803 : {
10804 117 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10805 : {
10806 67 : sym->result = sym->tlink->result;
10807 67 : if (!sym->result->attr.use_assoc)
10808 : {
10809 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10810 : sym->result->name);
10811 20 : st->n.sym = sym->result;
10812 20 : sym->result->refs++;
10813 : }
10814 : }
10815 : else
10816 50 : sym->result = sym;
10817 : }
10818 :
10819 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10820 : the symbol existed before. */
10821 267 : sym->declared_at = gfc_current_locus;
10822 :
10823 267 : if (!sym->attr.module_procedure)
10824 : return MATCH_ERROR;
10825 :
10826 : /* Signal match_end to expect "end procedure". */
10827 265 : sym->abr_modproc_decl = 1;
10828 :
10829 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10830 265 : sym->attr.if_source = IFSRC_DECL;
10831 :
10832 265 : gfc_new_block = sym;
10833 :
10834 : /* Make a new formal arglist with the symbols in the procedure
10835 : namespace. */
10836 265 : head = tail = NULL;
10837 600 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10838 : {
10839 335 : if (formal == sym->formal)
10840 238 : head = tail = gfc_get_formal_arglist ();
10841 : else
10842 : {
10843 97 : tail->next = gfc_get_formal_arglist ();
10844 97 : tail = tail->next;
10845 : }
10846 :
10847 335 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10848 0 : goto cleanup;
10849 :
10850 335 : tail->sym = fsym;
10851 335 : gfc_set_sym_referenced (fsym);
10852 : }
10853 :
10854 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10855 : interface declaration is cleared. This allows us to add the
10856 : explicit interface as is done for other type of procedure. */
10857 265 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10858 : &gfc_current_locus))
10859 : return MATCH_ERROR;
10860 :
10861 265 : if (gfc_match_eos () != MATCH_YES)
10862 : {
10863 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10864 : undone, such that the st->n.sym->formal points to the original symbol;
10865 : if now this namespace is finalized, the formal namespace is freed,
10866 : but it might be still needed in the parent namespace. */
10867 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10868 1 : st->n.sym = NULL;
10869 1 : gfc_free_symbol (sym->tlink);
10870 1 : sym->tlink = NULL;
10871 1 : sym->refs--;
10872 1 : gfc_syntax_error (ST_MODULE_PROC);
10873 1 : return MATCH_ERROR;
10874 : }
10875 :
10876 : return MATCH_YES;
10877 :
10878 0 : cleanup:
10879 0 : gfc_free_formal_arglist (head);
10880 0 : return MATCH_ERROR;
10881 : }
10882 :
10883 :
10884 : /* Match a module procedure statement. Note that we have to modify
10885 : symbols in the parent's namespace because the current one was there
10886 : to receive symbols that are in an interface's formal argument list. */
10887 :
10888 : match
10889 1626 : gfc_match_modproc (void)
10890 : {
10891 1626 : char name[GFC_MAX_SYMBOL_LEN + 1];
10892 1626 : gfc_symbol *sym;
10893 1626 : match m;
10894 1626 : locus old_locus;
10895 1626 : gfc_namespace *module_ns;
10896 1626 : gfc_interface *old_interface_head, *interface;
10897 :
10898 1626 : if (gfc_state_stack->previous == NULL
10899 1624 : || (gfc_state_stack->state != COMP_INTERFACE
10900 5 : && (gfc_state_stack->state != COMP_CONTAINS
10901 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10902 1619 : || current_interface.type == INTERFACE_NAMELESS
10903 1619 : || current_interface.type == INTERFACE_ABSTRACT)
10904 : {
10905 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10906 : "interface");
10907 8 : return MATCH_ERROR;
10908 : }
10909 :
10910 1618 : module_ns = gfc_current_ns->parent;
10911 1624 : for (; module_ns; module_ns = module_ns->parent)
10912 1624 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10913 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10914 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10915 12 : && !module_ns->proc_name->attr.contained))
10916 : break;
10917 :
10918 1618 : if (module_ns == NULL)
10919 : return MATCH_ERROR;
10920 :
10921 : /* Store the current state of the interface. We will need it if we
10922 : end up with a syntax error and need to recover. */
10923 1618 : old_interface_head = gfc_current_interface_head ();
10924 :
10925 : /* Check if the F2008 optional double colon appears. */
10926 1618 : gfc_gobble_whitespace ();
10927 1618 : old_locus = gfc_current_locus;
10928 1618 : if (gfc_match ("::") == MATCH_YES)
10929 : {
10930 31 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10931 : "MODULE PROCEDURE statement at %L", &old_locus))
10932 : return MATCH_ERROR;
10933 : }
10934 : else
10935 1587 : gfc_current_locus = old_locus;
10936 :
10937 1973 : for (;;)
10938 : {
10939 1973 : bool last = false;
10940 1973 : old_locus = gfc_current_locus;
10941 :
10942 1973 : m = gfc_match_name (name);
10943 1973 : if (m == MATCH_NO)
10944 1 : goto syntax;
10945 1972 : if (m != MATCH_YES)
10946 : return MATCH_ERROR;
10947 :
10948 : /* Check for syntax error before starting to add symbols to the
10949 : current namespace. */
10950 1972 : if (gfc_match_eos () == MATCH_YES)
10951 : last = true;
10952 :
10953 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10954 2 : goto syntax;
10955 :
10956 : /* Now we're sure the syntax is valid, we process this item
10957 : further. */
10958 1970 : if (gfc_get_symbol (name, module_ns, &sym))
10959 : return MATCH_ERROR;
10960 :
10961 1970 : if (sym->attr.intrinsic)
10962 : {
10963 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10964 : "PROCEDURE", &old_locus);
10965 1 : return MATCH_ERROR;
10966 : }
10967 :
10968 1969 : if (sym->attr.proc != PROC_MODULE
10969 1969 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10970 : return MATCH_ERROR;
10971 :
10972 1966 : if (!gfc_add_interface (sym))
10973 : return MATCH_ERROR;
10974 :
10975 1963 : sym->attr.mod_proc = 1;
10976 1963 : sym->declared_at = old_locus;
10977 :
10978 1963 : if (last)
10979 : break;
10980 : }
10981 :
10982 : return MATCH_YES;
10983 :
10984 3 : syntax:
10985 : /* Restore the previous state of the interface. */
10986 3 : interface = gfc_current_interface_head ();
10987 3 : gfc_set_current_interface_head (old_interface_head);
10988 :
10989 : /* Free the new interfaces. */
10990 10 : while (interface != old_interface_head)
10991 : {
10992 4 : gfc_interface *i = interface->next;
10993 4 : free (interface);
10994 4 : interface = i;
10995 : }
10996 :
10997 : /* And issue a syntax error. */
10998 3 : gfc_syntax_error (ST_MODULE_PROC);
10999 3 : return MATCH_ERROR;
11000 : }
11001 :
11002 :
11003 : /* Check a derived type that is being extended. */
11004 :
11005 : static gfc_symbol*
11006 1625 : check_extended_derived_type (char *name)
11007 : {
11008 1625 : gfc_symbol *extended;
11009 :
11010 1625 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
11011 : {
11012 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
11013 0 : return NULL;
11014 : }
11015 :
11016 1625 : extended = gfc_find_dt_in_generic (extended);
11017 :
11018 : /* F08:C428. */
11019 1625 : if (!extended)
11020 : {
11021 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
11022 2 : return NULL;
11023 : }
11024 :
11025 1623 : if (extended->attr.flavor != FL_DERIVED)
11026 : {
11027 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
11028 : "derived type", name);
11029 0 : return NULL;
11030 : }
11031 :
11032 1623 : if (extended->attr.is_bind_c)
11033 : {
11034 1 : gfc_error ("%qs cannot be extended at %C because it "
11035 : "is BIND(C)", extended->name);
11036 1 : return NULL;
11037 : }
11038 :
11039 1622 : if (extended->attr.sequence)
11040 : {
11041 1 : gfc_error ("%qs cannot be extended at %C because it "
11042 : "is a SEQUENCE type", extended->name);
11043 1 : return NULL;
11044 : }
11045 :
11046 : return extended;
11047 : }
11048 :
11049 :
11050 : /* Match the optional attribute specifiers for a type declaration.
11051 : Return MATCH_ERROR if an error is encountered in one of the handled
11052 : attributes (public, private, bind(c)), MATCH_NO if what's found is
11053 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
11054 : checking on attribute conflicts needs to be done. */
11055 :
11056 : static match
11057 20425 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
11058 : {
11059 : /* See if the derived type is marked as private. */
11060 20425 : if (gfc_match (" , private") == MATCH_YES)
11061 : {
11062 15 : if (gfc_current_state () != COMP_MODULE)
11063 : {
11064 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
11065 : "specification part of a module");
11066 1 : return MATCH_ERROR;
11067 : }
11068 :
11069 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
11070 0 : return MATCH_ERROR;
11071 : }
11072 20410 : else if (gfc_match (" , public") == MATCH_YES)
11073 : {
11074 558 : if (gfc_current_state () != COMP_MODULE)
11075 : {
11076 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
11077 : "specification part of a module");
11078 0 : return MATCH_ERROR;
11079 : }
11080 :
11081 558 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
11082 0 : return MATCH_ERROR;
11083 : }
11084 19852 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
11085 : {
11086 : /* If the type is defined to be bind(c) it then needs to make
11087 : sure that all fields are interoperable. This will
11088 : need to be a semantic check on the finished derived type.
11089 : See 15.2.3 (lines 9-12) of F2003 draft. */
11090 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
11091 0 : return MATCH_ERROR;
11092 :
11093 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
11094 : }
11095 19445 : else if (gfc_match (" , abstract") == MATCH_YES)
11096 : {
11097 349 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
11098 : return MATCH_ERROR;
11099 :
11100 348 : if (!gfc_add_abstract (attr, &gfc_current_locus))
11101 1 : return MATCH_ERROR;
11102 : }
11103 19096 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
11104 : {
11105 1626 : if (!gfc_add_extension (attr, &gfc_current_locus))
11106 0 : return MATCH_ERROR;
11107 : }
11108 : else
11109 : return MATCH_NO;
11110 :
11111 : /* If we get here, something matched. */
11112 : return MATCH_YES;
11113 : }
11114 :
11115 :
11116 : /* Common function for type declaration blocks similar to derived types, such
11117 : as STRUCTURES and MAPs. Unlike derived types, a structure type
11118 : does NOT have a generic symbol matching the name given by the user.
11119 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
11120 : for the creation of an independent symbol.
11121 : Other parameters are a message to prefix errors with, the name of the new
11122 : type to be created, and the flavor to add to the resulting symbol. */
11123 :
11124 : static bool
11125 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
11126 : gfc_symbol **result)
11127 : {
11128 717 : gfc_symbol *sym;
11129 717 : locus where;
11130 :
11131 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
11132 :
11133 717 : if (decl)
11134 717 : where = *decl;
11135 : else
11136 0 : where = gfc_current_locus;
11137 :
11138 717 : if (gfc_get_symbol (name, NULL, &sym))
11139 : return false;
11140 :
11141 717 : if (!sym)
11142 : {
11143 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
11144 : return false;
11145 : }
11146 :
11147 717 : if (sym->components != NULL || sym->attr.zero_comp)
11148 : {
11149 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
11150 : sym->name, &sym->declared_at);
11151 3 : return false;
11152 : }
11153 :
11154 714 : sym->declared_at = where;
11155 :
11156 714 : if (sym->attr.flavor != fl
11157 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
11158 : return false;
11159 :
11160 714 : if (!sym->hash_value)
11161 : /* Set the hash for the compound name for this type. */
11162 713 : sym->hash_value = gfc_hash_value (sym);
11163 :
11164 : /* Normally the type is expected to have been completely parsed by the time
11165 : a field declaration with this type is seen. For unions, maps, and nested
11166 : structure declarations, we need to indicate that it is okay that we
11167 : haven't seen any components yet. This will be updated after the structure
11168 : is fully parsed. */
11169 714 : sym->attr.zero_comp = 0;
11170 :
11171 : /* Structures always act like derived-types with the SEQUENCE attribute */
11172 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
11173 :
11174 714 : if (result) *result = sym;
11175 :
11176 : return true;
11177 : }
11178 :
11179 :
11180 : /* Match the opening of a MAP block. Like a struct within a union in C;
11181 : behaves identical to STRUCTURE blocks. */
11182 :
11183 : match
11184 259 : gfc_match_map (void)
11185 : {
11186 : /* Counter used to give unique internal names to map structures. */
11187 259 : static unsigned int gfc_map_id = 0;
11188 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
11189 259 : gfc_symbol *sym;
11190 259 : locus old_loc;
11191 :
11192 259 : old_loc = gfc_current_locus;
11193 :
11194 259 : if (gfc_match_eos () != MATCH_YES)
11195 : {
11196 1 : gfc_error ("Junk after MAP statement at %C");
11197 1 : gfc_current_locus = old_loc;
11198 1 : return MATCH_ERROR;
11199 : }
11200 :
11201 : /* Map blocks are anonymous so we make up unique names for the symbol table
11202 : which are invalid Fortran identifiers. */
11203 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
11204 :
11205 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
11206 : return MATCH_ERROR;
11207 :
11208 258 : gfc_new_block = sym;
11209 :
11210 258 : return MATCH_YES;
11211 : }
11212 :
11213 :
11214 : /* Match the opening of a UNION block. */
11215 :
11216 : match
11217 133 : gfc_match_union (void)
11218 : {
11219 : /* Counter used to give unique internal names to union types. */
11220 133 : static unsigned int gfc_union_id = 0;
11221 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
11222 133 : gfc_symbol *sym;
11223 133 : locus old_loc;
11224 :
11225 133 : old_loc = gfc_current_locus;
11226 :
11227 133 : if (gfc_match_eos () != MATCH_YES)
11228 : {
11229 1 : gfc_error ("Junk after UNION statement at %C");
11230 1 : gfc_current_locus = old_loc;
11231 1 : return MATCH_ERROR;
11232 : }
11233 :
11234 : /* Unions are anonymous so we make up unique names for the symbol table
11235 : which are invalid Fortran identifiers. */
11236 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
11237 :
11238 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
11239 : return MATCH_ERROR;
11240 :
11241 132 : gfc_new_block = sym;
11242 :
11243 132 : return MATCH_YES;
11244 : }
11245 :
11246 :
11247 : /* Match the beginning of a STRUCTURE declaration. This is similar to
11248 : matching the beginning of a derived type declaration with a few
11249 : twists. The resulting type symbol has no access control or other
11250 : interesting attributes. */
11251 :
11252 : match
11253 336 : gfc_match_structure_decl (void)
11254 : {
11255 : /* Counter used to give unique internal names to anonymous structures. */
11256 336 : static unsigned int gfc_structure_id = 0;
11257 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
11258 336 : gfc_symbol *sym;
11259 336 : match m;
11260 336 : locus where;
11261 :
11262 336 : if (!flag_dec_structure)
11263 : {
11264 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11265 : "%<-fdec-structure%>",
11266 : "STRUCTURE");
11267 3 : return MATCH_ERROR;
11268 : }
11269 :
11270 333 : name[0] = '\0';
11271 :
11272 333 : m = gfc_match (" /%n/", name);
11273 333 : if (m != MATCH_YES)
11274 : {
11275 : /* Non-nested structure declarations require a structure name. */
11276 24 : if (!gfc_comp_struct (gfc_current_state ()))
11277 : {
11278 4 : gfc_error ("Structure name expected in non-nested structure "
11279 : "declaration at %C");
11280 4 : return MATCH_ERROR;
11281 : }
11282 : /* This is an anonymous structure; make up a unique name for it
11283 : (upper-case letters never make it to symbol names from the source).
11284 : The important thing is initializing the type variable
11285 : and setting gfc_new_symbol, which is immediately used by
11286 : parse_structure () and variable_decl () to add components of
11287 : this type. */
11288 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11289 : }
11290 :
11291 329 : where = gfc_current_locus;
11292 : /* No field list allowed after non-nested structure declaration. */
11293 329 : if (!gfc_comp_struct (gfc_current_state ())
11294 296 : && gfc_match_eos () != MATCH_YES)
11295 : {
11296 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11297 1 : return MATCH_ERROR;
11298 : }
11299 :
11300 : /* Make sure the name is not the name of an intrinsic type. */
11301 328 : if (gfc_is_intrinsic_typename (name))
11302 : {
11303 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11304 : " intrinsic type", name);
11305 1 : return MATCH_ERROR;
11306 : }
11307 :
11308 : /* Store the actual type symbol for the structure with an upper-case first
11309 : letter (an invalid Fortran identifier). */
11310 :
11311 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11312 : return MATCH_ERROR;
11313 :
11314 324 : gfc_new_block = sym;
11315 324 : return MATCH_YES;
11316 : }
11317 :
11318 :
11319 : /* This function does some work to determine which matcher should be used to
11320 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11321 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11322 : * and [parameterized] derived type declarations. */
11323 :
11324 : match
11325 541907 : gfc_match_type (gfc_statement *st)
11326 : {
11327 541907 : char name[GFC_MAX_SYMBOL_LEN + 1];
11328 541907 : match m;
11329 541907 : locus old_loc;
11330 :
11331 : /* Requires -fdec. */
11332 541907 : if (!flag_dec)
11333 : return MATCH_NO;
11334 :
11335 2483 : m = gfc_match ("type");
11336 2483 : if (m != MATCH_YES)
11337 : return m;
11338 : /* If we already have an error in the buffer, it is probably from failing to
11339 : * match a derived type data declaration. Let it happen. */
11340 20 : else if (gfc_error_flag_test ())
11341 : return MATCH_NO;
11342 :
11343 20 : old_loc = gfc_current_locus;
11344 20 : *st = ST_NONE;
11345 :
11346 : /* If we see an attribute list before anything else it's definitely a derived
11347 : * type declaration. */
11348 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11349 8 : goto derived;
11350 :
11351 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11352 : * be something like "TYPE *" or "TYPE <fmt>". */
11353 12 : m = gfc_match_name (name);
11354 12 : if (m != MATCH_YES)
11355 : {
11356 : /* Let print match if it can, otherwise throw an error from
11357 : * gfc_match_derived_decl. */
11358 7 : gfc_current_locus = old_loc;
11359 7 : if (gfc_match_print () == MATCH_YES)
11360 : {
11361 7 : *st = ST_WRITE;
11362 7 : return MATCH_YES;
11363 : }
11364 0 : goto derived;
11365 : }
11366 :
11367 : /* Check for EOS. */
11368 5 : if (gfc_match_eos () == MATCH_YES)
11369 : {
11370 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11371 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11372 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11373 : * symbol which can be printed. */
11374 3 : gfc_current_locus = old_loc;
11375 3 : m = gfc_match_derived_decl ();
11376 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11377 : {
11378 2 : *st = ST_DERIVED_DECL;
11379 2 : return m;
11380 : }
11381 : }
11382 : else
11383 : {
11384 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11385 : like <type name(parameter)>. */
11386 2 : gfc_gobble_whitespace ();
11387 2 : bool paren = gfc_peek_ascii_char () == '(';
11388 2 : if (paren)
11389 : {
11390 1 : if (strcmp ("is", name) == 0)
11391 1 : goto typeis;
11392 : else
11393 0 : goto derived;
11394 : }
11395 : }
11396 :
11397 : /* Treat TYPE... like PRINT... */
11398 2 : gfc_current_locus = old_loc;
11399 2 : *st = ST_WRITE;
11400 2 : return gfc_match_print ();
11401 :
11402 8 : derived:
11403 8 : gfc_current_locus = old_loc;
11404 8 : *st = ST_DERIVED_DECL;
11405 8 : return gfc_match_derived_decl ();
11406 :
11407 1 : typeis:
11408 1 : gfc_current_locus = old_loc;
11409 1 : *st = ST_TYPE_IS;
11410 1 : return gfc_match_type_is ();
11411 : }
11412 :
11413 :
11414 : /* Match the beginning of a derived type declaration. If a type name
11415 : was the result of a function, then it is possible to have a symbol
11416 : already to be known as a derived type yet have no components. */
11417 :
11418 : match
11419 17477 : gfc_match_derived_decl (void)
11420 : {
11421 17477 : char name[GFC_MAX_SYMBOL_LEN + 1];
11422 17477 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11423 17477 : symbol_attribute attr;
11424 17477 : gfc_symbol *sym, *gensym;
11425 17477 : gfc_symbol *extended;
11426 17477 : match m;
11427 17477 : match is_type_attr_spec = MATCH_NO;
11428 17477 : bool seen_attr = false;
11429 17477 : gfc_interface *intr = NULL, *head;
11430 17477 : bool parameterized_type = false;
11431 17477 : bool seen_colons = false;
11432 :
11433 17477 : if (gfc_comp_struct (gfc_current_state ()))
11434 : return MATCH_NO;
11435 :
11436 17473 : name[0] = '\0';
11437 17473 : parent[0] = '\0';
11438 17473 : gfc_clear_attr (&attr);
11439 17473 : extended = NULL;
11440 :
11441 20425 : do
11442 : {
11443 20425 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11444 20425 : if (is_type_attr_spec == MATCH_ERROR)
11445 : return MATCH_ERROR;
11446 20422 : if (is_type_attr_spec == MATCH_YES)
11447 2952 : seen_attr = true;
11448 20422 : } while (is_type_attr_spec == MATCH_YES);
11449 :
11450 : /* Deal with derived type extensions. The extension attribute has
11451 : been added to 'attr' but now the parent type must be found and
11452 : checked. */
11453 17470 : if (parent[0])
11454 1625 : extended = check_extended_derived_type (parent);
11455 :
11456 17470 : if (parent[0] && !extended)
11457 : return MATCH_ERROR;
11458 :
11459 17466 : m = gfc_match (" ::");
11460 17466 : if (m == MATCH_YES)
11461 : {
11462 : seen_colons = true;
11463 : }
11464 10836 : else if (seen_attr)
11465 : {
11466 5 : gfc_error ("Expected :: in TYPE definition at %C");
11467 5 : return MATCH_ERROR;
11468 : }
11469 :
11470 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11471 : But, we need to simply return for TYPE(. */
11472 10831 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11473 : {
11474 10782 : char c = gfc_peek_ascii_char ();
11475 10782 : if (c == '(')
11476 : return m;
11477 10701 : if (!gfc_is_whitespace (c))
11478 : {
11479 4 : gfc_error ("Mangled derived type definition at %C");
11480 4 : return MATCH_NO;
11481 : }
11482 : }
11483 :
11484 17376 : m = gfc_match (" %n ", name);
11485 17376 : if (m != MATCH_YES)
11486 : return m;
11487 :
11488 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11489 : derived type named 'is'.
11490 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11491 : and checking if this is a(n intrinsic) typename. This picks up
11492 : misplaced TYPE IS statements such as in select_type_1.f03. */
11493 17364 : if (gfc_peek_ascii_char () == '(')
11494 : {
11495 4247 : if (gfc_current_state () == COMP_SELECT_TYPE
11496 627 : || (!seen_colons && !strcmp (name, "is")))
11497 : return MATCH_NO;
11498 : parameterized_type = true;
11499 : }
11500 :
11501 13742 : m = gfc_match_eos ();
11502 13742 : if (m != MATCH_YES && !parameterized_type)
11503 : return m;
11504 :
11505 : /* Make sure the name is not the name of an intrinsic type. */
11506 13739 : if (gfc_is_intrinsic_typename (name))
11507 : {
11508 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11509 : "type", name);
11510 18 : return MATCH_ERROR;
11511 : }
11512 :
11513 13721 : if (gfc_get_symbol (name, NULL, &gensym))
11514 : return MATCH_ERROR;
11515 :
11516 13721 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11517 : {
11518 5 : if (gensym->ts.u.derived)
11519 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11520 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11521 : else
11522 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11523 : gensym->name);
11524 : return MATCH_ERROR;
11525 : }
11526 :
11527 13716 : if (!gensym->attr.generic
11528 13716 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11529 : return MATCH_ERROR;
11530 :
11531 13712 : if (!gensym->attr.function
11532 13712 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11533 : return MATCH_ERROR;
11534 :
11535 13711 : if (gensym->attr.dummy)
11536 : {
11537 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11538 : name, &gensym->declared_at);
11539 1 : return MATCH_ERROR;
11540 : }
11541 :
11542 13710 : sym = gfc_find_dt_in_generic (gensym);
11543 :
11544 13710 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11545 : {
11546 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11547 : "defined", sym->name);
11548 1 : return MATCH_ERROR;
11549 : }
11550 :
11551 13709 : if (!sym)
11552 : {
11553 : /* Use upper case to save the actual derived-type symbol. */
11554 13619 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11555 13619 : sym->name = gfc_get_string ("%s", gensym->name);
11556 13619 : head = gensym->generic;
11557 13619 : intr = gfc_get_interface ();
11558 13619 : intr->sym = sym;
11559 13619 : intr->where = gfc_current_locus;
11560 13619 : intr->sym->declared_at = gfc_current_locus;
11561 13619 : intr->next = head;
11562 13619 : gensym->generic = intr;
11563 13619 : gensym->attr.if_source = IFSRC_DECL;
11564 : }
11565 :
11566 : /* The symbol may already have the derived attribute without the
11567 : components. The ways this can happen is via a function
11568 : definition, an INTRINSIC statement or a subtype in another
11569 : derived type that is a pointer. The first part of the AND clause
11570 : is true if the symbol is not the return value of a function. */
11571 13709 : if (sym->attr.flavor != FL_DERIVED
11572 13709 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11573 : return MATCH_ERROR;
11574 :
11575 13709 : if (attr.access != ACCESS_UNKNOWN
11576 13709 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11577 : return MATCH_ERROR;
11578 13709 : else if (sym->attr.access == ACCESS_UNKNOWN
11579 13141 : && gensym->attr.access != ACCESS_UNKNOWN
11580 14057 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11581 : sym->name, NULL))
11582 : return MATCH_ERROR;
11583 :
11584 13709 : if (sym->attr.access != ACCESS_UNKNOWN
11585 916 : && gensym->attr.access == ACCESS_UNKNOWN)
11586 568 : gensym->attr.access = sym->attr.access;
11587 :
11588 : /* See if the derived type was labeled as bind(c). */
11589 13709 : if (attr.is_bind_c != 0)
11590 404 : sym->attr.is_bind_c = attr.is_bind_c;
11591 :
11592 : /* Construct the f2k_derived namespace if it is not yet there. */
11593 13709 : if (!sym->f2k_derived)
11594 13709 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11595 :
11596 13709 : if (parameterized_type)
11597 : {
11598 : /* Ignore error or mismatches by going to the end of the statement
11599 : in order to avoid the component declarations causing problems. */
11600 625 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11601 625 : if (m != MATCH_YES)
11602 4 : gfc_error_recovery ();
11603 : else
11604 621 : sym->attr.pdt_template = 1;
11605 625 : m = gfc_match_eos ();
11606 625 : if (m != MATCH_YES)
11607 : {
11608 1 : gfc_error_recovery ();
11609 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11610 : }
11611 : }
11612 :
11613 13709 : if (extended && !sym->components)
11614 : {
11615 1621 : gfc_component *p;
11616 1621 : gfc_formal_arglist *f, *g, *h;
11617 :
11618 : /* Add the extended derived type as the first component. */
11619 1621 : gfc_add_component (sym, parent, &p);
11620 1621 : extended->refs++;
11621 1621 : gfc_set_sym_referenced (extended);
11622 :
11623 1621 : p->ts.type = BT_DERIVED;
11624 1621 : p->ts.u.derived = extended;
11625 1621 : p->initializer = gfc_default_initializer (&p->ts);
11626 :
11627 : /* Set extension level. */
11628 1621 : if (extended->attr.extension == 255)
11629 : {
11630 : /* Since the extension field is 8 bit wide, we can only have
11631 : up to 255 extension levels. */
11632 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11633 : extended->name, &extended->declared_at);
11634 0 : return MATCH_ERROR;
11635 : }
11636 1621 : sym->attr.extension = extended->attr.extension + 1;
11637 :
11638 : /* Provide the links between the extended type and its extension. */
11639 1621 : if (!extended->f2k_derived)
11640 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11641 :
11642 : /* Copy the extended type-param-name-list from the extended type,
11643 : append those of the extension and add the whole lot to the
11644 : extension. */
11645 1621 : if (extended->attr.pdt_template)
11646 : {
11647 76 : g = h = NULL;
11648 76 : sym->attr.pdt_template = 1;
11649 231 : for (f = extended->formal; f; f = f->next)
11650 : {
11651 155 : if (f == extended->formal)
11652 : {
11653 76 : g = gfc_get_formal_arglist ();
11654 76 : h = g;
11655 : }
11656 : else
11657 : {
11658 79 : g->next = gfc_get_formal_arglist ();
11659 79 : g = g->next;
11660 : }
11661 155 : g->sym = f->sym;
11662 : }
11663 76 : g->next = sym->formal;
11664 76 : sym->formal = h;
11665 : }
11666 : }
11667 :
11668 13709 : if (!sym->hash_value)
11669 : /* Set the hash for the compound name for this type. */
11670 13709 : sym->hash_value = gfc_hash_value (sym);
11671 :
11672 : /* Take over the ABSTRACT attribute. */
11673 13709 : sym->attr.abstract = attr.abstract;
11674 :
11675 13709 : gfc_new_block = sym;
11676 :
11677 13709 : return MATCH_YES;
11678 : }
11679 :
11680 :
11681 : /* Cray Pointees can be declared as:
11682 : pointer (ipt, a (n,m,...,*)) */
11683 :
11684 : match
11685 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11686 : {
11687 240 : as->cray_pointee = true; /* This will be useful to know later. */
11688 240 : if (as->type == AS_ASSUMED_SIZE)
11689 72 : as->cp_was_assumed = true;
11690 168 : else if (as->type == AS_ASSUMED_SHAPE)
11691 : {
11692 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11693 0 : return MATCH_ERROR;
11694 : }
11695 : return MATCH_YES;
11696 : }
11697 :
11698 :
11699 : /* Match the enum definition statement, here we are trying to match
11700 : the first line of enum definition statement.
11701 : Returns MATCH_YES if match is found. */
11702 :
11703 : match
11704 158 : gfc_match_enum (void)
11705 : {
11706 158 : match m;
11707 :
11708 158 : m = gfc_match_eos ();
11709 158 : if (m != MATCH_YES)
11710 : return m;
11711 :
11712 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11713 0 : return MATCH_ERROR;
11714 :
11715 : return MATCH_YES;
11716 : }
11717 :
11718 :
11719 : /* Returns an initializer whose value is one higher than the value of the
11720 : LAST_INITIALIZER argument. If the argument is NULL, the
11721 : initializers value will be set to zero. The initializer's kind
11722 : will be set to gfc_c_int_kind.
11723 :
11724 : If -fshort-enums is given, the appropriate kind will be selected
11725 : later after all enumerators have been parsed. A warning is issued
11726 : here if an initializer exceeds gfc_c_int_kind. */
11727 :
11728 : static gfc_expr *
11729 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11730 : {
11731 377 : gfc_expr *result;
11732 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11733 :
11734 377 : mpz_init (result->value.integer);
11735 :
11736 377 : if (last_initializer != NULL)
11737 : {
11738 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11739 266 : result->where = last_initializer->where;
11740 :
11741 266 : if (gfc_check_integer_range (result->value.integer,
11742 : gfc_c_int_kind) != ARITH_OK)
11743 : {
11744 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11745 0 : return NULL;
11746 : }
11747 : }
11748 : else
11749 : {
11750 : /* Control comes here, if it's the very first enumerator and no
11751 : initializer has been given. It will be initialized to zero. */
11752 111 : mpz_set_si (result->value.integer, 0);
11753 : }
11754 :
11755 : return result;
11756 : }
11757 :
11758 :
11759 : /* Match a variable name with an optional initializer. When this
11760 : subroutine is called, a variable is expected to be parsed next.
11761 : Depending on what is happening at the moment, updates either the
11762 : symbol table or the current interface. */
11763 :
11764 : static match
11765 549 : enumerator_decl (void)
11766 : {
11767 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11768 549 : gfc_expr *initializer;
11769 549 : gfc_array_spec *as = NULL;
11770 549 : gfc_charlen *saved_cl_list;
11771 549 : gfc_symbol *sym;
11772 549 : locus var_locus;
11773 549 : match m;
11774 549 : bool t;
11775 549 : locus old_locus;
11776 :
11777 549 : initializer = NULL;
11778 549 : saved_cl_list = gfc_current_ns->cl_list;
11779 549 : old_locus = gfc_current_locus;
11780 :
11781 : /* When we get here, we've just matched a list of attributes and
11782 : maybe a type and a double colon. The next thing we expect to see
11783 : is the name of the symbol. */
11784 549 : m = gfc_match_name (name);
11785 549 : if (m != MATCH_YES)
11786 1 : goto cleanup;
11787 :
11788 548 : var_locus = gfc_current_locus;
11789 :
11790 : /* OK, we've successfully matched the declaration. Now put the
11791 : symbol in the current namespace. If we fail to create the symbol,
11792 : bail out. */
11793 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11794 : {
11795 1 : m = MATCH_ERROR;
11796 1 : goto cleanup;
11797 : }
11798 :
11799 : /* The double colon must be present in order to have initializers.
11800 : Otherwise the statement is ambiguous with an assignment statement. */
11801 547 : if (colon_seen)
11802 : {
11803 471 : if (gfc_match_char ('=') == MATCH_YES)
11804 : {
11805 170 : m = gfc_match_init_expr (&initializer);
11806 170 : if (m == MATCH_NO)
11807 : {
11808 0 : gfc_error ("Expected an initialization expression at %C");
11809 0 : m = MATCH_ERROR;
11810 : }
11811 :
11812 170 : if (m != MATCH_YES)
11813 2 : goto cleanup;
11814 : }
11815 : }
11816 :
11817 : /* If we do not have an initializer, the initialization value of the
11818 : previous enumerator (stored in last_initializer) is incremented
11819 : by 1 and is used to initialize the current enumerator. */
11820 545 : if (initializer == NULL)
11821 377 : initializer = enum_initializer (last_initializer, old_locus);
11822 :
11823 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11824 : {
11825 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11826 : &var_locus);
11827 2 : m = MATCH_ERROR;
11828 2 : goto cleanup;
11829 : }
11830 :
11831 : /* Store this current initializer, for the next enumerator variable
11832 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11833 : use last_initializer below. */
11834 543 : last_initializer = initializer;
11835 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
11836 : saved_cl_list);
11837 :
11838 : /* Maintain enumerator history. */
11839 543 : gfc_find_symbol (name, NULL, 0, &sym);
11840 543 : create_enum_history (sym, last_initializer);
11841 :
11842 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11843 :
11844 6 : cleanup:
11845 : /* Free stuff up and return. */
11846 6 : gfc_free_expr (initializer);
11847 :
11848 6 : return m;
11849 : }
11850 :
11851 :
11852 : /* Match the enumerator definition statement. */
11853 :
11854 : match
11855 826160 : gfc_match_enumerator_def (void)
11856 : {
11857 826160 : match m;
11858 826160 : bool t;
11859 :
11860 826160 : gfc_clear_ts (¤t_ts);
11861 :
11862 826160 : m = gfc_match (" enumerator");
11863 826160 : if (m != MATCH_YES)
11864 : return m;
11865 :
11866 269 : m = gfc_match (" :: ");
11867 269 : if (m == MATCH_ERROR)
11868 : return m;
11869 :
11870 269 : colon_seen = (m == MATCH_YES);
11871 :
11872 269 : if (gfc_current_state () != COMP_ENUM)
11873 : {
11874 4 : gfc_error ("ENUM definition statement expected before %C");
11875 4 : gfc_free_enum_history ();
11876 4 : return MATCH_ERROR;
11877 : }
11878 :
11879 265 : (¤t_ts)->type = BT_INTEGER;
11880 265 : (¤t_ts)->kind = gfc_c_int_kind;
11881 :
11882 265 : gfc_clear_attr (¤t_attr);
11883 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11884 265 : if (!t)
11885 : {
11886 0 : m = MATCH_ERROR;
11887 0 : goto cleanup;
11888 : }
11889 :
11890 549 : for (;;)
11891 : {
11892 549 : m = enumerator_decl ();
11893 549 : if (m == MATCH_ERROR)
11894 : {
11895 6 : gfc_free_enum_history ();
11896 6 : goto cleanup;
11897 : }
11898 543 : if (m == MATCH_NO)
11899 : break;
11900 :
11901 542 : if (gfc_match_eos () == MATCH_YES)
11902 256 : goto cleanup;
11903 286 : if (gfc_match_char (',') != MATCH_YES)
11904 : break;
11905 : }
11906 :
11907 3 : if (gfc_current_state () == COMP_ENUM)
11908 : {
11909 3 : gfc_free_enum_history ();
11910 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11911 3 : m = MATCH_ERROR;
11912 : }
11913 :
11914 0 : cleanup:
11915 265 : gfc_free_array_spec (current_as);
11916 265 : current_as = NULL;
11917 265 : return m;
11918 :
11919 : }
11920 :
11921 :
11922 : /* Match binding attributes. */
11923 :
11924 : static match
11925 4750 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11926 : {
11927 4750 : bool found_passing = false;
11928 4750 : bool seen_ptr = false;
11929 4750 : match m = MATCH_YES;
11930 :
11931 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11932 : this case the defaults are in there. */
11933 4750 : ba->access = ACCESS_UNKNOWN;
11934 4750 : ba->pass_arg = NULL;
11935 4750 : ba->pass_arg_num = 0;
11936 4750 : ba->nopass = 0;
11937 4750 : ba->non_overridable = 0;
11938 4750 : ba->deferred = 0;
11939 4750 : ba->ppc = ppc;
11940 :
11941 : /* If we find a comma, we believe there are binding attributes. */
11942 4750 : m = gfc_match_char (',');
11943 4750 : if (m == MATCH_NO)
11944 2482 : goto done;
11945 :
11946 2829 : do
11947 : {
11948 : /* Access specifier. */
11949 :
11950 2829 : m = gfc_match (" public");
11951 2829 : if (m == MATCH_ERROR)
11952 0 : goto error;
11953 2829 : if (m == MATCH_YES)
11954 : {
11955 250 : if (ba->access != ACCESS_UNKNOWN)
11956 : {
11957 0 : gfc_error ("Duplicate access-specifier at %C");
11958 0 : goto error;
11959 : }
11960 :
11961 250 : ba->access = ACCESS_PUBLIC;
11962 250 : continue;
11963 : }
11964 :
11965 2579 : m = gfc_match (" private");
11966 2579 : if (m == MATCH_ERROR)
11967 0 : goto error;
11968 2579 : if (m == MATCH_YES)
11969 : {
11970 181 : if (ba->access != ACCESS_UNKNOWN)
11971 : {
11972 1 : gfc_error ("Duplicate access-specifier at %C");
11973 1 : goto error;
11974 : }
11975 :
11976 180 : ba->access = ACCESS_PRIVATE;
11977 180 : continue;
11978 : }
11979 :
11980 : /* If inside GENERIC, the following is not allowed. */
11981 2398 : if (!generic)
11982 : {
11983 :
11984 : /* NOPASS flag. */
11985 2397 : m = gfc_match (" nopass");
11986 2397 : if (m == MATCH_ERROR)
11987 0 : goto error;
11988 2397 : if (m == MATCH_YES)
11989 : {
11990 731 : if (found_passing)
11991 : {
11992 1 : gfc_error ("Binding attributes already specify passing,"
11993 : " illegal NOPASS at %C");
11994 1 : goto error;
11995 : }
11996 :
11997 730 : found_passing = true;
11998 730 : ba->nopass = 1;
11999 730 : continue;
12000 : }
12001 :
12002 : /* PASS possibly including argument. */
12003 1666 : m = gfc_match (" pass");
12004 1666 : if (m == MATCH_ERROR)
12005 0 : goto error;
12006 1666 : if (m == MATCH_YES)
12007 : {
12008 901 : char arg[GFC_MAX_SYMBOL_LEN + 1];
12009 :
12010 901 : if (found_passing)
12011 : {
12012 2 : gfc_error ("Binding attributes already specify passing,"
12013 : " illegal PASS at %C");
12014 2 : goto error;
12015 : }
12016 :
12017 899 : m = gfc_match (" ( %n )", arg);
12018 899 : if (m == MATCH_ERROR)
12019 0 : goto error;
12020 899 : if (m == MATCH_YES)
12021 490 : ba->pass_arg = gfc_get_string ("%s", arg);
12022 899 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
12023 :
12024 899 : found_passing = true;
12025 899 : ba->nopass = 0;
12026 899 : continue;
12027 899 : }
12028 :
12029 765 : if (ppc)
12030 : {
12031 : /* POINTER flag. */
12032 443 : m = gfc_match (" pointer");
12033 443 : if (m == MATCH_ERROR)
12034 0 : goto error;
12035 443 : if (m == MATCH_YES)
12036 : {
12037 443 : if (seen_ptr)
12038 : {
12039 1 : gfc_error ("Duplicate POINTER attribute at %C");
12040 1 : goto error;
12041 : }
12042 :
12043 442 : seen_ptr = true;
12044 442 : continue;
12045 : }
12046 : }
12047 : else
12048 : {
12049 : /* NON_OVERRIDABLE flag. */
12050 322 : m = gfc_match (" non_overridable");
12051 322 : if (m == MATCH_ERROR)
12052 0 : goto error;
12053 322 : if (m == MATCH_YES)
12054 : {
12055 62 : if (ba->non_overridable)
12056 : {
12057 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
12058 1 : goto error;
12059 : }
12060 :
12061 61 : ba->non_overridable = 1;
12062 61 : continue;
12063 : }
12064 :
12065 : /* DEFERRED flag. */
12066 260 : m = gfc_match (" deferred");
12067 260 : if (m == MATCH_ERROR)
12068 0 : goto error;
12069 260 : if (m == MATCH_YES)
12070 : {
12071 260 : if (ba->deferred)
12072 : {
12073 1 : gfc_error ("Duplicate DEFERRED at %C");
12074 1 : goto error;
12075 : }
12076 :
12077 259 : ba->deferred = 1;
12078 259 : continue;
12079 : }
12080 : }
12081 :
12082 : }
12083 :
12084 : /* Nothing matching found. */
12085 1 : if (generic)
12086 1 : gfc_error ("Expected access-specifier at %C");
12087 : else
12088 0 : gfc_error ("Expected binding attribute at %C");
12089 1 : goto error;
12090 : }
12091 2821 : while (gfc_match_char (',') == MATCH_YES);
12092 :
12093 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
12094 2260 : if (ba->non_overridable && ba->deferred)
12095 : {
12096 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
12097 1 : goto error;
12098 : }
12099 :
12100 : m = MATCH_YES;
12101 :
12102 4741 : done:
12103 4741 : if (ba->access == ACCESS_UNKNOWN)
12104 4312 : ba->access = ppc ? gfc_current_block()->component_access
12105 : : gfc_typebound_default_access;
12106 :
12107 4741 : if (ppc && !seen_ptr)
12108 : {
12109 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
12110 : " at %C");
12111 2 : goto error;
12112 : }
12113 :
12114 : return m;
12115 :
12116 4750 : error:
12117 : return MATCH_ERROR;
12118 : }
12119 :
12120 :
12121 : /* Match a PROCEDURE specific binding inside a derived type. */
12122 :
12123 : static match
12124 3254 : match_procedure_in_type (void)
12125 : {
12126 3254 : char name[GFC_MAX_SYMBOL_LEN + 1];
12127 3254 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
12128 3254 : char* target = NULL, *ifc = NULL;
12129 3254 : gfc_typebound_proc tb;
12130 3254 : bool seen_colons;
12131 3254 : bool seen_attrs;
12132 3254 : match m;
12133 3254 : gfc_symtree* stree;
12134 3254 : gfc_namespace* ns;
12135 3254 : gfc_symbol* block;
12136 3254 : int num;
12137 :
12138 : /* Check current state. */
12139 3254 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
12140 3254 : block = gfc_state_stack->previous->sym;
12141 3254 : gcc_assert (block);
12142 :
12143 : /* Try to match PROCEDURE(interface). */
12144 3254 : if (gfc_match (" (") == MATCH_YES)
12145 : {
12146 261 : m = gfc_match_name (target_buf);
12147 261 : if (m == MATCH_ERROR)
12148 : return m;
12149 261 : if (m != MATCH_YES)
12150 : {
12151 1 : gfc_error ("Interface-name expected after %<(%> at %C");
12152 1 : return MATCH_ERROR;
12153 : }
12154 :
12155 260 : if (gfc_match (" )") != MATCH_YES)
12156 : {
12157 1 : gfc_error ("%<)%> expected at %C");
12158 1 : return MATCH_ERROR;
12159 : }
12160 :
12161 : ifc = target_buf;
12162 : }
12163 :
12164 : /* Construct the data structure. */
12165 3252 : memset (&tb, 0, sizeof (tb));
12166 3252 : tb.where = gfc_current_locus;
12167 :
12168 : /* Match binding attributes. */
12169 3252 : m = match_binding_attributes (&tb, false, false);
12170 3252 : if (m == MATCH_ERROR)
12171 : return m;
12172 3245 : seen_attrs = (m == MATCH_YES);
12173 :
12174 : /* Check that attribute DEFERRED is given if an interface is specified. */
12175 3245 : if (tb.deferred && !ifc)
12176 : {
12177 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
12178 1 : return MATCH_ERROR;
12179 : }
12180 3244 : if (ifc && !tb.deferred)
12181 : {
12182 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
12183 1 : return MATCH_ERROR;
12184 : }
12185 :
12186 : /* Match the colons. */
12187 3243 : m = gfc_match (" ::");
12188 3243 : if (m == MATCH_ERROR)
12189 : return m;
12190 3243 : seen_colons = (m == MATCH_YES);
12191 3243 : if (seen_attrs && !seen_colons)
12192 : {
12193 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
12194 4 : return MATCH_ERROR;
12195 : }
12196 :
12197 : /* Match the binding names. */
12198 19 : for(num=1;;num++)
12199 : {
12200 3258 : m = gfc_match_name (name);
12201 3258 : if (m == MATCH_ERROR)
12202 : return m;
12203 3258 : if (m == MATCH_NO)
12204 : {
12205 5 : gfc_error ("Expected binding name at %C");
12206 5 : return MATCH_ERROR;
12207 : }
12208 :
12209 3253 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
12210 : return MATCH_ERROR;
12211 :
12212 : /* Try to match the '=> target', if it's there. */
12213 3252 : target = ifc;
12214 3252 : m = gfc_match (" =>");
12215 3252 : if (m == MATCH_ERROR)
12216 : return m;
12217 3252 : if (m == MATCH_YES)
12218 : {
12219 1250 : if (tb.deferred)
12220 : {
12221 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
12222 1 : return MATCH_ERROR;
12223 : }
12224 :
12225 1249 : if (!seen_colons)
12226 : {
12227 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
12228 : " at %C");
12229 1 : return MATCH_ERROR;
12230 : }
12231 :
12232 1248 : m = gfc_match_name (target_buf);
12233 1248 : if (m == MATCH_ERROR)
12234 : return m;
12235 1248 : if (m == MATCH_NO)
12236 : {
12237 2 : gfc_error ("Expected binding target after %<=>%> at %C");
12238 2 : return MATCH_ERROR;
12239 : }
12240 : target = target_buf;
12241 : }
12242 :
12243 : /* If no target was found, it has the same name as the binding. */
12244 2002 : if (!target)
12245 1747 : target = name;
12246 :
12247 : /* Get the namespace to insert the symbols into. */
12248 3248 : ns = block->f2k_derived;
12249 3248 : gcc_assert (ns);
12250 :
12251 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
12252 3248 : if (tb.deferred && !block->attr.abstract)
12253 : {
12254 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
12255 : "is not ABSTRACT", block->name);
12256 1 : return MATCH_ERROR;
12257 : }
12258 :
12259 : /* See if we already have a binding with this name in the symtree which
12260 : would be an error. If a GENERIC already targeted this binding, it may
12261 : be already there but then typebound is still NULL. */
12262 3247 : stree = gfc_find_symtree (ns->tb_sym_root, name);
12263 3247 : if (stree && stree->n.tb)
12264 : {
12265 2 : gfc_error ("There is already a procedure with binding name %qs for "
12266 : "the derived type %qs at %C", name, block->name);
12267 2 : return MATCH_ERROR;
12268 : }
12269 :
12270 : /* Insert it and set attributes. */
12271 :
12272 3126 : if (!stree)
12273 : {
12274 3126 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12275 3126 : gcc_assert (stree);
12276 : }
12277 3245 : stree->n.tb = gfc_get_typebound_proc (&tb);
12278 :
12279 3245 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12280 : false))
12281 : return MATCH_ERROR;
12282 3245 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12283 3245 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12284 3245 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12285 :
12286 3245 : if (gfc_match_eos () == MATCH_YES)
12287 : return MATCH_YES;
12288 20 : if (gfc_match_char (',') != MATCH_YES)
12289 1 : goto syntax;
12290 : }
12291 :
12292 1 : syntax:
12293 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12294 1 : return MATCH_ERROR;
12295 : }
12296 :
12297 :
12298 : /* Match a GENERIC statement.
12299 : F2018 15.4.3.3 GENERIC statement
12300 :
12301 : A GENERIC statement specifies a generic identifier for one or more specific
12302 : procedures, in the same way as a generic interface block that does not contain
12303 : interface bodies.
12304 :
12305 : R1510 generic-stmt is:
12306 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12307 :
12308 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12309 : procedure that was specified previously in any accessible interface with the
12310 : same generic identifier.
12311 :
12312 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12313 :
12314 : For GENERIC statements outside of a derived type, use is made of the existing,
12315 : typebound matching functions to obtain access-spec and generic-spec. After
12316 : this the standard INTERFACE machinery is used. */
12317 :
12318 : static match
12319 100 : match_generic_stmt (void)
12320 : {
12321 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12322 : /* Allow space for OPERATOR(...). */
12323 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12324 : /* Generics other than uops */
12325 100 : gfc_symbol* generic_spec = NULL;
12326 : /* Generic uops */
12327 100 : gfc_user_op *generic_uop = NULL;
12328 : /* For the matching calls */
12329 100 : gfc_typebound_proc tbattr;
12330 100 : gfc_namespace* ns = gfc_current_ns;
12331 100 : interface_type op_type;
12332 100 : gfc_intrinsic_op op;
12333 100 : match m;
12334 100 : gfc_symtree* st;
12335 : /* The specific-procedure-list */
12336 100 : gfc_interface *generic = NULL;
12337 : /* The head of the specific-procedure-list */
12338 100 : gfc_interface **generic_tail = NULL;
12339 :
12340 100 : memset (&tbattr, 0, sizeof (tbattr));
12341 100 : tbattr.where = gfc_current_locus;
12342 :
12343 : /* See if we get an access-specifier. */
12344 100 : m = match_binding_attributes (&tbattr, true, false);
12345 100 : tbattr.where = gfc_current_locus;
12346 100 : if (m == MATCH_ERROR)
12347 0 : goto error;
12348 :
12349 : /* Now the colons, those are required. */
12350 100 : if (gfc_match (" ::") != MATCH_YES)
12351 : {
12352 0 : gfc_error ("Expected %<::%> at %C");
12353 0 : goto error;
12354 : }
12355 :
12356 : /* Match the generic-spec name; depending on type (operator / generic) format
12357 : it for future error messages in 'generic_spec_name'. */
12358 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12359 100 : if (m == MATCH_ERROR)
12360 : return MATCH_ERROR;
12361 100 : if (m == MATCH_NO)
12362 : {
12363 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12364 0 : goto error;
12365 : }
12366 :
12367 100 : switch (op_type)
12368 : {
12369 63 : case INTERFACE_GENERIC:
12370 63 : case INTERFACE_DTIO:
12371 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12372 63 : break;
12373 :
12374 22 : case INTERFACE_USER_OP:
12375 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12376 22 : break;
12377 :
12378 13 : case INTERFACE_INTRINSIC_OP:
12379 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12380 : gfc_op2string (op));
12381 13 : break;
12382 :
12383 2 : case INTERFACE_NAMELESS:
12384 2 : gfc_error ("Malformed GENERIC statement at %C");
12385 2 : goto error;
12386 0 : break;
12387 :
12388 0 : default:
12389 0 : gcc_unreachable ();
12390 : }
12391 :
12392 : /* Match the required =>. */
12393 98 : if (gfc_match (" =>") != MATCH_YES)
12394 : {
12395 1 : gfc_error ("Expected %<=>%> at %C");
12396 1 : goto error;
12397 : }
12398 :
12399 :
12400 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12401 : {
12402 1 : gfc_error ("The access specification at %L not in a module",
12403 : &tbattr.where);
12404 1 : goto error;
12405 : }
12406 :
12407 : /* Try to find existing generic-spec with this name for this operator;
12408 : if there is something, check that it is another generic-spec and then
12409 : extend it rather than building a new symbol. Otherwise, create a new
12410 : one with the right attributes. */
12411 :
12412 96 : switch (op_type)
12413 : {
12414 61 : case INTERFACE_DTIO:
12415 61 : case INTERFACE_GENERIC:
12416 61 : st = gfc_find_symtree (ns->sym_root, name);
12417 61 : generic_spec = st ? st->n.sym : NULL;
12418 61 : if (generic_spec)
12419 : {
12420 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12421 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12422 : {
12423 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12424 : "name of an entity declared at %L that is not a "
12425 : "procedure", name, &generic_spec->declared_at);
12426 1 : goto error;
12427 : }
12428 :
12429 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12430 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12431 : {
12432 0 : gfc_error ("There's already a non-generic procedure with "
12433 : "name %qs at %C", generic_spec->name);
12434 0 : goto error;
12435 : }
12436 :
12437 24 : if (tbattr.access != ACCESS_UNKNOWN)
12438 : {
12439 2 : if (generic_spec->attr.access != tbattr.access)
12440 : {
12441 1 : gfc_error ("The access specification at %L conflicts with "
12442 : "that already given to %qs", &tbattr.where,
12443 : generic_spec->name);
12444 1 : goto error;
12445 : }
12446 : else
12447 : {
12448 1 : gfc_error ("The access specification at %L repeats that "
12449 : "already given to %qs", &tbattr.where,
12450 : generic_spec->name);
12451 1 : goto error;
12452 : }
12453 : }
12454 :
12455 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12456 : {
12457 1 : gfc_error ("The generic-spec in the generic statement at %C "
12458 : "has a type from the declaration at %L",
12459 : &generic_spec->declared_at);
12460 1 : goto error;
12461 : }
12462 : }
12463 :
12464 : /* Now create the generic_spec if it doesn't already exist and provide
12465 : is with the appropriate attributes. */
12466 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12467 : {
12468 45 : if (!generic_spec)
12469 : {
12470 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12471 36 : gfc_set_sym_referenced (generic_spec);
12472 36 : generic_spec->attr.access = tbattr.access;
12473 : }
12474 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12475 0 : generic_spec->attr.access = tbattr.access;
12476 45 : generic_spec->refs++;
12477 45 : generic_spec->attr.generic = 1;
12478 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12479 :
12480 45 : generic_spec->declared_at = gfc_current_locus;
12481 : }
12482 :
12483 : /* Prepare to add the specific procedures. */
12484 57 : generic = generic_spec->generic;
12485 57 : generic_tail = &generic_spec->generic;
12486 57 : break;
12487 :
12488 22 : case INTERFACE_USER_OP:
12489 22 : st = gfc_find_symtree (ns->uop_root, name);
12490 22 : generic_uop = st ? st->n.uop : NULL;
12491 2 : if (generic_uop)
12492 : {
12493 2 : if (generic_uop->access != ACCESS_UNKNOWN
12494 2 : && tbattr.access != ACCESS_UNKNOWN)
12495 : {
12496 2 : if (generic_uop->access != tbattr.access)
12497 : {
12498 1 : gfc_error ("The user operator at %L must have the same "
12499 : "access specification as already defined user "
12500 : "operator %qs", &tbattr.where, generic_spec_name);
12501 1 : goto error;
12502 : }
12503 : else
12504 : {
12505 1 : gfc_error ("The user operator at %L repeats the access "
12506 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12507 1 : goto error;
12508 : }
12509 : }
12510 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12511 0 : generic_uop->access = tbattr.access;
12512 : }
12513 : else
12514 : {
12515 20 : generic_uop = gfc_get_uop (name);
12516 20 : generic_uop->access = tbattr.access;
12517 : }
12518 :
12519 : /* Prepare to add the specific procedures. */
12520 20 : generic = generic_uop->op;
12521 20 : generic_tail = &generic_uop->op;
12522 20 : break;
12523 :
12524 13 : case INTERFACE_INTRINSIC_OP:
12525 13 : generic = ns->op[op];
12526 13 : generic_tail = &ns->op[op];
12527 13 : break;
12528 :
12529 0 : default:
12530 0 : gcc_unreachable ();
12531 : }
12532 :
12533 : /* Now, match all following names in the specific-procedure-list. */
12534 154 : do
12535 : {
12536 154 : m = gfc_match_name (name);
12537 154 : if (m == MATCH_ERROR)
12538 0 : goto error;
12539 154 : if (m == MATCH_NO)
12540 : {
12541 0 : gfc_error ("Expected specific procedure name at %C");
12542 0 : goto error;
12543 : }
12544 :
12545 154 : if (op_type == INTERFACE_GENERIC
12546 95 : && !strcmp (generic_spec->name, name))
12547 : {
12548 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12549 : "with that of the generic-spec", name);
12550 2 : goto error;
12551 : }
12552 :
12553 152 : generic = *generic_tail;
12554 242 : for (; generic; generic = generic->next)
12555 : {
12556 90 : if (!strcmp (generic->sym->name, name))
12557 : {
12558 0 : gfc_error ("%qs already defined as a specific procedure for the"
12559 : " generic %qs at %C", name, generic_spec->name);
12560 0 : goto error;
12561 : }
12562 : }
12563 :
12564 152 : gfc_find_sym_tree (name, ns, 1, &st);
12565 152 : if (!st)
12566 : {
12567 : /* This might be a procedure that has not yet been parsed. If
12568 : so gfc_fixup_sibling_symbols will replace this symbol with
12569 : that of the procedure. */
12570 75 : gfc_get_sym_tree (name, ns, &st, false);
12571 75 : st->n.sym->refs++;
12572 : }
12573 :
12574 152 : generic = gfc_get_interface();
12575 152 : generic->next = *generic_tail;
12576 152 : *generic_tail = generic;
12577 152 : generic->where = gfc_current_locus;
12578 152 : generic->sym = st->n.sym;
12579 : }
12580 152 : while (gfc_match (" ,") == MATCH_YES);
12581 :
12582 88 : if (gfc_match_eos () != MATCH_YES)
12583 : {
12584 0 : gfc_error ("Junk after GENERIC statement at %C");
12585 0 : goto error;
12586 : }
12587 :
12588 88 : gfc_commit_symbols ();
12589 88 : return MATCH_YES;
12590 :
12591 100 : error:
12592 : return MATCH_ERROR;
12593 : }
12594 :
12595 :
12596 : /* Match a GENERIC procedure binding inside a derived type. */
12597 :
12598 : static match
12599 954 : match_typebound_generic (void)
12600 : {
12601 954 : char name[GFC_MAX_SYMBOL_LEN + 1];
12602 954 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12603 954 : gfc_symbol* block;
12604 954 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12605 954 : gfc_typebound_proc* tb;
12606 954 : gfc_namespace* ns;
12607 954 : interface_type op_type;
12608 954 : gfc_intrinsic_op op;
12609 954 : match m;
12610 :
12611 : /* Check current state. */
12612 954 : if (gfc_current_state () == COMP_DERIVED)
12613 : {
12614 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12615 0 : return MATCH_ERROR;
12616 : }
12617 954 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12618 : return MATCH_NO;
12619 954 : block = gfc_state_stack->previous->sym;
12620 954 : ns = block->f2k_derived;
12621 954 : gcc_assert (block && ns);
12622 :
12623 954 : memset (&tbattr, 0, sizeof (tbattr));
12624 954 : tbattr.where = gfc_current_locus;
12625 :
12626 : /* See if we get an access-specifier. */
12627 954 : m = match_binding_attributes (&tbattr, true, false);
12628 954 : if (m == MATCH_ERROR)
12629 1 : goto error;
12630 :
12631 : /* Now the colons, those are required. */
12632 953 : if (gfc_match (" ::") != MATCH_YES)
12633 : {
12634 0 : gfc_error ("Expected %<::%> at %C");
12635 0 : goto error;
12636 : }
12637 :
12638 : /* Match the binding name; depending on type (operator / generic) format
12639 : it for future error messages into bind_name. */
12640 :
12641 953 : m = gfc_match_generic_spec (&op_type, name, &op);
12642 953 : if (m == MATCH_ERROR)
12643 : return MATCH_ERROR;
12644 953 : if (m == MATCH_NO)
12645 : {
12646 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12647 0 : goto error;
12648 : }
12649 :
12650 953 : switch (op_type)
12651 : {
12652 470 : case INTERFACE_GENERIC:
12653 470 : case INTERFACE_DTIO:
12654 470 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12655 470 : break;
12656 :
12657 47 : case INTERFACE_USER_OP:
12658 47 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12659 47 : break;
12660 :
12661 435 : case INTERFACE_INTRINSIC_OP:
12662 435 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12663 : gfc_op2string (op));
12664 435 : break;
12665 :
12666 1 : case INTERFACE_NAMELESS:
12667 1 : gfc_error ("Malformed GENERIC statement at %C");
12668 1 : goto error;
12669 0 : break;
12670 :
12671 0 : default:
12672 0 : gcc_unreachable ();
12673 : }
12674 :
12675 : /* Match the required =>. */
12676 952 : if (gfc_match (" =>") != MATCH_YES)
12677 : {
12678 0 : gfc_error ("Expected %<=>%> at %C");
12679 0 : goto error;
12680 : }
12681 :
12682 : /* Try to find existing GENERIC binding with this name / for this operator;
12683 : if there is something, check that it is another GENERIC and then extend
12684 : it rather than building a new node. Otherwise, create it and put it
12685 : at the right position. */
12686 :
12687 952 : switch (op_type)
12688 : {
12689 517 : case INTERFACE_DTIO:
12690 517 : case INTERFACE_USER_OP:
12691 517 : case INTERFACE_GENERIC:
12692 517 : {
12693 517 : const bool is_op = (op_type == INTERFACE_USER_OP);
12694 517 : gfc_symtree* st;
12695 :
12696 517 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12697 517 : tb = st ? st->n.tb : NULL;
12698 : break;
12699 : }
12700 :
12701 435 : case INTERFACE_INTRINSIC_OP:
12702 435 : tb = ns->tb_op[op];
12703 435 : break;
12704 :
12705 0 : default:
12706 0 : gcc_unreachable ();
12707 : }
12708 :
12709 446 : if (tb)
12710 : {
12711 9 : if (!tb->is_generic)
12712 : {
12713 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12714 1 : gfc_error ("There's already a non-generic procedure with binding name"
12715 : " %qs for the derived type %qs at %C",
12716 : bind_name, block->name);
12717 1 : goto error;
12718 : }
12719 :
12720 8 : if (tb->access != tbattr.access)
12721 : {
12722 2 : gfc_error ("Binding at %C must have the same access as already"
12723 : " defined binding %qs", bind_name);
12724 2 : goto error;
12725 : }
12726 : }
12727 : else
12728 : {
12729 943 : tb = gfc_get_typebound_proc (NULL);
12730 943 : tb->where = gfc_current_locus;
12731 943 : tb->access = tbattr.access;
12732 943 : tb->is_generic = 1;
12733 943 : tb->u.generic = NULL;
12734 :
12735 943 : switch (op_type)
12736 : {
12737 508 : case INTERFACE_DTIO:
12738 508 : case INTERFACE_GENERIC:
12739 508 : case INTERFACE_USER_OP:
12740 508 : {
12741 508 : const bool is_op = (op_type == INTERFACE_USER_OP);
12742 508 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12743 : &ns->tb_sym_root, name);
12744 508 : gcc_assert (st);
12745 508 : st->n.tb = tb;
12746 :
12747 508 : break;
12748 : }
12749 :
12750 435 : case INTERFACE_INTRINSIC_OP:
12751 435 : ns->tb_op[op] = tb;
12752 435 : break;
12753 :
12754 0 : default:
12755 0 : gcc_unreachable ();
12756 : }
12757 : }
12758 :
12759 : /* Now, match all following names as specific targets. */
12760 1106 : do
12761 : {
12762 1106 : gfc_symtree* target_st;
12763 1106 : gfc_tbp_generic* target;
12764 :
12765 1106 : m = gfc_match_name (name);
12766 1106 : if (m == MATCH_ERROR)
12767 0 : goto error;
12768 1106 : if (m == MATCH_NO)
12769 : {
12770 1 : gfc_error ("Expected specific binding name at %C");
12771 1 : goto error;
12772 : }
12773 :
12774 1105 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12775 :
12776 : /* See if this is a duplicate specification. */
12777 1340 : for (target = tb->u.generic; target; target = target->next)
12778 236 : if (target_st == target->specific_st)
12779 : {
12780 1 : gfc_error ("%qs already defined as specific binding for the"
12781 : " generic %qs at %C", name, bind_name);
12782 1 : goto error;
12783 : }
12784 :
12785 1104 : target = gfc_get_tbp_generic ();
12786 1104 : target->specific_st = target_st;
12787 1104 : target->specific = NULL;
12788 1104 : target->next = tb->u.generic;
12789 1104 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12790 1104 : || (op_type == INTERFACE_INTRINSIC_OP));
12791 1104 : tb->u.generic = target;
12792 : }
12793 1104 : while (gfc_match (" ,") == MATCH_YES);
12794 :
12795 : /* Here should be the end. */
12796 947 : if (gfc_match_eos () != MATCH_YES)
12797 : {
12798 1 : gfc_error ("Junk after GENERIC binding at %C");
12799 1 : goto error;
12800 : }
12801 :
12802 : return MATCH_YES;
12803 :
12804 954 : error:
12805 : return MATCH_ERROR;
12806 : }
12807 :
12808 :
12809 : match
12810 1054 : gfc_match_generic ()
12811 : {
12812 1054 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12813 1052 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12814 100 : return match_generic_stmt ();
12815 : else
12816 954 : return match_typebound_generic ();
12817 : }
12818 :
12819 :
12820 : /* Match a FINAL declaration inside a derived type. */
12821 :
12822 : match
12823 490 : gfc_match_final_decl (void)
12824 : {
12825 490 : char name[GFC_MAX_SYMBOL_LEN + 1];
12826 490 : gfc_symbol* sym;
12827 490 : match m;
12828 490 : gfc_namespace* module_ns;
12829 490 : bool first, last;
12830 490 : gfc_symbol* block;
12831 :
12832 490 : if (gfc_current_form == FORM_FREE)
12833 : {
12834 490 : char c = gfc_peek_ascii_char ();
12835 490 : if (!gfc_is_whitespace (c) && c != ':')
12836 : return MATCH_NO;
12837 : }
12838 :
12839 489 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12840 : {
12841 1 : if (gfc_current_form == FORM_FIXED)
12842 : return MATCH_NO;
12843 :
12844 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12845 : "CONTAINS section");
12846 1 : return MATCH_ERROR;
12847 : }
12848 :
12849 488 : block = gfc_state_stack->previous->sym;
12850 488 : gcc_assert (block);
12851 :
12852 488 : if (gfc_state_stack->previous->previous
12853 488 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12854 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12855 : {
12856 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12857 : " specification part of a MODULE");
12858 0 : return MATCH_ERROR;
12859 : }
12860 :
12861 488 : module_ns = gfc_current_ns;
12862 488 : gcc_assert (module_ns);
12863 488 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12864 :
12865 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12866 488 : if (gfc_match (" ::") == MATCH_ERROR)
12867 : return MATCH_ERROR;
12868 :
12869 : /* Match the sequence of procedure names. */
12870 : first = true;
12871 : last = false;
12872 592 : do
12873 : {
12874 592 : gfc_finalizer* f;
12875 :
12876 592 : if (first && gfc_match_eos () == MATCH_YES)
12877 : {
12878 2 : gfc_error ("Empty FINAL at %C");
12879 2 : return MATCH_ERROR;
12880 : }
12881 :
12882 590 : m = gfc_match_name (name);
12883 590 : if (m == MATCH_NO)
12884 : {
12885 1 : gfc_error ("Expected module procedure name at %C");
12886 1 : return MATCH_ERROR;
12887 : }
12888 589 : else if (m != MATCH_YES)
12889 : return MATCH_ERROR;
12890 :
12891 589 : if (gfc_match_eos () == MATCH_YES)
12892 : last = true;
12893 105 : if (!last && gfc_match_char (',') != MATCH_YES)
12894 : {
12895 1 : gfc_error ("Expected %<,%> at %C");
12896 1 : return MATCH_ERROR;
12897 : }
12898 :
12899 588 : if (gfc_get_symbol (name, module_ns, &sym))
12900 : {
12901 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12902 0 : return MATCH_ERROR;
12903 : }
12904 :
12905 : /* Mark the symbol as module procedure. */
12906 588 : if (sym->attr.proc != PROC_MODULE
12907 588 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12908 : return MATCH_ERROR;
12909 :
12910 : /* Check if we already have this symbol in the list, this is an error. */
12911 805 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12912 218 : if (f->proc_sym == sym)
12913 : {
12914 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12915 : name);
12916 1 : return MATCH_ERROR;
12917 : }
12918 :
12919 : /* Add this symbol to the list of finalizers. */
12920 587 : gcc_assert (block->f2k_derived);
12921 587 : sym->refs++;
12922 587 : f = XCNEW (gfc_finalizer);
12923 587 : f->proc_sym = sym;
12924 587 : f->proc_tree = NULL;
12925 587 : f->where = gfc_current_locus;
12926 587 : f->next = block->f2k_derived->finalizers;
12927 587 : block->f2k_derived->finalizers = f;
12928 :
12929 587 : first = false;
12930 : }
12931 587 : while (!last);
12932 :
12933 : return MATCH_YES;
12934 : }
12935 :
12936 :
12937 : const ext_attr_t ext_attr_list[] = {
12938 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12939 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12940 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12941 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12942 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12943 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12944 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12945 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12946 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12947 : { "weak", EXT_ATTR_WEAK, NULL },
12948 : { "inline", EXT_ATTR_INLINE, NULL },
12949 : { "always_inline",EXT_ATTR_ALWAYS_INLINE,NULL },
12950 : { NULL, EXT_ATTR_LAST, NULL }
12951 : };
12952 :
12953 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12954 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12955 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12956 :
12957 : TODO: We should support all GCC attributes using the same syntax for
12958 : the attribute list, i.e. the list in C
12959 : __attributes(( attribute-list ))
12960 : matches then
12961 : !GCC$ ATTRIBUTES attribute-list ::
12962 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12963 : saved into a TREE.
12964 :
12965 : As there is absolutely no risk of confusion, we should never return
12966 : MATCH_NO. */
12967 : match
12968 2984 : gfc_match_gcc_attributes (void)
12969 : {
12970 2984 : symbol_attribute attr;
12971 2984 : char name[GFC_MAX_SYMBOL_LEN + 1];
12972 2984 : unsigned id;
12973 2984 : gfc_symbol *sym;
12974 2984 : match m;
12975 :
12976 2984 : gfc_clear_attr (&attr);
12977 2988 : for(;;)
12978 : {
12979 2986 : char ch;
12980 :
12981 2986 : if (gfc_match_name (name) != MATCH_YES)
12982 : return MATCH_ERROR;
12983 :
12984 18042 : for (id = 0; id < EXT_ATTR_LAST; id++)
12985 18042 : if (strcmp (name, ext_attr_list[id].name) == 0)
12986 : break;
12987 :
12988 2986 : if (id == EXT_ATTR_LAST)
12989 : {
12990 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12991 0 : return MATCH_ERROR;
12992 : }
12993 :
12994 2986 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12995 : return MATCH_ERROR;
12996 :
12997 2986 : gfc_gobble_whitespace ();
12998 2986 : ch = gfc_next_ascii_char ();
12999 2986 : if (ch == ':')
13000 : {
13001 : /* This is the successful exit condition for the loop. */
13002 2984 : if (gfc_next_ascii_char () == ':')
13003 : break;
13004 : }
13005 :
13006 2 : if (ch == ',')
13007 2 : continue;
13008 :
13009 0 : goto syntax;
13010 2 : }
13011 :
13012 2984 : if (gfc_match_eos () == MATCH_YES)
13013 0 : goto syntax;
13014 :
13015 2999 : for(;;)
13016 : {
13017 2999 : m = gfc_match_name (name);
13018 2999 : if (m != MATCH_YES)
13019 : return m;
13020 :
13021 2999 : if (find_special (name, &sym, true))
13022 : return MATCH_ERROR;
13023 :
13024 2999 : sym->attr.ext_attr |= attr.ext_attr;
13025 :
13026 : /* INLINE and ALWAYS_INLINE are incompatible with NOINLINE. In the
13027 : middle-end the DECL_UNINLINABLE flag set by NOINLINE always wins, so
13028 : the inline request would be silently ignored. Warn and drop it. */
13029 2999 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NOINLINE))
13030 : {
13031 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_ALWAYS_INLINE))
13032 : {
13033 2 : gfc_warning (0, "Attribute %<ALWAYS_INLINE%> at %C is "
13034 : "incompatible with %<NOINLINE%> for %qs and will "
13035 : "be ignored", sym->name);
13036 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_ALWAYS_INLINE);
13037 : }
13038 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_INLINE))
13039 : {
13040 2 : gfc_warning (0, "Attribute %<INLINE%> at %C is incompatible "
13041 : "with %<NOINLINE%> for %qs and will be ignored",
13042 : sym->name);
13043 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_INLINE);
13044 : }
13045 : }
13046 :
13047 2999 : if (gfc_match_eos () == MATCH_YES)
13048 : break;
13049 :
13050 15 : if (gfc_match_char (',') != MATCH_YES)
13051 0 : goto syntax;
13052 : }
13053 :
13054 : return MATCH_YES;
13055 :
13056 0 : syntax:
13057 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
13058 0 : return MATCH_ERROR;
13059 : }
13060 :
13061 :
13062 : /* Match a !GCC$ UNROLL statement of the form:
13063 : !GCC$ UNROLL n
13064 :
13065 : The parameter n is the number of times we are supposed to unroll.
13066 :
13067 : When we come here, we have already matched the !GCC$ UNROLL string. */
13068 : match
13069 19 : gfc_match_gcc_unroll (void)
13070 : {
13071 19 : int value;
13072 :
13073 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
13074 19 : if (gfc_match_small_int (&value) == MATCH_YES)
13075 : {
13076 19 : if (value < 0 || value > USHRT_MAX)
13077 : {
13078 2 : gfc_error ("%<GCC unroll%> directive requires a"
13079 : " non-negative integral constant"
13080 : " less than or equal to %u at %C",
13081 : USHRT_MAX
13082 : );
13083 2 : return MATCH_ERROR;
13084 : }
13085 17 : if (gfc_match_eos () == MATCH_YES)
13086 : {
13087 17 : directive_unroll = value == 0 ? 1 : value;
13088 17 : return MATCH_YES;
13089 : }
13090 : }
13091 :
13092 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
13093 0 : return MATCH_ERROR;
13094 : }
13095 :
13096 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
13097 :
13098 : The parameter b is name of a middle-end built-in.
13099 : FLAGS is optional and must be one of:
13100 : - (inbranch)
13101 : - (notinbranch)
13102 :
13103 : IF('target') is optional and TARGET is a name of a multilib ABI.
13104 :
13105 : When we come here, we have already matched the !GCC$ builtin string. */
13106 :
13107 : match
13108 3513273 : gfc_match_gcc_builtin (void)
13109 : {
13110 3513273 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
13111 3513273 : char target[GFC_MAX_SYMBOL_LEN + 1];
13112 :
13113 3513273 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
13114 : return MATCH_ERROR;
13115 :
13116 3513273 : gfc_simd_clause clause = SIMD_NONE;
13117 3513273 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
13118 : clause = SIMD_NOTINBRANCH;
13119 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
13120 15 : clause = SIMD_INBRANCH;
13121 :
13122 3513273 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
13123 : {
13124 3513243 : if (strcmp (target, "fastmath") == 0)
13125 : {
13126 0 : if (!fast_math_flags_set_p (&global_options))
13127 : return MATCH_YES;
13128 : }
13129 : else
13130 : {
13131 3513243 : const char *abi = targetm.get_multilib_abi_name ();
13132 3513243 : if (abi == NULL || strcmp (abi, target) != 0)
13133 : return MATCH_YES;
13134 : }
13135 : }
13136 :
13137 1734566 : if (gfc_vectorized_builtins == NULL)
13138 32127 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
13139 :
13140 1734566 : char *r = XNEWVEC (char, strlen (builtin) + 32);
13141 1734566 : sprintf (r, "__builtin_%s", builtin);
13142 :
13143 1734566 : bool existed;
13144 1734566 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
13145 1734566 : value |= clause;
13146 1734566 : if (existed)
13147 23 : free (r);
13148 :
13149 : return MATCH_YES;
13150 : }
13151 :
13152 : /* Match an !GCC$ IVDEP statement.
13153 : When we come here, we have already matched the !GCC$ IVDEP string. */
13154 :
13155 : match
13156 3 : gfc_match_gcc_ivdep (void)
13157 : {
13158 3 : if (gfc_match_eos () == MATCH_YES)
13159 : {
13160 3 : directive_ivdep = true;
13161 3 : return MATCH_YES;
13162 : }
13163 :
13164 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
13165 0 : return MATCH_ERROR;
13166 : }
13167 :
13168 : /* Match an !GCC$ VECTOR statement.
13169 : When we come here, we have already matched the !GCC$ VECTOR string. */
13170 :
13171 : match
13172 3 : gfc_match_gcc_vector (void)
13173 : {
13174 3 : if (gfc_match_eos () == MATCH_YES)
13175 : {
13176 3 : directive_vector = true;
13177 3 : directive_novector = false;
13178 3 : return MATCH_YES;
13179 : }
13180 :
13181 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
13182 0 : return MATCH_ERROR;
13183 : }
13184 :
13185 : /* Match an !GCC$ NOVECTOR statement.
13186 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
13187 :
13188 : match
13189 3 : gfc_match_gcc_novector (void)
13190 : {
13191 3 : if (gfc_match_eos () == MATCH_YES)
13192 : {
13193 3 : directive_novector = true;
13194 3 : directive_vector = false;
13195 3 : return MATCH_YES;
13196 : }
13197 :
13198 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
13199 0 : return MATCH_ERROR;
13200 : }
|
