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_current_ns->cl_list = cl->next;
130 1 : gfc_free_expr (cl->length);
131 1 : free (cl);
132 : }
133 :
134 : /* Drop the charlen nodes created while matching a declaration that is about
135 : to be rejected. Callers must clear any surviving owners before using this
136 : helper, so only the statement-local nodes remain on the namespace list. */
137 :
138 : static void
139 3 : discard_pending_charlens (gfc_charlen *saved_cl)
140 : {
141 3 : if (!gfc_current_ns)
142 : return;
143 :
144 14 : while (gfc_current_ns->cl_list != saved_cl)
145 : {
146 11 : gfc_charlen *cl = gfc_current_ns->cl_list;
147 :
148 11 : gcc_assert (cl);
149 11 : gfc_current_ns->cl_list = cl->next;
150 11 : gfc_free_expr (cl->length);
151 11 : free (cl);
152 : }
153 : }
154 :
155 : /********************* DATA statement subroutines *********************/
156 :
157 : static bool in_match_data = false;
158 :
159 : bool
160 9074 : gfc_in_match_data (void)
161 : {
162 9074 : return in_match_data;
163 : }
164 :
165 : static void
166 4840 : set_in_match_data (bool set_value)
167 : {
168 4840 : in_match_data = set_value;
169 2420 : }
170 :
171 : /* Free a gfc_data_variable structure and everything beneath it. */
172 :
173 : static void
174 5663 : free_variable (gfc_data_variable *p)
175 : {
176 5663 : gfc_data_variable *q;
177 :
178 8752 : for (; p; p = q)
179 : {
180 3089 : q = p->next;
181 3089 : gfc_free_expr (p->expr);
182 3089 : gfc_free_iterator (&p->iter, 0);
183 3089 : free_variable (p->list);
184 3089 : free (p);
185 : }
186 5663 : }
187 :
188 :
189 : /* Free a gfc_data_value structure and everything beneath it. */
190 :
191 : static void
192 2574 : free_value (gfc_data_value *p)
193 : {
194 2574 : gfc_data_value *q;
195 :
196 10886 : for (; p; p = q)
197 : {
198 8312 : q = p->next;
199 8312 : mpz_clear (p->repeat);
200 8312 : gfc_free_expr (p->expr);
201 8312 : free (p);
202 : }
203 2574 : }
204 :
205 :
206 : /* Free a list of gfc_data structures. */
207 :
208 : void
209 518042 : gfc_free_data (gfc_data *p)
210 : {
211 518042 : gfc_data *q;
212 :
213 520616 : for (; p; p = q)
214 : {
215 2574 : q = p->next;
216 2574 : free_variable (p->var);
217 2574 : free_value (p->value);
218 2574 : free (p);
219 : }
220 518042 : }
221 :
222 :
223 : /* Free all data in a namespace. */
224 :
225 : static void
226 41 : gfc_free_data_all (gfc_namespace *ns)
227 : {
228 41 : gfc_data *d;
229 :
230 47 : for (;ns->data;)
231 : {
232 6 : d = ns->data->next;
233 6 : free (ns->data);
234 6 : ns->data = d;
235 : }
236 41 : }
237 :
238 : /* Reject data parsed since the last restore point was marked. */
239 :
240 : void
241 8961025 : gfc_reject_data (gfc_namespace *ns)
242 : {
243 8961025 : gfc_data *d;
244 :
245 8961027 : while (ns->data && ns->data != ns->old_data)
246 : {
247 2 : d = ns->data->next;
248 2 : free (ns->data);
249 2 : ns->data = d;
250 : }
251 8961025 : }
252 :
253 : static match var_element (gfc_data_variable *);
254 :
255 : /* Match a list of variables terminated by an iterator and a right
256 : parenthesis. */
257 :
258 : static match
259 154 : var_list (gfc_data_variable *parent)
260 : {
261 154 : gfc_data_variable *tail, var;
262 154 : match m;
263 :
264 154 : m = var_element (&var);
265 154 : if (m == MATCH_ERROR)
266 : return MATCH_ERROR;
267 154 : if (m == MATCH_NO)
268 0 : goto syntax;
269 :
270 154 : tail = gfc_get_data_variable ();
271 154 : *tail = var;
272 :
273 154 : parent->list = tail;
274 :
275 156 : for (;;)
276 : {
277 155 : if (gfc_match_char (',') != MATCH_YES)
278 0 : goto syntax;
279 :
280 155 : m = gfc_match_iterator (&parent->iter, 1);
281 155 : if (m == MATCH_YES)
282 : break;
283 1 : if (m == MATCH_ERROR)
284 : return MATCH_ERROR;
285 :
286 1 : m = var_element (&var);
287 1 : if (m == MATCH_ERROR)
288 : return MATCH_ERROR;
289 1 : if (m == MATCH_NO)
290 0 : goto syntax;
291 :
292 1 : tail->next = gfc_get_data_variable ();
293 1 : tail = tail->next;
294 :
295 1 : *tail = var;
296 : }
297 :
298 154 : if (gfc_match_char (')') != MATCH_YES)
299 0 : goto syntax;
300 : return MATCH_YES;
301 :
302 0 : syntax:
303 0 : gfc_syntax_error (ST_DATA);
304 0 : return MATCH_ERROR;
305 : }
306 :
307 :
308 : /* Match a single element in a data variable list, which can be a
309 : variable-iterator list. */
310 :
311 : static match
312 3047 : var_element (gfc_data_variable *new_var)
313 : {
314 3047 : match m;
315 3047 : gfc_symbol *sym;
316 :
317 3047 : memset (new_var, 0, sizeof (gfc_data_variable));
318 :
319 3047 : if (gfc_match_char ('(') == MATCH_YES)
320 154 : return var_list (new_var);
321 :
322 2893 : m = gfc_match_variable (&new_var->expr, 0);
323 2893 : if (m != MATCH_YES)
324 : return m;
325 :
326 2889 : if (new_var->expr->expr_type == EXPR_CONSTANT
327 2 : && new_var->expr->symtree == NULL)
328 : {
329 2 : gfc_error ("Inquiry parameter cannot appear in a "
330 : "data-stmt-object-list at %C");
331 2 : return MATCH_ERROR;
332 : }
333 :
334 2887 : sym = new_var->expr->symtree->n.sym;
335 :
336 : /* Symbol should already have an associated type. */
337 2887 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
338 : return MATCH_ERROR;
339 :
340 2886 : if (!sym->attr.function && gfc_current_ns->parent
341 148 : && gfc_current_ns->parent == sym->ns)
342 : {
343 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
344 : "statement at %C", sym->name);
345 1 : return MATCH_ERROR;
346 : }
347 :
348 2885 : if (gfc_current_state () != COMP_BLOCK_DATA
349 2732 : && sym->attr.in_common
350 2914 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
351 : "common block variable %qs in DATA statement at %C",
352 : sym->name))
353 : return MATCH_ERROR;
354 :
355 2883 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
356 : return MATCH_ERROR;
357 :
358 : return MATCH_YES;
359 : }
360 :
361 :
362 : /* Match the top-level list of data variables. */
363 :
364 : static match
365 2517 : top_var_list (gfc_data *d)
366 : {
367 2517 : gfc_data_variable var, *tail, *new_var;
368 2517 : match m;
369 :
370 2517 : tail = NULL;
371 :
372 2892 : for (;;)
373 : {
374 2892 : m = var_element (&var);
375 2892 : if (m == MATCH_NO)
376 0 : goto syntax;
377 2892 : if (m == MATCH_ERROR)
378 : return MATCH_ERROR;
379 :
380 2877 : new_var = gfc_get_data_variable ();
381 2877 : *new_var = var;
382 2877 : if (new_var->expr)
383 2751 : new_var->expr->where = gfc_current_locus;
384 :
385 2877 : if (tail == NULL)
386 2502 : d->var = new_var;
387 : else
388 375 : tail->next = new_var;
389 :
390 2877 : tail = new_var;
391 :
392 2877 : if (gfc_match_char ('/') == MATCH_YES)
393 : break;
394 378 : if (gfc_match_char (',') != MATCH_YES)
395 3 : goto syntax;
396 : }
397 :
398 : return MATCH_YES;
399 :
400 3 : syntax:
401 3 : gfc_syntax_error (ST_DATA);
402 3 : gfc_free_data_all (gfc_current_ns);
403 3 : return MATCH_ERROR;
404 : }
405 :
406 :
407 : static match
408 8713 : match_data_constant (gfc_expr **result)
409 : {
410 8713 : char name[GFC_MAX_SYMBOL_LEN + 1];
411 8713 : gfc_symbol *sym, *dt_sym = NULL;
412 8713 : gfc_expr *expr;
413 8713 : match m;
414 8713 : locus old_loc;
415 8713 : gfc_symtree *symtree;
416 :
417 8713 : m = gfc_match_literal_constant (&expr, 1);
418 8713 : if (m == MATCH_YES)
419 : {
420 8368 : *result = expr;
421 8368 : return MATCH_YES;
422 : }
423 :
424 345 : if (m == MATCH_ERROR)
425 : return MATCH_ERROR;
426 :
427 337 : m = gfc_match_null (result);
428 337 : if (m != MATCH_NO)
429 : return m;
430 :
431 329 : old_loc = gfc_current_locus;
432 :
433 : /* Should this be a structure component, try to match it
434 : before matching a name. */
435 329 : m = gfc_match_rvalue (result);
436 329 : if (m == MATCH_ERROR)
437 : return m;
438 :
439 329 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
440 : {
441 4 : if (!gfc_simplify_expr (*result, 0))
442 0 : m = MATCH_ERROR;
443 4 : return m;
444 : }
445 319 : else if (m == MATCH_YES)
446 : {
447 : /* If a parameter inquiry ends up here, symtree is NULL but **result
448 : contains the right constant expression. Check here. */
449 319 : if ((*result)->symtree == NULL
450 37 : && (*result)->expr_type == EXPR_CONSTANT
451 37 : && ((*result)->ts.type == BT_INTEGER
452 1 : || (*result)->ts.type == BT_REAL))
453 : return m;
454 :
455 : /* F2018:R845 data-stmt-constant is initial-data-target.
456 : A data-stmt-constant shall be ... initial-data-target if and
457 : only if the corresponding data-stmt-object has the POINTER
458 : attribute. ... If data-stmt-constant is initial-data-target
459 : the corresponding data statement object shall be
460 : data-pointer-initialization compatible (7.5.4.6) with the initial
461 : data target; the data statement object is initially associated
462 : with the target. */
463 283 : if ((*result)->symtree
464 282 : && (*result)->symtree->n.sym->attr.save
465 218 : && (*result)->symtree->n.sym->attr.target)
466 : return m;
467 250 : gfc_free_expr (*result);
468 : }
469 :
470 256 : gfc_current_locus = old_loc;
471 :
472 256 : m = gfc_match_name (name);
473 256 : if (m != MATCH_YES)
474 : return m;
475 :
476 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
477 : return MATCH_ERROR;
478 :
479 250 : sym = symtree->n.sym;
480 :
481 250 : if (sym && sym->attr.generic)
482 60 : dt_sym = gfc_find_dt_in_generic (sym);
483 :
484 60 : if (sym == NULL
485 250 : || (sym->attr.flavor != FL_PARAMETER
486 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
487 : {
488 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
489 : name);
490 5 : *result = NULL;
491 5 : return MATCH_ERROR;
492 : }
493 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
494 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
495 :
496 : /* Check to see if the value is an initialization array expression. */
497 185 : if (sym->value->expr_type == EXPR_ARRAY)
498 : {
499 67 : gfc_current_locus = old_loc;
500 :
501 67 : m = gfc_match_init_expr (result);
502 67 : if (m == MATCH_ERROR)
503 : return m;
504 :
505 66 : if (m == MATCH_YES)
506 : {
507 66 : if (!gfc_simplify_expr (*result, 0))
508 0 : m = MATCH_ERROR;
509 :
510 66 : if ((*result)->expr_type == EXPR_CONSTANT)
511 : return m;
512 : else
513 : {
514 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
515 2 : return MATCH_ERROR;
516 : }
517 : }
518 : }
519 :
520 118 : *result = gfc_copy_expr (sym->value);
521 118 : return MATCH_YES;
522 : }
523 :
524 :
525 : /* Match a list of values in a DATA statement. The leading '/' has
526 : already been seen at this point. */
527 :
528 : static match
529 2560 : top_val_list (gfc_data *data)
530 : {
531 2560 : gfc_data_value *new_val, *tail;
532 2560 : gfc_expr *expr;
533 2560 : match m;
534 :
535 2560 : tail = NULL;
536 :
537 8349 : for (;;)
538 : {
539 8349 : m = match_data_constant (&expr);
540 8349 : if (m == MATCH_NO)
541 3 : goto syntax;
542 8346 : if (m == MATCH_ERROR)
543 : return MATCH_ERROR;
544 :
545 8324 : new_val = gfc_get_data_value ();
546 8324 : mpz_init (new_val->repeat);
547 :
548 8324 : if (tail == NULL)
549 2535 : data->value = new_val;
550 : else
551 5789 : tail->next = new_val;
552 :
553 8324 : tail = new_val;
554 :
555 8324 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
556 : {
557 8119 : tail->expr = expr;
558 8119 : mpz_set_ui (tail->repeat, 1);
559 : }
560 : else
561 : {
562 205 : mpz_set (tail->repeat, expr->value.integer);
563 205 : gfc_free_expr (expr);
564 :
565 205 : m = match_data_constant (&tail->expr);
566 205 : if (m == MATCH_NO)
567 0 : goto syntax;
568 205 : if (m == MATCH_ERROR)
569 : return MATCH_ERROR;
570 : }
571 :
572 8320 : if (gfc_match_char ('/') == MATCH_YES)
573 : break;
574 5790 : if (gfc_match_char (',') == MATCH_NO)
575 1 : goto syntax;
576 : }
577 :
578 : return MATCH_YES;
579 :
580 4 : syntax:
581 4 : gfc_syntax_error (ST_DATA);
582 4 : gfc_free_data_all (gfc_current_ns);
583 4 : return MATCH_ERROR;
584 : }
585 :
586 :
587 : /* Matches an old style initialization. */
588 :
589 : static match
590 70 : match_old_style_init (const char *name)
591 : {
592 70 : match m;
593 70 : gfc_symtree *st;
594 70 : gfc_symbol *sym;
595 70 : gfc_data *newdata, *nd;
596 :
597 : /* Set up data structure to hold initializers. */
598 70 : gfc_find_sym_tree (name, NULL, 0, &st);
599 70 : sym = st->n.sym;
600 :
601 70 : newdata = gfc_get_data ();
602 70 : newdata->var = gfc_get_data_variable ();
603 70 : newdata->var->expr = gfc_get_variable_expr (st);
604 70 : newdata->var->expr->where = sym->declared_at;
605 70 : newdata->where = gfc_current_locus;
606 :
607 : /* Match initial value list. This also eats the terminal '/'. */
608 70 : m = top_val_list (newdata);
609 70 : if (m != MATCH_YES)
610 : {
611 1 : free (newdata);
612 1 : return m;
613 : }
614 :
615 : /* Check that a BOZ did not creep into an old-style initialization. */
616 137 : for (nd = newdata; nd; nd = nd->next)
617 : {
618 69 : if (nd->value->expr->ts.type == BT_BOZ
619 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
620 : "initialization"), &nd->value->expr->where))
621 : return MATCH_ERROR;
622 :
623 68 : if (nd->var->expr->ts.type != BT_INTEGER
624 27 : && nd->var->expr->ts.type != BT_REAL
625 21 : && nd->value->expr->ts.type == BT_BOZ)
626 : {
627 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
628 : "a %qs variable in an old-style initialization"),
629 0 : &nd->value->expr->where,
630 : gfc_typename (&nd->value->expr->ts));
631 0 : return MATCH_ERROR;
632 : }
633 : }
634 :
635 68 : if (gfc_pure (NULL))
636 : {
637 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
638 1 : free (newdata);
639 1 : return MATCH_ERROR;
640 : }
641 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
642 :
643 : /* Mark the variable as having appeared in a data statement. */
644 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
645 : {
646 2 : free (newdata);
647 2 : return MATCH_ERROR;
648 : }
649 :
650 : /* Chain in namespace list of DATA initializers. */
651 65 : newdata->next = gfc_current_ns->data;
652 65 : gfc_current_ns->data = newdata;
653 :
654 65 : return m;
655 : }
656 :
657 :
658 : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
659 : we are matching a DATA statement and are therefore issuing an error
660 : if we encounter something unexpected, if not, we're trying to match
661 : an old-style initialization expression of the form INTEGER I /2/. */
662 :
663 : match
664 2422 : gfc_match_data (void)
665 : {
666 2422 : gfc_data *new_data;
667 2422 : gfc_expr *e;
668 2422 : gfc_ref *ref;
669 2422 : match m;
670 2422 : char c;
671 :
672 : /* DATA has been matched. In free form source code, the next character
673 : needs to be whitespace or '(' from an implied do-loop. Check that
674 : here. */
675 2422 : c = gfc_peek_ascii_char ();
676 2422 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
677 : return MATCH_NO;
678 :
679 : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
680 2421 : if ((gfc_current_state () == COMP_FUNCTION
681 2421 : || gfc_current_state () == COMP_SUBROUTINE)
682 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
683 : {
684 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
685 1 : return MATCH_ERROR;
686 : }
687 :
688 2420 : set_in_match_data (true);
689 :
690 2614 : for (;;)
691 : {
692 2517 : new_data = gfc_get_data ();
693 2517 : new_data->where = gfc_current_locus;
694 :
695 2517 : m = top_var_list (new_data);
696 2517 : if (m != MATCH_YES)
697 18 : goto cleanup;
698 :
699 2499 : if (new_data->var->iter.var
700 117 : && new_data->var->iter.var->ts.type == BT_INTEGER
701 74 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
702 68 : && new_data->var->list
703 68 : && new_data->var->list->expr
704 55 : && new_data->var->list->expr->ts.type == BT_CHARACTER
705 3 : && new_data->var->list->expr->ref
706 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
707 : {
708 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
709 : "statement", &new_data->var->list->expr->where);
710 1 : goto cleanup;
711 : }
712 :
713 : /* Check for an entity with an allocatable component, which is not
714 : allowed. */
715 2498 : e = new_data->var->expr;
716 2498 : if (e)
717 : {
718 2382 : bool invalid;
719 :
720 2382 : invalid = false;
721 3606 : for (ref = e->ref; ref; ref = ref->next)
722 1224 : if ((ref->type == REF_COMPONENT
723 140 : && ref->u.c.component->attr.allocatable)
724 1222 : || (ref->type == REF_ARRAY
725 1034 : && e->symtree->n.sym->attr.pointer != 1
726 1031 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
727 1224 : invalid = true;
728 :
729 2382 : if (invalid)
730 : {
731 2 : gfc_error ("Allocatable component or deferred-shaped array "
732 : "near %C in DATA statement");
733 2 : goto cleanup;
734 : }
735 :
736 : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
737 : as a data-stmt-object shall not be an object designator in which
738 : a pointer appears other than as the entire rightmost part-ref. */
739 2380 : if (!e->ref && e->ts.type == BT_DERIVED
740 43 : && e->symtree->n.sym->attr.pointer)
741 4 : goto partref;
742 :
743 2376 : ref = e->ref;
744 2376 : if (e->symtree->n.sym->ts.type == BT_DERIVED
745 125 : && e->symtree->n.sym->attr.pointer
746 1 : && ref->type == REF_COMPONENT)
747 1 : goto partref;
748 :
749 3591 : for (; ref; ref = ref->next)
750 1217 : if (ref->type == REF_COMPONENT
751 135 : && ref->u.c.component->attr.pointer
752 27 : && ref->next)
753 1 : goto partref;
754 : }
755 :
756 2490 : m = top_val_list (new_data);
757 2490 : if (m != MATCH_YES)
758 29 : goto cleanup;
759 :
760 2461 : new_data->next = gfc_current_ns->data;
761 2461 : gfc_current_ns->data = new_data;
762 :
763 : /* A BOZ literal constant cannot appear in a structure constructor.
764 : Check for that here for a data statement value. */
765 2461 : if (new_data->value->expr->ts.type == BT_DERIVED
766 37 : && new_data->value->expr->value.constructor)
767 : {
768 35 : gfc_constructor *c;
769 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
770 106 : for (; c; c = gfc_constructor_next (c))
771 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
772 : {
773 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
774 : "structure constructor", &c->expr->where);
775 0 : return MATCH_ERROR;
776 : }
777 : }
778 :
779 2461 : if (gfc_match_eos () == MATCH_YES)
780 : break;
781 :
782 97 : gfc_match_char (','); /* Optional comma */
783 97 : }
784 :
785 2364 : set_in_match_data (false);
786 :
787 2364 : if (gfc_pure (NULL))
788 : {
789 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
790 0 : return MATCH_ERROR;
791 : }
792 2364 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
793 :
794 2364 : return MATCH_YES;
795 :
796 6 : partref:
797 :
798 6 : gfc_error ("part-ref with pointer attribute near %L is not "
799 : "rightmost part-ref of data-stmt-object",
800 : &e->where);
801 :
802 56 : cleanup:
803 56 : set_in_match_data (false);
804 56 : gfc_free_data (new_data);
805 56 : return MATCH_ERROR;
806 : }
807 :
808 :
809 : /************************ Declaration statements *********************/
810 :
811 :
812 : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
813 : list). The difference here is the expression is a list of constants
814 : and is surrounded by '/'.
815 : The typespec ts must match the typespec of the variable which the
816 : clist is initializing.
817 : The arrayspec tells whether this should match a list of constants
818 : corresponding to array elements or a scalar (as == NULL). */
819 :
820 : static match
821 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
822 : {
823 74 : gfc_constructor_base array_head = NULL;
824 74 : gfc_expr *expr = NULL;
825 74 : match m = MATCH_ERROR;
826 74 : locus where;
827 74 : mpz_t repeat, cons_size, as_size;
828 74 : bool scalar;
829 74 : int cmp;
830 :
831 74 : gcc_assert (ts);
832 :
833 : /* We have already matched '/' - now look for a constant list, as with
834 : top_val_list from decl.cc, but append the result to an array. */
835 74 : if (gfc_match ("/") == MATCH_YES)
836 : {
837 1 : gfc_error ("Empty old style initializer list at %C");
838 1 : return MATCH_ERROR;
839 : }
840 :
841 73 : where = gfc_current_locus;
842 73 : scalar = !as || !as->rank;
843 :
844 42 : if (!scalar && !spec_size (as, &as_size))
845 : {
846 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
847 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
848 : /* Nothing to cleanup yet. */
849 1 : return MATCH_ERROR;
850 : }
851 :
852 72 : mpz_init_set_ui (repeat, 0);
853 :
854 143 : for (;;)
855 : {
856 143 : m = match_data_constant (&expr);
857 143 : if (m != MATCH_YES)
858 3 : expr = NULL; /* match_data_constant may set expr to garbage */
859 3 : if (m == MATCH_NO)
860 2 : goto syntax;
861 141 : if (m == MATCH_ERROR)
862 1 : goto cleanup;
863 :
864 : /* Found r in repeat spec r*c; look for the constant to repeat. */
865 140 : if ( gfc_match_char ('*') == MATCH_YES)
866 : {
867 18 : if (scalar)
868 : {
869 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
870 1 : goto cleanup;
871 : }
872 17 : if (expr->ts.type != BT_INTEGER)
873 : {
874 1 : gfc_error ("Repeat spec must be an integer at %C");
875 1 : goto cleanup;
876 : }
877 16 : mpz_set (repeat, expr->value.integer);
878 16 : gfc_free_expr (expr);
879 16 : expr = NULL;
880 :
881 16 : m = match_data_constant (&expr);
882 16 : if (m == MATCH_NO)
883 : {
884 1 : m = MATCH_ERROR;
885 1 : gfc_error ("Expected data constant after repeat spec at %C");
886 : }
887 16 : if (m != MATCH_YES)
888 1 : goto cleanup;
889 : }
890 : /* No repeat spec, we matched the data constant itself. */
891 : else
892 122 : mpz_set_ui (repeat, 1);
893 :
894 137 : if (!scalar)
895 : {
896 : /* Add the constant initializer as many times as repeated. */
897 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
898 : {
899 : /* Make sure types of elements match */
900 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
901 12 : && !gfc_convert_type (expr, ts, 1))
902 0 : goto cleanup;
903 :
904 144 : gfc_constructor_append_expr (&array_head,
905 : gfc_copy_expr (expr), &gfc_current_locus);
906 : }
907 :
908 107 : gfc_free_expr (expr);
909 107 : expr = NULL;
910 : }
911 :
912 : /* For scalar initializers quit after one element. */
913 : else
914 : {
915 30 : if(gfc_match_char ('/') != MATCH_YES)
916 : {
917 1 : gfc_error ("End of scalar initializer expected at %C");
918 1 : goto cleanup;
919 : }
920 : break;
921 : }
922 :
923 107 : if (gfc_match_char ('/') == MATCH_YES)
924 : break;
925 72 : if (gfc_match_char (',') == MATCH_NO)
926 1 : goto syntax;
927 : }
928 :
929 : /* If we break early from here out, we encountered an error. */
930 64 : m = MATCH_ERROR;
931 :
932 : /* Set up expr as an array constructor. */
933 64 : if (!scalar)
934 : {
935 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
936 35 : expr->ts = *ts;
937 35 : expr->value.constructor = array_head;
938 :
939 : /* Validate sizes. We built expr ourselves, so cons_size will be
940 : constant (we fail above for non-constant expressions).
941 : We still need to verify that the sizes match. */
942 35 : gcc_assert (gfc_array_size (expr, &cons_size));
943 35 : cmp = mpz_cmp (cons_size, as_size);
944 35 : if (cmp < 0)
945 2 : gfc_error ("Not enough elements in array initializer at %C");
946 33 : else if (cmp > 0)
947 3 : gfc_error ("Too many elements in array initializer at %C");
948 35 : mpz_clear (cons_size);
949 35 : if (cmp)
950 5 : goto cleanup;
951 :
952 : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
953 30 : expr->rank = as->rank;
954 30 : expr->corank = as->corank;
955 30 : expr->shape = gfc_get_shape (as->rank);
956 66 : for (int i = 0; i < as->rank; ++i)
957 36 : spec_dimen_size (as, i, &expr->shape[i]);
958 : }
959 :
960 : /* Make sure scalar types match. */
961 29 : else if (!gfc_compare_types (&expr->ts, ts)
962 29 : && !gfc_convert_type (expr, ts, 1))
963 2 : goto cleanup;
964 :
965 57 : if (expr->ts.u.cl)
966 1 : expr->ts.u.cl->length_from_typespec = 1;
967 :
968 57 : *result = expr;
969 57 : m = MATCH_YES;
970 57 : goto done;
971 :
972 3 : syntax:
973 3 : m = MATCH_ERROR;
974 3 : gfc_error ("Syntax error in old style initializer list at %C");
975 :
976 15 : cleanup:
977 15 : if (expr)
978 10 : expr->value.constructor = NULL;
979 15 : gfc_free_expr (expr);
980 15 : gfc_constructor_free (array_head);
981 :
982 72 : done:
983 72 : mpz_clear (repeat);
984 72 : if (!scalar)
985 41 : mpz_clear (as_size);
986 : return m;
987 : }
988 :
989 :
990 : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
991 :
992 : static bool
993 114 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
994 : {
995 114 : if ((from->type == AS_ASSUMED_RANK && to->corank)
996 112 : || (to->type == AS_ASSUMED_RANK && from->corank))
997 : {
998 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
999 5 : return false;
1000 : }
1001 :
1002 109 : if (to->rank == 0 && from->rank > 0)
1003 : {
1004 48 : to->rank = from->rank;
1005 48 : to->type = from->type;
1006 48 : to->cray_pointee = from->cray_pointee;
1007 48 : to->cp_was_assumed = from->cp_was_assumed;
1008 :
1009 152 : for (int i = to->corank - 1; i >= 0; i--)
1010 : {
1011 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1012 : cleans up elsewhere. */
1013 104 : int j = from->rank + i;
1014 104 : if (j >= GFC_MAX_DIMENSIONS)
1015 : break;
1016 :
1017 104 : to->lower[j] = to->lower[i];
1018 104 : to->upper[j] = to->upper[i];
1019 : }
1020 115 : for (int i = 0; i < from->rank; i++)
1021 : {
1022 67 : if (copy)
1023 : {
1024 43 : to->lower[i] = gfc_copy_expr (from->lower[i]);
1025 43 : to->upper[i] = gfc_copy_expr (from->upper[i]);
1026 : }
1027 : else
1028 : {
1029 24 : to->lower[i] = from->lower[i];
1030 24 : to->upper[i] = from->upper[i];
1031 : }
1032 : }
1033 : }
1034 61 : else if (to->corank == 0 && from->corank > 0)
1035 : {
1036 34 : to->corank = from->corank;
1037 34 : to->cotype = from->cotype;
1038 :
1039 104 : for (int i = 0; i < from->corank; i++)
1040 : {
1041 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1042 : cleans up elsewhere. */
1043 71 : int k = from->rank + i;
1044 71 : int j = to->rank + i;
1045 71 : if (j >= GFC_MAX_DIMENSIONS)
1046 : break;
1047 :
1048 70 : if (copy)
1049 : {
1050 37 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1051 37 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1052 : }
1053 : else
1054 : {
1055 33 : to->lower[j] = from->lower[k];
1056 33 : to->upper[j] = from->upper[k];
1057 : }
1058 : }
1059 : }
1060 :
1061 109 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1062 : {
1063 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1064 : "allowed dimensions of %d",
1065 : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1066 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1067 1 : return false;
1068 : }
1069 : return true;
1070 : }
1071 :
1072 :
1073 : /* Match an intent specification. Since this can only happen after an
1074 : INTENT word, a legal intent-spec must follow. */
1075 :
1076 : static sym_intent
1077 27025 : match_intent_spec (void)
1078 : {
1079 :
1080 27025 : if (gfc_match (" ( in out )") == MATCH_YES)
1081 : return INTENT_INOUT;
1082 23978 : if (gfc_match (" ( in )") == MATCH_YES)
1083 : return INTENT_IN;
1084 3589 : if (gfc_match (" ( out )") == MATCH_YES)
1085 : return INTENT_OUT;
1086 :
1087 2 : gfc_error ("Bad INTENT specification at %C");
1088 2 : return INTENT_UNKNOWN;
1089 : }
1090 :
1091 :
1092 : /* Matches a character length specification, which is either a
1093 : specification expression, '*', or ':'. */
1094 :
1095 : static match
1096 27461 : char_len_param_value (gfc_expr **expr, bool *deferred)
1097 : {
1098 27461 : match m;
1099 27461 : gfc_expr *p;
1100 :
1101 27461 : *expr = NULL;
1102 27461 : *deferred = false;
1103 :
1104 27461 : if (gfc_match_char ('*') == MATCH_YES)
1105 : return MATCH_YES;
1106 :
1107 20974 : if (gfc_match_char (':') == MATCH_YES)
1108 : {
1109 3292 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1110 : return MATCH_ERROR;
1111 :
1112 3290 : *deferred = true;
1113 :
1114 3290 : return MATCH_YES;
1115 : }
1116 :
1117 17682 : m = gfc_match_expr (expr);
1118 :
1119 17682 : if (m == MATCH_NO || m == MATCH_ERROR)
1120 : return m;
1121 :
1122 17677 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1123 : return MATCH_ERROR;
1124 :
1125 : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1126 17671 : p = gfc_copy_expr (*expr);
1127 17671 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1128 14639 : gfc_replace_expr (*expr, p);
1129 : else
1130 3032 : gfc_free_expr (p);
1131 :
1132 17671 : if ((*expr)->expr_type == EXPR_FUNCTION)
1133 : {
1134 1015 : if ((*expr)->ts.type == BT_INTEGER
1135 1014 : || ((*expr)->ts.type == BT_UNKNOWN
1136 1014 : && strcmp((*expr)->symtree->name, "null") != 0))
1137 : return MATCH_YES;
1138 :
1139 2 : goto syntax;
1140 : }
1141 16656 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1142 : {
1143 : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1144 : processor dependent and its value is greater than or equal to zero.
1145 : F2008, 4.4.3.2: If the character length parameter value evaluates
1146 : to a negative value, the length of character entities declared
1147 : is zero. */
1148 :
1149 14568 : if ((*expr)->ts.type == BT_INTEGER)
1150 : {
1151 14550 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1152 4 : mpz_set_si ((*expr)->value.integer, 0);
1153 : }
1154 : else
1155 18 : goto syntax;
1156 : }
1157 2088 : else if ((*expr)->expr_type == EXPR_ARRAY)
1158 8 : goto syntax;
1159 2080 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1160 : {
1161 1512 : bool t;
1162 1512 : gfc_expr *e;
1163 :
1164 1512 : e = gfc_copy_expr (*expr);
1165 :
1166 : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1167 : which causes an ICE if gfc_reduce_init_expr() is called. */
1168 1512 : if (e->ref && e->ref->type == REF_ARRAY
1169 8 : && e->ref->u.ar.type == AR_UNKNOWN
1170 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1171 2 : goto syntax;
1172 :
1173 1510 : t = gfc_reduce_init_expr (e);
1174 :
1175 1510 : if (!t && e->ts.type == BT_UNKNOWN
1176 7 : && e->symtree->n.sym->attr.untyped == 1
1177 7 : && (flag_implicit_none
1178 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1179 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1180 : {
1181 7 : gfc_free_expr (e);
1182 7 : goto syntax;
1183 : }
1184 :
1185 1503 : if ((e->ref && e->ref->type == REF_ARRAY
1186 4 : && e->ref->u.ar.type != AR_ELEMENT)
1187 1502 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1188 : {
1189 2 : gfc_free_expr (e);
1190 2 : goto syntax;
1191 : }
1192 :
1193 1501 : gfc_free_expr (e);
1194 : }
1195 :
1196 16619 : if (gfc_seen_div0)
1197 52 : m = MATCH_ERROR;
1198 :
1199 : return m;
1200 :
1201 39 : syntax:
1202 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1203 39 : return MATCH_ERROR;
1204 : }
1205 :
1206 :
1207 : /* A character length is a '*' followed by a literal integer or a
1208 : char_len_param_value in parenthesis. */
1209 :
1210 : static match
1211 62253 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1212 : {
1213 62253 : int length;
1214 62253 : match m;
1215 :
1216 62253 : *deferred = false;
1217 62253 : m = gfc_match_char ('*');
1218 62253 : if (m != MATCH_YES)
1219 : return m;
1220 :
1221 2641 : m = gfc_match_small_literal_int (&length, NULL);
1222 2641 : if (m == MATCH_ERROR)
1223 : return m;
1224 :
1225 2641 : if (m == MATCH_YES)
1226 : {
1227 2137 : if (obsolescent_check
1228 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1229 : return MATCH_ERROR;
1230 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1231 2137 : return m;
1232 : }
1233 :
1234 504 : if (gfc_match_char ('(') == MATCH_NO)
1235 0 : goto syntax;
1236 :
1237 504 : m = char_len_param_value (expr, deferred);
1238 504 : if (m != MATCH_YES && gfc_matching_function)
1239 : {
1240 0 : gfc_undo_symbols ();
1241 0 : m = MATCH_YES;
1242 : }
1243 :
1244 1 : if (m == MATCH_ERROR)
1245 : return m;
1246 503 : if (m == MATCH_NO)
1247 0 : goto syntax;
1248 :
1249 503 : if (gfc_match_char (')') == MATCH_NO)
1250 : {
1251 0 : gfc_free_expr (*expr);
1252 0 : *expr = NULL;
1253 0 : goto syntax;
1254 : }
1255 :
1256 503 : if (obsolescent_check
1257 503 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1258 : return MATCH_ERROR;
1259 :
1260 : return MATCH_YES;
1261 :
1262 0 : syntax:
1263 0 : gfc_error ("Syntax error in character length specification at %C");
1264 0 : return MATCH_ERROR;
1265 : }
1266 :
1267 :
1268 : /* Special subroutine for finding a symbol. Check if the name is found
1269 : in the current name space. If not, and we're compiling a function or
1270 : subroutine and the parent compilation unit is an interface, then check
1271 : to see if the name we've been given is the name of the interface
1272 : (located in another namespace). */
1273 :
1274 : static int
1275 278744 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1276 : {
1277 278744 : gfc_state_data *s;
1278 278744 : gfc_symtree *st;
1279 278744 : int i;
1280 :
1281 278744 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1282 278744 : if (i == 0)
1283 : {
1284 278744 : *result = st ? st->n.sym : NULL;
1285 278744 : goto end;
1286 : }
1287 :
1288 0 : if (gfc_current_state () != COMP_SUBROUTINE
1289 0 : && gfc_current_state () != COMP_FUNCTION)
1290 0 : goto end;
1291 :
1292 0 : s = gfc_state_stack->previous;
1293 0 : if (s == NULL)
1294 0 : goto end;
1295 :
1296 0 : if (s->state != COMP_INTERFACE)
1297 0 : goto end;
1298 0 : if (s->sym == NULL)
1299 0 : goto end; /* Nameless interface. */
1300 :
1301 0 : if (strcmp (name, s->sym->name) == 0)
1302 : {
1303 0 : *result = s->sym;
1304 0 : return 0;
1305 : }
1306 :
1307 0 : end:
1308 : return i;
1309 : }
1310 :
1311 :
1312 : /* Special subroutine for getting a symbol node associated with a
1313 : procedure name, used in SUBROUTINE and FUNCTION statements. The
1314 : symbol is created in the parent using with symtree node in the
1315 : child unit pointing to the symbol. If the current namespace has no
1316 : parent, then the symbol is just created in the current unit. */
1317 :
1318 : static int
1319 62788 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1320 : {
1321 62788 : gfc_symtree *st;
1322 62788 : gfc_symbol *sym;
1323 62788 : int rc = 0;
1324 :
1325 : /* Module functions have to be left in their own namespace because
1326 : they have potentially (almost certainly!) already been referenced.
1327 : In this sense, they are rather like external functions. This is
1328 : fixed up in resolve.cc(resolve_entries), where the symbol name-
1329 : space is set to point to the master function, so that the fake
1330 : result mechanism can work. */
1331 62788 : if (module_fcn_entry)
1332 : {
1333 : /* Present if entry is declared to be a module procedure. */
1334 260 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1335 :
1336 260 : if (*result == NULL)
1337 217 : rc = gfc_get_symbol (name, NULL, result);
1338 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1339 43 : && (*result)->ts.type == BT_UNKNOWN
1340 86 : && sym->attr.flavor == FL_UNKNOWN)
1341 : /* Pick up the typespec for the entry, if declared in the function
1342 : body. Note that this symbol is FL_UNKNOWN because it will
1343 : only have appeared in a type declaration. The local symtree
1344 : is set to point to the module symbol and a unique symtree
1345 : to the local version. This latter ensures a correct clearing
1346 : of the symbols. */
1347 : {
1348 : /* If the ENTRY proceeds its specification, we need to ensure
1349 : that this does not raise a "has no IMPLICIT type" error. */
1350 43 : if (sym->ts.type == BT_UNKNOWN)
1351 23 : sym->attr.untyped = 1;
1352 :
1353 43 : (*result)->ts = sym->ts;
1354 :
1355 : /* Put the symbol in the procedure namespace so that, should
1356 : the ENTRY precede its specification, the specification
1357 : can be applied. */
1358 43 : (*result)->ns = gfc_current_ns;
1359 :
1360 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1361 43 : st->n.sym = *result;
1362 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1363 43 : sym->refs++;
1364 43 : st->n.sym = sym;
1365 : }
1366 : }
1367 : else
1368 62528 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1369 :
1370 62788 : if (rc)
1371 : return rc;
1372 :
1373 62787 : sym = *result;
1374 62787 : if (sym->attr.proc == PROC_ST_FUNCTION)
1375 : return rc;
1376 :
1377 62786 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1378 : {
1379 : /* Create a partially populated interface symbol to carry the
1380 : characteristics of the procedure and the result. */
1381 443 : sym->tlink = gfc_new_symbol (name, sym->ns);
1382 443 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1383 443 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1384 443 : if (sym->attr.dimension)
1385 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1386 :
1387 : /* Ideally, at this point, a copy would be made of the formal
1388 : arguments and their namespace. However, this does not appear
1389 : to be necessary, albeit at the expense of not being able to
1390 : use gfc_compare_interfaces directly. */
1391 :
1392 443 : if (sym->result && sym->result != sym)
1393 : {
1394 105 : sym->tlink->result = sym->result;
1395 105 : sym->result = NULL;
1396 : }
1397 338 : else if (sym->result)
1398 : {
1399 90 : sym->tlink->result = sym->tlink;
1400 : }
1401 : }
1402 62343 : else if (sym && !sym->gfc_new
1403 23998 : && gfc_current_state () != COMP_INTERFACE)
1404 : {
1405 : /* Trap another encompassed procedure with the same name. All
1406 : these conditions are necessary to avoid picking up an entry
1407 : whose name clashes with that of the encompassing procedure;
1408 : this is handled using gsymbols to register unique, globally
1409 : accessible names. */
1410 22990 : if (sym->attr.flavor != 0
1411 20925 : && sym->attr.proc != 0
1412 2343 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1413 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1414 : {
1415 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1416 : name, &sym->declared_at);
1417 7 : return true;
1418 : }
1419 22983 : if (sym->attr.flavor != 0
1420 20918 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1421 : {
1422 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1423 : name, &sym->declared_at);
1424 1 : return true;
1425 : }
1426 :
1427 22982 : if (sym->attr.external && sym->attr.procedure
1428 2 : && gfc_current_state () == COMP_CONTAINS)
1429 : {
1430 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1431 : "procedure defined at %L",
1432 : name, &sym->declared_at);
1433 1 : return true;
1434 : }
1435 :
1436 : /* Trap a procedure with a name the same as interface in the
1437 : encompassing scope. */
1438 22981 : if (sym->attr.generic != 0
1439 60 : && (sym->attr.subroutine || sym->attr.function)
1440 1 : && !sym->attr.mod_proc)
1441 : {
1442 1 : gfc_error_now ("Name %qs at %C is already defined"
1443 : " as a generic interface at %L",
1444 : name, &sym->declared_at);
1445 1 : return true;
1446 : }
1447 :
1448 : /* Trap declarations of attributes in encompassing scope. The
1449 : signature for this is that ts.kind is nonzero for no-CLASS
1450 : entity. For a CLASS entity, ts.kind is zero. */
1451 22980 : if ((sym->ts.kind != 0
1452 22607 : || sym->ts.type == BT_CLASS
1453 22606 : || sym->ts.type == BT_DERIVED)
1454 397 : && !sym->attr.implicit_type
1455 396 : && sym->attr.proc == 0
1456 378 : && gfc_current_ns->parent != NULL
1457 138 : && sym->attr.access == 0
1458 136 : && !module_fcn_entry)
1459 : {
1460 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1461 : "from a previous declaration", name);
1462 5 : return true;
1463 : }
1464 : }
1465 :
1466 : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1467 : subroutine-stmt of a module subprogram or of a nonabstract interface
1468 : body that is declared in the scoping unit of a module or submodule. */
1469 62771 : if (sym->attr.external
1470 92 : && (sym->attr.subroutine || sym->attr.function)
1471 91 : && sym->attr.if_source == IFSRC_IFBODY
1472 91 : && !current_attr.module_procedure
1473 3 : && sym->attr.proc == PROC_MODULE
1474 3 : && gfc_state_stack->state == COMP_CONTAINS)
1475 : {
1476 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1477 : "clashes with internal procedure defined at %C",
1478 : name, &sym->declared_at);
1479 1 : return true;
1480 : }
1481 :
1482 62770 : if (sym && !sym->gfc_new
1483 24425 : && sym->attr.flavor != FL_UNKNOWN
1484 21979 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1485 217 : && gfc_state_stack->state == COMP_CONTAINS
1486 212 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1487 : {
1488 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1489 : name, &sym->declared_at);
1490 1 : return true;
1491 : }
1492 :
1493 62769 : if (gfc_current_ns->parent == NULL || *result == NULL)
1494 : return rc;
1495 :
1496 : /* Module function entries will already have a symtree in
1497 : the current namespace but will need one at module level. */
1498 50728 : if (module_fcn_entry)
1499 : {
1500 : /* Present if entry is declared to be a module procedure. */
1501 258 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1502 258 : if (st == NULL)
1503 217 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1504 : }
1505 : else
1506 50470 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1507 :
1508 50728 : st->n.sym = sym;
1509 50728 : sym->refs++;
1510 :
1511 : /* See if the procedure should be a module procedure. */
1512 :
1513 50728 : if (((sym->ns->proc_name != NULL
1514 50728 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1515 20706 : && sym->attr.proc != PROC_MODULE)
1516 50728 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1517 68678 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1518 : rc = 2;
1519 :
1520 : return rc;
1521 : }
1522 :
1523 :
1524 : /* Verify that the given symbol representing a parameter is C
1525 : interoperable, by checking to see if it was marked as such after
1526 : its declaration. If the given symbol is not interoperable, a
1527 : warning is reported, thus removing the need to return the status to
1528 : the calling function. The standard does not require the user use
1529 : one of the iso_c_binding named constants to declare an
1530 : interoperable parameter, but we can't be sure if the param is C
1531 : interop or not if the user doesn't. For example, integer(4) may be
1532 : legal Fortran, but doesn't have meaning in C. It may interop with
1533 : a number of the C types, which causes a problem because the
1534 : compiler can't know which one. This code is almost certainly not
1535 : portable, and the user will get what they deserve if the C type
1536 : across platforms isn't always interoperable with integer(4). If
1537 : the user had used something like integer(c_int) or integer(c_long),
1538 : the compiler could have automatically handled the varying sizes
1539 : across platforms. */
1540 :
1541 : bool
1542 16409 : gfc_verify_c_interop_param (gfc_symbol *sym)
1543 : {
1544 16409 : int is_c_interop = 0;
1545 16409 : bool retval = true;
1546 :
1547 : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1548 : Don't repeat the checks here. */
1549 16409 : if (sym->attr.implicit_type)
1550 : return true;
1551 :
1552 : /* For subroutines or functions that are passed to a BIND(C) procedure,
1553 : they're interoperable if they're BIND(C) and their params are all
1554 : interoperable. */
1555 16409 : if (sym->attr.flavor == FL_PROCEDURE)
1556 : {
1557 4 : if (sym->attr.is_bind_c == 0)
1558 : {
1559 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1560 : "attribute to be C interoperable", sym->name,
1561 : &(sym->declared_at));
1562 0 : return false;
1563 : }
1564 : else
1565 : {
1566 4 : if (sym->attr.is_c_interop == 1)
1567 : /* We've already checked this procedure; don't check it again. */
1568 : return true;
1569 : else
1570 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1571 4 : sym->common_block);
1572 : }
1573 : }
1574 :
1575 : /* See if we've stored a reference to a procedure that owns sym. */
1576 16405 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1577 : {
1578 16405 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1579 : {
1580 16366 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1581 16366 : bool f2018_added = false;
1582 :
1583 16366 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1584 :
1585 : /* F2018:18.3.6 has the following text:
1586 : "(5) any dummy argument without the VALUE attribute corresponds to
1587 : a formal parameter of the prototype that is of a pointer type, and
1588 : either
1589 : • the dummy argument is interoperable with an entity of the
1590 : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1591 : the formal parameter (this is equivalent to the F2008 text),
1592 : • the dummy argument is a nonallocatable nonpointer variable of
1593 : type CHARACTER with assumed character length and the formal
1594 : parameter is a pointer to CFI_cdesc_t,
1595 : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1596 : or a pointer without the CONTIGUOUS attribute, and the formal
1597 : parameter is a pointer to CFI_cdesc_t, or
1598 : • the dummy argument is assumed-type and not allocatable,
1599 : assumed-shape, assumed-rank, or a pointer, and the formal
1600 : parameter is a pointer to void," */
1601 3720 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1602 : {
1603 2354 : bool as_ar = (sym->as
1604 2354 : && (sym->as->type == AS_ASSUMED_SHAPE
1605 2109 : || sym->as->type == AS_ASSUMED_RANK));
1606 4708 : bool cond1 = (sym->ts.type == BT_CHARACTER
1607 1564 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1608 904 : && !sym->attr.allocatable
1609 3240 : && !sym->attr.pointer);
1610 4708 : bool cond2 = (sym->attr.allocatable
1611 2257 : || as_ar
1612 3370 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1613 4708 : bool cond3 = (sym->ts.type == BT_ASSUMED
1614 0 : && !sym->attr.allocatable
1615 0 : && !sym->attr.pointer
1616 2354 : && !as_ar);
1617 2354 : f2018_added = cond1 || cond2 || cond3;
1618 : }
1619 :
1620 16366 : if (is_c_interop != 1 && !f2018_added)
1621 : {
1622 : /* Make personalized messages to give better feedback. */
1623 1828 : if (sym->ts.type == BT_DERIVED)
1624 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1625 : "BIND(C) procedure %qs but is not C interoperable "
1626 : "because derived type %qs is not C interoperable",
1627 : sym->name, &(sym->declared_at),
1628 1 : sym->ns->proc_name->name,
1629 1 : sym->ts.u.derived->name);
1630 1827 : else if (sym->ts.type == BT_CLASS)
1631 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1632 : "BIND(C) procedure %qs but is not C interoperable "
1633 : "because it is polymorphic",
1634 : sym->name, &(sym->declared_at),
1635 6 : sym->ns->proc_name->name);
1636 1821 : else if (warn_c_binding_type)
1637 39 : gfc_warning (OPT_Wc_binding_type,
1638 : "Variable %qs at %L is a dummy argument of the "
1639 : "BIND(C) procedure %qs but may not be C "
1640 : "interoperable",
1641 : sym->name, &(sym->declared_at),
1642 39 : sym->ns->proc_name->name);
1643 : }
1644 :
1645 : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1646 16366 : if (sym->attr.pointer && sym->attr.contiguous)
1647 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1648 : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1649 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1650 :
1651 : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1652 : procedure that are default-initialized are not permitted. */
1653 15728 : if ((sym->attr.pointer || sym->attr.allocatable)
1654 1037 : && sym->ts.type == BT_DERIVED
1655 16744 : && gfc_has_default_initializer (sym->ts.u.derived))
1656 : {
1657 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1658 : "attribute at %L is not permitted in BIND(C) "
1659 : "procedure %qs", sym->name,
1660 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1661 4 : &sym->declared_at, sym->ns->proc_name->name);
1662 4 : retval = false;
1663 : }
1664 :
1665 : /* Character strings are only C interoperable if they have a
1666 : length of 1. However, as an argument they are also interoperable
1667 : when passed as descriptor (which requires len=: or len=*). */
1668 16366 : if (sym->ts.type == BT_CHARACTER)
1669 : {
1670 2338 : gfc_charlen *cl = sym->ts.u.cl;
1671 :
1672 2338 : if (sym->attr.allocatable || sym->attr.pointer)
1673 : {
1674 : /* F2018, 18.3.6 (6). */
1675 193 : if (!sym->ts.deferred)
1676 : {
1677 64 : if (sym->attr.allocatable)
1678 32 : gfc_error ("Allocatable character dummy argument %qs "
1679 : "at %L must have deferred length as "
1680 : "procedure %qs is BIND(C)", sym->name,
1681 32 : &sym->declared_at, sym->ns->proc_name->name);
1682 : else
1683 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1684 : "must have deferred length as procedure %qs "
1685 : "is BIND(C)", sym->name, &sym->declared_at,
1686 32 : sym->ns->proc_name->name);
1687 : retval = false;
1688 : }
1689 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1690 : "Deferred-length character dummy "
1691 : "argument %qs at %L of procedure "
1692 : "%qs with BIND(C) attribute",
1693 : sym->name, &sym->declared_at,
1694 129 : sym->ns->proc_name->name))
1695 102 : retval = false;
1696 : }
1697 2145 : else if (sym->attr.value
1698 354 : && (!cl || !cl->length
1699 354 : || cl->length->expr_type != EXPR_CONSTANT
1700 354 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1701 : {
1702 1 : gfc_error ("Character dummy argument %qs at %L must be "
1703 : "of length 1 as it has the VALUE attribute",
1704 : sym->name, &sym->declared_at);
1705 1 : retval = false;
1706 : }
1707 2144 : else if (!cl || !cl->length)
1708 : {
1709 : /* Assumed length; F2018, 18.3.6 (5)(2).
1710 : Uses the CFI array descriptor - also for scalars and
1711 : explicit-size/assumed-size arrays. */
1712 957 : if (!gfc_notify_std (GFC_STD_F2018,
1713 : "Assumed-length character dummy argument "
1714 : "%qs at %L of procedure %qs with BIND(C) "
1715 : "attribute", sym->name, &sym->declared_at,
1716 957 : sym->ns->proc_name->name))
1717 102 : retval = false;
1718 : }
1719 1187 : else if (cl->length->expr_type != EXPR_CONSTANT
1720 873 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1721 : {
1722 : /* F2018, 18.3.6, (5), item 4. */
1723 653 : if (!sym->attr.dimension
1724 645 : || sym->as->type == AS_ASSUMED_SIZE
1725 639 : || sym->as->type == AS_EXPLICIT)
1726 : {
1727 20 : gfc_error ("Character dummy argument %qs at %L must be "
1728 : "of constant length of one or assumed length, "
1729 : "unless it has assumed shape or assumed rank, "
1730 : "as procedure %qs has the BIND(C) attribute",
1731 : sym->name, &sym->declared_at,
1732 20 : sym->ns->proc_name->name);
1733 20 : retval = false;
1734 : }
1735 : /* else: valid only since F2018 - and an assumed-shape/rank
1736 : array; however, gfc_notify_std is already called when
1737 : those array types are used. Thus, silently accept F200x. */
1738 : }
1739 : }
1740 :
1741 : /* We have to make sure that any param to a bind(c) routine does
1742 : not have the allocatable, pointer, or optional attributes,
1743 : according to J3/04-007, section 5.1. */
1744 16366 : if (sym->attr.allocatable == 1
1745 16765 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1746 : "ALLOCATABLE attribute in procedure %qs "
1747 : "with BIND(C)", sym->name,
1748 : &(sym->declared_at),
1749 399 : sym->ns->proc_name->name))
1750 : retval = false;
1751 :
1752 16366 : if (sym->attr.pointer == 1
1753 17004 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1754 : "POINTER attribute in procedure %qs "
1755 : "with BIND(C)", sym->name,
1756 : &(sym->declared_at),
1757 638 : sym->ns->proc_name->name))
1758 : retval = false;
1759 :
1760 16366 : if (sym->attr.optional == 1 && sym->attr.value)
1761 : {
1762 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1763 : "and the VALUE attribute because procedure %qs "
1764 : "is BIND(C)", sym->name, &(sym->declared_at),
1765 9 : sym->ns->proc_name->name);
1766 9 : retval = false;
1767 : }
1768 16357 : else if (sym->attr.optional == 1
1769 17301 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1770 : "at %L with OPTIONAL attribute in "
1771 : "procedure %qs which is BIND(C)",
1772 : sym->name, &(sym->declared_at),
1773 944 : sym->ns->proc_name->name))
1774 : retval = false;
1775 :
1776 : /* Make sure that if it has the dimension attribute, that it is
1777 : either assumed size or explicit shape. Deferred shape is already
1778 : covered by the pointer/allocatable attribute. */
1779 5399 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1780 17696 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1781 : "at %L as dummy argument to the BIND(C) "
1782 : "procedure %qs at %L", sym->name,
1783 : &(sym->declared_at),
1784 : sym->ns->proc_name->name,
1785 1330 : &(sym->ns->proc_name->declared_at)))
1786 : retval = false;
1787 : }
1788 : }
1789 :
1790 : return retval;
1791 : }
1792 :
1793 :
1794 :
1795 : /* Function called by variable_decl() that adds a name to the symbol table. */
1796 :
1797 : static bool
1798 258041 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1799 : gfc_array_spec **as, locus *var_locus)
1800 : {
1801 258041 : symbol_attribute attr;
1802 258041 : gfc_symbol *sym;
1803 258041 : int upper;
1804 258041 : gfc_symtree *st, *host_st = NULL;
1805 :
1806 : /* Symbols in a submodule are host associated from the parent module or
1807 : submodules. Therefore, they can be overridden by declarations in the
1808 : submodule scope. Deal with this by attaching the existing symbol to
1809 : a new symtree and recycling the old symtree with a new symbol... */
1810 258041 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1811 258041 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1812 3 : && gfc_current_ns->parent)
1813 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1814 :
1815 258041 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1816 12 : && st->n.sym != NULL
1817 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1818 : {
1819 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1820 12 : s->n.sym = st->n.sym;
1821 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1822 :
1823 12 : st->n.sym = sym;
1824 12 : sym->refs++;
1825 12 : gfc_set_sym_referenced (sym);
1826 12 : }
1827 : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1828 : current scope are not violated by local redeclarations. Note that there is
1829 : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1830 : only set for these standards. */
1831 258029 : else if (host_st && host_st->n.sym
1832 2 : && host_st->n.sym != gfc_current_ns->proc_name
1833 2 : && !(st && st->n.sym
1834 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1835 : {
1836 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1837 : "statement and must not be re-declared", name, var_locus,
1838 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1839 2 : return false;
1840 : }
1841 : /* ...Otherwise generate a new symtree and new symbol. */
1842 258027 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1843 : return false;
1844 :
1845 : /* Check if the name has already been defined as a type. The
1846 : first letter of the symtree will be in upper case then. Of
1847 : course, this is only necessary if the upper case letter is
1848 : actually different. */
1849 :
1850 258039 : upper = TOUPPER(name[0]);
1851 258039 : if (upper != name[0])
1852 : {
1853 257401 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1854 257401 : gfc_symtree *st;
1855 :
1856 257401 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1857 257401 : strcpy (u_name, name);
1858 257401 : u_name[0] = upper;
1859 :
1860 257401 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1861 :
1862 : /* STRUCTURE types can alias symbol names */
1863 257401 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1864 : {
1865 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1866 : &st->n.sym->declared_at);
1867 1 : return false;
1868 : }
1869 : }
1870 :
1871 : /* Start updating the symbol table. Add basic type attribute if present. */
1872 258038 : if (current_ts.type != BT_UNKNOWN
1873 258038 : && (sym->attr.implicit_type == 0
1874 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1875 515894 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1876 : {
1877 : /* Duplicate-type rejection can leave a fresh CHARACTER length node on
1878 : the namespace list before it is attached to any surviving symbol.
1879 : Drop only that unattached node; shared constant charlen nodes are
1880 : already reachable from earlier declarations. PR82721. */
1881 27 : if (current_ts.type == BT_CHARACTER && cl && elem == 1)
1882 : {
1883 1 : discard_pending_charlen (cl);
1884 1 : gfc_clear_ts (¤t_ts);
1885 : }
1886 26 : else if (current_ts.type == BT_CHARACTER && cl && cl != current_ts.u.cl)
1887 0 : discard_pending_charlen (cl);
1888 27 : return false;
1889 : }
1890 :
1891 258011 : if (sym->ts.type == BT_CHARACTER)
1892 : {
1893 28702 : if (elem > 1)
1894 4123 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1895 : else
1896 24579 : sym->ts.u.cl = cl;
1897 28702 : sym->ts.deferred = cl_deferred;
1898 : }
1899 :
1900 : /* Add dimension attribute if present. */
1901 258011 : if (!gfc_set_array_spec (sym, *as, var_locus))
1902 : return false;
1903 258009 : *as = NULL;
1904 :
1905 : /* Add attribute to symbol. The copy is so that we can reset the
1906 : dimension attribute. */
1907 258009 : attr = current_attr;
1908 258009 : attr.dimension = 0;
1909 258009 : attr.codimension = 0;
1910 :
1911 258009 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1912 : return false;
1913 :
1914 : /* Finish any work that may need to be done for the binding label,
1915 : if it's a bind(c). The bind(c) attr is found before the symbol
1916 : is made, and before the symbol name (for data decls), so the
1917 : current_ts is holding the binding label, or nothing if the
1918 : name= attr wasn't given. Therefore, test here if we're dealing
1919 : with a bind(c) and make sure the binding label is set correctly. */
1920 257995 : if (sym->attr.is_bind_c == 1)
1921 : {
1922 1354 : if (!sym->binding_label)
1923 : {
1924 : /* Set the binding label and verify that if a NAME= was specified
1925 : then only one identifier was in the entity-decl-list. */
1926 136 : if (!set_binding_label (&sym->binding_label, sym->name,
1927 : num_idents_on_line))
1928 : return false;
1929 : }
1930 : }
1931 :
1932 : /* See if we know we're in a common block, and if it's a bind(c)
1933 : common then we need to make sure we're an interoperable type. */
1934 257993 : if (sym->attr.in_common == 1)
1935 : {
1936 : /* Test the common block object. */
1937 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1938 6 : && sym->ts.is_c_interop != 1)
1939 : {
1940 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1941 : "must be declared with a C interoperable "
1942 : "kind since common block %qs is BIND(C)",
1943 : sym->name, sym->common_block->name,
1944 0 : sym->common_block->name);
1945 0 : gfc_clear_error ();
1946 : }
1947 : }
1948 :
1949 257993 : sym->attr.implied_index = 0;
1950 :
1951 : /* Use the parameter expressions for a parameterized derived type. */
1952 257993 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1953 36451 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1954 1056 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1955 :
1956 257993 : if (sym->ts.type == BT_CLASS)
1957 10959 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1958 :
1959 : return true;
1960 : }
1961 :
1962 :
1963 : /* Set character constant to the given length. The constant will be padded or
1964 : truncated. If we're inside an array constructor without a typespec, we
1965 : additionally check that all elements have the same length; check_len -1
1966 : means no checking. */
1967 :
1968 : void
1969 14020 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1970 : gfc_charlen_t check_len)
1971 : {
1972 14020 : gfc_char_t *s;
1973 14020 : gfc_charlen_t slen;
1974 :
1975 14020 : if (expr->ts.type != BT_CHARACTER)
1976 : return;
1977 :
1978 14018 : if (expr->expr_type != EXPR_CONSTANT)
1979 : {
1980 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1981 1 : return;
1982 : }
1983 :
1984 14017 : slen = expr->value.character.length;
1985 14017 : if (len != slen)
1986 : {
1987 2141 : s = gfc_get_wide_string (len + 1);
1988 2141 : memcpy (s, expr->value.character.string,
1989 2141 : MIN (len, slen) * sizeof (gfc_char_t));
1990 2141 : if (len > slen)
1991 1850 : gfc_wide_memset (&s[slen], ' ', len - slen);
1992 :
1993 2141 : if (warn_character_truncation && slen > len)
1994 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1995 : "CHARACTER expression at %L is being truncated "
1996 : "(%ld/%ld)", &expr->where,
1997 : (long) slen, (long) len);
1998 :
1999 : /* Apply the standard by 'hand' otherwise it gets cleared for
2000 : initializers. */
2001 2141 : if (check_len != -1 && slen != check_len)
2002 : {
2003 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
2004 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
2005 : "at %L must have the same length (%ld/%ld)",
2006 : &expr->where, (long) slen,
2007 : (long) check_len);
2008 : else
2009 3 : gfc_notify_std (GFC_STD_LEGACY,
2010 : "The CHARACTER elements of the array constructor "
2011 : "at %L must have the same length (%ld/%ld)",
2012 : &expr->where, (long) slen,
2013 : (long) check_len);
2014 : }
2015 :
2016 2141 : s[len] = '\0';
2017 2141 : free (expr->value.character.string);
2018 2141 : expr->value.character.string = s;
2019 2141 : expr->value.character.length = len;
2020 : /* If explicit representation was given, clear it
2021 : as it is no longer needed after padding. */
2022 2141 : if (expr->representation.length)
2023 : {
2024 45 : expr->representation.length = 0;
2025 45 : free (expr->representation.string);
2026 45 : expr->representation.string = NULL;
2027 : }
2028 : }
2029 : }
2030 :
2031 :
2032 : /* Function to create and update the enumerator history
2033 : using the information passed as arguments.
2034 : Pointer "max_enum" is also updated, to point to
2035 : enum history node containing largest initializer.
2036 :
2037 : SYM points to the symbol node of enumerator.
2038 : INIT points to its enumerator value. */
2039 :
2040 : static void
2041 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
2042 : {
2043 543 : enumerator_history *new_enum_history;
2044 543 : gcc_assert (sym != NULL && init != NULL);
2045 :
2046 543 : new_enum_history = XCNEW (enumerator_history);
2047 :
2048 543 : new_enum_history->sym = sym;
2049 543 : new_enum_history->initializer = init;
2050 543 : new_enum_history->next = NULL;
2051 :
2052 543 : if (enum_history == NULL)
2053 : {
2054 160 : enum_history = new_enum_history;
2055 160 : max_enum = enum_history;
2056 : }
2057 : else
2058 : {
2059 383 : new_enum_history->next = enum_history;
2060 383 : enum_history = new_enum_history;
2061 :
2062 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2063 383 : new_enum_history->initializer->value.integer) < 0)
2064 381 : max_enum = new_enum_history;
2065 : }
2066 543 : }
2067 :
2068 :
2069 : /* Function to free enum kind history. */
2070 :
2071 : void
2072 175 : gfc_free_enum_history (void)
2073 : {
2074 175 : enumerator_history *current = enum_history;
2075 175 : enumerator_history *next;
2076 :
2077 718 : while (current != NULL)
2078 : {
2079 543 : next = current->next;
2080 543 : free (current);
2081 543 : current = next;
2082 : }
2083 175 : max_enum = NULL;
2084 175 : enum_history = NULL;
2085 175 : }
2086 :
2087 :
2088 : /* Function to fix initializer character length if the length of the
2089 : symbol or component is constant. */
2090 :
2091 : static bool
2092 2723 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2093 : {
2094 2723 : if (!gfc_specification_expr (ts->u.cl->length))
2095 : return false;
2096 :
2097 2723 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2098 :
2099 : /* resolve_charlen will complain later on if the length
2100 : is too large. Just skip the initialization in that case. */
2101 2723 : if (mpz_cmp (ts->u.cl->length->value.integer,
2102 2723 : gfc_integer_kinds[k].huge) <= 0)
2103 : {
2104 2722 : HOST_WIDE_INT len
2105 2722 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2106 :
2107 2722 : if (init->expr_type == EXPR_CONSTANT)
2108 1988 : gfc_set_constant_character_len (len, init, -1);
2109 734 : else if (init->expr_type == EXPR_ARRAY)
2110 : {
2111 733 : gfc_constructor *cons;
2112 :
2113 : /* Build a new charlen to prevent simplification from
2114 : deleting the length before it is resolved. */
2115 733 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2116 733 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2117 733 : cons = gfc_constructor_first (init->value.constructor);
2118 4971 : for (; cons; cons = gfc_constructor_next (cons))
2119 3505 : gfc_set_constant_character_len (len, cons->expr, -1);
2120 : }
2121 : }
2122 :
2123 : return true;
2124 : }
2125 :
2126 :
2127 : /* Function called by variable_decl() that adds an initialization
2128 : expression to a symbol. */
2129 :
2130 : static bool
2131 265493 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus,
2132 : gfc_charlen *saved_cl_list)
2133 : {
2134 265493 : symbol_attribute attr;
2135 265493 : gfc_symbol *sym;
2136 265493 : gfc_expr *init;
2137 :
2138 265493 : init = *initp;
2139 265493 : if (find_special (name, &sym, false))
2140 : return false;
2141 :
2142 265493 : attr = sym->attr;
2143 :
2144 : /* If this symbol is confirming an implicit parameter type,
2145 : then an initialization expression is not allowed. */
2146 265493 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2147 : {
2148 1 : if (*initp != NULL)
2149 : {
2150 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2151 : sym->name);
2152 0 : return false;
2153 : }
2154 : else
2155 : return true;
2156 : }
2157 :
2158 265492 : if (init == NULL)
2159 : {
2160 : /* An initializer is required for PARAMETER declarations. */
2161 233373 : if (attr.flavor == FL_PARAMETER)
2162 : {
2163 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2164 1 : return false;
2165 : }
2166 : }
2167 : else
2168 : {
2169 : /* If a variable appears in a DATA block, it cannot have an
2170 : initializer. */
2171 32119 : if (sym->attr.data)
2172 : {
2173 0 : gfc_error ("Variable %qs at %C with an initializer already "
2174 : "appears in a DATA statement", sym->name);
2175 0 : return false;
2176 : }
2177 :
2178 : /* Check if the assignment can happen. This has to be put off
2179 : until later for derived type variables and procedure pointers. */
2180 30958 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2181 30935 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2182 30885 : && !sym->attr.proc_pointer
2183 62902 : && !gfc_check_assign_symbol (sym, NULL, init))
2184 : return false;
2185 :
2186 32088 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2187 3414 : && init->ts.type == BT_CHARACTER)
2188 : {
2189 : /* Update symbol character length according initializer. */
2190 3250 : if (!gfc_check_assign_symbol (sym, NULL, init))
2191 : return false;
2192 :
2193 3250 : if (sym->ts.u.cl->length == NULL)
2194 : {
2195 843 : gfc_charlen_t clen;
2196 : /* If there are multiple CHARACTER variables declared on the
2197 : same line, we don't want them to share the same length. */
2198 843 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2199 :
2200 843 : if (sym->attr.flavor == FL_PARAMETER)
2201 : {
2202 834 : if (init->expr_type == EXPR_CONSTANT)
2203 : {
2204 549 : clen = init->value.character.length;
2205 549 : sym->ts.u.cl->length
2206 549 : = gfc_get_int_expr (gfc_charlen_int_kind,
2207 : NULL, clen);
2208 : }
2209 285 : else if (init->expr_type == EXPR_ARRAY)
2210 : {
2211 285 : if (init->ts.u.cl && init->ts.u.cl->length)
2212 : {
2213 273 : const gfc_expr *length = init->ts.u.cl->length;
2214 273 : if (length->expr_type != EXPR_CONSTANT)
2215 : {
2216 3 : gfc_error ("Cannot initialize parameter array "
2217 : "at %L "
2218 : "with variable length elements",
2219 : &sym->declared_at);
2220 :
2221 : /* This rejection path can leave several
2222 : declaration-local charlens on cl_list,
2223 : including the replacement symbol charlen and
2224 : the array-constructor typespec charlen.
2225 : Clear the surviving owners first, then drop
2226 : only the nodes created by this declaration. */
2227 3 : sym->ts.u.cl = NULL;
2228 3 : init->ts.u.cl = NULL;
2229 3 : discard_pending_charlens (saved_cl_list);
2230 3 : return false;
2231 : }
2232 270 : clen = mpz_get_si (length->value.integer);
2233 270 : }
2234 12 : else if (init->value.constructor)
2235 : {
2236 12 : gfc_constructor *c;
2237 12 : c = gfc_constructor_first (init->value.constructor);
2238 12 : clen = c->expr->value.character.length;
2239 : }
2240 : else
2241 0 : gcc_unreachable ();
2242 282 : sym->ts.u.cl->length
2243 282 : = gfc_get_int_expr (gfc_charlen_int_kind,
2244 : NULL, clen);
2245 : }
2246 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2247 0 : sym->ts.u.cl->length =
2248 0 : gfc_copy_expr (init->ts.u.cl->length);
2249 : }
2250 : }
2251 : /* Update initializer character length according to symbol. */
2252 2407 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2253 2407 : && !fix_initializer_charlen (&sym->ts, init))
2254 : return false;
2255 : }
2256 :
2257 32085 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2258 3767 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2259 : {
2260 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2261 : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2262 3 : return false;
2263 : }
2264 :
2265 : /* If sym is implied-shape, set its upper bounds from init. */
2266 32082 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2267 3764 : && sym->as && sym->as->type == AS_IMPLIED_SHAPE)
2268 : {
2269 1038 : int dim;
2270 :
2271 1038 : if (init->rank == 0)
2272 : {
2273 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2274 : " with scalar", &sym->declared_at);
2275 1 : return false;
2276 : }
2277 :
2278 : /* The shape may be NULL for EXPR_ARRAY, set it. */
2279 1037 : if (init->shape == NULL)
2280 : {
2281 5 : if (init->expr_type != EXPR_ARRAY)
2282 : {
2283 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2284 2 : return false;
2285 : }
2286 :
2287 3 : init->shape = gfc_get_shape (1);
2288 3 : if (!gfc_array_size (init, &init->shape[0]))
2289 : {
2290 1 : gfc_error ("Cannot determine shape of initializer at %L",
2291 : &init->where);
2292 1 : free (init->shape);
2293 1 : init->shape = NULL;
2294 1 : return false;
2295 : }
2296 : }
2297 :
2298 2169 : for (dim = 0; dim < sym->as->rank; ++dim)
2299 : {
2300 1136 : int k;
2301 1136 : gfc_expr *e, *lower;
2302 :
2303 1136 : lower = sym->as->lower[dim];
2304 :
2305 : /* If the lower bound is an array element from another
2306 : parameterized array, then it is marked with EXPR_VARIABLE and
2307 : is an initialization expression. Try to reduce it. */
2308 1136 : if (lower->expr_type == EXPR_VARIABLE)
2309 7 : gfc_reduce_init_expr (lower);
2310 :
2311 1136 : if (lower->expr_type == EXPR_CONSTANT)
2312 : {
2313 : /* All dimensions must be without upper bound. */
2314 1135 : gcc_assert (!sym->as->upper[dim]);
2315 :
2316 1135 : k = lower->ts.kind;
2317 1135 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2318 1135 : mpz_add (e->value.integer, lower->value.integer,
2319 1135 : init->shape[dim]);
2320 1135 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2321 1135 : sym->as->upper[dim] = e;
2322 : }
2323 : else
2324 : {
2325 1 : gfc_error ("Non-constant lower bound in implied-shape"
2326 : " declaration at %L", &lower->where);
2327 1 : return false;
2328 : }
2329 : }
2330 :
2331 1033 : sym->as->type = AS_EXPLICIT;
2332 : }
2333 :
2334 : /* Ensure that explicit bounds are simplified. */
2335 32077 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2336 3759 : && sym->as && sym->as->type == AS_EXPLICIT)
2337 : {
2338 8350 : for (int dim = 0; dim < sym->as->rank; ++dim)
2339 : {
2340 4603 : gfc_expr *e;
2341 :
2342 4603 : e = sym->as->lower[dim];
2343 4603 : if (e->expr_type != EXPR_CONSTANT)
2344 12 : gfc_reduce_init_expr (e);
2345 :
2346 4603 : e = sym->as->upper[dim];
2347 4603 : if (e->expr_type != EXPR_CONSTANT)
2348 106 : gfc_reduce_init_expr (e);
2349 : }
2350 : }
2351 :
2352 : /* Need to check if the expression we initialized this
2353 : to was one of the iso_c_binding named constants. If so,
2354 : and we're a parameter (constant), let it be iso_c.
2355 : For example:
2356 : integer(c_int), parameter :: my_int = c_int
2357 : integer(my_int) :: my_int_2
2358 : If we mark my_int as iso_c (since we can see it's value
2359 : is equal to one of the named constants), then my_int_2
2360 : will be considered C interoperable. */
2361 32077 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2362 : {
2363 27508 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2364 27508 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2365 : /* attr bits needed for module files. */
2366 27508 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2367 27508 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2368 27508 : if (init->ts.is_iso_c)
2369 113 : sym->ts.f90_type = init->ts.f90_type;
2370 : }
2371 :
2372 : /* Catch the case: type(t), parameter :: x = z'1'. */
2373 32077 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2374 : {
2375 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2376 : "literal constant", name, &sym->declared_at);
2377 1 : return false;
2378 : }
2379 :
2380 : /* Add initializer. Make sure we keep the ranks sane. */
2381 32076 : if (sym->attr.dimension && init->rank == 0)
2382 : {
2383 1242 : mpz_t size;
2384 1242 : gfc_expr *array;
2385 1242 : int n;
2386 1242 : if (sym->attr.flavor == FL_PARAMETER
2387 439 : && gfc_is_constant_expr (init)
2388 439 : && (init->expr_type == EXPR_CONSTANT
2389 32 : || init->expr_type == EXPR_STRUCTURE)
2390 1681 : && spec_size (sym->as, &size))
2391 : {
2392 435 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2393 : &init->where);
2394 435 : if (init->ts.type == BT_DERIVED)
2395 32 : array->ts.u.derived = init->ts.u.derived;
2396 67551 : for (n = 0; n < (int)mpz_get_si (size); n++)
2397 133938 : gfc_constructor_append_expr (&array->value.constructor,
2398 : n == 0
2399 : ? init
2400 66822 : : gfc_copy_expr (init),
2401 : &init->where);
2402 :
2403 435 : array->shape = gfc_get_shape (sym->as->rank);
2404 996 : for (n = 0; n < sym->as->rank; n++)
2405 561 : spec_dimen_size (sym->as, n, &array->shape[n]);
2406 :
2407 435 : init = array;
2408 435 : mpz_clear (size);
2409 : }
2410 1242 : init->rank = sym->as->rank;
2411 1242 : init->corank = sym->as->corank;
2412 : }
2413 :
2414 32076 : sym->value = init;
2415 32076 : if (sym->attr.save == SAVE_NONE)
2416 27599 : sym->attr.save = SAVE_IMPLICIT;
2417 32076 : *initp = NULL;
2418 : }
2419 :
2420 : return true;
2421 : }
2422 :
2423 :
2424 : /* Function called by variable_decl() that adds a name to a structure
2425 : being built. */
2426 :
2427 : static bool
2428 17866 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2429 : gfc_array_spec **as)
2430 : {
2431 17866 : gfc_state_data *s;
2432 17866 : gfc_component *c;
2433 :
2434 : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2435 : constructing, it must have the pointer attribute. */
2436 17866 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2437 3385 : && current_ts.u.derived == gfc_current_block ()
2438 267 : && current_attr.pointer == 0)
2439 : {
2440 106 : if (current_attr.allocatable
2441 106 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2442 : "must have the POINTER attribute"))
2443 : {
2444 : return false;
2445 : }
2446 105 : else if (current_attr.allocatable == 0)
2447 : {
2448 0 : gfc_error ("Component at %C must have the POINTER attribute");
2449 0 : return false;
2450 : }
2451 : }
2452 :
2453 : /* F03:C437. */
2454 17865 : if (current_ts.type == BT_CLASS
2455 830 : && !(current_attr.pointer || current_attr.allocatable))
2456 : {
2457 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2458 : "or pointer", name);
2459 5 : return false;
2460 : }
2461 :
2462 17860 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2463 : {
2464 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2465 : {
2466 0 : gfc_error ("Array component of structure at %C must have explicit "
2467 : "or deferred shape");
2468 0 : return false;
2469 : }
2470 : }
2471 :
2472 : /* If we are in a nested union/map definition, gfc_add_component will not
2473 : properly find repeated components because:
2474 : (i) gfc_add_component does a flat search, where components of unions
2475 : and maps are implicity chained so nested components may conflict.
2476 : (ii) Unions and maps are not linked as components of their parent
2477 : structures until after they are parsed.
2478 : For (i) we use gfc_find_component which searches recursively, and for (ii)
2479 : we search each block directly from the parse stack until we find the top
2480 : level structure. */
2481 :
2482 17860 : s = gfc_state_stack;
2483 17860 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2484 : {
2485 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2486 : {
2487 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2488 1434 : if (c != NULL)
2489 : {
2490 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2491 : name, &c->loc);
2492 0 : return false;
2493 : }
2494 : /* Break after we've searched the entire chain. */
2495 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2496 : break;
2497 1000 : s = s->previous;
2498 : }
2499 : }
2500 :
2501 17860 : if (!gfc_add_component (gfc_current_block(), name, &c))
2502 : return false;
2503 :
2504 17854 : c->ts = current_ts;
2505 17854 : if (c->ts.type == BT_CHARACTER)
2506 1932 : c->ts.u.cl = cl;
2507 :
2508 17854 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2509 14475 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2510 2112 : && saved_kind_expr != NULL)
2511 194 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2512 :
2513 17854 : c->attr = current_attr;
2514 :
2515 17854 : c->initializer = *init;
2516 17854 : *init = NULL;
2517 :
2518 : /* Update initializer character length according to component. */
2519 1932 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2520 1532 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2521 1468 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2522 18173 : && !fix_initializer_charlen (&c->ts, c->initializer))
2523 : return false;
2524 :
2525 17854 : c->as = *as;
2526 17854 : if (c->as != NULL)
2527 : {
2528 4700 : if (c->as->corank)
2529 107 : c->attr.codimension = 1;
2530 4700 : if (c->as->rank)
2531 4625 : c->attr.dimension = 1;
2532 : }
2533 17854 : *as = NULL;
2534 :
2535 17854 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2536 :
2537 : /* Check array components. */
2538 17854 : if (!c->attr.dimension)
2539 13229 : goto scalar;
2540 :
2541 4625 : if (c->attr.pointer)
2542 : {
2543 682 : if (c->as->type != AS_DEFERRED)
2544 : {
2545 5 : gfc_error ("Pointer array component of structure at %C must have a "
2546 : "deferred shape");
2547 5 : return false;
2548 : }
2549 : }
2550 3943 : else if (c->attr.allocatable)
2551 : {
2552 2330 : const char *err = G_("Allocatable component of structure at %C must have "
2553 : "a deferred shape");
2554 2330 : if (c->as->type != AS_DEFERRED)
2555 : {
2556 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2557 : {
2558 : /* Issue an immediate error and allow this component to pass for
2559 : the sake of clean error recovery. Set the error flag for the
2560 : containing derived type so that finalizers are not built. */
2561 4 : gfc_error_now (err);
2562 4 : s->sym->error = 1;
2563 4 : c->as->type = AS_DEFERRED;
2564 : }
2565 : else
2566 : {
2567 10 : gfc_error (err);
2568 10 : return false;
2569 : }
2570 : }
2571 : }
2572 : else
2573 : {
2574 1613 : if (c->as->type != AS_EXPLICIT)
2575 : {
2576 7 : gfc_error ("Array component of structure at %C must have an "
2577 : "explicit shape");
2578 7 : return false;
2579 : }
2580 : }
2581 :
2582 1606 : scalar:
2583 17832 : if (c->ts.type == BT_CLASS)
2584 822 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2585 :
2586 17010 : if (c->attr.pdt_kind || c->attr.pdt_len)
2587 : {
2588 584 : gfc_symbol *sym;
2589 584 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2590 : 0, &sym);
2591 584 : if (sym == NULL)
2592 : {
2593 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2594 : "in the type parameter name list at %L",
2595 0 : c->name, &gfc_current_block ()->declared_at);
2596 0 : return false;
2597 : }
2598 584 : sym->ts = c->ts;
2599 584 : sym->attr.pdt_kind = c->attr.pdt_kind;
2600 584 : sym->attr.pdt_len = c->attr.pdt_len;
2601 584 : if (c->initializer)
2602 234 : sym->value = gfc_copy_expr (c->initializer);
2603 584 : sym->attr.flavor = FL_VARIABLE;
2604 : }
2605 :
2606 17010 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2607 2554 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2608 130 : && decl_type_param_list)
2609 130 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2610 :
2611 : return true;
2612 : }
2613 :
2614 :
2615 : /* Match a 'NULL()', and possibly take care of some side effects. */
2616 :
2617 : match
2618 1697 : gfc_match_null (gfc_expr **result)
2619 : {
2620 1697 : gfc_symbol *sym;
2621 1697 : match m, m2 = MATCH_NO;
2622 :
2623 1697 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2624 : return MATCH_ERROR;
2625 :
2626 1697 : if (m == MATCH_NO)
2627 : {
2628 505 : locus old_loc;
2629 505 : char name[GFC_MAX_SYMBOL_LEN + 1];
2630 :
2631 505 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2632 499 : return m2;
2633 :
2634 6 : old_loc = gfc_current_locus;
2635 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2636 : return MATCH_ERROR;
2637 6 : if (m2 != MATCH_YES
2638 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2639 : return MATCH_ERROR;
2640 6 : if (m2 == MATCH_NO)
2641 : {
2642 0 : gfc_current_locus = old_loc;
2643 0 : return MATCH_NO;
2644 : }
2645 : }
2646 :
2647 : /* The NULL symbol now has to be/become an intrinsic function. */
2648 1198 : if (gfc_get_symbol ("null", NULL, &sym))
2649 : {
2650 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2651 0 : return MATCH_ERROR;
2652 : }
2653 :
2654 1198 : gfc_intrinsic_symbol (sym);
2655 :
2656 1198 : if (sym->attr.proc != PROC_INTRINSIC
2657 840 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2658 2037 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2659 839 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2660 0 : return MATCH_ERROR;
2661 :
2662 1198 : *result = gfc_get_null_expr (&gfc_current_locus);
2663 :
2664 : /* Invalid per F2008, C512. */
2665 1198 : if (m2 == MATCH_YES)
2666 : {
2667 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2668 6 : return MATCH_ERROR;
2669 : }
2670 :
2671 : return MATCH_YES;
2672 : }
2673 :
2674 :
2675 : /* Match the initialization expr for a data pointer or procedure pointer. */
2676 :
2677 : static match
2678 1361 : match_pointer_init (gfc_expr **init, int procptr)
2679 : {
2680 1361 : match m;
2681 :
2682 1361 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2683 : {
2684 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2685 : "a PURE procedure");
2686 1 : return MATCH_ERROR;
2687 : }
2688 1360 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2689 :
2690 : /* Match NULL() initialization. */
2691 1360 : m = gfc_match_null (init);
2692 1360 : if (m != MATCH_NO)
2693 : return m;
2694 :
2695 : /* Match non-NULL initialization. */
2696 170 : gfc_matching_ptr_assignment = !procptr;
2697 170 : gfc_matching_procptr_assignment = procptr;
2698 170 : m = gfc_match_rvalue (init);
2699 170 : gfc_matching_ptr_assignment = 0;
2700 170 : gfc_matching_procptr_assignment = 0;
2701 170 : if (m == MATCH_ERROR)
2702 : return MATCH_ERROR;
2703 169 : else if (m == MATCH_NO)
2704 : {
2705 2 : gfc_error ("Error in pointer initialization at %C");
2706 2 : return MATCH_ERROR;
2707 : }
2708 :
2709 167 : if (!procptr && !gfc_resolve_expr (*init))
2710 : return MATCH_ERROR;
2711 :
2712 166 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2713 : "initialization at %C"))
2714 : return MATCH_ERROR;
2715 :
2716 : return MATCH_YES;
2717 : }
2718 :
2719 :
2720 : static bool
2721 285658 : check_function_name (char *name)
2722 : {
2723 : /* In functions that have a RESULT variable defined, the function name always
2724 : refers to function calls. Therefore, the name is not allowed to appear in
2725 : specification statements. When checking this, be careful about
2726 : 'hidden' procedure pointer results ('ppr@'). */
2727 :
2728 285658 : if (gfc_current_state () == COMP_FUNCTION)
2729 : {
2730 45624 : gfc_symbol *block = gfc_current_block ();
2731 45624 : if (block && block->result && block->result != block
2732 15122 : && strcmp (block->result->name, "ppr@") != 0
2733 15063 : && strcmp (block->name, name) == 0)
2734 : {
2735 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2736 : "from appearing in a specification statement",
2737 : block->result->name, &block->result->declared_at, name);
2738 9 : return false;
2739 : }
2740 : }
2741 :
2742 : return true;
2743 : }
2744 :
2745 :
2746 : /* Match a variable name with an optional initializer. When this
2747 : subroutine is called, a variable is expected to be parsed next.
2748 : Depending on what is happening at the moment, updates either the
2749 : symbol table or the current interface. */
2750 :
2751 : static match
2752 275590 : variable_decl (int elem)
2753 : {
2754 275590 : char name[GFC_MAX_SYMBOL_LEN + 1];
2755 275590 : static unsigned int fill_id = 0;
2756 275590 : gfc_expr *initializer, *char_len;
2757 275590 : gfc_array_spec *as;
2758 275590 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2759 275590 : gfc_charlen *cl;
2760 275590 : gfc_charlen *saved_cl_list;
2761 275590 : bool cl_deferred;
2762 275590 : locus var_locus;
2763 275590 : match m;
2764 275590 : bool t;
2765 275590 : gfc_symbol *sym;
2766 275590 : char c;
2767 :
2768 275590 : initializer = NULL;
2769 275590 : as = NULL;
2770 275590 : cp_as = NULL;
2771 275590 : saved_cl_list = gfc_current_ns->cl_list;
2772 :
2773 : /* When we get here, we've just matched a list of attributes and
2774 : maybe a type and a double colon. The next thing we expect to see
2775 : is the name of the symbol. */
2776 :
2777 : /* If we are parsing a structure with legacy support, we allow the symbol
2778 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2779 275590 : m = MATCH_NO;
2780 275590 : gfc_gobble_whitespace ();
2781 275590 : var_locus = gfc_current_locus;
2782 275590 : c = gfc_peek_ascii_char ();
2783 275590 : if (c == '%')
2784 : {
2785 12 : gfc_next_ascii_char (); /* Burn % character. */
2786 12 : m = gfc_match ("fill");
2787 12 : if (m == MATCH_YES)
2788 : {
2789 11 : if (gfc_current_state () != COMP_STRUCTURE)
2790 : {
2791 2 : if (flag_dec_structure)
2792 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2793 : else
2794 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2795 : "%<-fdec-structure%>", "%FILL");
2796 2 : m = MATCH_ERROR;
2797 2 : goto cleanup;
2798 : }
2799 :
2800 9 : if (attr_seen)
2801 : {
2802 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2803 1 : m = MATCH_ERROR;
2804 1 : goto cleanup;
2805 : }
2806 :
2807 : /* %FILL components are given invalid fortran names. */
2808 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2809 : }
2810 : else
2811 : {
2812 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2813 1 : return MATCH_ERROR;
2814 : }
2815 : }
2816 : else
2817 : {
2818 275578 : m = gfc_match_name (name);
2819 275577 : if (m != MATCH_YES)
2820 10 : goto cleanup;
2821 : }
2822 :
2823 : /* Now we could see the optional array spec. or character length. */
2824 275575 : m = gfc_match_array_spec (&as, true, true);
2825 275574 : if (m == MATCH_ERROR)
2826 57 : goto cleanup;
2827 :
2828 275517 : if (m == MATCH_NO)
2829 215042 : as = gfc_copy_array_spec (current_as);
2830 60475 : else if (current_as
2831 60475 : && !merge_array_spec (current_as, as, true))
2832 : {
2833 4 : m = MATCH_ERROR;
2834 4 : goto cleanup;
2835 : }
2836 :
2837 275513 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2838 : &gfc_current_locus);
2839 275513 : if (flag_cray_pointer)
2840 3063 : cp_as = gfc_copy_array_spec (as);
2841 :
2842 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2843 : determine (and check) whether it can be implied-shape. If it
2844 : was parsed as assumed-size, change it because PARAMETERs cannot
2845 : be assumed-size.
2846 :
2847 : An explicit-shape-array cannot appear under several conditions.
2848 : That check is done here as well. */
2849 275513 : if (as)
2850 : {
2851 82982 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2852 : {
2853 2 : m = MATCH_ERROR;
2854 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2855 : name, &var_locus);
2856 2 : goto cleanup;
2857 : }
2858 :
2859 82980 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2860 6459 : && current_attr.flavor == FL_PARAMETER)
2861 990 : as->type = AS_IMPLIED_SHAPE;
2862 :
2863 82980 : if (as->type == AS_IMPLIED_SHAPE
2864 82980 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2865 : &var_locus))
2866 : {
2867 1 : m = MATCH_ERROR;
2868 1 : goto cleanup;
2869 : }
2870 :
2871 82979 : gfc_seen_div0 = false;
2872 :
2873 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2874 : constant expressions shall appear only in a subprogram, derived
2875 : type definition, BLOCK construct, or interface body. */
2876 82979 : if (as->type == AS_EXPLICIT
2877 41497 : && gfc_current_state () != COMP_BLOCK
2878 : && gfc_current_state () != COMP_DERIVED
2879 : && gfc_current_state () != COMP_FUNCTION
2880 : && gfc_current_state () != COMP_INTERFACE
2881 : && gfc_current_state () != COMP_SUBROUTINE)
2882 : {
2883 : gfc_expr *e;
2884 49403 : bool not_constant = false;
2885 :
2886 49403 : for (int i = 0; i < as->rank; i++)
2887 : {
2888 28150 : e = gfc_copy_expr (as->lower[i]);
2889 28150 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2890 : {
2891 0 : m = MATCH_ERROR;
2892 0 : goto cleanup;
2893 : }
2894 :
2895 28150 : gfc_simplify_expr (e, 0);
2896 28150 : if (e && (e->expr_type != EXPR_CONSTANT))
2897 : {
2898 : not_constant = true;
2899 : break;
2900 : }
2901 28150 : gfc_free_expr (e);
2902 :
2903 28150 : e = gfc_copy_expr (as->upper[i]);
2904 28150 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2905 : {
2906 4 : m = MATCH_ERROR;
2907 4 : goto cleanup;
2908 : }
2909 :
2910 28146 : gfc_simplify_expr (e, 0);
2911 28146 : if (e && (e->expr_type != EXPR_CONSTANT))
2912 : {
2913 : not_constant = true;
2914 : break;
2915 : }
2916 28133 : gfc_free_expr (e);
2917 : }
2918 :
2919 21266 : if (not_constant && e->ts.type != BT_INTEGER)
2920 : {
2921 4 : gfc_error ("Explicit array shape at %C must be constant of "
2922 : "INTEGER type and not %s type",
2923 : gfc_basic_typename (e->ts.type));
2924 4 : m = MATCH_ERROR;
2925 4 : goto cleanup;
2926 : }
2927 9 : if (not_constant)
2928 : {
2929 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2930 9 : m = MATCH_ERROR;
2931 9 : goto cleanup;
2932 : }
2933 : }
2934 82962 : if (as->type == AS_EXPLICIT)
2935 : {
2936 99391 : for (int i = 0; i < as->rank; i++)
2937 : {
2938 57911 : gfc_expr *e, *n;
2939 57911 : e = as->lower[i];
2940 57911 : if (e->expr_type != EXPR_CONSTANT)
2941 : {
2942 452 : n = gfc_copy_expr (e);
2943 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2944 : {
2945 0 : m = MATCH_ERROR;
2946 0 : goto cleanup;
2947 : }
2948 :
2949 452 : if (n->expr_type == EXPR_CONSTANT)
2950 22 : gfc_replace_expr (e, n);
2951 : else
2952 430 : gfc_free_expr (n);
2953 : }
2954 57911 : e = as->upper[i];
2955 57911 : if (e->expr_type != EXPR_CONSTANT)
2956 : {
2957 6617 : n = gfc_copy_expr (e);
2958 6617 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2959 : {
2960 0 : m = MATCH_ERROR;
2961 0 : goto cleanup;
2962 : }
2963 :
2964 6617 : if (n->expr_type == EXPR_CONSTANT)
2965 45 : gfc_replace_expr (e, n);
2966 : else
2967 6572 : gfc_free_expr (n);
2968 : }
2969 : /* For an explicit-shape spec with constant bounds, ensure
2970 : that the effective upper bound is not lower than the
2971 : respective lower bound minus one. Otherwise adjust it so
2972 : that the extent is trivially derived to be zero. */
2973 57911 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2974 57481 : && as->upper[i]->expr_type == EXPR_CONSTANT
2975 51333 : && as->lower[i]->ts.type == BT_INTEGER
2976 51333 : && as->upper[i]->ts.type == BT_INTEGER
2977 51328 : && mpz_cmp (as->upper[i]->value.integer,
2978 51328 : as->lower[i]->value.integer) < 0)
2979 1212 : mpz_sub_ui (as->upper[i]->value.integer,
2980 : as->lower[i]->value.integer, 1);
2981 : }
2982 : }
2983 : }
2984 :
2985 275493 : char_len = NULL;
2986 275493 : cl = NULL;
2987 275493 : cl_deferred = false;
2988 :
2989 275493 : if (current_ts.type == BT_CHARACTER)
2990 : {
2991 30675 : switch (match_char_length (&char_len, &cl_deferred, false))
2992 : {
2993 435 : case MATCH_YES:
2994 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2995 :
2996 435 : cl->length = char_len;
2997 435 : break;
2998 :
2999 : /* Non-constant lengths need to be copied after the first
3000 : element. Also copy assumed lengths. */
3001 30239 : case MATCH_NO:
3002 30239 : if (elem > 1
3003 3892 : && (current_ts.u.cl->length == NULL
3004 2697 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
3005 : {
3006 1250 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3007 1250 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
3008 : }
3009 : else
3010 28989 : cl = current_ts.u.cl;
3011 :
3012 30239 : cl_deferred = current_ts.deferred;
3013 :
3014 30239 : break;
3015 :
3016 1 : case MATCH_ERROR:
3017 1 : goto cleanup;
3018 : }
3019 : }
3020 :
3021 : /* The dummy arguments and result of the abbreviated form of MODULE
3022 : PROCEDUREs, used in SUBMODULES should not be redefined. */
3023 275492 : if (gfc_current_ns->proc_name
3024 271000 : && gfc_current_ns->proc_name->abr_modproc_decl)
3025 : {
3026 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
3027 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
3028 : {
3029 2 : m = MATCH_ERROR;
3030 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
3031 : "in the corresponding interface for MODULE "
3032 : "PROCEDURE %qs", sym->name, &var_locus,
3033 2 : gfc_current_ns->proc_name->name);
3034 2 : goto cleanup;
3035 : }
3036 : }
3037 :
3038 : /* %FILL components may not have initializers. */
3039 275490 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
3040 : {
3041 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
3042 : &var_locus);
3043 1 : m = MATCH_ERROR;
3044 1 : goto cleanup;
3045 : }
3046 :
3047 : /* If this symbol has already shown up in a Cray Pointer declaration,
3048 : and this is not a component declaration,
3049 : then we want to set the type & bail out. */
3050 275489 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
3051 : {
3052 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3053 2959 : if (sym != NULL && sym->attr.cray_pointee)
3054 : {
3055 101 : m = MATCH_YES;
3056 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
3057 : {
3058 1 : m = MATCH_ERROR;
3059 1 : goto cleanup;
3060 : }
3061 :
3062 : /* Check to see if we have an array specification. */
3063 100 : if (cp_as != NULL)
3064 : {
3065 49 : if (sym->as != NULL)
3066 : {
3067 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3068 1 : gfc_free_array_spec (cp_as);
3069 1 : m = MATCH_ERROR;
3070 1 : goto cleanup;
3071 : }
3072 : else
3073 : {
3074 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3075 0 : gfc_internal_error ("Cannot set pointee array spec.");
3076 :
3077 : /* Fix the array spec. */
3078 48 : m = gfc_mod_pointee_as (sym->as);
3079 48 : if (m == MATCH_ERROR)
3080 0 : goto cleanup;
3081 : }
3082 : }
3083 99 : goto cleanup;
3084 : }
3085 : else
3086 : {
3087 2858 : gfc_free_array_spec (cp_as);
3088 : }
3089 : }
3090 :
3091 : /* Procedure pointer as function result. */
3092 275388 : if (gfc_current_state () == COMP_FUNCTION
3093 44264 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3094 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3095 7 : strcpy (name, "ppr@");
3096 :
3097 275388 : if (gfc_current_state () == COMP_FUNCTION
3098 44264 : && strcmp (name, gfc_current_block ()->name) == 0
3099 7599 : && gfc_current_block ()->result
3100 7599 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3101 16 : strcpy (name, "ppr@");
3102 :
3103 : /* OK, we've successfully matched the declaration. Now put the
3104 : symbol in the current namespace, because it might be used in the
3105 : optional initialization expression for this symbol, e.g. this is
3106 : perfectly legal:
3107 :
3108 : integer, parameter :: i = huge(i)
3109 :
3110 : This is only true for parameters or variables of a basic type.
3111 : For components of derived types, it is not true, so we don't
3112 : create a symbol for those yet. If we fail to create the symbol,
3113 : bail out. */
3114 275388 : if (!gfc_comp_struct (gfc_current_state ())
3115 257493 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3116 : {
3117 48 : m = MATCH_ERROR;
3118 48 : goto cleanup;
3119 : }
3120 :
3121 275340 : if (!check_function_name (name))
3122 : {
3123 0 : m = MATCH_ERROR;
3124 0 : goto cleanup;
3125 : }
3126 :
3127 : /* We allow old-style initializations of the form
3128 : integer i /2/, j(4) /3*3, 1/
3129 : (if no colon has been seen). These are different from data
3130 : statements in that initializers are only allowed to apply to the
3131 : variable immediately preceding, i.e.
3132 : integer i, j /1, 2/
3133 : is not allowed. Therefore we have to do some work manually, that
3134 : could otherwise be left to the matchers for DATA statements. */
3135 :
3136 275340 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3137 : {
3138 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3139 : "initialization at %C"))
3140 : return MATCH_ERROR;
3141 :
3142 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3143 : but not components of derived types. */
3144 146 : else if (gfc_current_state () == COMP_DERIVED)
3145 : {
3146 2 : gfc_error ("Invalid old style initialization for derived type "
3147 : "component at %C");
3148 2 : m = MATCH_ERROR;
3149 2 : goto cleanup;
3150 : }
3151 :
3152 : /* For structure components, read the initializer as a special
3153 : expression and let the rest of this function apply the initializer
3154 : as usual. */
3155 144 : else if (gfc_comp_struct (gfc_current_state ()))
3156 : {
3157 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3158 74 : if (m == MATCH_NO)
3159 : gfc_error ("Syntax error in old style initialization of %s at %C",
3160 : name);
3161 74 : if (m != MATCH_YES)
3162 14 : goto cleanup;
3163 : }
3164 :
3165 : /* Otherwise we treat the old style initialization just like a
3166 : DATA declaration for the current variable. */
3167 : else
3168 70 : return match_old_style_init (name);
3169 : }
3170 :
3171 : /* The double colon must be present in order to have initializers.
3172 : Otherwise the statement is ambiguous with an assignment statement. */
3173 275254 : if (colon_seen)
3174 : {
3175 230263 : if (gfc_match (" =>") == MATCH_YES)
3176 : {
3177 1191 : if (!current_attr.pointer)
3178 : {
3179 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3180 0 : m = MATCH_ERROR;
3181 0 : goto cleanup;
3182 : }
3183 :
3184 1191 : m = match_pointer_init (&initializer, 0);
3185 1191 : if (m != MATCH_YES)
3186 10 : goto cleanup;
3187 :
3188 : /* The target of a pointer initialization must have the SAVE
3189 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3190 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3191 1181 : if (initializer->expr_type == EXPR_VARIABLE
3192 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3193 25 : && (gfc_current_state () == COMP_PROGRAM
3194 : || gfc_current_state () == COMP_MODULE
3195 25 : || gfc_current_state () == COMP_SUBMODULE))
3196 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3197 : }
3198 229072 : else if (gfc_match_char ('=') == MATCH_YES)
3199 : {
3200 25842 : if (current_attr.pointer)
3201 : {
3202 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3203 : "not %<=%>");
3204 0 : m = MATCH_ERROR;
3205 0 : goto cleanup;
3206 : }
3207 :
3208 25842 : if (gfc_comp_struct (gfc_current_state ())
3209 2433 : && gfc_current_block ()->attr.pdt_template)
3210 : {
3211 257 : m = gfc_match_expr (&initializer);
3212 257 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3213 115 : initializer->ts = current_ts;
3214 : }
3215 : else
3216 25585 : m = gfc_match_init_expr (&initializer);
3217 :
3218 25842 : if (m == MATCH_NO)
3219 : {
3220 1 : gfc_error ("Expected an initialization expression at %C");
3221 1 : m = MATCH_ERROR;
3222 : }
3223 :
3224 10007 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3225 25844 : && !gfc_comp_struct (gfc_state_stack->state))
3226 : {
3227 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3228 : "a PURE procedure");
3229 1 : m = MATCH_ERROR;
3230 : }
3231 :
3232 25842 : if (current_attr.flavor != FL_PARAMETER
3233 10007 : && !gfc_comp_struct (gfc_state_stack->state))
3234 7574 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3235 :
3236 25842 : if (m != MATCH_YES)
3237 160 : goto cleanup;
3238 : }
3239 : }
3240 :
3241 275084 : if (initializer != NULL && current_attr.allocatable
3242 3 : && gfc_comp_struct (gfc_current_state ()))
3243 : {
3244 2 : gfc_error ("Initialization of allocatable component at %C is not "
3245 : "allowed");
3246 2 : m = MATCH_ERROR;
3247 2 : goto cleanup;
3248 : }
3249 :
3250 275082 : if (gfc_current_state () == COMP_DERIVED
3251 16853 : && initializer && initializer->ts.type == BT_HOLLERITH)
3252 : {
3253 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3254 : "constant at %L is not allowed", &initializer->where);
3255 1 : m = MATCH_ERROR;
3256 1 : goto cleanup;
3257 : }
3258 :
3259 275081 : if (gfc_current_state () == COMP_DERIVED
3260 16852 : && gfc_current_block ()->attr.pdt_template)
3261 : {
3262 1106 : gfc_symbol *param;
3263 1106 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3264 : 0, ¶m);
3265 1106 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3266 : {
3267 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3268 : "not appear in the type parameter list at %L",
3269 1 : &gfc_current_block ()->declared_at);
3270 1 : m = MATCH_ERROR;
3271 4 : goto cleanup;
3272 : }
3273 1105 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3274 : {
3275 1 : gfc_error ("The component at %C that appears in the type parameter "
3276 : "list at %L has neither the KIND nor LEN attribute",
3277 1 : &gfc_current_block ()->declared_at);
3278 1 : m = MATCH_ERROR;
3279 1 : goto cleanup;
3280 : }
3281 1104 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3282 : {
3283 1 : gfc_error ("The component at %C which is a type parameter must be "
3284 : "a scalar");
3285 1 : m = MATCH_ERROR;
3286 1 : goto cleanup;
3287 : }
3288 1103 : else if (param && initializer)
3289 : {
3290 235 : if (initializer->ts.type == BT_BOZ)
3291 : {
3292 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3293 : "initializer", &initializer->where);
3294 1 : m = MATCH_ERROR;
3295 1 : goto cleanup;
3296 : }
3297 234 : param->value = gfc_copy_expr (initializer);
3298 : }
3299 : }
3300 :
3301 : /* Before adding a possible initializer, do a simple check for compatibility
3302 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3303 : good thing. */
3304 28023 : if (current_ts.type == BT_DERIVED && initializer
3305 276496 : && (gfc_numeric_ts (&initializer->ts)
3306 1417 : || initializer->ts.type == BT_LOGICAL
3307 1417 : || initializer->ts.type == BT_CHARACTER))
3308 : {
3309 2 : gfc_error ("Incompatible initialization between a derived type "
3310 : "entity and an entity with %qs type at %C",
3311 : gfc_typename (initializer));
3312 2 : m = MATCH_ERROR;
3313 2 : goto cleanup;
3314 : }
3315 :
3316 :
3317 : /* Add the initializer. Note that it is fine if initializer is
3318 : NULL here, because we sometimes also need to check if a
3319 : declaration *must* have an initialization expression. */
3320 275075 : if (!gfc_comp_struct (gfc_current_state ()))
3321 257209 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
3322 : saved_cl_list);
3323 : else
3324 : {
3325 17866 : if (current_ts.type == BT_DERIVED
3326 2554 : && !current_attr.pointer && !initializer)
3327 2007 : initializer = gfc_default_initializer (¤t_ts);
3328 17866 : t = build_struct (name, cl, &initializer, &as);
3329 :
3330 : /* If we match a nested structure definition we expect to see the
3331 : * body even if the variable declarations blow up, so we need to keep
3332 : * the structure declaration around. */
3333 17866 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3334 34 : gfc_commit_symbol (gfc_new_block);
3335 : }
3336 :
3337 275223 : m = (t) ? MATCH_YES : MATCH_ERROR;
3338 :
3339 275517 : cleanup:
3340 : /* Free stuff up and return. */
3341 275517 : gfc_seen_div0 = false;
3342 275517 : gfc_free_expr (initializer);
3343 275517 : gfc_free_array_spec (as);
3344 :
3345 275517 : return m;
3346 : }
3347 :
3348 :
3349 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3350 : This assumes that the byte size is equal to the kind number for
3351 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3352 :
3353 : static match
3354 106342 : gfc_match_old_kind_spec (gfc_typespec *ts)
3355 : {
3356 106342 : match m;
3357 106342 : int original_kind;
3358 :
3359 106342 : if (gfc_match_char ('*') != MATCH_YES)
3360 : return MATCH_NO;
3361 :
3362 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3363 1150 : if (m != MATCH_YES)
3364 : return MATCH_ERROR;
3365 :
3366 1150 : original_kind = ts->kind;
3367 :
3368 : /* Massage the kind numbers for complex types. */
3369 1150 : if (ts->type == BT_COMPLEX)
3370 : {
3371 79 : if (ts->kind % 2)
3372 : {
3373 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3374 : gfc_basic_typename (ts->type), original_kind);
3375 0 : return MATCH_ERROR;
3376 : }
3377 79 : ts->kind /= 2;
3378 :
3379 : }
3380 :
3381 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3382 0 : ts->kind = 8;
3383 :
3384 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3385 : {
3386 858 : if (ts->kind == 4)
3387 : {
3388 224 : if (flag_real4_kind == 8)
3389 24 : ts->kind = 8;
3390 224 : if (flag_real4_kind == 10)
3391 24 : ts->kind = 10;
3392 224 : if (flag_real4_kind == 16)
3393 24 : ts->kind = 16;
3394 : }
3395 634 : else if (ts->kind == 8)
3396 : {
3397 629 : if (flag_real8_kind == 4)
3398 24 : ts->kind = 4;
3399 629 : if (flag_real8_kind == 10)
3400 24 : ts->kind = 10;
3401 629 : if (flag_real8_kind == 16)
3402 24 : ts->kind = 16;
3403 : }
3404 : }
3405 :
3406 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3407 : {
3408 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3409 : gfc_basic_typename (ts->type), original_kind);
3410 8 : return MATCH_ERROR;
3411 : }
3412 :
3413 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3414 : "Nonstandard type declaration %s*%d at %C",
3415 : gfc_basic_typename(ts->type), original_kind))
3416 : return MATCH_ERROR;
3417 :
3418 : return MATCH_YES;
3419 : }
3420 :
3421 :
3422 : /* Match a kind specification. Since kinds are generally optional, we
3423 : usually return MATCH_NO if something goes wrong. If a "kind="
3424 : string is found, then we know we have an error. */
3425 :
3426 : match
3427 156036 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3428 : {
3429 156036 : locus where, loc;
3430 156036 : gfc_expr *e;
3431 156036 : match m, n;
3432 156036 : char c;
3433 :
3434 156036 : m = MATCH_NO;
3435 156036 : n = MATCH_YES;
3436 156036 : e = NULL;
3437 156036 : saved_kind_expr = NULL;
3438 :
3439 156036 : where = loc = gfc_current_locus;
3440 :
3441 156036 : if (kind_expr_only)
3442 0 : goto kind_expr;
3443 :
3444 156036 : if (gfc_match_char ('(') == MATCH_NO)
3445 : return MATCH_NO;
3446 :
3447 : /* Also gobbles optional text. */
3448 48256 : if (gfc_match (" kind = ") == MATCH_YES)
3449 48256 : m = MATCH_ERROR;
3450 :
3451 48256 : loc = gfc_current_locus;
3452 :
3453 48256 : kind_expr:
3454 :
3455 48256 : n = gfc_match_init_expr (&e);
3456 :
3457 48256 : if (gfc_derived_parameter_expr (e))
3458 : {
3459 160 : ts->kind = 0;
3460 160 : saved_kind_expr = gfc_copy_expr (e);
3461 160 : goto close_brackets;
3462 : }
3463 :
3464 48096 : if (n != MATCH_YES)
3465 : {
3466 345 : if (gfc_matching_function)
3467 : {
3468 : /* The function kind expression might include use associated or
3469 : imported parameters and try again after the specification
3470 : expressions..... */
3471 317 : if (gfc_match_char (')') != MATCH_YES)
3472 : {
3473 1 : gfc_error ("Missing right parenthesis at %C");
3474 1 : m = MATCH_ERROR;
3475 1 : goto no_match;
3476 : }
3477 :
3478 316 : gfc_free_expr (e);
3479 316 : gfc_undo_symbols ();
3480 316 : return MATCH_YES;
3481 : }
3482 : else
3483 : {
3484 : /* ....or else, the match is real. */
3485 28 : if (n == MATCH_NO)
3486 0 : gfc_error ("Expected initialization expression at %C");
3487 28 : if (n != MATCH_YES)
3488 28 : return MATCH_ERROR;
3489 : }
3490 : }
3491 :
3492 47751 : if (e->rank != 0)
3493 : {
3494 0 : gfc_error ("Expected scalar initialization expression at %C");
3495 0 : m = MATCH_ERROR;
3496 0 : goto no_match;
3497 : }
3498 :
3499 47751 : if (gfc_extract_int (e, &ts->kind, 1))
3500 : {
3501 0 : m = MATCH_ERROR;
3502 0 : goto no_match;
3503 : }
3504 :
3505 : /* Before throwing away the expression, let's see if we had a
3506 : C interoperable kind (and store the fact). */
3507 47751 : if (e->ts.is_c_interop == 1)
3508 : {
3509 : /* Mark this as C interoperable if being declared with one
3510 : of the named constants from iso_c_binding. */
3511 17677 : ts->is_c_interop = e->ts.is_iso_c;
3512 17677 : ts->f90_type = e->ts.f90_type;
3513 17677 : if (e->symtree)
3514 17676 : ts->interop_kind = e->symtree->n.sym;
3515 : }
3516 :
3517 47751 : gfc_free_expr (e);
3518 47751 : e = NULL;
3519 :
3520 : /* Ignore errors to this point, if we've gotten here. This means
3521 : we ignore the m=MATCH_ERROR from above. */
3522 47751 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3523 : {
3524 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3525 : gfc_basic_typename (ts->type));
3526 7 : gfc_current_locus = where;
3527 7 : return MATCH_ERROR;
3528 : }
3529 :
3530 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3531 : if, e.g., c_double is used for COMPLEX as the standard
3532 : explicitly says that the kind type parameter for complex and real
3533 : variable is the same, i.e. c_float == c_float_complex. */
3534 47744 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3535 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3536 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3537 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3538 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3539 : gfc_basic_typename (ts->type));
3540 :
3541 47731 : close_brackets:
3542 :
3543 47904 : gfc_gobble_whitespace ();
3544 47904 : if ((c = gfc_next_ascii_char ()) != ')'
3545 47904 : && (ts->type != BT_CHARACTER || c != ','))
3546 : {
3547 0 : if (ts->type == BT_CHARACTER)
3548 0 : gfc_error ("Missing right parenthesis or comma at %C");
3549 : else
3550 0 : gfc_error ("Missing right parenthesis at %C");
3551 0 : m = MATCH_ERROR;
3552 0 : goto no_match;
3553 : }
3554 : else
3555 : /* All tests passed. */
3556 47904 : m = MATCH_YES;
3557 :
3558 47904 : if(m == MATCH_ERROR)
3559 : gfc_current_locus = where;
3560 :
3561 47904 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3562 0 : ts->kind = 8;
3563 :
3564 47904 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3565 : {
3566 13879 : if (ts->kind == 4)
3567 : {
3568 4484 : if (flag_real4_kind == 8)
3569 54 : ts->kind = 8;
3570 4484 : if (flag_real4_kind == 10)
3571 54 : ts->kind = 10;
3572 4484 : if (flag_real4_kind == 16)
3573 54 : ts->kind = 16;
3574 : }
3575 9395 : else if (ts->kind == 8)
3576 : {
3577 6413 : if (flag_real8_kind == 4)
3578 48 : ts->kind = 4;
3579 6413 : if (flag_real8_kind == 10)
3580 48 : ts->kind = 10;
3581 6413 : if (flag_real8_kind == 16)
3582 48 : ts->kind = 16;
3583 : }
3584 : }
3585 :
3586 : /* Return what we know from the test(s). */
3587 : return m;
3588 :
3589 1 : no_match:
3590 1 : gfc_free_expr (e);
3591 1 : gfc_current_locus = where;
3592 1 : return m;
3593 : }
3594 :
3595 :
3596 : static match
3597 4685 : match_char_kind (int * kind, int * is_iso_c)
3598 : {
3599 4685 : locus where;
3600 4685 : gfc_expr *e;
3601 4685 : match m, n;
3602 4685 : bool fail;
3603 :
3604 4685 : m = MATCH_NO;
3605 4685 : e = NULL;
3606 4685 : where = gfc_current_locus;
3607 :
3608 4685 : n = gfc_match_init_expr (&e);
3609 :
3610 4685 : if (n != MATCH_YES && gfc_matching_function)
3611 : {
3612 : /* The expression might include use-associated or imported
3613 : parameters and try again after the specification
3614 : expressions. */
3615 7 : gfc_free_expr (e);
3616 7 : gfc_undo_symbols ();
3617 7 : return MATCH_YES;
3618 : }
3619 :
3620 7 : if (n == MATCH_NO)
3621 2 : gfc_error ("Expected initialization expression at %C");
3622 4678 : if (n != MATCH_YES)
3623 : return MATCH_ERROR;
3624 :
3625 4671 : if (e->rank != 0)
3626 : {
3627 0 : gfc_error ("Expected scalar initialization expression at %C");
3628 0 : m = MATCH_ERROR;
3629 0 : goto no_match;
3630 : }
3631 :
3632 4671 : if (gfc_derived_parameter_expr (e))
3633 : {
3634 14 : saved_kind_expr = e;
3635 14 : *kind = 0;
3636 14 : return MATCH_YES;
3637 : }
3638 :
3639 4657 : fail = gfc_extract_int (e, kind, 1);
3640 4657 : *is_iso_c = e->ts.is_iso_c;
3641 4657 : if (fail)
3642 : {
3643 0 : m = MATCH_ERROR;
3644 0 : goto no_match;
3645 : }
3646 :
3647 4657 : gfc_free_expr (e);
3648 :
3649 : /* Ignore errors to this point, if we've gotten here. This means
3650 : we ignore the m=MATCH_ERROR from above. */
3651 4657 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3652 : {
3653 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3654 14 : m = MATCH_ERROR;
3655 : }
3656 : else
3657 : /* All tests passed. */
3658 : m = MATCH_YES;
3659 :
3660 14 : if (m == MATCH_ERROR)
3661 14 : gfc_current_locus = where;
3662 :
3663 : /* Return what we know from the test(s). */
3664 : return m;
3665 :
3666 0 : no_match:
3667 0 : gfc_free_expr (e);
3668 0 : gfc_current_locus = where;
3669 0 : return m;
3670 : }
3671 :
3672 :
3673 : /* Match the various kind/length specifications in a CHARACTER
3674 : declaration. We don't return MATCH_NO. */
3675 :
3676 : match
3677 31578 : gfc_match_char_spec (gfc_typespec *ts)
3678 : {
3679 31578 : int kind, seen_length, is_iso_c;
3680 31578 : gfc_charlen *cl;
3681 31578 : gfc_expr *len;
3682 31578 : match m;
3683 31578 : bool deferred;
3684 :
3685 31578 : len = NULL;
3686 31578 : seen_length = 0;
3687 31578 : kind = 0;
3688 31578 : is_iso_c = 0;
3689 31578 : deferred = false;
3690 :
3691 : /* Try the old-style specification first. */
3692 31578 : old_char_selector = 0;
3693 :
3694 31578 : m = match_char_length (&len, &deferred, true);
3695 31578 : if (m != MATCH_NO)
3696 : {
3697 2205 : if (m == MATCH_YES)
3698 2205 : old_char_selector = 1;
3699 2205 : seen_length = 1;
3700 2205 : goto done;
3701 : }
3702 :
3703 29373 : m = gfc_match_char ('(');
3704 29373 : if (m != MATCH_YES)
3705 : {
3706 1884 : m = MATCH_YES; /* Character without length is a single char. */
3707 1884 : goto done;
3708 : }
3709 :
3710 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3711 27489 : if (gfc_match (" kind =") == MATCH_YES)
3712 : {
3713 3264 : m = match_char_kind (&kind, &is_iso_c);
3714 :
3715 3264 : if (m == MATCH_ERROR)
3716 16 : goto done;
3717 3248 : if (m == MATCH_NO)
3718 : goto syntax;
3719 :
3720 3248 : if (gfc_match (" , len =") == MATCH_NO)
3721 516 : goto rparen;
3722 :
3723 2732 : m = char_len_param_value (&len, &deferred);
3724 2732 : if (m == MATCH_NO)
3725 0 : goto syntax;
3726 2732 : if (m == MATCH_ERROR)
3727 2 : goto done;
3728 2730 : seen_length = 1;
3729 :
3730 2730 : goto rparen;
3731 : }
3732 :
3733 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3734 24225 : if (gfc_match (" len =") == MATCH_YES)
3735 : {
3736 13832 : m = char_len_param_value (&len, &deferred);
3737 13832 : if (m == MATCH_NO)
3738 2 : goto syntax;
3739 13830 : if (m == MATCH_ERROR)
3740 8 : goto done;
3741 13822 : seen_length = 1;
3742 :
3743 13822 : if (gfc_match_char (')') == MATCH_YES)
3744 12543 : goto done;
3745 :
3746 1279 : if (gfc_match (" , kind =") != MATCH_YES)
3747 0 : goto syntax;
3748 :
3749 1279 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3750 2 : goto done;
3751 :
3752 1277 : goto rparen;
3753 : }
3754 :
3755 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3756 10393 : m = char_len_param_value (&len, &deferred);
3757 10393 : if (m == MATCH_NO)
3758 0 : goto syntax;
3759 10393 : if (m == MATCH_ERROR)
3760 44 : goto done;
3761 10349 : seen_length = 1;
3762 :
3763 10349 : m = gfc_match_char (')');
3764 10349 : if (m == MATCH_YES)
3765 10205 : goto done;
3766 :
3767 144 : if (gfc_match_char (',') != MATCH_YES)
3768 2 : goto syntax;
3769 :
3770 142 : gfc_match (" kind ="); /* Gobble optional text. */
3771 :
3772 142 : m = match_char_kind (&kind, &is_iso_c);
3773 142 : if (m == MATCH_ERROR)
3774 3 : goto done;
3775 : if (m == MATCH_NO)
3776 : goto syntax;
3777 :
3778 4662 : rparen:
3779 : /* Require a right-paren at this point. */
3780 4662 : m = gfc_match_char (')');
3781 4662 : if (m == MATCH_YES)
3782 4662 : goto done;
3783 :
3784 0 : syntax:
3785 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3786 4 : m = MATCH_ERROR;
3787 4 : gfc_free_expr (len);
3788 4 : return m;
3789 :
3790 31574 : done:
3791 : /* Deal with character functions after USE and IMPORT statements. */
3792 31574 : if (gfc_matching_function)
3793 : {
3794 1418 : gfc_free_expr (len);
3795 1418 : gfc_undo_symbols ();
3796 1418 : return MATCH_YES;
3797 : }
3798 :
3799 30156 : if (m != MATCH_YES)
3800 : {
3801 65 : gfc_free_expr (len);
3802 65 : return m;
3803 : }
3804 :
3805 : /* Do some final massaging of the length values. */
3806 30091 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3807 :
3808 30091 : if (seen_length == 0)
3809 2348 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3810 : else
3811 : {
3812 : /* If gfortran ends up here, then len may be reducible to a constant.
3813 : Try to do that here. If it does not reduce, simply assign len to
3814 : charlen. A complication occurs with user-defined generic functions,
3815 : which are not resolved. Use a private namespace to deal with
3816 : generic functions. */
3817 :
3818 27743 : if (len && len->expr_type != EXPR_CONSTANT)
3819 : {
3820 3044 : gfc_namespace *old_ns;
3821 3044 : gfc_expr *e;
3822 :
3823 3044 : old_ns = gfc_current_ns;
3824 3044 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3825 :
3826 3044 : e = gfc_copy_expr (len);
3827 3044 : gfc_push_suppress_errors ();
3828 3044 : gfc_reduce_init_expr (e);
3829 3044 : gfc_pop_suppress_errors ();
3830 3044 : if (e->expr_type == EXPR_CONSTANT)
3831 : {
3832 294 : gfc_replace_expr (len, e);
3833 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3834 7 : mpz_set_ui (len->value.integer, 0);
3835 : }
3836 : else
3837 2750 : gfc_free_expr (e);
3838 :
3839 3044 : gfc_free_namespace (gfc_current_ns);
3840 3044 : gfc_current_ns = old_ns;
3841 : }
3842 :
3843 27743 : cl->length = len;
3844 : }
3845 :
3846 30091 : ts->u.cl = cl;
3847 30091 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3848 30091 : ts->deferred = deferred;
3849 :
3850 : /* We have to know if it was a C interoperable kind so we can
3851 : do accurate type checking of bind(c) procs, etc. */
3852 30091 : if (kind != 0)
3853 : /* Mark this as C interoperable if being declared with one
3854 : of the named constants from iso_c_binding. */
3855 4568 : ts->is_c_interop = is_iso_c;
3856 25523 : else if (len != NULL)
3857 : /* Here, we might have parsed something such as: character(c_char)
3858 : In this case, the parsing code above grabs the c_char when
3859 : looking for the length (line 1690, roughly). it's the last
3860 : testcase for parsing the kind params of a character variable.
3861 : However, it's not actually the length. this seems like it
3862 : could be an error.
3863 : To see if the user used a C interop kind, test the expr
3864 : of the so called length, and see if it's C interoperable. */
3865 16455 : ts->is_c_interop = len->ts.is_iso_c;
3866 :
3867 : return MATCH_YES;
3868 : }
3869 :
3870 :
3871 : /* Matches a RECORD declaration. */
3872 :
3873 : static match
3874 949437 : match_record_decl (char *name)
3875 : {
3876 949437 : locus old_loc;
3877 949437 : old_loc = gfc_current_locus;
3878 949437 : match m;
3879 :
3880 949437 : m = gfc_match (" record /");
3881 949437 : if (m == MATCH_YES)
3882 : {
3883 353 : if (!flag_dec_structure)
3884 : {
3885 6 : gfc_current_locus = old_loc;
3886 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3887 : "%<-fdec-structure%>");
3888 6 : return MATCH_ERROR;
3889 : }
3890 347 : m = gfc_match (" %n/", name);
3891 347 : if (m == MATCH_YES)
3892 : return MATCH_YES;
3893 : }
3894 :
3895 949087 : gfc_current_locus = old_loc;
3896 949087 : if (flag_dec_structure
3897 949087 : && (gfc_match (" record% ") == MATCH_YES
3898 8026 : || gfc_match (" record%t") == MATCH_YES))
3899 6 : gfc_error ("Structure name expected after RECORD at %C");
3900 949087 : if (m == MATCH_NO)
3901 : return MATCH_NO;
3902 :
3903 : return MATCH_ERROR;
3904 : }
3905 :
3906 :
3907 : /* In parsing a PDT, it is possible that one of the type parameters has the
3908 : same name as a previously declared symbol that is not a type parameter.
3909 : Intercept this now by looking for the symtree in f2k_derived. */
3910 :
3911 : static bool
3912 863 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3913 : {
3914 863 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3915 : return false;
3916 :
3917 698 : if (!(e->symtree->n.sym->attr.pdt_len
3918 115 : || e->symtree->n.sym->attr.pdt_kind))
3919 : {
3920 37 : gfc_symtree *st;
3921 37 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3922 : e->symtree->n.sym->name);
3923 37 : if (st && st->n.sym
3924 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3925 : {
3926 30 : gfc_expr *new_expr;
3927 30 : gfc_set_sym_referenced (st->n.sym);
3928 30 : new_expr = gfc_get_expr ();
3929 30 : new_expr->ts = st->n.sym->ts;
3930 30 : new_expr->expr_type = EXPR_VARIABLE;
3931 30 : new_expr->symtree = st;
3932 30 : new_expr->where = e->where;
3933 30 : gfc_replace_expr (e, new_expr);
3934 : }
3935 : }
3936 :
3937 : return false;
3938 : }
3939 :
3940 :
3941 : void
3942 640 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3943 : {
3944 640 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3945 : return;
3946 608 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3947 : }
3948 :
3949 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3950 : of expressions to substitute into the possibly parameterized expression
3951 : 'e'. Using a list is inefficient but should not be too bad since the
3952 : number of type parameters is not likely to be large. */
3953 : static bool
3954 3146 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3955 : int* f)
3956 : {
3957 3146 : gfc_actual_arglist *param;
3958 3146 : gfc_expr *copy;
3959 :
3960 3146 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
3961 : return false;
3962 :
3963 1392 : gcc_assert (e->symtree);
3964 1392 : if (e->symtree->n.sym->attr.pdt_kind
3965 1025 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
3966 506 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
3967 : {
3968 1378 : for (param = type_param_spec_list; param; param = param->next)
3969 1331 : if (!strcmp (e->symtree->n.sym->name, param->name))
3970 : break;
3971 :
3972 932 : if (param && param->expr)
3973 : {
3974 884 : copy = gfc_copy_expr (param->expr);
3975 884 : gfc_replace_expr (e, copy);
3976 : /* Catch variables declared without a value expression. */
3977 884 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
3978 21 : e->ts = e->symtree->n.sym->ts;
3979 : }
3980 : }
3981 :
3982 : return false;
3983 : }
3984 :
3985 :
3986 : static bool
3987 930 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3988 : {
3989 930 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3990 : }
3991 :
3992 :
3993 : bool
3994 1775 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3995 : {
3996 1775 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3997 1775 : type_param_spec_list = param_list;
3998 1775 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3999 1775 : type_param_spec_list = old_param_spec_list;
4000 1775 : return res;
4001 : }
4002 :
4003 : /* Determines the instance of a parameterized derived type to be used by
4004 : matching determining the values of the kind parameters and using them
4005 : in the name of the instance. If the instance exists, it is used, otherwise
4006 : a new derived type is created. */
4007 : match
4008 2643 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
4009 : gfc_actual_arglist **ext_param_list)
4010 : {
4011 : /* The PDT template symbol. */
4012 2643 : gfc_symbol *pdt = *sym;
4013 : /* The symbol for the parameter in the template f2k_namespace. */
4014 2643 : gfc_symbol *param;
4015 : /* The hoped for instance of the PDT. */
4016 2643 : gfc_symbol *instance = NULL;
4017 : /* The list of parameters appearing in the PDT declaration. */
4018 2643 : gfc_formal_arglist *type_param_name_list;
4019 : /* Used to store the parameter specification list during recursive calls. */
4020 2643 : gfc_actual_arglist *old_param_spec_list;
4021 : /* Pointers to the parameter specification being used. */
4022 2643 : gfc_actual_arglist *actual_param;
4023 2643 : gfc_actual_arglist *tail = NULL;
4024 : /* Used to build up the name of the PDT instance. */
4025 2643 : char *name;
4026 2643 : bool name_seen = (param_list == NULL);
4027 2643 : bool assumed_seen = false;
4028 2643 : bool deferred_seen = false;
4029 2643 : bool spec_error = false;
4030 2643 : bool alloc_seen = false;
4031 2643 : bool ptr_seen = false;
4032 2643 : int i;
4033 2643 : gfc_expr *kind_expr;
4034 2643 : gfc_component *c1, *c2;
4035 2643 : match m;
4036 2643 : gfc_symtree *s = NULL;
4037 :
4038 2643 : type_param_spec_list = NULL;
4039 :
4040 2643 : type_param_name_list = pdt->formal;
4041 2643 : actual_param = param_list;
4042 :
4043 : /* Prevent a PDT component of the same type as the template from being
4044 : converted into an instance. Doing this results in the component being
4045 : lost. */
4046 2643 : if (gfc_current_state () == COMP_DERIVED
4047 101 : && !(gfc_state_stack->previous
4048 101 : && gfc_state_stack->previous->state == COMP_DERIVED)
4049 101 : && gfc_current_block ()->attr.pdt_template)
4050 : {
4051 100 : if (ext_param_list)
4052 100 : *ext_param_list = gfc_copy_actual_arglist (param_list);
4053 100 : return MATCH_YES;
4054 : }
4055 :
4056 2543 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
4057 :
4058 : /* Run through the parameter name list and pick up the actual
4059 : parameter values or use the default values in the PDT declaration. */
4060 5959 : for (; type_param_name_list;
4061 3416 : type_param_name_list = type_param_name_list->next)
4062 : {
4063 3484 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4064 : {
4065 3094 : if (actual_param->spec_type == SPEC_ASSUMED)
4066 : spec_error = deferred_seen;
4067 : else
4068 3094 : spec_error = assumed_seen;
4069 :
4070 3094 : if (spec_error)
4071 : {
4072 : gfc_error ("The type parameter spec list at %C cannot contain "
4073 : "both ASSUMED and DEFERRED parameters");
4074 : goto error_return;
4075 : }
4076 : }
4077 :
4078 3094 : if (actual_param && actual_param->name)
4079 3484 : name_seen = true;
4080 3484 : param = type_param_name_list->sym;
4081 :
4082 3484 : if (!param || !param->name)
4083 2 : continue;
4084 :
4085 3482 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4086 : /* An error should already have been thrown in resolve.cc
4087 : (resolve_fl_derived0). */
4088 3482 : if (!pdt->attr.use_assoc && !c1)
4089 8 : goto error_return;
4090 :
4091 : /* Resolution PDT class components of derived types are handled here.
4092 : They can arrive without a parameter list and no KIND parameters. */
4093 3474 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4094 14 : continue;
4095 :
4096 3460 : kind_expr = NULL;
4097 3460 : if (!name_seen)
4098 : {
4099 2022 : if (!actual_param && !(c1 && c1->initializer))
4100 : {
4101 2 : gfc_error ("The type parameter spec list at %C does not contain "
4102 : "enough parameter expressions");
4103 2 : goto error_return;
4104 : }
4105 2020 : else if (!actual_param && c1 && c1->initializer)
4106 5 : kind_expr = gfc_copy_expr (c1->initializer);
4107 2015 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4108 1814 : kind_expr = gfc_copy_expr (actual_param->expr);
4109 : }
4110 : else
4111 : {
4112 : actual_param = param_list;
4113 1898 : for (;actual_param; actual_param = actual_param->next)
4114 1514 : if (actual_param->name
4115 1494 : && strcmp (actual_param->name, param->name) == 0)
4116 : break;
4117 1438 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4118 893 : kind_expr = gfc_copy_expr (actual_param->expr);
4119 : else
4120 : {
4121 545 : if (c1->initializer)
4122 481 : kind_expr = gfc_copy_expr (c1->initializer);
4123 64 : else if (!(actual_param && param->attr.pdt_len))
4124 : {
4125 9 : gfc_error ("The derived parameter %qs at %C does not "
4126 : "have a default value", param->name);
4127 9 : goto error_return;
4128 : }
4129 : }
4130 : }
4131 :
4132 3193 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4133 252 : && kind_expr->ts.type != BT_INTEGER
4134 118 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4135 : {
4136 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4137 : "type and not %s", &kind_expr->where,
4138 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4139 12 : goto error_return;
4140 : }
4141 :
4142 : /* Store the current parameter expressions in a temporary actual
4143 : arglist 'list' so that they can be substituted in the corresponding
4144 : expressions in the PDT instance. */
4145 3437 : if (type_param_spec_list == NULL)
4146 : {
4147 2506 : type_param_spec_list = gfc_get_actual_arglist ();
4148 2506 : tail = type_param_spec_list;
4149 : }
4150 : else
4151 : {
4152 931 : tail->next = gfc_get_actual_arglist ();
4153 931 : tail = tail->next;
4154 : }
4155 3437 : tail->name = param->name;
4156 :
4157 3437 : if (kind_expr)
4158 : {
4159 : /* Try simplification even for LEN expressions. */
4160 3181 : bool ok;
4161 3181 : gfc_resolve_expr (kind_expr);
4162 :
4163 3181 : if (c1->attr.pdt_kind
4164 1624 : && kind_expr->expr_type != EXPR_CONSTANT
4165 28 : && type_param_spec_list)
4166 28 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4167 :
4168 3181 : ok = gfc_simplify_expr (kind_expr, 1);
4169 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4170 : initializer so allow for this. */
4171 3181 : if (kind_expr->ts.type != BT_INTEGER
4172 135 : && kind_expr->ts.type != BT_PROCEDURE)
4173 : {
4174 29 : gfc_error ("The parameter expression at %C must be of "
4175 : "INTEGER type and not %s type",
4176 : gfc_basic_typename (kind_expr->ts.type));
4177 29 : goto error_return;
4178 : }
4179 3152 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4180 : {
4181 4 : gfc_error ("The parameter expression at %C does not "
4182 : "simplify to an INTEGER constant");
4183 4 : goto error_return;
4184 : }
4185 :
4186 3148 : tail->expr = gfc_copy_expr (kind_expr);
4187 : }
4188 :
4189 3404 : if (actual_param)
4190 3022 : tail->spec_type = actual_param->spec_type;
4191 :
4192 3404 : if (!param->attr.pdt_kind)
4193 : {
4194 1805 : if (!name_seen && actual_param)
4195 1084 : actual_param = actual_param->next;
4196 1805 : if (kind_expr)
4197 : {
4198 1551 : gfc_free_expr (kind_expr);
4199 1551 : kind_expr = NULL;
4200 : }
4201 1805 : continue;
4202 : }
4203 :
4204 1599 : if (actual_param
4205 1261 : && (actual_param->spec_type == SPEC_ASSUMED
4206 1261 : || actual_param->spec_type == SPEC_DEFERRED))
4207 : {
4208 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4209 : "ASSUMED or DEFERRED", param->name);
4210 2 : goto error_return;
4211 : }
4212 :
4213 1597 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4214 : {
4215 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4216 : "reduce to a constant expression", param->name);
4217 2 : goto error_return;
4218 : }
4219 :
4220 : /* This can come about during the parsing of nested pdt_templates. An
4221 : error arises because the KIND parameter expression has not been
4222 : provided. Use the template instead of an incorrect instance. */
4223 1595 : if (kind_expr->expr_type != EXPR_CONSTANT
4224 1595 : || kind_expr->ts.type != BT_INTEGER)
4225 : {
4226 0 : gfc_free_actual_arglist (type_param_spec_list);
4227 0 : free (name);
4228 0 : return MATCH_YES;
4229 : }
4230 :
4231 1595 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4232 1595 : char *old_name = name;
4233 1595 : name = xasprintf ("%s_%s", old_name, kind_value);
4234 1595 : free (old_name);
4235 1595 : free (kind_value);
4236 :
4237 1595 : if (!name_seen && actual_param)
4238 882 : actual_param = actual_param->next;
4239 1595 : gfc_free_expr (kind_expr);
4240 : }
4241 :
4242 2475 : if (!name_seen && actual_param)
4243 : {
4244 2 : gfc_error ("The type parameter spec list at %C contains too many "
4245 : "parameter expressions");
4246 2 : goto error_return;
4247 : }
4248 :
4249 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4250 : build it, using 'pdt' as a template. */
4251 2473 : if (gfc_get_symbol (name, pdt->ns, &instance))
4252 : {
4253 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4254 0 : goto error_return;
4255 : }
4256 :
4257 : /* If we are in an interface body, the instance will not have been imported.
4258 : Make sure that it is imported implicitly. */
4259 2473 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4260 2473 : if (gfc_current_ns->proc_name
4261 2426 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4262 93 : && s && s->import_only && pdt->attr.imported)
4263 : {
4264 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4265 2 : if (!s)
4266 : {
4267 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4268 : &gfc_current_locus);
4269 1 : s->n.sym = instance;
4270 : }
4271 2 : s->n.sym->attr.imported = 1;
4272 2 : s->import_only = 1;
4273 : }
4274 :
4275 2473 : m = MATCH_YES;
4276 :
4277 2473 : if (instance->attr.flavor == FL_DERIVED
4278 1965 : && instance->attr.pdt_type
4279 1965 : && instance->components)
4280 : {
4281 1965 : instance->refs++;
4282 1965 : if (ext_param_list)
4283 924 : *ext_param_list = type_param_spec_list;
4284 1965 : *sym = instance;
4285 1965 : gfc_commit_symbols ();
4286 1965 : free (name);
4287 1965 : return m;
4288 : }
4289 :
4290 : /* Start building the new instance of the parameterized type. */
4291 508 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4292 508 : if (pdt->attr.use_assoc)
4293 41 : instance->module = pdt->module;
4294 508 : instance->attr.pdt_template = 0;
4295 508 : instance->attr.pdt_type = 1;
4296 508 : instance->declared_at = gfc_current_locus;
4297 :
4298 : /* In resolution, the finalizers are copied, according to the type of the
4299 : argument, to the instance finalizers. However, they are retained by the
4300 : template and procedures are freed there. */
4301 508 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4302 : {
4303 12 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4304 12 : instance->template_sym = pdt;
4305 12 : *instance->f2k_derived = *pdt->f2k_derived;
4306 : }
4307 :
4308 : /* Add the components, replacing the parameters in all expressions
4309 : with the expressions for their values in 'type_param_spec_list'. */
4310 508 : c1 = pdt->components;
4311 508 : tail = type_param_spec_list;
4312 1889 : for (; c1; c1 = c1->next)
4313 : {
4314 1383 : gfc_add_component (instance, c1->name, &c2);
4315 :
4316 1383 : c2->ts = c1->ts;
4317 1383 : c2->attr = c1->attr;
4318 1383 : if (c1->tb)
4319 : {
4320 6 : c2->tb = gfc_get_tbp ();
4321 6 : *c2->tb = *c1->tb;
4322 : }
4323 :
4324 : /* The order of declaration of the type_specs might not be the
4325 : same as that of the components. */
4326 1383 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4327 : {
4328 983 : for (tail = type_param_spec_list; tail; tail = tail->next)
4329 973 : if (strcmp (c1->name, tail->name) == 0)
4330 : break;
4331 : }
4332 :
4333 : /* Deal with type extension by recursively calling this function
4334 : to obtain the instance of the extended type. */
4335 1383 : if (gfc_current_state () != COMP_DERIVED
4336 1381 : && c1 == pdt->components
4337 507 : && c1->ts.type == BT_DERIVED
4338 42 : && c1->ts.u.derived
4339 1425 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4340 : {
4341 42 : if (c1->ts.u.derived->attr.pdt_template)
4342 : {
4343 35 : gfc_formal_arglist *f;
4344 :
4345 35 : old_param_spec_list = type_param_spec_list;
4346 :
4347 : /* Obtain a spec list appropriate to the extended type..*/
4348 35 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4349 35 : type_param_spec_list = actual_param;
4350 67 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4351 32 : actual_param = actual_param->next;
4352 35 : if (actual_param)
4353 : {
4354 35 : gfc_free_actual_arglist (actual_param->next);
4355 35 : actual_param->next = NULL;
4356 : }
4357 :
4358 : /* Now obtain the PDT instance for the extended type. */
4359 35 : c2->param_list = type_param_spec_list;
4360 35 : m = gfc_get_pdt_instance (type_param_spec_list,
4361 : &c2->ts.u.derived,
4362 : &c2->param_list);
4363 35 : type_param_spec_list = old_param_spec_list;
4364 : }
4365 : else
4366 7 : c2->ts = c1->ts;
4367 :
4368 42 : c2->ts.u.derived->refs++;
4369 42 : gfc_set_sym_referenced (c2->ts.u.derived);
4370 :
4371 : /* If the component is allocatable or the parent has allocatable
4372 : components, make sure that the new instance also is marked as
4373 : having allocatable components. */
4374 42 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4375 6 : instance->attr.alloc_comp = 1;
4376 :
4377 : /* Set extension level. */
4378 42 : if (c2->ts.u.derived->attr.extension == 255)
4379 : {
4380 : /* Since the extension field is 8 bit wide, we can only have
4381 : up to 255 extension levels. */
4382 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4383 : c2->ts.u.derived->name,
4384 : &c2->ts.u.derived->declared_at);
4385 0 : goto error_return;
4386 : }
4387 42 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4388 :
4389 42 : continue;
4390 42 : }
4391 :
4392 : /* Addressing PR82943, this will fix the issue where a function or
4393 : subroutine is declared as not a member of the PDT instance.
4394 : The reason for this is because the PDT instance did not have access
4395 : to its template's f2k_derived namespace in order to find the
4396 : typebound procedures.
4397 :
4398 : The number of references to the PDT template's f2k_derived will
4399 : ensure that f2k_derived is properly freed later on. */
4400 :
4401 1341 : if (!instance->f2k_derived && pdt->f2k_derived)
4402 : {
4403 489 : instance->f2k_derived = pdt->f2k_derived;
4404 489 : instance->f2k_derived->refs++;
4405 : }
4406 :
4407 : /* Set the component kind using the parameterized expression. */
4408 1341 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4409 464 : && c1->kind_expr != NULL)
4410 : {
4411 272 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4412 272 : gfc_insert_kind_parameter_exprs (e);
4413 272 : gfc_simplify_expr (e, 1);
4414 272 : gfc_extract_int (e, &c2->ts.kind);
4415 272 : gfc_free_expr (e);
4416 272 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4417 : {
4418 2 : gfc_error ("Kind %d not supported for type %s at %C",
4419 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4420 2 : goto error_return;
4421 : }
4422 270 : if (c2->attr.proc_pointer && c2->attr.function
4423 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4424 : {
4425 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4426 0 : c2->ts.interface->result = c2->ts.interface;
4427 0 : c2->ts.interface->ts = c2->ts;
4428 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4429 0 : c2->ts.interface->attr.function = 1;
4430 0 : c2->attr.function = 1;
4431 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4432 : }
4433 : }
4434 :
4435 : /* Set up either the KIND/LEN initializer, if constant,
4436 : or the parameterized expression. Use the template
4437 : initializer if one is not already set in this instance. */
4438 1339 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4439 : {
4440 692 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4441 576 : c2->initializer = gfc_copy_expr (tail->expr);
4442 116 : else if (tail && tail->expr)
4443 : {
4444 10 : c2->param_list = gfc_get_actual_arglist ();
4445 10 : c2->param_list->name = tail->name;
4446 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4447 10 : c2->param_list->next = NULL;
4448 : }
4449 :
4450 692 : if (!c2->initializer && c1->initializer)
4451 24 : c2->initializer = gfc_copy_expr (c1->initializer);
4452 :
4453 692 : if (c2->initializer)
4454 600 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4455 : }
4456 :
4457 : /* Copy the array spec. */
4458 1339 : c2->as = gfc_copy_array_spec (c1->as);
4459 1339 : if (c1->ts.type == BT_CLASS)
4460 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4461 :
4462 1339 : if (c1->attr.allocatable)
4463 64 : alloc_seen = true;
4464 :
4465 1339 : if (c1->attr.pointer)
4466 20 : ptr_seen = true;
4467 :
4468 : /* Determine if an array spec is parameterized. If so, substitute
4469 : in the parameter expressions for the bounds and set the pdt_array
4470 : attribute. Notice that this attribute must be unconditionally set
4471 : if this is an array of parameterized character length. */
4472 1339 : if (c1->as && c1->as->type == AS_EXPLICIT)
4473 : {
4474 : bool pdt_array = false;
4475 :
4476 : /* Are the bounds of the array parameterized? */
4477 499 : for (i = 0; i < c1->as->rank; i++)
4478 : {
4479 297 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4480 6 : pdt_array = true;
4481 297 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4482 283 : pdt_array = true;
4483 : }
4484 :
4485 : /* If they are, free the expressions for the bounds and
4486 : replace them with the template expressions with substitute
4487 : values. */
4488 485 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4489 : {
4490 283 : gfc_expr *e;
4491 283 : e = gfc_copy_expr (c1->as->lower[i]);
4492 283 : gfc_insert_kind_parameter_exprs (e);
4493 283 : if (gfc_simplify_expr (e, 1))
4494 283 : gfc_replace_expr (c2->as->lower[i], e);
4495 : else
4496 0 : gfc_free_expr (e);
4497 283 : e = gfc_copy_expr (c1->as->upper[i]);
4498 283 : gfc_insert_kind_parameter_exprs (e);
4499 283 : if (gfc_simplify_expr (e, 1))
4500 283 : gfc_replace_expr (c2->as->upper[i], e);
4501 : else
4502 0 : gfc_free_expr (e);
4503 : }
4504 :
4505 202 : c2->attr.pdt_array = 1;
4506 202 : if (c1->initializer)
4507 : {
4508 7 : c2->initializer = gfc_copy_expr (c1->initializer);
4509 7 : gfc_insert_kind_parameter_exprs (c2->initializer);
4510 7 : gfc_simplify_expr (c2->initializer, 1);
4511 : }
4512 : }
4513 :
4514 : /* Similarly, set the string length if parameterized. */
4515 1339 : if (c1->ts.type == BT_CHARACTER
4516 86 : && c1->ts.u.cl->length
4517 1424 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4518 : {
4519 85 : gfc_expr *e;
4520 85 : e = gfc_copy_expr (c1->ts.u.cl->length);
4521 85 : gfc_insert_kind_parameter_exprs (e);
4522 85 : if (gfc_simplify_expr (e, 1))
4523 85 : gfc_replace_expr (c2->ts.u.cl->length, e);
4524 : else
4525 0 : gfc_free_expr (e);
4526 85 : c2->attr.pdt_string = 1;
4527 : }
4528 :
4529 : /* Recurse into this function for PDT components. */
4530 1339 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4531 131 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4532 : {
4533 123 : gfc_actual_arglist *params;
4534 : /* The component in the template has a list of specification
4535 : expressions derived from its declaration. */
4536 123 : params = gfc_copy_actual_arglist (c1->param_list);
4537 123 : actual_param = params;
4538 : /* Substitute the template parameters with the expressions
4539 : from the specification list. */
4540 384 : for (;actual_param; actual_param = actual_param->next)
4541 : {
4542 138 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4543 138 : gfc_insert_parameter_exprs (actual_param->expr,
4544 : type_param_spec_list);
4545 : }
4546 :
4547 : /* Now obtain the PDT instance for the component. */
4548 123 : old_param_spec_list = type_param_spec_list;
4549 246 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4550 123 : &c2->param_list);
4551 123 : type_param_spec_list = old_param_spec_list;
4552 :
4553 123 : if (!(c2->attr.pointer || c2->attr.allocatable))
4554 : {
4555 83 : if (!c1->initializer
4556 58 : || c1->initializer->expr_type != EXPR_FUNCTION)
4557 82 : c2->initializer = gfc_default_initializer (&c2->ts);
4558 : else
4559 : {
4560 1 : gfc_symtree *s;
4561 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4562 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4563 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4564 1 : if (s)
4565 0 : c2->initializer->symtree = s;
4566 1 : c2->initializer->ts = c2->ts;
4567 1 : if (!s)
4568 1 : gfc_insert_parameter_exprs (c2->initializer,
4569 : type_param_spec_list);
4570 1 : gfc_simplify_expr (c2->initializer, 1);
4571 : }
4572 : }
4573 :
4574 123 : if (c2->attr.allocatable)
4575 32 : instance->attr.alloc_comp = 1;
4576 : }
4577 1216 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4578 439 : || c2->attr.pdt_array) && c1->initializer)
4579 : {
4580 30 : c2->initializer = gfc_copy_expr (c1->initializer);
4581 30 : if (c2->initializer->ts.type == BT_UNKNOWN)
4582 12 : c2->initializer->ts = c2->ts;
4583 30 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4584 : /* The template initializers are parsed using gfc_match_expr rather
4585 : than gfc_match_init_expr. Apply the missing reduction to the
4586 : PDT instance initializers. */
4587 30 : if (!gfc_reduce_init_expr (c2->initializer))
4588 : {
4589 0 : gfc_free_expr (c2->initializer);
4590 0 : goto error_return;
4591 : }
4592 30 : gfc_simplify_expr (c2->initializer, 1);
4593 : }
4594 : }
4595 :
4596 506 : if (alloc_seen)
4597 61 : instance->attr.alloc_comp = 1;
4598 506 : if (ptr_seen)
4599 20 : instance->attr.pointer_comp = 1;
4600 :
4601 :
4602 506 : gfc_commit_symbol (instance);
4603 506 : if (ext_param_list)
4604 329 : *ext_param_list = type_param_spec_list;
4605 506 : *sym = instance;
4606 506 : free (name);
4607 506 : return m;
4608 :
4609 72 : error_return:
4610 72 : gfc_free_actual_arglist (type_param_spec_list);
4611 72 : free (name);
4612 72 : return MATCH_ERROR;
4613 : }
4614 :
4615 :
4616 : /* Match a legacy nonstandard BYTE type-spec. */
4617 :
4618 : static match
4619 1166538 : match_byte_typespec (gfc_typespec *ts)
4620 : {
4621 1166538 : if (gfc_match (" byte") == MATCH_YES)
4622 : {
4623 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4624 : return MATCH_ERROR;
4625 :
4626 31 : if (gfc_current_form == FORM_FREE)
4627 : {
4628 19 : char c = gfc_peek_ascii_char ();
4629 19 : if (!gfc_is_whitespace (c) && c != ',')
4630 : return MATCH_NO;
4631 : }
4632 :
4633 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4634 : {
4635 0 : gfc_error ("BYTE type used at %C "
4636 : "is not available on the target machine");
4637 0 : return MATCH_ERROR;
4638 : }
4639 :
4640 29 : ts->type = BT_INTEGER;
4641 29 : ts->kind = 1;
4642 29 : return MATCH_YES;
4643 : }
4644 : return MATCH_NO;
4645 : }
4646 :
4647 :
4648 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4649 : structure to the matched specification. This is necessary for FUNCTION and
4650 : IMPLICIT statements.
4651 :
4652 : If implicit_flag is nonzero, then we don't check for the optional
4653 : kind specification. Not doing so is needed for matching an IMPLICIT
4654 : statement correctly. */
4655 :
4656 : match
4657 1166538 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4658 : {
4659 : /* Provide sufficient space to hold "pdtsymbol". */
4660 1166538 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4661 1166538 : gfc_symbol *sym, *dt_sym;
4662 1166538 : match m;
4663 1166538 : char c;
4664 1166538 : bool seen_deferred_kind, matched_type;
4665 1166538 : const char *dt_name;
4666 :
4667 1166538 : decl_type_param_list = NULL;
4668 :
4669 : /* A belt and braces check that the typespec is correctly being treated
4670 : as a deferred characteristic association. */
4671 2333076 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4672 80792 : && (gfc_current_block ()->result->ts.kind == -1)
4673 1178213 : && (ts->kind == -1);
4674 1166538 : gfc_clear_ts (ts);
4675 1166538 : if (seen_deferred_kind)
4676 9470 : ts->kind = -1;
4677 :
4678 : /* Clear the current binding label, in case one is given. */
4679 1166538 : curr_binding_label = NULL;
4680 :
4681 : /* Match BYTE type-spec. */
4682 1166538 : m = match_byte_typespec (ts);
4683 1166538 : if (m != MATCH_NO)
4684 : return m;
4685 :
4686 1166507 : m = gfc_match (" type (");
4687 1166507 : matched_type = (m == MATCH_YES);
4688 1166507 : if (matched_type)
4689 : {
4690 31054 : gfc_gobble_whitespace ();
4691 31054 : if (gfc_peek_ascii_char () == '*')
4692 : {
4693 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4694 : return m;
4695 5617 : if (gfc_comp_struct (gfc_current_state ()))
4696 : {
4697 2 : gfc_error ("Assumed type at %C is not allowed for components");
4698 2 : return MATCH_ERROR;
4699 : }
4700 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4701 : return MATCH_ERROR;
4702 5613 : ts->type = BT_ASSUMED;
4703 5613 : return MATCH_YES;
4704 : }
4705 :
4706 25437 : m = gfc_match ("%n", name);
4707 25437 : matched_type = (m == MATCH_YES);
4708 : }
4709 :
4710 25437 : if ((matched_type && strcmp ("integer", name) == 0)
4711 1160890 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4712 : {
4713 108540 : ts->type = BT_INTEGER;
4714 108540 : ts->kind = gfc_default_integer_kind;
4715 108540 : goto get_kind;
4716 : }
4717 :
4718 1052350 : if (flag_unsigned)
4719 : {
4720 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4721 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4722 : {
4723 1036 : ts->type = BT_UNSIGNED;
4724 1036 : ts->kind = gfc_default_integer_kind;
4725 1036 : goto get_kind;
4726 : }
4727 : }
4728 :
4729 25431 : if ((matched_type && strcmp ("character", name) == 0)
4730 1051314 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4731 : {
4732 28647 : if (matched_type
4733 28647 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4734 : "intrinsic-type-spec at %C"))
4735 : return MATCH_ERROR;
4736 :
4737 28646 : ts->type = BT_CHARACTER;
4738 28646 : if (implicit_flag == 0)
4739 28540 : m = gfc_match_char_spec (ts);
4740 : else
4741 : m = MATCH_YES;
4742 :
4743 28646 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4744 : {
4745 1 : gfc_error ("Malformed type-spec at %C");
4746 1 : return MATCH_ERROR;
4747 : }
4748 :
4749 28645 : return m;
4750 : }
4751 :
4752 25427 : if ((matched_type && strcmp ("real", name) == 0)
4753 1022667 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4754 : {
4755 29653 : ts->type = BT_REAL;
4756 29653 : ts->kind = gfc_default_real_kind;
4757 29653 : goto get_kind;
4758 : }
4759 :
4760 993014 : if ((matched_type
4761 25424 : && (strcmp ("doubleprecision", name) == 0
4762 25423 : || (strcmp ("double", name) == 0
4763 5 : && gfc_match (" precision") == MATCH_YES)))
4764 993014 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4765 : {
4766 2551 : if (matched_type
4767 2551 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4768 : "intrinsic-type-spec at %C"))
4769 : return MATCH_ERROR;
4770 :
4771 2550 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4772 : {
4773 2 : gfc_error ("Malformed type-spec at %C");
4774 2 : return MATCH_ERROR;
4775 : }
4776 :
4777 2548 : ts->type = BT_REAL;
4778 2548 : ts->kind = gfc_default_double_kind;
4779 2548 : return MATCH_YES;
4780 : }
4781 :
4782 25420 : if ((matched_type && strcmp ("complex", name) == 0)
4783 990463 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4784 : {
4785 4023 : ts->type = BT_COMPLEX;
4786 4023 : ts->kind = gfc_default_complex_kind;
4787 4023 : goto get_kind;
4788 : }
4789 :
4790 986440 : if ((matched_type
4791 25420 : && (strcmp ("doublecomplex", name) == 0
4792 25419 : || (strcmp ("double", name) == 0
4793 2 : && gfc_match (" complex") == MATCH_YES)))
4794 986440 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4795 : {
4796 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4797 : return MATCH_ERROR;
4798 :
4799 203 : if (matched_type
4800 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4801 : "intrinsic-type-spec at %C"))
4802 : return MATCH_ERROR;
4803 :
4804 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4805 : {
4806 2 : gfc_error ("Malformed type-spec at %C");
4807 2 : return MATCH_ERROR;
4808 : }
4809 :
4810 201 : ts->type = BT_COMPLEX;
4811 201 : ts->kind = gfc_default_double_kind;
4812 201 : return MATCH_YES;
4813 : }
4814 :
4815 25417 : if ((matched_type && strcmp ("logical", name) == 0)
4816 986236 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4817 : {
4818 11385 : ts->type = BT_LOGICAL;
4819 11385 : ts->kind = gfc_default_logical_kind;
4820 11385 : goto get_kind;
4821 : }
4822 :
4823 974851 : if (matched_type)
4824 : {
4825 25414 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4826 25414 : if (m == MATCH_ERROR)
4827 : return m;
4828 :
4829 25414 : gfc_gobble_whitespace ();
4830 25414 : if (gfc_peek_ascii_char () != ')')
4831 : {
4832 1 : gfc_error ("Malformed type-spec at %C");
4833 1 : return MATCH_ERROR;
4834 : }
4835 25413 : m = gfc_match_char (')'); /* Burn closing ')'. */
4836 : }
4837 :
4838 974850 : if (m != MATCH_YES)
4839 949437 : m = match_record_decl (name);
4840 :
4841 974850 : if (matched_type || m == MATCH_YES)
4842 : {
4843 25757 : ts->type = BT_DERIVED;
4844 : /* We accept record/s/ or type(s) where s is a structure, but we
4845 : * don't need all the extra derived-type stuff for structures. */
4846 25757 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4847 : {
4848 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4849 1 : return MATCH_ERROR;
4850 : }
4851 :
4852 25756 : if (sym && sym->attr.flavor == FL_DERIVED
4853 24998 : && sym->attr.pdt_template
4854 987 : && gfc_current_state () != COMP_DERIVED)
4855 : {
4856 872 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4857 872 : if (m != MATCH_YES)
4858 : return m;
4859 857 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4860 857 : ts->u.derived = sym;
4861 857 : const char* lower = gfc_dt_lower_string (sym->name);
4862 857 : size_t len = strlen (lower);
4863 : /* Reallocate with sufficient size. */
4864 857 : if (len > GFC_MAX_SYMBOL_LEN)
4865 2 : name = XALLOCAVEC (char, len + 1);
4866 857 : memcpy (name, lower, len);
4867 857 : name[len] = '\0';
4868 : }
4869 :
4870 25741 : if (sym && sym->attr.flavor == FL_STRUCT)
4871 : {
4872 361 : ts->u.derived = sym;
4873 361 : return MATCH_YES;
4874 : }
4875 : /* Actually a derived type. */
4876 : }
4877 :
4878 : else
4879 : {
4880 : /* Match nested STRUCTURE declarations; only valid within another
4881 : structure declaration. */
4882 949093 : if (flag_dec_structure
4883 8032 : && (gfc_current_state () == COMP_STRUCTURE
4884 7570 : || gfc_current_state () == COMP_MAP))
4885 : {
4886 732 : m = gfc_match (" structure");
4887 732 : if (m == MATCH_YES)
4888 : {
4889 27 : m = gfc_match_structure_decl ();
4890 27 : if (m == MATCH_YES)
4891 : {
4892 : /* gfc_new_block is updated by match_structure_decl. */
4893 26 : ts->type = BT_DERIVED;
4894 26 : ts->u.derived = gfc_new_block;
4895 26 : return MATCH_YES;
4896 : }
4897 : }
4898 706 : if (m == MATCH_ERROR)
4899 : return MATCH_ERROR;
4900 : }
4901 :
4902 : /* Match CLASS declarations. */
4903 949066 : m = gfc_match (" class ( * )");
4904 949066 : if (m == MATCH_ERROR)
4905 : return MATCH_ERROR;
4906 949066 : else if (m == MATCH_YES)
4907 : {
4908 1906 : gfc_symbol *upe;
4909 1906 : gfc_symtree *st;
4910 1906 : ts->type = BT_CLASS;
4911 1906 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4912 1906 : if (upe == NULL)
4913 : {
4914 1167 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4915 1167 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4916 1167 : st->n.sym = upe;
4917 1167 : gfc_set_sym_referenced (upe);
4918 1167 : upe->refs++;
4919 1167 : upe->ts.type = BT_VOID;
4920 1167 : upe->attr.unlimited_polymorphic = 1;
4921 : /* This is essential to force the construction of
4922 : unlimited polymorphic component class containers. */
4923 1167 : upe->attr.zero_comp = 1;
4924 1167 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4925 : &gfc_current_locus))
4926 : return MATCH_ERROR;
4927 : }
4928 : else
4929 : {
4930 739 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4931 739 : st->n.sym = upe;
4932 739 : upe->refs++;
4933 : }
4934 1906 : ts->u.derived = upe;
4935 1906 : return m;
4936 : }
4937 :
4938 947160 : m = gfc_match (" class (");
4939 :
4940 947160 : if (m == MATCH_YES)
4941 8897 : m = gfc_match ("%n", name);
4942 : else
4943 : return m;
4944 :
4945 8897 : if (m != MATCH_YES)
4946 : return m;
4947 8897 : ts->type = BT_CLASS;
4948 :
4949 8897 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4950 : return MATCH_ERROR;
4951 :
4952 8896 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4953 8896 : if (m == MATCH_ERROR)
4954 : return m;
4955 :
4956 8896 : m = gfc_match_char (')');
4957 8896 : if (m != MATCH_YES)
4958 : return m;
4959 : }
4960 :
4961 : /* This picks up function declarations with a PDT typespec. Since a
4962 : pdt_type has been generated, there is no more to do. Within the
4963 : function body, this type must be used for the typespec so that
4964 : the "being used before it is defined warning" does not arise. */
4965 34276 : if (ts->type == BT_DERIVED
4966 25380 : && sym && sym->attr.pdt_type
4967 35133 : && (gfc_current_state () == COMP_CONTAINS
4968 841 : || (gfc_current_state () == COMP_FUNCTION
4969 268 : && gfc_current_block ()->ts.type == BT_DERIVED
4970 60 : && gfc_current_block ()->ts.u.derived == sym
4971 30 : && !gfc_find_symtree (gfc_current_ns->sym_root,
4972 : sym->name))))
4973 : {
4974 42 : if (gfc_current_state () == COMP_FUNCTION)
4975 : {
4976 26 : gfc_symtree *pdt_st;
4977 26 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
4978 : sym->name);
4979 26 : pdt_st->n.sym = sym;
4980 26 : sym->refs++;
4981 : }
4982 42 : ts->u.derived = sym;
4983 42 : return MATCH_YES;
4984 : }
4985 :
4986 : /* Defer association of the derived type until the end of the
4987 : specification block. However, if the derived type can be
4988 : found, add it to the typespec. */
4989 34234 : if (gfc_matching_function)
4990 : {
4991 1035 : ts->u.derived = NULL;
4992 1035 : if (gfc_current_state () != COMP_INTERFACE
4993 1035 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4994 : {
4995 512 : sym = gfc_find_dt_in_generic (sym);
4996 512 : ts->u.derived = sym;
4997 : }
4998 1035 : return MATCH_YES;
4999 : }
5000 :
5001 : /* Search for the name but allow the components to be defined later. If
5002 : type = -1, this typespec has been seen in a function declaration but
5003 : the type could not be accessed at that point. The actual derived type is
5004 : stored in a symtree with the first letter of the name capitalized; the
5005 : symtree with the all lower-case name contains the associated
5006 : generic function. */
5007 33199 : dt_name = gfc_dt_upper_string (name);
5008 33199 : sym = NULL;
5009 33199 : dt_sym = NULL;
5010 33199 : if (ts->kind != -1)
5011 : {
5012 31995 : gfc_get_ha_symbol (name, &sym);
5013 31995 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
5014 : {
5015 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5016 0 : return MATCH_ERROR;
5017 : }
5018 31995 : if (sym->generic && !dt_sym)
5019 13159 : dt_sym = gfc_find_dt_in_generic (sym);
5020 :
5021 : /* Host associated PDTs can get confused with their constructors
5022 : because they are instantiated in the template's namespace. */
5023 31995 : if (!dt_sym)
5024 : {
5025 919 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5026 : {
5027 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5028 0 : return MATCH_ERROR;
5029 : }
5030 919 : if (dt_sym && !dt_sym->attr.pdt_type)
5031 0 : dt_sym = NULL;
5032 : }
5033 : }
5034 1204 : else if (ts->kind == -1)
5035 : {
5036 2408 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
5037 1204 : || gfc_current_ns->has_import_set;
5038 1204 : gfc_find_symbol (name, NULL, iface, &sym);
5039 1204 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5040 : {
5041 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5042 0 : return MATCH_ERROR;
5043 : }
5044 1204 : if (sym && sym->generic && !dt_sym)
5045 0 : dt_sym = gfc_find_dt_in_generic (sym);
5046 :
5047 1204 : ts->kind = 0;
5048 1204 : if (sym == NULL)
5049 : return MATCH_NO;
5050 : }
5051 :
5052 33182 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
5053 32479 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
5054 33180 : || sym->attr.subroutine)
5055 : {
5056 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
5057 : "entity at %L, which has the same name", name,
5058 : &sym->declared_at);
5059 2 : return MATCH_ERROR;
5060 : }
5061 :
5062 33180 : if (dt_sym && decl_type_param_list
5063 891 : && dt_sym->attr.flavor == FL_DERIVED
5064 891 : && !dt_sym->attr.pdt_type
5065 232 : && !dt_sym->attr.pdt_template)
5066 : {
5067 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5068 : "list at %C may not appear", dt_sym->name);
5069 1 : return MATCH_ERROR;
5070 : }
5071 :
5072 33179 : if (sym && sym->attr.flavor == FL_DERIVED
5073 : && sym->attr.pdt_template
5074 : && gfc_current_state () != COMP_DERIVED)
5075 : {
5076 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5077 : if (m != MATCH_YES)
5078 : return m;
5079 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5080 : ts->u.derived = sym;
5081 : strcpy (name, gfc_dt_lower_string (sym->name));
5082 : }
5083 :
5084 33179 : gfc_save_symbol_data (sym);
5085 33179 : gfc_set_sym_referenced (sym);
5086 33179 : if (!sym->attr.generic
5087 33179 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5088 : return MATCH_ERROR;
5089 :
5090 33179 : if (!sym->attr.function
5091 33179 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5092 : return MATCH_ERROR;
5093 :
5094 33179 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5095 33047 : && dt_sym->attr.pdt_template
5096 242 : && gfc_current_state () != COMP_DERIVED)
5097 : {
5098 121 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5099 121 : if (m != MATCH_YES)
5100 : return m;
5101 121 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5102 : }
5103 :
5104 33179 : if (!dt_sym)
5105 : {
5106 132 : gfc_interface *intr, *head;
5107 :
5108 : /* Use upper case to save the actual derived-type symbol. */
5109 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5110 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5111 132 : head = sym->generic;
5112 132 : intr = gfc_get_interface ();
5113 132 : intr->sym = dt_sym;
5114 132 : intr->where = gfc_current_locus;
5115 132 : intr->next = head;
5116 132 : sym->generic = intr;
5117 132 : sym->attr.if_source = IFSRC_DECL;
5118 : }
5119 : else
5120 33047 : gfc_save_symbol_data (dt_sym);
5121 :
5122 33179 : gfc_set_sym_referenced (dt_sym);
5123 :
5124 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5125 33311 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5126 : return MATCH_ERROR;
5127 :
5128 33179 : ts->u.derived = dt_sym;
5129 :
5130 33179 : return MATCH_YES;
5131 :
5132 154637 : get_kind:
5133 154637 : if (matched_type
5134 154637 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5135 : "intrinsic-type-spec at %C"))
5136 : return MATCH_ERROR;
5137 :
5138 : /* For all types except double, derived and character, look for an
5139 : optional kind specifier. MATCH_NO is actually OK at this point. */
5140 154634 : if (implicit_flag == 1)
5141 : {
5142 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5143 : return MATCH_ERROR;
5144 :
5145 223 : return MATCH_YES;
5146 : }
5147 :
5148 154411 : if (gfc_current_form == FORM_FREE)
5149 : {
5150 140660 : c = gfc_peek_ascii_char ();
5151 140660 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5152 69922 : && c != ':' && c != ',')
5153 : {
5154 167 : if (matched_type && c == ')')
5155 : {
5156 3 : gfc_next_ascii_char ();
5157 3 : return MATCH_YES;
5158 : }
5159 164 : gfc_error ("Malformed type-spec at %C");
5160 164 : return MATCH_NO;
5161 : }
5162 : }
5163 :
5164 154244 : m = gfc_match_kind_spec (ts, false);
5165 154244 : if (m == MATCH_ERROR)
5166 : return MATCH_ERROR;
5167 :
5168 154208 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5169 : {
5170 106302 : m = gfc_match_old_kind_spec (ts);
5171 106302 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5172 : return MATCH_ERROR;
5173 : }
5174 :
5175 154200 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5176 : {
5177 0 : gfc_error ("Malformed type-spec at %C");
5178 0 : return MATCH_ERROR;
5179 : }
5180 :
5181 : /* Defer association of the KIND expression of function results
5182 : until after USE and IMPORT statements. */
5183 4454 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5184 158627 : || gfc_matching_function)
5185 7068 : return MATCH_YES;
5186 :
5187 147132 : if (m == MATCH_NO)
5188 150023 : m = MATCH_YES; /* No kind specifier found. */
5189 :
5190 : return m;
5191 : }
5192 :
5193 :
5194 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5195 : already matched in parse.cc, or we would not end up here in the
5196 : first place. So the only thing we need to check, is if there is
5197 : trailing garbage. If not, the match is successful. */
5198 :
5199 : match
5200 23454 : gfc_match_implicit_none (void)
5201 : {
5202 23454 : char c;
5203 23454 : match m;
5204 23454 : char name[GFC_MAX_SYMBOL_LEN + 1];
5205 23454 : bool type = false;
5206 23454 : bool external = false;
5207 23454 : locus cur_loc = gfc_current_locus;
5208 :
5209 23454 : if (gfc_current_ns->seen_implicit_none
5210 23452 : || gfc_current_ns->has_implicit_none_export)
5211 : {
5212 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5213 4 : return MATCH_ERROR;
5214 : }
5215 :
5216 23450 : gfc_gobble_whitespace ();
5217 23450 : c = gfc_peek_ascii_char ();
5218 23450 : if (c == '(')
5219 : {
5220 1066 : (void) gfc_next_ascii_char ();
5221 1066 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5222 : return MATCH_ERROR;
5223 :
5224 1065 : gfc_gobble_whitespace ();
5225 1065 : if (gfc_peek_ascii_char () == ')')
5226 : {
5227 1 : (void) gfc_next_ascii_char ();
5228 1 : type = true;
5229 : }
5230 : else
5231 3168 : for(;;)
5232 : {
5233 2116 : m = gfc_match (" %n", name);
5234 2116 : if (m != MATCH_YES)
5235 : return MATCH_ERROR;
5236 :
5237 2116 : if (strcmp (name, "type") == 0)
5238 : type = true;
5239 1064 : else if (strcmp (name, "external") == 0)
5240 : external = true;
5241 : else
5242 : return MATCH_ERROR;
5243 :
5244 2116 : gfc_gobble_whitespace ();
5245 2116 : c = gfc_next_ascii_char ();
5246 2116 : if (c == ',')
5247 1052 : continue;
5248 1064 : if (c == ')')
5249 : break;
5250 : return MATCH_ERROR;
5251 : }
5252 : }
5253 : else
5254 : type = true;
5255 :
5256 23449 : if (gfc_match_eos () != MATCH_YES)
5257 : return MATCH_ERROR;
5258 :
5259 23449 : gfc_set_implicit_none (type, external, &cur_loc);
5260 :
5261 23449 : return MATCH_YES;
5262 : }
5263 :
5264 :
5265 : /* Match the letter range(s) of an IMPLICIT statement. */
5266 :
5267 : static match
5268 600 : match_implicit_range (void)
5269 : {
5270 600 : char c, c1, c2;
5271 600 : int inner;
5272 600 : locus cur_loc;
5273 :
5274 600 : cur_loc = gfc_current_locus;
5275 :
5276 600 : gfc_gobble_whitespace ();
5277 600 : c = gfc_next_ascii_char ();
5278 600 : if (c != '(')
5279 : {
5280 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5281 59 : goto bad;
5282 : }
5283 :
5284 : inner = 1;
5285 1195 : while (inner)
5286 : {
5287 722 : gfc_gobble_whitespace ();
5288 722 : c1 = gfc_next_ascii_char ();
5289 722 : if (!ISALPHA (c1))
5290 33 : goto bad;
5291 :
5292 689 : gfc_gobble_whitespace ();
5293 689 : c = gfc_next_ascii_char ();
5294 :
5295 689 : switch (c)
5296 : {
5297 201 : case ')':
5298 201 : inner = 0; /* Fall through. */
5299 :
5300 : case ',':
5301 : c2 = c1;
5302 : break;
5303 :
5304 439 : case '-':
5305 439 : gfc_gobble_whitespace ();
5306 439 : c2 = gfc_next_ascii_char ();
5307 439 : if (!ISALPHA (c2))
5308 0 : goto bad;
5309 :
5310 439 : gfc_gobble_whitespace ();
5311 439 : c = gfc_next_ascii_char ();
5312 :
5313 439 : if ((c != ',') && (c != ')'))
5314 0 : goto bad;
5315 439 : if (c == ')')
5316 272 : inner = 0;
5317 :
5318 : break;
5319 :
5320 35 : default:
5321 35 : goto bad;
5322 : }
5323 :
5324 654 : if (c1 > c2)
5325 : {
5326 0 : gfc_error ("Letters must be in alphabetic order in "
5327 : "IMPLICIT statement at %C");
5328 0 : goto bad;
5329 : }
5330 :
5331 : /* See if we can add the newly matched range to the pending
5332 : implicits from this IMPLICIT statement. We do not check for
5333 : conflicts with whatever earlier IMPLICIT statements may have
5334 : set. This is done when we've successfully finished matching
5335 : the current one. */
5336 654 : if (!gfc_add_new_implicit_range (c1, c2))
5337 0 : goto bad;
5338 : }
5339 :
5340 : return MATCH_YES;
5341 :
5342 127 : bad:
5343 127 : gfc_syntax_error (ST_IMPLICIT);
5344 :
5345 127 : gfc_current_locus = cur_loc;
5346 127 : return MATCH_ERROR;
5347 : }
5348 :
5349 :
5350 : /* Match an IMPLICIT statement, storing the types for
5351 : gfc_set_implicit() if the statement is accepted by the parser.
5352 : There is a strange looking, but legal syntactic construction
5353 : possible. It looks like:
5354 :
5355 : IMPLICIT INTEGER (a-b) (c-d)
5356 :
5357 : This is legal if "a-b" is a constant expression that happens to
5358 : equal one of the legal kinds for integers. The real problem
5359 : happens with an implicit specification that looks like:
5360 :
5361 : IMPLICIT INTEGER (a-b)
5362 :
5363 : In this case, a typespec matcher that is "greedy" (as most of the
5364 : matchers are) gobbles the character range as a kindspec, leaving
5365 : nothing left. We therefore have to go a bit more slowly in the
5366 : matching process by inhibiting the kindspec checking during
5367 : typespec matching and checking for a kind later. */
5368 :
5369 : match
5370 23880 : gfc_match_implicit (void)
5371 : {
5372 23880 : gfc_typespec ts;
5373 23880 : locus cur_loc;
5374 23880 : char c;
5375 23880 : match m;
5376 :
5377 23880 : if (gfc_current_ns->seen_implicit_none)
5378 : {
5379 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5380 : "statement");
5381 4 : return MATCH_ERROR;
5382 : }
5383 :
5384 23876 : gfc_clear_ts (&ts);
5385 :
5386 : /* We don't allow empty implicit statements. */
5387 23876 : if (gfc_match_eos () == MATCH_YES)
5388 : {
5389 0 : gfc_error ("Empty IMPLICIT statement at %C");
5390 0 : return MATCH_ERROR;
5391 : }
5392 :
5393 23905 : do
5394 : {
5395 : /* First cleanup. */
5396 23905 : gfc_clear_new_implicit ();
5397 :
5398 : /* A basic type is mandatory here. */
5399 23905 : m = gfc_match_decl_type_spec (&ts, 1);
5400 23905 : if (m == MATCH_ERROR)
5401 0 : goto error;
5402 23905 : if (m == MATCH_NO)
5403 23452 : goto syntax;
5404 :
5405 453 : cur_loc = gfc_current_locus;
5406 453 : m = match_implicit_range ();
5407 :
5408 453 : if (m == MATCH_YES)
5409 : {
5410 : /* We may have <TYPE> (<RANGE>). */
5411 326 : gfc_gobble_whitespace ();
5412 326 : c = gfc_peek_ascii_char ();
5413 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5414 : {
5415 : /* Check for CHARACTER with no length parameter. */
5416 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5417 : {
5418 32 : ts.kind = gfc_default_character_kind;
5419 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5420 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5421 : NULL, 1);
5422 : }
5423 :
5424 : /* Record the Successful match. */
5425 299 : if (!gfc_merge_new_implicit (&ts))
5426 : return MATCH_ERROR;
5427 297 : if (c == ',')
5428 28 : c = gfc_next_ascii_char ();
5429 269 : else if (gfc_match_eos () == MATCH_ERROR)
5430 0 : goto error;
5431 297 : continue;
5432 : }
5433 :
5434 27 : gfc_current_locus = cur_loc;
5435 : }
5436 :
5437 : /* Discard the (incorrectly) matched range. */
5438 154 : gfc_clear_new_implicit ();
5439 :
5440 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5441 154 : if (ts.type == BT_CHARACTER)
5442 74 : m = gfc_match_char_spec (&ts);
5443 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5444 : {
5445 76 : m = gfc_match_kind_spec (&ts, false);
5446 76 : if (m == MATCH_NO)
5447 : {
5448 40 : m = gfc_match_old_kind_spec (&ts);
5449 40 : if (m == MATCH_ERROR)
5450 0 : goto error;
5451 40 : if (m == MATCH_NO)
5452 0 : goto syntax;
5453 : }
5454 : }
5455 154 : if (m == MATCH_ERROR)
5456 7 : goto error;
5457 :
5458 147 : m = match_implicit_range ();
5459 147 : if (m == MATCH_ERROR)
5460 0 : goto error;
5461 147 : if (m == MATCH_NO)
5462 : goto syntax;
5463 :
5464 147 : gfc_gobble_whitespace ();
5465 147 : c = gfc_next_ascii_char ();
5466 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5467 0 : goto syntax;
5468 :
5469 147 : if (!gfc_merge_new_implicit (&ts))
5470 : return MATCH_ERROR;
5471 : }
5472 444 : while (c == ',');
5473 :
5474 : return MATCH_YES;
5475 :
5476 23452 : syntax:
5477 23452 : gfc_syntax_error (ST_IMPLICIT);
5478 :
5479 : error:
5480 : return MATCH_ERROR;
5481 : }
5482 :
5483 :
5484 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5485 :
5486 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5487 :
5488 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5489 :
5490 : C1211 (R1209) Each import-name shall be the name of an entity in the
5491 : host scoping unit.
5492 :
5493 : under the description of an interface block. Under F2008, IMPORT was
5494 : split out of the interface block description to 12.4.3.3 and C1210
5495 : became
5496 :
5497 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5498 : that is not a module procedure interface body.
5499 :
5500 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5501 :
5502 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5503 : or IMPORT, ONLY : import-name-list
5504 : or IMPORT, NONE
5505 : or IMPORT, ALL
5506 :
5507 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5508 : a main-program, external-subprogram, module, or block-data.
5509 :
5510 : C897 (R867) Each import-name shall be the name of an entity in the host
5511 : scoping unit.
5512 :
5513 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5514 : all IMPORT statements in that scoping unit shall have an ONLY
5515 : specifier.
5516 :
5517 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5518 :
5519 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5520 : unit, no other IMPORT statement shall appear in that scoping unit.
5521 :
5522 : C8101 Within an interface body, an entity that is accessed by host
5523 : association shall be accessible by host or use association within
5524 : the host scoping unit, or explicitly declared prior to the interface
5525 : body.
5526 :
5527 : C8102 An entity whose name appears as an import-name or which is made
5528 : accessible by an IMPORT, ALL statement shall not appear in any
5529 : context described in 19.5.1.4 that would cause the host entity
5530 : of that name to be inaccessible. */
5531 :
5532 : match
5533 3909 : gfc_match_import (void)
5534 : {
5535 3909 : char name[GFC_MAX_SYMBOL_LEN + 1];
5536 3909 : match m;
5537 3909 : gfc_symbol *sym;
5538 3909 : gfc_symtree *st;
5539 3909 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5540 3909 : importstate current_import_state = gfc_current_ns->import_state;
5541 :
5542 3909 : if (!f2018_allowed
5543 13 : && (gfc_current_ns->proc_name == NULL
5544 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5545 : {
5546 3 : gfc_error ("IMPORT statement at %C only permitted in "
5547 : "an INTERFACE body");
5548 3 : return MATCH_ERROR;
5549 : }
5550 : else if (f2018_allowed
5551 3896 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5552 4 : goto C897;
5553 :
5554 3892 : if (f2018_allowed
5555 3892 : && (current_import_state == IMPORT_ALL
5556 3892 : || current_import_state == IMPORT_NONE))
5557 2 : goto C8100;
5558 :
5559 3900 : if (gfc_current_ns->proc_name
5560 3899 : && gfc_current_ns->proc_name->attr.module_procedure)
5561 : {
5562 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5563 : "in a module procedure interface body");
5564 1 : return MATCH_ERROR;
5565 : }
5566 :
5567 3899 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5568 : return MATCH_ERROR;
5569 :
5570 3895 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5571 3895 : if (f2018_allowed)
5572 : {
5573 3889 : if (gfc_match (" , none") == MATCH_YES)
5574 : {
5575 8 : if (current_import_state == IMPORT_ONLY)
5576 0 : goto C898;
5577 8 : if (gfc_current_state () == COMP_SUBMODULE)
5578 0 : goto C899;
5579 8 : gfc_current_ns->import_state = IMPORT_NONE;
5580 : }
5581 3881 : else if (gfc_match (" , only :") == MATCH_YES)
5582 : {
5583 19 : if (current_import_state != IMPORT_NOT_SET
5584 19 : && current_import_state != IMPORT_ONLY)
5585 0 : goto C898;
5586 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5587 : }
5588 3862 : else if (gfc_match (" , all") == MATCH_YES)
5589 : {
5590 1 : if (current_import_state == IMPORT_ONLY)
5591 0 : goto C898;
5592 1 : gfc_current_ns->import_state = IMPORT_ALL;
5593 : }
5594 :
5595 3889 : if (current_import_state != IMPORT_NOT_SET
5596 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5597 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5598 0 : goto C8100;
5599 : }
5600 :
5601 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5602 3895 : if (gfc_match_eos () == MATCH_YES)
5603 : {
5604 : /* This is the F2008 variant. */
5605 227 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5606 : {
5607 218 : if (current_import_state == IMPORT_ONLY)
5608 0 : goto C898;
5609 218 : gfc_current_ns->import_state = IMPORT_F2008;
5610 : }
5611 :
5612 : /* Host variables should be imported. */
5613 227 : if (gfc_current_ns->import_state != IMPORT_NONE)
5614 219 : gfc_current_ns->has_import_set = 1;
5615 227 : return MATCH_YES;
5616 : }
5617 :
5618 3668 : if (gfc_match (" ::") == MATCH_YES
5619 3668 : && gfc_current_ns->import_state != IMPORT_ONLY)
5620 : {
5621 1160 : if (gfc_match_eos () == MATCH_YES)
5622 1 : goto expecting_list;
5623 1159 : gfc_current_ns->import_state = IMPORT_F2008;
5624 : }
5625 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5626 : {
5627 19 : if (gfc_match_eos () == MATCH_YES)
5628 0 : goto expecting_list;
5629 : }
5630 :
5631 4352 : for(;;)
5632 : {
5633 4352 : sym = NULL;
5634 4352 : m = gfc_match (" %n", name);
5635 4352 : switch (m)
5636 : {
5637 4352 : case MATCH_YES:
5638 : /* Before checking if the symbol is available from host
5639 : association into a SUBROUTINE or FUNCTION within an
5640 : INTERFACE, check if it is already in local scope. */
5641 4352 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5642 4352 : if (sym
5643 25 : && gfc_state_stack->previous
5644 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5645 : {
5646 2 : gfc_error ("import-name %qs at %C is in the "
5647 : "local scope", name);
5648 2 : return MATCH_ERROR;
5649 : }
5650 :
5651 4350 : if (gfc_current_ns->parent != NULL
5652 4350 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5653 : {
5654 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5655 0 : return MATCH_ERROR;
5656 : }
5657 4350 : else if (!sym
5658 5 : && gfc_current_ns->proc_name
5659 4 : && gfc_current_ns->proc_name->ns->parent
5660 4351 : && gfc_find_symbol (name,
5661 : gfc_current_ns->proc_name->ns->parent,
5662 : 1, &sym))
5663 : {
5664 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5665 0 : return MATCH_ERROR;
5666 : }
5667 :
5668 4350 : if (sym == NULL)
5669 : {
5670 5 : if (gfc_current_ns->proc_name
5671 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5672 : {
5673 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5674 : "at %C - does not exist.", name);
5675 1 : return MATCH_ERROR;
5676 : }
5677 : else
5678 : {
5679 : /* This might be a procedure that has not yet been parsed. If
5680 : so gfc_fixup_sibling_symbols will replace this symbol with
5681 : that of the procedure. */
5682 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5683 : &gfc_current_locus);
5684 4 : st->n.sym->refs++;
5685 4 : st->n.sym->attr.imported = 1;
5686 4 : st->import_only = 1;
5687 4 : goto next_item;
5688 : }
5689 : }
5690 :
5691 4345 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5692 4345 : if (st && st->n.sym && st->n.sym->attr.imported)
5693 : {
5694 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5695 : "at %C", name);
5696 0 : goto next_item;
5697 : }
5698 :
5699 4345 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5700 4345 : st->n.sym = sym;
5701 4345 : sym->refs++;
5702 4345 : sym->attr.imported = 1;
5703 4345 : st->import_only = 1;
5704 :
5705 4345 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5706 : {
5707 : /* The actual derived type is stored in a symtree with the first
5708 : letter of the name capitalized; the symtree with the all
5709 : lower-case name contains the associated generic function. */
5710 599 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5711 : gfc_dt_upper_string (name));
5712 599 : st->n.sym = sym;
5713 599 : sym->refs++;
5714 599 : sym->attr.imported = 1;
5715 599 : st->import_only = 1;
5716 : }
5717 :
5718 4345 : goto next_item;
5719 :
5720 : case MATCH_NO:
5721 : break;
5722 :
5723 : case MATCH_ERROR:
5724 : return MATCH_ERROR;
5725 : }
5726 :
5727 4349 : next_item:
5728 4349 : if (gfc_match_eos () == MATCH_YES)
5729 : break;
5730 685 : if (gfc_match_char (',') != MATCH_YES)
5731 0 : goto syntax;
5732 : }
5733 :
5734 : return MATCH_YES;
5735 :
5736 0 : syntax:
5737 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5738 0 : return MATCH_ERROR;
5739 :
5740 4 : C897:
5741 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5742 : "program, an external subprogram, a module or block data");
5743 4 : return MATCH_ERROR;
5744 :
5745 0 : C898:
5746 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5747 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5748 : "with an ONLY specifier");
5749 0 : return MATCH_ERROR;
5750 :
5751 0 : C899:
5752 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5753 : " of a submodule as at %C");
5754 0 : return MATCH_ERROR;
5755 :
5756 2 : C8100:
5757 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5758 : "%s has already been declared, which must be unique in the "
5759 : "scoping unit",
5760 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5761 : "IMPORT, NONE");
5762 2 : return MATCH_ERROR;
5763 :
5764 1 : expecting_list:
5765 1 : gfc_error ("Expecting list of named entities at %C");
5766 1 : return MATCH_ERROR;
5767 : }
5768 :
5769 :
5770 : /* A minimal implementation of gfc_match without whitespace, escape
5771 : characters or variable arguments. Returns true if the next
5772 : characters match the TARGET template exactly. */
5773 :
5774 : static bool
5775 143168 : match_string_p (const char *target)
5776 : {
5777 143168 : const char *p;
5778 :
5779 905041 : for (p = target; *p; p++)
5780 761874 : if ((char) gfc_next_ascii_char () != *p)
5781 : return false;
5782 : return true;
5783 : }
5784 :
5785 : /* Matches an attribute specification including array specs. If
5786 : successful, leaves the variables current_attr and current_as
5787 : holding the specification. Also sets the colon_seen variable for
5788 : later use by matchers associated with initializations.
5789 :
5790 : This subroutine is a little tricky in the sense that we don't know
5791 : if we really have an attr-spec until we hit the double colon.
5792 : Until that time, we can only return MATCH_NO. This forces us to
5793 : check for duplicate specification at this level. */
5794 :
5795 : static match
5796 212262 : match_attr_spec (void)
5797 : {
5798 : /* Modifiers that can exist in a type statement. */
5799 212262 : enum
5800 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5801 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5802 : DECL_DIMENSION, DECL_EXTERNAL,
5803 : DECL_INTRINSIC, DECL_OPTIONAL,
5804 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5805 : DECL_STATIC, DECL_AUTOMATIC,
5806 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5807 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5808 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5809 : };
5810 :
5811 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5812 : #define NUM_DECL GFC_DECL_END
5813 :
5814 : /* Make sure that values from sym_intent are safe to be used here. */
5815 212262 : gcc_assert (INTENT_IN > 0);
5816 :
5817 212262 : locus start, seen_at[NUM_DECL];
5818 212262 : int seen[NUM_DECL];
5819 212262 : unsigned int d;
5820 212262 : const char *attr;
5821 212262 : match m;
5822 212262 : bool t;
5823 :
5824 212262 : gfc_clear_attr (¤t_attr);
5825 212262 : start = gfc_current_locus;
5826 :
5827 212262 : current_as = NULL;
5828 212262 : colon_seen = 0;
5829 212262 : attr_seen = 0;
5830 :
5831 : /* See if we get all of the keywords up to the final double colon. */
5832 5731074 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5833 5518812 : seen[d] = 0;
5834 :
5835 328756 : for (;;)
5836 : {
5837 328756 : char ch;
5838 :
5839 328756 : d = DECL_NONE;
5840 328756 : gfc_gobble_whitespace ();
5841 :
5842 328756 : ch = gfc_next_ascii_char ();
5843 328756 : if (ch == ':')
5844 : {
5845 : /* This is the successful exit condition for the loop. */
5846 179614 : if (gfc_next_ascii_char () == ':')
5847 : break;
5848 : }
5849 149142 : else if (ch == ',')
5850 : {
5851 116506 : gfc_gobble_whitespace ();
5852 116506 : switch (gfc_peek_ascii_char ())
5853 : {
5854 18214 : case 'a':
5855 18214 : gfc_next_ascii_char ();
5856 18214 : switch (gfc_next_ascii_char ())
5857 : {
5858 18149 : case 'l':
5859 18149 : if (match_string_p ("locatable"))
5860 : {
5861 : /* Matched "allocatable". */
5862 : d = DECL_ALLOCATABLE;
5863 : }
5864 : break;
5865 :
5866 24 : case 's':
5867 24 : if (match_string_p ("ynchronous"))
5868 : {
5869 : /* Matched "asynchronous". */
5870 : d = DECL_ASYNCHRONOUS;
5871 : }
5872 : break;
5873 :
5874 41 : case 'u':
5875 41 : if (match_string_p ("tomatic"))
5876 : {
5877 : /* Matched "automatic". */
5878 : d = DECL_AUTOMATIC;
5879 : }
5880 : break;
5881 : }
5882 : break;
5883 :
5884 163 : case 'b':
5885 : /* Try and match the bind(c). */
5886 163 : m = gfc_match_bind_c (NULL, true);
5887 163 : if (m == MATCH_YES)
5888 : d = DECL_IS_BIND_C;
5889 0 : else if (m == MATCH_ERROR)
5890 0 : goto cleanup;
5891 : break;
5892 :
5893 2139 : case 'c':
5894 2139 : gfc_next_ascii_char ();
5895 2139 : if ('o' != gfc_next_ascii_char ())
5896 : break;
5897 2138 : switch (gfc_next_ascii_char ())
5898 : {
5899 68 : case 'd':
5900 68 : if (match_string_p ("imension"))
5901 : {
5902 : d = DECL_CODIMENSION;
5903 : break;
5904 : }
5905 : /* FALLTHRU */
5906 2070 : case 'n':
5907 2070 : if (match_string_p ("tiguous"))
5908 : {
5909 : d = DECL_CONTIGUOUS;
5910 : break;
5911 : }
5912 : }
5913 : break;
5914 :
5915 19574 : case 'd':
5916 19574 : if (match_string_p ("dimension"))
5917 : d = DECL_DIMENSION;
5918 : break;
5919 :
5920 177 : case 'e':
5921 177 : if (match_string_p ("external"))
5922 : d = DECL_EXTERNAL;
5923 : break;
5924 :
5925 26826 : case 'i':
5926 26826 : if (match_string_p ("int"))
5927 : {
5928 26826 : ch = gfc_next_ascii_char ();
5929 26826 : if (ch == 'e')
5930 : {
5931 26820 : if (match_string_p ("nt"))
5932 : {
5933 : /* Matched "intent". */
5934 26819 : d = match_intent_spec ();
5935 26819 : if (d == INTENT_UNKNOWN)
5936 : {
5937 2 : m = MATCH_ERROR;
5938 2 : goto cleanup;
5939 : }
5940 : }
5941 : }
5942 6 : else if (ch == 'r')
5943 : {
5944 6 : if (match_string_p ("insic"))
5945 : {
5946 : /* Matched "intrinsic". */
5947 : d = DECL_INTRINSIC;
5948 : }
5949 : }
5950 : }
5951 : break;
5952 :
5953 286 : case 'k':
5954 286 : if (match_string_p ("kind"))
5955 : d = DECL_KIND;
5956 : break;
5957 :
5958 301 : case 'l':
5959 301 : if (match_string_p ("len"))
5960 : d = DECL_LEN;
5961 : break;
5962 :
5963 5042 : case 'o':
5964 5042 : if (match_string_p ("optional"))
5965 : d = DECL_OPTIONAL;
5966 : break;
5967 :
5968 26769 : case 'p':
5969 26769 : gfc_next_ascii_char ();
5970 26769 : switch (gfc_next_ascii_char ())
5971 : {
5972 14103 : case 'a':
5973 14103 : if (match_string_p ("rameter"))
5974 : {
5975 : /* Matched "parameter". */
5976 : d = DECL_PARAMETER;
5977 : }
5978 : break;
5979 :
5980 12147 : case 'o':
5981 12147 : if (match_string_p ("inter"))
5982 : {
5983 : /* Matched "pointer". */
5984 : d = DECL_POINTER;
5985 : }
5986 : break;
5987 :
5988 267 : case 'r':
5989 267 : ch = gfc_next_ascii_char ();
5990 267 : if (ch == 'i')
5991 : {
5992 216 : if (match_string_p ("vate"))
5993 : {
5994 : /* Matched "private". */
5995 : d = DECL_PRIVATE;
5996 : }
5997 : }
5998 51 : else if (ch == 'o')
5999 : {
6000 51 : if (match_string_p ("tected"))
6001 : {
6002 : /* Matched "protected". */
6003 : d = DECL_PROTECTED;
6004 : }
6005 : }
6006 : break;
6007 :
6008 252 : case 'u':
6009 252 : if (match_string_p ("blic"))
6010 : {
6011 : /* Matched "public". */
6012 : d = DECL_PUBLIC;
6013 : }
6014 : break;
6015 : }
6016 : break;
6017 :
6018 1210 : case 's':
6019 1210 : gfc_next_ascii_char ();
6020 1210 : switch (gfc_next_ascii_char ())
6021 : {
6022 1197 : case 'a':
6023 1197 : if (match_string_p ("ve"))
6024 : {
6025 : /* Matched "save". */
6026 : d = DECL_SAVE;
6027 : }
6028 : break;
6029 :
6030 13 : case 't':
6031 13 : if (match_string_p ("atic"))
6032 : {
6033 : /* Matched "static". */
6034 : d = DECL_STATIC;
6035 : }
6036 : break;
6037 : }
6038 : break;
6039 :
6040 5280 : case 't':
6041 5280 : if (match_string_p ("target"))
6042 : d = DECL_TARGET;
6043 : break;
6044 :
6045 10525 : case 'v':
6046 10525 : gfc_next_ascii_char ();
6047 10525 : ch = gfc_next_ascii_char ();
6048 10525 : if (ch == 'a')
6049 : {
6050 10017 : if (match_string_p ("lue"))
6051 : {
6052 : /* Matched "value". */
6053 : d = DECL_VALUE;
6054 : }
6055 : }
6056 508 : else if (ch == 'o')
6057 : {
6058 508 : if (match_string_p ("latile"))
6059 : {
6060 : /* Matched "volatile". */
6061 : d = DECL_VOLATILE;
6062 : }
6063 : }
6064 : break;
6065 : }
6066 : }
6067 :
6068 : /* No double colon and no recognizable decl_type, so assume that
6069 : we've been looking at something else the whole time. */
6070 : if (d == DECL_NONE)
6071 : {
6072 32639 : m = MATCH_NO;
6073 32639 : goto cleanup;
6074 : }
6075 :
6076 : /* Check to make sure any parens are paired up correctly. */
6077 116502 : if (gfc_match_parens () == MATCH_ERROR)
6078 : {
6079 1 : m = MATCH_ERROR;
6080 1 : goto cleanup;
6081 : }
6082 :
6083 116501 : seen[d]++;
6084 116501 : seen_at[d] = gfc_current_locus;
6085 :
6086 116501 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6087 : {
6088 19641 : gfc_array_spec *as = NULL;
6089 :
6090 19641 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6091 : d == DECL_CODIMENSION);
6092 :
6093 19641 : if (current_as == NULL)
6094 19616 : current_as = as;
6095 25 : else if (m == MATCH_YES)
6096 : {
6097 25 : if (!merge_array_spec (as, current_as, false))
6098 2 : m = MATCH_ERROR;
6099 25 : free (as);
6100 : }
6101 :
6102 19641 : if (m == MATCH_NO)
6103 : {
6104 0 : if (d == DECL_CODIMENSION)
6105 0 : gfc_error ("Missing codimension specification at %C");
6106 : else
6107 0 : gfc_error ("Missing dimension specification at %C");
6108 : m = MATCH_ERROR;
6109 : }
6110 :
6111 19641 : if (m == MATCH_ERROR)
6112 7 : goto cleanup;
6113 : }
6114 : }
6115 :
6116 : /* Since we've seen a double colon, we have to be looking at an
6117 : attr-spec. This means that we can now issue errors. */
6118 4849530 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6119 4669919 : if (seen[d] > 1)
6120 : {
6121 2 : switch (d)
6122 : {
6123 : case DECL_ALLOCATABLE:
6124 : attr = "ALLOCATABLE";
6125 : break;
6126 0 : case DECL_ASYNCHRONOUS:
6127 0 : attr = "ASYNCHRONOUS";
6128 0 : break;
6129 0 : case DECL_CODIMENSION:
6130 0 : attr = "CODIMENSION";
6131 0 : break;
6132 0 : case DECL_CONTIGUOUS:
6133 0 : attr = "CONTIGUOUS";
6134 0 : break;
6135 0 : case DECL_DIMENSION:
6136 0 : attr = "DIMENSION";
6137 0 : break;
6138 0 : case DECL_EXTERNAL:
6139 0 : attr = "EXTERNAL";
6140 0 : break;
6141 0 : case DECL_IN:
6142 0 : attr = "INTENT (IN)";
6143 0 : break;
6144 0 : case DECL_OUT:
6145 0 : attr = "INTENT (OUT)";
6146 0 : break;
6147 0 : case DECL_INOUT:
6148 0 : attr = "INTENT (IN OUT)";
6149 0 : break;
6150 0 : case DECL_INTRINSIC:
6151 0 : attr = "INTRINSIC";
6152 0 : break;
6153 0 : case DECL_OPTIONAL:
6154 0 : attr = "OPTIONAL";
6155 0 : break;
6156 0 : case DECL_KIND:
6157 0 : attr = "KIND";
6158 0 : break;
6159 0 : case DECL_LEN:
6160 0 : attr = "LEN";
6161 0 : break;
6162 0 : case DECL_PARAMETER:
6163 0 : attr = "PARAMETER";
6164 0 : break;
6165 0 : case DECL_POINTER:
6166 0 : attr = "POINTER";
6167 0 : break;
6168 0 : case DECL_PROTECTED:
6169 0 : attr = "PROTECTED";
6170 0 : break;
6171 0 : case DECL_PRIVATE:
6172 0 : attr = "PRIVATE";
6173 0 : break;
6174 0 : case DECL_PUBLIC:
6175 0 : attr = "PUBLIC";
6176 0 : break;
6177 0 : case DECL_SAVE:
6178 0 : attr = "SAVE";
6179 0 : break;
6180 0 : case DECL_STATIC:
6181 0 : attr = "STATIC";
6182 0 : break;
6183 1 : case DECL_AUTOMATIC:
6184 1 : attr = "AUTOMATIC";
6185 1 : break;
6186 0 : case DECL_TARGET:
6187 0 : attr = "TARGET";
6188 0 : break;
6189 0 : case DECL_IS_BIND_C:
6190 0 : attr = "IS_BIND_C";
6191 0 : break;
6192 0 : case DECL_VALUE:
6193 0 : attr = "VALUE";
6194 0 : break;
6195 1 : case DECL_VOLATILE:
6196 1 : attr = "VOLATILE";
6197 1 : break;
6198 0 : default:
6199 0 : attr = NULL; /* This shouldn't happen. */
6200 : }
6201 :
6202 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6203 2 : m = MATCH_ERROR;
6204 2 : goto cleanup;
6205 : }
6206 :
6207 : /* Now that we've dealt with duplicate attributes, add the attributes
6208 : to the current attribute. */
6209 4848710 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6210 : {
6211 4669172 : if (seen[d] == 0)
6212 4552687 : continue;
6213 : else
6214 116485 : attr_seen = 1;
6215 :
6216 116485 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6217 52 : && !flag_dec_static)
6218 : {
6219 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6220 : "%<-fdec-static%>",
6221 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6222 2 : m = MATCH_ERROR;
6223 2 : goto cleanup;
6224 : }
6225 : /* Allow SAVE with STATIC, but don't complain. */
6226 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6227 0 : continue;
6228 :
6229 116483 : if (gfc_comp_struct (gfc_current_state ())
6230 6688 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6231 5736 : && d != DECL_POINTER && d != DECL_PRIVATE
6232 4096 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6233 : {
6234 4039 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6235 4039 : if (d == DECL_ALLOCATABLE)
6236 : {
6237 3439 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6238 : ? G_("ALLOCATABLE attribute at %C in a "
6239 : "TYPE definition")
6240 : : G_("ALLOCATABLE attribute at %C in a "
6241 : "STRUCTURE definition")))
6242 : {
6243 2 : m = MATCH_ERROR;
6244 2 : goto cleanup;
6245 : }
6246 : }
6247 600 : else if (d == DECL_KIND)
6248 : {
6249 284 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6250 : ? G_("KIND attribute at %C in a "
6251 : "TYPE definition")
6252 : : G_("KIND attribute at %C in a "
6253 : "STRUCTURE definition")))
6254 : {
6255 1 : m = MATCH_ERROR;
6256 1 : goto cleanup;
6257 : }
6258 283 : if (current_ts.type != BT_INTEGER)
6259 : {
6260 2 : gfc_error ("Component with KIND attribute at %C must be "
6261 : "INTEGER");
6262 2 : m = MATCH_ERROR;
6263 2 : goto cleanup;
6264 : }
6265 : }
6266 316 : else if (d == DECL_LEN)
6267 : {
6268 300 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6269 : ? G_("LEN attribute at %C in a "
6270 : "TYPE definition")
6271 : : G_("LEN attribute at %C in a "
6272 : "STRUCTURE definition")))
6273 : {
6274 0 : m = MATCH_ERROR;
6275 0 : goto cleanup;
6276 : }
6277 300 : if (current_ts.type != BT_INTEGER)
6278 : {
6279 1 : gfc_error ("Component with LEN attribute at %C must be "
6280 : "INTEGER");
6281 1 : m = MATCH_ERROR;
6282 1 : goto cleanup;
6283 : }
6284 : }
6285 : else
6286 : {
6287 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6288 : "TYPE definition")
6289 : : G_("Attribute at %L is not allowed in a "
6290 : "STRUCTURE definition"), &seen_at[d]);
6291 16 : m = MATCH_ERROR;
6292 16 : goto cleanup;
6293 : }
6294 : }
6295 :
6296 116461 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6297 468 : && gfc_current_state () != COMP_MODULE)
6298 : {
6299 147 : if (d == DECL_PRIVATE)
6300 : attr = "PRIVATE";
6301 : else
6302 43 : attr = "PUBLIC";
6303 147 : if (gfc_current_state () == COMP_DERIVED
6304 141 : && gfc_state_stack->previous
6305 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6306 : {
6307 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6308 : "at %L in a TYPE definition", attr,
6309 : &seen_at[d]))
6310 : {
6311 2 : m = MATCH_ERROR;
6312 2 : goto cleanup;
6313 : }
6314 : }
6315 : else
6316 : {
6317 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6318 : "specification part of a module", attr, &seen_at[d]);
6319 9 : m = MATCH_ERROR;
6320 9 : goto cleanup;
6321 : }
6322 : }
6323 :
6324 116450 : if (gfc_current_state () != COMP_DERIVED
6325 109793 : && (d == DECL_KIND || d == DECL_LEN))
6326 : {
6327 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6328 : "definition", &seen_at[d]);
6329 3 : m = MATCH_ERROR;
6330 3 : goto cleanup;
6331 : }
6332 :
6333 116447 : switch (d)
6334 : {
6335 18147 : case DECL_ALLOCATABLE:
6336 18147 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6337 18147 : break;
6338 :
6339 23 : case DECL_ASYNCHRONOUS:
6340 23 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6341 : t = false;
6342 : else
6343 23 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6344 : break;
6345 :
6346 66 : case DECL_CODIMENSION:
6347 66 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6348 66 : break;
6349 :
6350 2070 : case DECL_CONTIGUOUS:
6351 2070 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6352 : t = false;
6353 : else
6354 2069 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6355 : break;
6356 :
6357 19566 : case DECL_DIMENSION:
6358 19566 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6359 19566 : break;
6360 :
6361 176 : case DECL_EXTERNAL:
6362 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6363 176 : break;
6364 :
6365 20217 : case DECL_IN:
6366 20217 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6367 20217 : break;
6368 :
6369 3583 : case DECL_OUT:
6370 3583 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6371 3583 : break;
6372 :
6373 3013 : case DECL_INOUT:
6374 3013 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6375 3013 : break;
6376 :
6377 5 : case DECL_INTRINSIC:
6378 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6379 5 : break;
6380 :
6381 5041 : case DECL_OPTIONAL:
6382 5041 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6383 5041 : break;
6384 :
6385 281 : case DECL_KIND:
6386 281 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6387 281 : break;
6388 :
6389 299 : case DECL_LEN:
6390 299 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6391 299 : break;
6392 :
6393 14102 : case DECL_PARAMETER:
6394 14102 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6395 14102 : break;
6396 :
6397 12146 : case DECL_POINTER:
6398 12146 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6399 12146 : break;
6400 :
6401 50 : case DECL_PROTECTED:
6402 50 : if (gfc_current_state () != COMP_MODULE
6403 48 : || (gfc_current_ns->proc_name
6404 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6405 : {
6406 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6407 : "part of a module");
6408 2 : t = false;
6409 2 : break;
6410 : }
6411 :
6412 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6413 : t = false;
6414 : else
6415 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6416 : break;
6417 :
6418 213 : case DECL_PRIVATE:
6419 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6420 : &seen_at[d]);
6421 213 : break;
6422 :
6423 244 : case DECL_PUBLIC:
6424 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6425 : &seen_at[d]);
6426 244 : break;
6427 :
6428 1207 : case DECL_STATIC:
6429 1207 : case DECL_SAVE:
6430 1207 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6431 1207 : break;
6432 :
6433 37 : case DECL_AUTOMATIC:
6434 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6435 37 : break;
6436 :
6437 5278 : case DECL_TARGET:
6438 5278 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6439 5278 : break;
6440 :
6441 162 : case DECL_IS_BIND_C:
6442 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6443 162 : break;
6444 :
6445 10016 : case DECL_VALUE:
6446 10016 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6447 : t = false;
6448 : else
6449 10016 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6450 : break;
6451 :
6452 505 : case DECL_VOLATILE:
6453 505 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6454 : t = false;
6455 : else
6456 504 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6457 : break;
6458 :
6459 0 : default:
6460 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6461 : }
6462 :
6463 116441 : if (!t)
6464 : {
6465 35 : m = MATCH_ERROR;
6466 35 : goto cleanup;
6467 : }
6468 : }
6469 :
6470 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6471 179538 : if ((gfc_current_state () == COMP_MODULE
6472 179538 : || gfc_current_state () == COMP_SUBMODULE)
6473 5704 : && !current_attr.save
6474 5522 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6475 5430 : current_attr.save = SAVE_IMPLICIT;
6476 :
6477 179538 : colon_seen = 1;
6478 179538 : return MATCH_YES;
6479 :
6480 32724 : cleanup:
6481 32724 : gfc_current_locus = start;
6482 32724 : gfc_free_array_spec (current_as);
6483 32724 : current_as = NULL;
6484 32724 : attr_seen = 0;
6485 32724 : return m;
6486 : }
6487 :
6488 :
6489 : /* Set the binding label, dest_label, either with the binding label
6490 : stored in the given gfc_typespec, ts, or if none was provided, it
6491 : will be the symbol name in all lower case, as required by the draft
6492 : (J3/04-007, section 15.4.1). If a binding label was given and
6493 : there is more than one argument (num_idents), it is an error. */
6494 :
6495 : static bool
6496 346 : set_binding_label (const char **dest_label, const char *sym_name,
6497 : int num_idents)
6498 : {
6499 346 : if (num_idents > 1 && has_name_equals)
6500 : {
6501 4 : gfc_error ("Multiple identifiers provided with "
6502 : "single NAME= specifier at %C");
6503 4 : return false;
6504 : }
6505 :
6506 342 : if (curr_binding_label)
6507 : /* Binding label given; store in temp holder till have sym. */
6508 107 : *dest_label = curr_binding_label;
6509 : else
6510 : {
6511 : /* No binding label given, and the NAME= specifier did not exist,
6512 : which means there was no NAME="". */
6513 235 : if (sym_name != NULL && has_name_equals == 0)
6514 205 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6515 : }
6516 :
6517 : return true;
6518 : }
6519 :
6520 :
6521 : /* Set the status of the given common block as being BIND(C) or not,
6522 : depending on the given parameter, is_bind_c. */
6523 :
6524 : static void
6525 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6526 : {
6527 76 : com_block->is_bind_c = is_bind_c;
6528 76 : return;
6529 : }
6530 :
6531 :
6532 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6533 :
6534 : bool
6535 20066 : gfc_verify_c_interop (gfc_typespec *ts)
6536 : {
6537 20066 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6538 4276 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6539 8509 : ? true : false;
6540 15806 : else if (ts->type == BT_CLASS)
6541 : return false;
6542 15798 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6543 3971 : return false;
6544 :
6545 : return true;
6546 : }
6547 :
6548 :
6549 : /* Verify that the variables of a given common block, which has been
6550 : defined with the attribute specifier bind(c), to be of a C
6551 : interoperable type. Errors will be reported here, if
6552 : encountered. */
6553 :
6554 : bool
6555 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6556 : {
6557 1 : gfc_symbol *curr_sym = NULL;
6558 1 : bool retval = true;
6559 :
6560 1 : curr_sym = com_block->head;
6561 :
6562 : /* Make sure we have at least one symbol. */
6563 1 : if (curr_sym == NULL)
6564 : return retval;
6565 :
6566 : /* Here we know we have a symbol, so we'll execute this loop
6567 : at least once. */
6568 1 : do
6569 : {
6570 : /* The second to last param, 1, says this is in a common block. */
6571 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6572 1 : curr_sym = curr_sym->common_next;
6573 1 : } while (curr_sym != NULL);
6574 :
6575 : return retval;
6576 : }
6577 :
6578 :
6579 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6580 : an appropriate error message is reported. */
6581 :
6582 : bool
6583 6869 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6584 : int is_in_common, gfc_common_head *com_block)
6585 : {
6586 6869 : bool bind_c_function = false;
6587 6869 : bool retval = true;
6588 :
6589 6869 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6590 6869 : bind_c_function = true;
6591 :
6592 6869 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6593 : {
6594 2705 : tmp_sym = tmp_sym->result;
6595 : /* Make sure it wasn't an implicitly typed result. */
6596 2705 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6597 : {
6598 1 : gfc_warning (OPT_Wc_binding_type,
6599 : "Implicitly declared BIND(C) function %qs at "
6600 : "%L may not be C interoperable", tmp_sym->name,
6601 : &tmp_sym->declared_at);
6602 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6603 : /* Mark it as C interoperable to prevent duplicate warnings. */
6604 1 : tmp_sym->ts.is_c_interop = 1;
6605 1 : tmp_sym->attr.is_c_interop = 1;
6606 : }
6607 : }
6608 :
6609 : /* Here, we know we have the bind(c) attribute, so if we have
6610 : enough type info, then verify that it's a C interop kind.
6611 : The info could be in the symbol already, or possibly still in
6612 : the given ts (current_ts), so look in both. */
6613 6869 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6614 : {
6615 2863 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6616 : {
6617 : /* See if we're dealing with a sym in a common block or not. */
6618 236 : if (is_in_common == 1 && warn_c_binding_type)
6619 : {
6620 0 : gfc_warning (OPT_Wc_binding_type,
6621 : "Variable %qs in common block %qs at %L "
6622 : "may not be a C interoperable "
6623 : "kind though common block %qs is BIND(C)",
6624 : tmp_sym->name, com_block->name,
6625 0 : &(tmp_sym->declared_at), com_block->name);
6626 : }
6627 : else
6628 : {
6629 236 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6630 234 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6631 : {
6632 3 : gfc_error ("Type declaration %qs at %L is not C "
6633 : "interoperable but it is BIND(C)",
6634 : tmp_sym->name, &(tmp_sym->declared_at));
6635 3 : retval = false;
6636 : }
6637 233 : else if (warn_c_binding_type)
6638 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6639 : "may not be a C interoperable "
6640 : "kind but it is BIND(C)",
6641 : tmp_sym->name, &(tmp_sym->declared_at));
6642 : }
6643 : }
6644 :
6645 : /* Variables declared w/in a common block can't be bind(c)
6646 : since there's no way for C to see these variables, so there's
6647 : semantically no reason for the attribute. */
6648 2863 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6649 : {
6650 1 : gfc_error ("Variable %qs in common block %qs at "
6651 : "%L cannot be declared with BIND(C) "
6652 : "since it is not a global",
6653 1 : tmp_sym->name, com_block->name,
6654 : &(tmp_sym->declared_at));
6655 1 : retval = false;
6656 : }
6657 :
6658 : /* Scalar variables that are bind(c) cannot have the pointer
6659 : or allocatable attributes. */
6660 2863 : if (tmp_sym->attr.is_bind_c == 1)
6661 : {
6662 2330 : if (tmp_sym->attr.pointer == 1)
6663 : {
6664 1 : gfc_error ("Variable %qs at %L cannot have both the "
6665 : "POINTER and BIND(C) attributes",
6666 : tmp_sym->name, &(tmp_sym->declared_at));
6667 1 : retval = false;
6668 : }
6669 :
6670 2330 : if (tmp_sym->attr.allocatable == 1)
6671 : {
6672 0 : gfc_error ("Variable %qs at %L cannot have both the "
6673 : "ALLOCATABLE and BIND(C) attributes",
6674 : tmp_sym->name, &(tmp_sym->declared_at));
6675 0 : retval = false;
6676 : }
6677 :
6678 : }
6679 :
6680 : /* If it is a BIND(C) function, make sure the return value is a
6681 : scalar value. The previous tests in this function made sure
6682 : the type is interoperable. */
6683 2863 : if (bind_c_function && tmp_sym->as != NULL)
6684 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6685 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6686 :
6687 : /* BIND(C) functions cannot return a character string. */
6688 2705 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6689 116 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6690 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6691 : "type at %L must have length 1", tmp_sym->name,
6692 : &(tmp_sym->declared_at));
6693 : }
6694 :
6695 : /* See if the symbol has been marked as private. If it has, warn if
6696 : there is a binding label with default binding name. */
6697 6869 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6698 11 : && tmp_sym->binding_label
6699 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6700 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6701 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6702 4 : gfc_warning (OPT_Wsurprising,
6703 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6704 : "via its default binding name %qs", tmp_sym->name,
6705 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6706 :
6707 6869 : return retval;
6708 : }
6709 :
6710 :
6711 : /* Set the appropriate fields for a symbol that's been declared as
6712 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6713 : the type is C interoperable. Errors are reported by the functions
6714 : used to set/test these fields. */
6715 :
6716 : static bool
6717 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6718 : {
6719 47 : bool retval = true;
6720 :
6721 : /* TODO: Do we need to make sure the vars aren't marked private? */
6722 :
6723 : /* Set the is_bind_c bit in symbol_attribute. */
6724 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6725 :
6726 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6727 : return false;
6728 :
6729 : return retval;
6730 : }
6731 :
6732 :
6733 : /* Set the fields marking the given common block as BIND(C), including
6734 : a binding label, and report any errors encountered. */
6735 :
6736 : static bool
6737 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6738 : {
6739 76 : bool retval = true;
6740 :
6741 : /* destLabel, common name, typespec (which may have binding label). */
6742 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6743 : num_idents))
6744 : return false;
6745 :
6746 : /* Set the given common block (com_block) to being bind(c) (1). */
6747 76 : set_com_block_bind_c (com_block, 1);
6748 :
6749 76 : return retval;
6750 : }
6751 :
6752 :
6753 : /* Retrieve the list of one or more identifiers that the given bind(c)
6754 : attribute applies to. */
6755 :
6756 : static bool
6757 102 : get_bind_c_idents (void)
6758 : {
6759 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6760 102 : int num_idents = 0;
6761 102 : gfc_symbol *tmp_sym = NULL;
6762 102 : match found_id;
6763 102 : gfc_common_head *com_block = NULL;
6764 :
6765 102 : if (gfc_match_name (name) == MATCH_YES)
6766 : {
6767 38 : found_id = MATCH_YES;
6768 38 : gfc_get_ha_symbol (name, &tmp_sym);
6769 : }
6770 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6771 : {
6772 64 : found_id = MATCH_YES;
6773 64 : com_block = gfc_get_common (name, 0);
6774 : }
6775 : else
6776 : {
6777 0 : gfc_error ("Need either entity or common block name for "
6778 : "attribute specification statement at %C");
6779 0 : return false;
6780 : }
6781 :
6782 : /* Save the current identifier and look for more. */
6783 123 : do
6784 : {
6785 : /* Increment the number of identifiers found for this spec stmt. */
6786 123 : num_idents++;
6787 :
6788 : /* Make sure we have a sym or com block, and verify that it can
6789 : be bind(c). Set the appropriate field(s) and look for more
6790 : identifiers. */
6791 123 : if (tmp_sym != NULL || com_block != NULL)
6792 : {
6793 123 : if (tmp_sym != NULL)
6794 : {
6795 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6796 : return false;
6797 : }
6798 : else
6799 : {
6800 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6801 : return false;
6802 : }
6803 :
6804 : /* Look to see if we have another identifier. */
6805 122 : tmp_sym = NULL;
6806 122 : if (gfc_match_eos () == MATCH_YES)
6807 : found_id = MATCH_NO;
6808 21 : else if (gfc_match_char (',') != MATCH_YES)
6809 : found_id = MATCH_NO;
6810 21 : else if (gfc_match_name (name) == MATCH_YES)
6811 : {
6812 9 : found_id = MATCH_YES;
6813 9 : gfc_get_ha_symbol (name, &tmp_sym);
6814 : }
6815 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6816 : {
6817 12 : found_id = MATCH_YES;
6818 12 : com_block = gfc_get_common (name, 0);
6819 : }
6820 : else
6821 : {
6822 0 : gfc_error ("Missing entity or common block name for "
6823 : "attribute specification statement at %C");
6824 0 : return false;
6825 : }
6826 : }
6827 : else
6828 : {
6829 0 : gfc_internal_error ("Missing symbol");
6830 : }
6831 122 : } while (found_id == MATCH_YES);
6832 :
6833 : /* if we get here we were successful */
6834 : return true;
6835 : }
6836 :
6837 :
6838 : /* Try and match a BIND(C) attribute specification statement. */
6839 :
6840 : match
6841 140 : gfc_match_bind_c_stmt (void)
6842 : {
6843 140 : match found_match = MATCH_NO;
6844 140 : gfc_typespec *ts;
6845 :
6846 140 : ts = ¤t_ts;
6847 :
6848 : /* This may not be necessary. */
6849 140 : gfc_clear_ts (ts);
6850 : /* Clear the temporary binding label holder. */
6851 140 : curr_binding_label = NULL;
6852 :
6853 : /* Look for the bind(c). */
6854 140 : found_match = gfc_match_bind_c (NULL, true);
6855 :
6856 140 : if (found_match == MATCH_YES)
6857 : {
6858 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6859 : return MATCH_ERROR;
6860 :
6861 : /* Look for the :: now, but it is not required. */
6862 102 : gfc_match (" :: ");
6863 :
6864 : /* Get the identifier(s) that needs to be updated. This may need to
6865 : change to hand the flag(s) for the attr specified so all identifiers
6866 : found can have all appropriate parts updated (assuming that the same
6867 : spec stmt can have multiple attrs, such as both bind(c) and
6868 : allocatable...). */
6869 102 : if (!get_bind_c_idents ())
6870 : /* Error message should have printed already. */
6871 : return MATCH_ERROR;
6872 : }
6873 :
6874 : return found_match;
6875 : }
6876 :
6877 :
6878 : /* Match a data declaration statement. */
6879 :
6880 : match
6881 1008453 : gfc_match_data_decl (void)
6882 : {
6883 1008453 : gfc_symbol *sym;
6884 1008453 : match m;
6885 1008453 : int elem;
6886 1008453 : gfc_component *comp_tail = NULL;
6887 :
6888 1008453 : type_param_spec_list = NULL;
6889 1008453 : decl_type_param_list = NULL;
6890 :
6891 1008453 : num_idents_on_line = 0;
6892 :
6893 : /* Record the last component before we start, so that we can roll back
6894 : any components added during this statement on error. PR106946.
6895 : Must be set before any 'goto cleanup' with m == MATCH_ERROR. */
6896 1008453 : if (gfc_comp_struct (gfc_current_state ()))
6897 : {
6898 31117 : gfc_symbol *block = gfc_current_block ();
6899 31117 : if (block)
6900 : {
6901 31117 : comp_tail = block->components;
6902 31117 : if (comp_tail)
6903 32603 : while (comp_tail->next)
6904 : comp_tail = comp_tail->next;
6905 : }
6906 : }
6907 :
6908 1008453 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6909 1008453 : if (m != MATCH_YES)
6910 : return m;
6911 :
6912 211114 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6913 34408 : && !gfc_comp_struct (gfc_current_state ()))
6914 : {
6915 31104 : sym = gfc_use_derived (current_ts.u.derived);
6916 :
6917 31104 : if (sym == NULL)
6918 : {
6919 22 : m = MATCH_ERROR;
6920 22 : goto cleanup;
6921 : }
6922 :
6923 31082 : current_ts.u.derived = sym;
6924 : }
6925 :
6926 211092 : m = match_attr_spec ();
6927 211092 : if (m == MATCH_ERROR)
6928 : {
6929 84 : m = MATCH_NO;
6930 84 : goto cleanup;
6931 : }
6932 :
6933 : /* F2018:C708. */
6934 211008 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6935 : {
6936 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6937 6 : m = MATCH_ERROR;
6938 6 : goto cleanup;
6939 : }
6940 :
6941 211002 : if (current_ts.type == BT_CLASS
6942 10729 : && current_ts.u.derived->attr.unlimited_polymorphic)
6943 1878 : goto ok;
6944 :
6945 209124 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6946 32501 : && current_ts.u.derived->components == NULL
6947 2802 : && !current_ts.u.derived->attr.zero_comp)
6948 : {
6949 :
6950 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6951 136 : goto ok;
6952 :
6953 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6954 47 : goto ok;
6955 :
6956 27 : gfc_find_symbol (current_ts.u.derived->name,
6957 27 : current_ts.u.derived->ns, 1, &sym);
6958 :
6959 : /* Any symbol that we find had better be a type definition
6960 : which has its components defined, or be a structure definition
6961 : actively being parsed. */
6962 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6963 26 : && (current_ts.u.derived->components != NULL
6964 26 : || current_ts.u.derived->attr.zero_comp
6965 26 : || current_ts.u.derived == gfc_new_block))
6966 26 : goto ok;
6967 :
6968 1 : gfc_error ("Derived type at %C has not been previously defined "
6969 : "and so cannot appear in a derived type definition");
6970 1 : m = MATCH_ERROR;
6971 1 : goto cleanup;
6972 : }
6973 :
6974 208914 : ok:
6975 : /* If we have an old-style character declaration, and no new-style
6976 : attribute specifications, then there a comma is optional between
6977 : the type specification and the variable list. */
6978 211001 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6979 1407 : gfc_match_char (',');
6980 :
6981 : /* Give the types/attributes to symbols that follow. Give the element
6982 : a number so that repeat character length expressions can be copied. */
6983 : elem = 1;
6984 275590 : for (;;)
6985 : {
6986 275590 : num_idents_on_line++;
6987 275590 : m = variable_decl (elem++);
6988 275588 : if (m == MATCH_ERROR)
6989 415 : goto cleanup;
6990 275173 : if (m == MATCH_NO)
6991 : break;
6992 :
6993 275162 : if (gfc_match_eos () == MATCH_YES)
6994 210549 : goto cleanup;
6995 64613 : if (gfc_match_char (',') != MATCH_YES)
6996 : break;
6997 : }
6998 :
6999 35 : if (!gfc_error_flag_test ())
7000 : {
7001 : /* An anonymous structure declaration is unambiguous; if we matched one
7002 : according to gfc_match_structure_decl, we need to return MATCH_YES
7003 : here to avoid confusing the remaining matchers, even if there was an
7004 : error during variable_decl. We must flush any such errors. Note this
7005 : causes the parser to gracefully continue parsing the remaining input
7006 : as a structure body, which likely follows. */
7007 11 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
7008 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
7009 : {
7010 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
7011 : " at %C");
7012 : /* Skip the bad variable_decl and line up for the start of the
7013 : structure body. */
7014 1 : gfc_error_recovery ();
7015 1 : m = MATCH_YES;
7016 1 : goto cleanup;
7017 : }
7018 :
7019 10 : gfc_error ("Syntax error in data declaration at %C");
7020 : }
7021 :
7022 34 : m = MATCH_ERROR;
7023 :
7024 34 : gfc_free_data_all (gfc_current_ns);
7025 :
7026 211112 : cleanup:
7027 : /* If we failed inside a derived type definition, remove any CLASS
7028 : components that were added during this failed statement. For CLASS
7029 : components, gfc_build_class_symbol creates an extra container symbol in
7030 : the namespace outside the normal undo machinery. When reject_statement
7031 : later calls gfc_undo_symbols, the declaration state is rolled back but
7032 : that helper symbol survives and leaves the component dangling. Ordinary
7033 : components do not create that extra helper symbol, so leave them in
7034 : place for the usual follow-up diagnostics. PR106946.
7035 :
7036 : CLASS containers are shared between components of the same class type
7037 : and attributes (gfc_build_class_symbol reuses existing containers).
7038 : We must not free a container that is still referenced by a previously
7039 : committed component. Unlink and free the components first, then clean
7040 : up only orphaned containers. PR124482. */
7041 211112 : if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
7042 : {
7043 86 : gfc_symbol *block = gfc_current_block ();
7044 86 : if (block)
7045 : {
7046 86 : gfc_component **prev;
7047 86 : if (comp_tail)
7048 43 : prev = &comp_tail->next;
7049 : else
7050 43 : prev = &block->components;
7051 :
7052 : /* Record the CLASS container from the removed components.
7053 : Normally all components in one declaration share a single
7054 : container, but per-variable array specs can produce
7055 : additional ones; any beyond the first are harmlessly
7056 : leaked until namespace destruction. */
7057 86 : gfc_symbol *fclass_container = NULL;
7058 :
7059 120 : while (*prev)
7060 : {
7061 34 : gfc_component *c = *prev;
7062 34 : if (c->ts.type == BT_CLASS && c->ts.u.derived
7063 6 : && c->ts.u.derived->attr.is_class)
7064 : {
7065 3 : *prev = c->next;
7066 3 : if (!fclass_container)
7067 3 : fclass_container = c->ts.u.derived;
7068 3 : c->ts.u.derived = NULL;
7069 3 : gfc_free_component (c);
7070 : }
7071 : else
7072 31 : prev = &c->next;
7073 : }
7074 :
7075 : /* Free the container only if no remaining component still
7076 : references it. CLASS containers are shared between
7077 : components of the same class type and attributes
7078 : (gfc_build_class_symbol reuses existing ones). */
7079 86 : if (fclass_container)
7080 : {
7081 3 : bool shared = false;
7082 3 : for (gfc_component *q = block->components; q; q = q->next)
7083 1 : if (q->ts.type == BT_CLASS
7084 1 : && q->ts.u.derived == fclass_container)
7085 : {
7086 : shared = true;
7087 : break;
7088 : }
7089 3 : if (!shared)
7090 : {
7091 2 : if (gfc_find_symtree (fclass_container->ns->sym_root,
7092 : fclass_container->name))
7093 2 : gfc_delete_symtree (&fclass_container->ns->sym_root,
7094 : fclass_container->name);
7095 2 : gfc_release_symbol (fclass_container);
7096 : }
7097 : }
7098 : }
7099 : }
7100 :
7101 211112 : if (saved_kind_expr)
7102 174 : gfc_free_expr (saved_kind_expr);
7103 211112 : if (type_param_spec_list)
7104 924 : gfc_free_actual_arglist (type_param_spec_list);
7105 211112 : if (decl_type_param_list)
7106 893 : gfc_free_actual_arglist (decl_type_param_list);
7107 211112 : saved_kind_expr = NULL;
7108 211112 : gfc_free_array_spec (current_as);
7109 211112 : current_as = NULL;
7110 211112 : return m;
7111 : }
7112 :
7113 : static bool
7114 23888 : in_module_or_interface(void)
7115 : {
7116 23888 : if (gfc_current_state () == COMP_MODULE
7117 23888 : || gfc_current_state () == COMP_SUBMODULE
7118 23888 : || gfc_current_state () == COMP_INTERFACE)
7119 : return true;
7120 :
7121 19998 : if (gfc_state_stack->state == COMP_CONTAINS
7122 19191 : || gfc_state_stack->state == COMP_FUNCTION
7123 19088 : || gfc_state_stack->state == COMP_SUBROUTINE)
7124 : {
7125 910 : gfc_state_data *p;
7126 953 : for (p = gfc_state_stack->previous; p ; p = p->previous)
7127 : {
7128 949 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
7129 115 : || p->state == COMP_INTERFACE)
7130 : return true;
7131 : }
7132 : }
7133 : return false;
7134 : }
7135 :
7136 : /* Match a prefix associated with a function or subroutine
7137 : declaration. If the typespec pointer is nonnull, then a typespec
7138 : can be matched. Note that if nothing matches, MATCH_YES is
7139 : returned (the null string was matched). */
7140 :
7141 : match
7142 236943 : gfc_match_prefix (gfc_typespec *ts)
7143 : {
7144 236943 : bool seen_type;
7145 236943 : bool seen_impure;
7146 236943 : bool found_prefix;
7147 :
7148 236943 : gfc_clear_attr (¤t_attr);
7149 236943 : seen_type = false;
7150 236943 : seen_impure = false;
7151 :
7152 236943 : gcc_assert (!gfc_matching_prefix);
7153 236943 : gfc_matching_prefix = true;
7154 :
7155 246482 : do
7156 : {
7157 265874 : found_prefix = false;
7158 :
7159 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7160 : corresponding attribute seems natural and distinguishes these
7161 : procedures from procedure types of PROC_MODULE, which these are
7162 : as well. */
7163 265874 : if (gfc_match ("module% ") == MATCH_YES)
7164 : {
7165 24163 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7166 275 : goto error;
7167 :
7168 23888 : if (!in_module_or_interface ())
7169 : {
7170 19092 : gfc_error ("MODULE prefix at %C found outside of a module, "
7171 : "submodule, or interface");
7172 19092 : goto error;
7173 : }
7174 :
7175 4796 : current_attr.module_procedure = 1;
7176 4796 : found_prefix = true;
7177 : }
7178 :
7179 246507 : if (!seen_type && ts != NULL)
7180 : {
7181 132584 : match m;
7182 132584 : m = gfc_match_decl_type_spec (ts, 0);
7183 132584 : if (m == MATCH_ERROR)
7184 15 : goto error;
7185 132569 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7186 : {
7187 : seen_type = true;
7188 : found_prefix = true;
7189 : }
7190 : }
7191 :
7192 246492 : if (gfc_match ("elemental% ") == MATCH_YES)
7193 : {
7194 5229 : if (!gfc_add_elemental (¤t_attr, NULL))
7195 2 : goto error;
7196 :
7197 : found_prefix = true;
7198 : }
7199 :
7200 246490 : if (gfc_match ("pure% ") == MATCH_YES)
7201 : {
7202 2375 : if (!gfc_add_pure (¤t_attr, NULL))
7203 2 : goto error;
7204 :
7205 : found_prefix = true;
7206 : }
7207 :
7208 246488 : if (gfc_match ("recursive% ") == MATCH_YES)
7209 : {
7210 469 : if (!gfc_add_recursive (¤t_attr, NULL))
7211 2 : goto error;
7212 :
7213 : found_prefix = true;
7214 : }
7215 :
7216 : /* IMPURE is a somewhat special case, as it needs not set an actual
7217 : attribute but rather only prevents ELEMENTAL routines from being
7218 : automatically PURE. */
7219 246486 : if (gfc_match ("impure% ") == MATCH_YES)
7220 : {
7221 681 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7222 4 : goto error;
7223 :
7224 : seen_impure = true;
7225 : found_prefix = true;
7226 : }
7227 : }
7228 : while (found_prefix);
7229 :
7230 : /* IMPURE and PURE must not both appear, of course. */
7231 217551 : if (seen_impure && current_attr.pure)
7232 : {
7233 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7234 4 : goto error;
7235 : }
7236 :
7237 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7238 216874 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7239 : {
7240 4570 : if (!gfc_add_pure (¤t_attr, NULL))
7241 0 : goto error;
7242 : }
7243 :
7244 : /* At this point, the next item is not a prefix. */
7245 217547 : gcc_assert (gfc_matching_prefix);
7246 :
7247 217547 : gfc_matching_prefix = false;
7248 217547 : return MATCH_YES;
7249 :
7250 19396 : error:
7251 19396 : gcc_assert (gfc_matching_prefix);
7252 19396 : gfc_matching_prefix = false;
7253 19396 : return MATCH_ERROR;
7254 : }
7255 :
7256 :
7257 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7258 :
7259 : static bool
7260 61677 : copy_prefix (symbol_attribute *dest, locus *where)
7261 : {
7262 61677 : if (dest->module_procedure)
7263 : {
7264 674 : if (current_attr.elemental)
7265 13 : dest->elemental = 1;
7266 :
7267 674 : if (current_attr.pure)
7268 61 : dest->pure = 1;
7269 :
7270 674 : if (current_attr.recursive)
7271 8 : dest->recursive = 1;
7272 :
7273 : /* Module procedures are unusual in that the 'dest' is copied from
7274 : the interface declaration. However, this is an oportunity to
7275 : check that the submodule declaration is compliant with the
7276 : interface. */
7277 674 : if (dest->elemental && !current_attr.elemental)
7278 : {
7279 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7280 : "missing at %L", where);
7281 1 : return false;
7282 : }
7283 :
7284 673 : if (dest->pure && !current_attr.pure)
7285 : {
7286 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7287 : "missing at %L", where);
7288 1 : return false;
7289 : }
7290 :
7291 672 : if (dest->recursive && !current_attr.recursive)
7292 : {
7293 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7294 : "missing at %L", where);
7295 1 : return false;
7296 : }
7297 :
7298 : return true;
7299 : }
7300 :
7301 61003 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7302 : return false;
7303 :
7304 61001 : if (current_attr.pure && !gfc_add_pure (dest, where))
7305 : return false;
7306 :
7307 61001 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7308 : return false;
7309 :
7310 : return true;
7311 : }
7312 :
7313 :
7314 : /* Match a formal argument list or, if typeparam is true, a
7315 : type_param_name_list. */
7316 :
7317 : match
7318 476249 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7319 : int null_flag, bool typeparam)
7320 : {
7321 476249 : gfc_formal_arglist *head, *tail, *p, *q;
7322 476249 : char name[GFC_MAX_SYMBOL_LEN + 1];
7323 476249 : gfc_symbol *sym;
7324 476249 : match m;
7325 476249 : gfc_formal_arglist *formal = NULL;
7326 :
7327 476249 : head = tail = NULL;
7328 :
7329 : /* Keep the interface formal argument list and null it so that the
7330 : matching for the new declaration can be done. The numbers and
7331 : names of the arguments are checked here. The interface formal
7332 : arguments are retained in formal_arglist and the characteristics
7333 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7334 : in get_proc_name about the eventual need to copy the formal_arglist
7335 : and populate the formal namespace of the interface symbol. */
7336 476249 : if (progname->attr.module_procedure
7337 678 : && progname->attr.host_assoc)
7338 : {
7339 180 : formal = progname->formal;
7340 180 : progname->formal = NULL;
7341 : }
7342 :
7343 476249 : if (gfc_match_char ('(') != MATCH_YES)
7344 : {
7345 282190 : if (null_flag)
7346 6425 : goto ok;
7347 : return MATCH_NO;
7348 : }
7349 :
7350 194059 : if (gfc_match_char (')') == MATCH_YES)
7351 : {
7352 10356 : if (typeparam)
7353 : {
7354 1 : gfc_error_now ("A type parameter list is required at %C");
7355 1 : m = MATCH_ERROR;
7356 1 : goto cleanup;
7357 : }
7358 : else
7359 10355 : goto ok;
7360 : }
7361 :
7362 245035 : for (;;)
7363 : {
7364 245035 : gfc_gobble_whitespace ();
7365 245035 : if (gfc_match_char ('*') == MATCH_YES)
7366 : {
7367 10281 : sym = NULL;
7368 10281 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7369 : "Alternate-return argument at %C"))
7370 : {
7371 1 : m = MATCH_ERROR;
7372 1 : goto cleanup;
7373 : }
7374 10280 : else if (typeparam)
7375 2 : gfc_error_now ("A parameter name is required at %C");
7376 : }
7377 : else
7378 : {
7379 234754 : locus loc = gfc_current_locus;
7380 234754 : m = gfc_match_name (name);
7381 234754 : if (m != MATCH_YES)
7382 : {
7383 15917 : if(typeparam)
7384 1 : gfc_error_now ("A parameter name is required at %C");
7385 15933 : goto cleanup;
7386 : }
7387 218837 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7388 :
7389 218837 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7390 16 : goto cleanup;
7391 218821 : else if (typeparam
7392 218821 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7393 0 : goto cleanup;
7394 : }
7395 :
7396 229101 : p = gfc_get_formal_arglist ();
7397 :
7398 229101 : if (head == NULL)
7399 : head = tail = p;
7400 : else
7401 : {
7402 60629 : tail->next = p;
7403 60629 : tail = p;
7404 : }
7405 :
7406 229101 : tail->sym = sym;
7407 :
7408 : /* We don't add the VARIABLE flavor because the name could be a
7409 : dummy procedure. We don't apply these attributes to formal
7410 : arguments of statement functions. */
7411 218821 : if (sym != NULL && !st_flag
7412 328008 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7413 98907 : || !gfc_missing_attr (&sym->attr, NULL)))
7414 : {
7415 0 : m = MATCH_ERROR;
7416 0 : goto cleanup;
7417 : }
7418 :
7419 : /* The name of a program unit can be in a different namespace,
7420 : so check for it explicitly. After the statement is accepted,
7421 : the name is checked for especially in gfc_get_symbol(). */
7422 229101 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7423 97663 : && strcmp (sym->name, gfc_new_block->name) == 0)
7424 : {
7425 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7426 : sym->name);
7427 0 : m = MATCH_ERROR;
7428 0 : goto cleanup;
7429 : }
7430 :
7431 229101 : if (gfc_match_char (')') == MATCH_YES)
7432 120598 : goto ok;
7433 :
7434 108503 : m = gfc_match_char (',');
7435 108503 : if (m != MATCH_YES)
7436 : {
7437 47171 : if (typeparam)
7438 1 : gfc_error_now ("Expected parameter list in type declaration "
7439 : "at %C");
7440 : else
7441 47170 : gfc_error ("Unexpected junk in formal argument list at %C");
7442 47171 : goto cleanup;
7443 : }
7444 : }
7445 :
7446 137378 : ok:
7447 : /* Check for duplicate symbols in the formal argument list. */
7448 137378 : if (head != NULL)
7449 : {
7450 179607 : for (p = head; p->next; p = p->next)
7451 : {
7452 59057 : if (p->sym == NULL)
7453 327 : continue;
7454 :
7455 234270 : for (q = p->next; q; q = q->next)
7456 175588 : if (p->sym == q->sym)
7457 : {
7458 48 : if (typeparam)
7459 1 : gfc_error_now ("Duplicate name %qs in parameter "
7460 : "list at %C", p->sym->name);
7461 : else
7462 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7463 : "list at %C", p->sym->name);
7464 :
7465 48 : m = MATCH_ERROR;
7466 48 : goto cleanup;
7467 : }
7468 : }
7469 : }
7470 :
7471 137330 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7472 : {
7473 0 : m = MATCH_ERROR;
7474 0 : goto cleanup;
7475 : }
7476 :
7477 : /* gfc_error_now used in following and return with MATCH_YES because
7478 : doing otherwise results in a cascade of extraneous errors and in
7479 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7480 137330 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7481 : {
7482 179 : bool arg_count_mismatch = false;
7483 :
7484 179 : if (!formal && head)
7485 : arg_count_mismatch = true;
7486 :
7487 : /* Abbreviated module procedure declaration is not meant to have any
7488 : formal arguments! */
7489 179 : if (!progname->abr_modproc_decl && formal && !head)
7490 1 : arg_count_mismatch = true;
7491 :
7492 349 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7493 : {
7494 170 : if ((p->next != NULL && q->next == NULL)
7495 169 : || (p->next == NULL && q->next != NULL))
7496 : arg_count_mismatch = true;
7497 168 : else if ((p->sym == NULL && q->sym == NULL)
7498 168 : || (p->sym && q->sym
7499 166 : && strcmp (p->sym->name, q->sym->name) == 0))
7500 164 : continue;
7501 : else
7502 : {
7503 4 : if (q->sym == NULL)
7504 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7505 : "conflicts with alternate return at %C",
7506 : p->sym->name);
7507 3 : else if (p->sym == NULL)
7508 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7509 : "alternate return and conflicts with "
7510 : "%qs in the separate declaration at %C",
7511 : q->sym->name);
7512 : else
7513 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7514 : "argument names (%s/%s) at %C",
7515 : p->sym->name, q->sym->name);
7516 : }
7517 : }
7518 :
7519 179 : if (arg_count_mismatch)
7520 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7521 : "formal arguments at %C");
7522 : }
7523 :
7524 : return MATCH_YES;
7525 :
7526 63154 : cleanup:
7527 63154 : gfc_free_formal_arglist (head);
7528 63154 : return m;
7529 : }
7530 :
7531 :
7532 : /* Match a RESULT specification following a function declaration or
7533 : ENTRY statement. Also matches the end-of-statement. */
7534 :
7535 : static match
7536 8022 : match_result (gfc_symbol *function, gfc_symbol **result)
7537 : {
7538 8022 : char name[GFC_MAX_SYMBOL_LEN + 1];
7539 8022 : gfc_symbol *r;
7540 8022 : match m;
7541 :
7542 8022 : if (gfc_match (" result (") != MATCH_YES)
7543 : return MATCH_NO;
7544 :
7545 5906 : m = gfc_match_name (name);
7546 5906 : if (m != MATCH_YES)
7547 : return m;
7548 :
7549 : /* Get the right paren, and that's it because there could be the
7550 : bind(c) attribute after the result clause. */
7551 5906 : if (gfc_match_char (')') != MATCH_YES)
7552 : {
7553 : /* TODO: should report the missing right paren here. */
7554 : return MATCH_ERROR;
7555 : }
7556 :
7557 5906 : if (strcmp (function->name, name) == 0)
7558 : {
7559 1 : gfc_error ("RESULT variable at %C must be different than function name");
7560 1 : return MATCH_ERROR;
7561 : }
7562 :
7563 5905 : if (gfc_get_symbol (name, NULL, &r))
7564 : return MATCH_ERROR;
7565 :
7566 5905 : if (!gfc_add_result (&r->attr, r->name, NULL))
7567 : return MATCH_ERROR;
7568 :
7569 5905 : *result = r;
7570 :
7571 5905 : return MATCH_YES;
7572 : }
7573 :
7574 :
7575 : /* Match a function suffix, which could be a combination of a result
7576 : clause and BIND(C), either one, or neither. The draft does not
7577 : require them to come in a specific order. */
7578 :
7579 : static match
7580 8026 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7581 : {
7582 8026 : match is_bind_c; /* Found bind(c). */
7583 8026 : match is_result; /* Found result clause. */
7584 8026 : match found_match; /* Status of whether we've found a good match. */
7585 8026 : char peek_char; /* Character we're going to peek at. */
7586 8026 : bool allow_binding_name;
7587 :
7588 : /* Initialize to having found nothing. */
7589 8026 : found_match = MATCH_NO;
7590 8026 : is_bind_c = MATCH_NO;
7591 8026 : is_result = MATCH_NO;
7592 :
7593 : /* Get the next char to narrow between result and bind(c). */
7594 8026 : gfc_gobble_whitespace ();
7595 8026 : peek_char = gfc_peek_ascii_char ();
7596 :
7597 : /* C binding names are not allowed for internal procedures. */
7598 8026 : if (gfc_current_state () == COMP_CONTAINS
7599 4670 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7600 : allow_binding_name = false;
7601 : else
7602 6363 : allow_binding_name = true;
7603 :
7604 8026 : switch (peek_char)
7605 : {
7606 5535 : case 'r':
7607 : /* Look for result clause. */
7608 5535 : is_result = match_result (sym, result);
7609 5535 : if (is_result == MATCH_YES)
7610 : {
7611 : /* Now see if there is a bind(c) after it. */
7612 5534 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7613 : /* We've found the result clause and possibly bind(c). */
7614 5534 : found_match = MATCH_YES;
7615 : }
7616 : else
7617 : /* This should only be MATCH_ERROR. */
7618 : found_match = is_result;
7619 : break;
7620 2491 : case 'b':
7621 : /* Look for bind(c) first. */
7622 2491 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7623 2491 : if (is_bind_c == MATCH_YES)
7624 : {
7625 : /* Now see if a result clause followed it. */
7626 2487 : is_result = match_result (sym, result);
7627 2487 : found_match = MATCH_YES;
7628 : }
7629 : else
7630 : {
7631 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7632 : found_match = MATCH_ERROR;
7633 : }
7634 : break;
7635 0 : default:
7636 0 : gfc_error ("Unexpected junk after function declaration at %C");
7637 0 : found_match = MATCH_ERROR;
7638 0 : break;
7639 : }
7640 :
7641 8021 : if (is_bind_c == MATCH_YES)
7642 : {
7643 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7644 2649 : if (gfc_current_state () == COMP_CONTAINS
7645 423 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7646 2667 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7647 : "at %L may not be specified for an internal "
7648 : "procedure", &gfc_current_locus))
7649 : return MATCH_ERROR;
7650 :
7651 2646 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7652 : return MATCH_ERROR;
7653 : }
7654 :
7655 : return found_match;
7656 : }
7657 :
7658 :
7659 : /* Procedure pointer return value without RESULT statement:
7660 : Add "hidden" result variable named "ppr@". */
7661 :
7662 : static bool
7663 73163 : add_hidden_procptr_result (gfc_symbol *sym)
7664 : {
7665 73163 : bool case1,case2;
7666 :
7667 73163 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7668 : return false;
7669 :
7670 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7671 1520 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7672 1520 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7673 73549 : && sym->attr.external;
7674 : /* Second usage case: INTERFACE statements. */
7675 14027 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7676 14027 : && gfc_state_stack->previous->state == COMP_FUNCTION
7677 73210 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7678 :
7679 72979 : if (case1 || case2)
7680 : {
7681 124 : gfc_symtree *stree;
7682 124 : if (case1)
7683 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7684 : else
7685 : {
7686 30 : gfc_symtree *st2;
7687 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7688 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7689 30 : st2->n.sym = stree->n.sym;
7690 30 : stree->n.sym->refs++;
7691 : }
7692 124 : sym->result = stree->n.sym;
7693 :
7694 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7695 124 : sym->result->attr.pointer = sym->attr.pointer;
7696 124 : sym->result->attr.external = sym->attr.external;
7697 124 : sym->result->attr.referenced = sym->attr.referenced;
7698 124 : sym->result->ts = sym->ts;
7699 124 : sym->attr.proc_pointer = 0;
7700 124 : sym->attr.pointer = 0;
7701 124 : sym->attr.external = 0;
7702 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7703 : {
7704 4 : sym->result->attr.pointer = 0;
7705 4 : sym->result->attr.proc_pointer = 1;
7706 : }
7707 :
7708 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7709 : }
7710 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7711 72885 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7712 399 : && sym->result && sym->result != sym && sym->result->attr.external
7713 28 : && sym == gfc_current_ns->proc_name
7714 28 : && sym == sym->result->ns->proc_name
7715 28 : && strcmp ("ppr@", sym->result->name) == 0)
7716 : {
7717 28 : sym->result->attr.proc_pointer = 1;
7718 28 : sym->attr.pointer = 0;
7719 28 : return true;
7720 : }
7721 : else
7722 : return false;
7723 : }
7724 :
7725 :
7726 : /* Match the interface for a PROCEDURE declaration,
7727 : including brackets (R1212). */
7728 :
7729 : static match
7730 1597 : match_procedure_interface (gfc_symbol **proc_if)
7731 : {
7732 1597 : match m;
7733 1597 : gfc_symtree *st;
7734 1597 : locus old_loc, entry_loc;
7735 1597 : gfc_namespace *old_ns = gfc_current_ns;
7736 1597 : char name[GFC_MAX_SYMBOL_LEN + 1];
7737 :
7738 1597 : old_loc = entry_loc = gfc_current_locus;
7739 1597 : gfc_clear_ts (¤t_ts);
7740 :
7741 1597 : if (gfc_match (" (") != MATCH_YES)
7742 : {
7743 1 : gfc_current_locus = entry_loc;
7744 1 : return MATCH_NO;
7745 : }
7746 :
7747 : /* Get the type spec. for the procedure interface. */
7748 1596 : old_loc = gfc_current_locus;
7749 1596 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7750 1596 : gfc_gobble_whitespace ();
7751 1596 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7752 395 : goto got_ts;
7753 :
7754 1201 : if (m == MATCH_ERROR)
7755 : return m;
7756 :
7757 : /* Procedure interface is itself a procedure. */
7758 1201 : gfc_current_locus = old_loc;
7759 1201 : m = gfc_match_name (name);
7760 :
7761 : /* First look to see if it is already accessible in the current
7762 : namespace because it is use associated or contained. */
7763 1201 : st = NULL;
7764 1201 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7765 : return MATCH_ERROR;
7766 :
7767 : /* If it is still not found, then try the parent namespace, if it
7768 : exists and create the symbol there if it is still not found. */
7769 1201 : if (gfc_current_ns->parent)
7770 415 : gfc_current_ns = gfc_current_ns->parent;
7771 1201 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7772 : return MATCH_ERROR;
7773 :
7774 1201 : gfc_current_ns = old_ns;
7775 1201 : *proc_if = st->n.sym;
7776 :
7777 1201 : if (*proc_if)
7778 : {
7779 1201 : (*proc_if)->refs++;
7780 : /* Resolve interface if possible. That way, attr.procedure is only set
7781 : if it is declared by a later procedure-declaration-stmt, which is
7782 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7783 1201 : while ((*proc_if)->ts.interface
7784 1208 : && *proc_if != (*proc_if)->ts.interface)
7785 7 : *proc_if = (*proc_if)->ts.interface;
7786 :
7787 1201 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7788 388 : && (*proc_if)->ts.type == BT_UNKNOWN
7789 1589 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7790 : (*proc_if)->name, NULL))
7791 : return MATCH_ERROR;
7792 : }
7793 :
7794 0 : got_ts:
7795 1596 : if (gfc_match (" )") != MATCH_YES)
7796 : {
7797 0 : gfc_current_locus = entry_loc;
7798 0 : return MATCH_NO;
7799 : }
7800 :
7801 : return MATCH_YES;
7802 : }
7803 :
7804 :
7805 : /* Match a PROCEDURE declaration (R1211). */
7806 :
7807 : static match
7808 1170 : match_procedure_decl (void)
7809 : {
7810 1170 : match m;
7811 1170 : gfc_symbol *sym, *proc_if = NULL;
7812 1170 : int num;
7813 1170 : gfc_expr *initializer = NULL;
7814 :
7815 : /* Parse interface (with brackets). */
7816 1170 : m = match_procedure_interface (&proc_if);
7817 1170 : if (m != MATCH_YES)
7818 : return m;
7819 :
7820 : /* Parse attributes (with colons). */
7821 1170 : m = match_attr_spec();
7822 1170 : if (m == MATCH_ERROR)
7823 : return MATCH_ERROR;
7824 :
7825 1169 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7826 : {
7827 53 : current_attr.is_bind_c = 1;
7828 53 : has_name_equals = 0;
7829 53 : curr_binding_label = NULL;
7830 : }
7831 :
7832 : /* Get procedure symbols. */
7833 79 : for(num=1;;num++)
7834 : {
7835 1248 : m = gfc_match_symbol (&sym, 0);
7836 1248 : if (m == MATCH_NO)
7837 1 : goto syntax;
7838 1247 : else if (m == MATCH_ERROR)
7839 : return m;
7840 :
7841 : /* Add current_attr to the symbol attributes. */
7842 1247 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7843 : return MATCH_ERROR;
7844 :
7845 1245 : if (sym->attr.is_bind_c)
7846 : {
7847 : /* Check for C1218. */
7848 90 : if (!proc_if || !proc_if->attr.is_bind_c)
7849 : {
7850 1 : gfc_error ("BIND(C) attribute at %C requires "
7851 : "an interface with BIND(C)");
7852 1 : return MATCH_ERROR;
7853 : }
7854 : /* Check for C1217. */
7855 89 : if (has_name_equals && sym->attr.pointer)
7856 : {
7857 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7858 : "POINTER attribute at %C");
7859 1 : return MATCH_ERROR;
7860 : }
7861 88 : if (has_name_equals && sym->attr.dummy)
7862 : {
7863 1 : gfc_error ("Dummy procedure at %C may not have "
7864 : "BIND(C) attribute with NAME");
7865 1 : return MATCH_ERROR;
7866 : }
7867 : /* Set binding label for BIND(C). */
7868 87 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7869 : return MATCH_ERROR;
7870 : }
7871 :
7872 1241 : if (!gfc_add_external (&sym->attr, NULL))
7873 : return MATCH_ERROR;
7874 :
7875 1237 : if (add_hidden_procptr_result (sym))
7876 67 : sym = sym->result;
7877 :
7878 1237 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7879 : return MATCH_ERROR;
7880 :
7881 : /* Set interface. */
7882 1236 : if (proc_if != NULL)
7883 : {
7884 893 : if (sym->ts.type != BT_UNKNOWN)
7885 : {
7886 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7887 : sym->name, &gfc_current_locus,
7888 : gfc_basic_typename (sym->ts.type));
7889 1 : return MATCH_ERROR;
7890 : }
7891 892 : sym->ts.interface = proc_if;
7892 892 : sym->attr.untyped = 1;
7893 892 : sym->attr.if_source = IFSRC_IFBODY;
7894 : }
7895 343 : else if (current_ts.type != BT_UNKNOWN)
7896 : {
7897 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7898 : return MATCH_ERROR;
7899 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7900 198 : sym->ts.interface->ts = current_ts;
7901 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7902 198 : sym->ts.interface->attr.function = 1;
7903 198 : sym->attr.function = 1;
7904 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7905 : }
7906 :
7907 1234 : if (gfc_match (" =>") == MATCH_YES)
7908 : {
7909 103 : if (!current_attr.pointer)
7910 : {
7911 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7912 0 : m = MATCH_ERROR;
7913 0 : goto cleanup;
7914 : }
7915 :
7916 103 : m = match_pointer_init (&initializer, 1);
7917 103 : if (m != MATCH_YES)
7918 1 : goto cleanup;
7919 :
7920 102 : if (!add_init_expr_to_sym (sym->name, &initializer,
7921 : &gfc_current_locus,
7922 : gfc_current_ns->cl_list))
7923 0 : goto cleanup;
7924 :
7925 : }
7926 :
7927 1233 : if (gfc_match_eos () == MATCH_YES)
7928 : return MATCH_YES;
7929 79 : if (gfc_match_char (',') != MATCH_YES)
7930 0 : goto syntax;
7931 : }
7932 :
7933 1 : syntax:
7934 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7935 1 : return MATCH_ERROR;
7936 :
7937 1 : cleanup:
7938 : /* Free stuff up and return. */
7939 1 : gfc_free_expr (initializer);
7940 1 : return m;
7941 : }
7942 :
7943 :
7944 : static match
7945 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7946 :
7947 :
7948 : /* Match a procedure pointer component declaration (R445). */
7949 :
7950 : static match
7951 427 : match_ppc_decl (void)
7952 : {
7953 427 : match m;
7954 427 : gfc_symbol *proc_if = NULL;
7955 427 : gfc_typespec ts;
7956 427 : int num;
7957 427 : gfc_component *c;
7958 427 : gfc_expr *initializer = NULL;
7959 427 : gfc_typebound_proc* tb;
7960 427 : char name[GFC_MAX_SYMBOL_LEN + 1];
7961 :
7962 : /* Parse interface (with brackets). */
7963 427 : m = match_procedure_interface (&proc_if);
7964 427 : if (m != MATCH_YES)
7965 1 : goto syntax;
7966 :
7967 : /* Parse attributes. */
7968 426 : tb = XCNEW (gfc_typebound_proc);
7969 426 : tb->where = gfc_current_locus;
7970 426 : m = match_binding_attributes (tb, false, true);
7971 426 : if (m == MATCH_ERROR)
7972 : return m;
7973 :
7974 423 : gfc_clear_attr (¤t_attr);
7975 423 : current_attr.procedure = 1;
7976 423 : current_attr.proc_pointer = 1;
7977 423 : current_attr.access = tb->access;
7978 423 : current_attr.flavor = FL_PROCEDURE;
7979 :
7980 : /* Match the colons (required). */
7981 423 : if (gfc_match (" ::") != MATCH_YES)
7982 : {
7983 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7984 1 : return MATCH_ERROR;
7985 : }
7986 :
7987 : /* Check for C450. */
7988 422 : if (!tb->nopass && proc_if == NULL)
7989 : {
7990 2 : gfc_error("NOPASS or explicit interface required at %C");
7991 2 : return MATCH_ERROR;
7992 : }
7993 :
7994 420 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7995 : return MATCH_ERROR;
7996 :
7997 : /* Match PPC names. */
7998 419 : ts = current_ts;
7999 419 : for(num=1;;num++)
8000 : {
8001 420 : m = gfc_match_name (name);
8002 420 : if (m == MATCH_NO)
8003 0 : goto syntax;
8004 420 : else if (m == MATCH_ERROR)
8005 : return m;
8006 :
8007 420 : if (!gfc_add_component (gfc_current_block(), name, &c))
8008 : return MATCH_ERROR;
8009 :
8010 : /* Add current_attr to the symbol attributes. */
8011 420 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
8012 : return MATCH_ERROR;
8013 :
8014 420 : if (!gfc_add_external (&c->attr, NULL))
8015 : return MATCH_ERROR;
8016 :
8017 420 : if (!gfc_add_proc (&c->attr, name, NULL))
8018 : return MATCH_ERROR;
8019 :
8020 420 : if (num == 1)
8021 419 : c->tb = tb;
8022 : else
8023 : {
8024 1 : c->tb = XCNEW (gfc_typebound_proc);
8025 1 : c->tb->where = gfc_current_locus;
8026 1 : *c->tb = *tb;
8027 : }
8028 :
8029 420 : if (saved_kind_expr)
8030 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
8031 :
8032 : /* Set interface. */
8033 420 : if (proc_if != NULL)
8034 : {
8035 353 : c->ts.interface = proc_if;
8036 353 : c->attr.untyped = 1;
8037 353 : c->attr.if_source = IFSRC_IFBODY;
8038 : }
8039 67 : else if (ts.type != BT_UNKNOWN)
8040 : {
8041 29 : c->ts = ts;
8042 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
8043 29 : c->ts.interface->result = c->ts.interface;
8044 29 : c->ts.interface->ts = ts;
8045 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
8046 29 : c->ts.interface->attr.function = 1;
8047 29 : c->attr.function = 1;
8048 29 : c->attr.if_source = IFSRC_UNKNOWN;
8049 : }
8050 :
8051 420 : if (gfc_match (" =>") == MATCH_YES)
8052 : {
8053 67 : m = match_pointer_init (&initializer, 1);
8054 67 : if (m != MATCH_YES)
8055 : {
8056 0 : gfc_free_expr (initializer);
8057 0 : return m;
8058 : }
8059 67 : c->initializer = initializer;
8060 : }
8061 :
8062 420 : if (gfc_match_eos () == MATCH_YES)
8063 : return MATCH_YES;
8064 1 : if (gfc_match_char (',') != MATCH_YES)
8065 0 : goto syntax;
8066 : }
8067 :
8068 1 : syntax:
8069 1 : gfc_error ("Syntax error in procedure pointer component at %C");
8070 1 : return MATCH_ERROR;
8071 : }
8072 :
8073 :
8074 : /* Match a PROCEDURE declaration inside an interface (R1206). */
8075 :
8076 : static match
8077 1561 : match_procedure_in_interface (void)
8078 : {
8079 1561 : match m;
8080 1561 : gfc_symbol *sym;
8081 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
8082 1561 : locus old_locus;
8083 :
8084 1561 : if (current_interface.type == INTERFACE_NAMELESS
8085 1561 : || current_interface.type == INTERFACE_ABSTRACT)
8086 : {
8087 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
8088 1 : return MATCH_ERROR;
8089 : }
8090 :
8091 : /* Check if the F2008 optional double colon appears. */
8092 1560 : gfc_gobble_whitespace ();
8093 1560 : old_locus = gfc_current_locus;
8094 1560 : if (gfc_match ("::") == MATCH_YES)
8095 : {
8096 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8097 : "MODULE PROCEDURE statement at %L", &old_locus))
8098 : return MATCH_ERROR;
8099 : }
8100 : else
8101 685 : gfc_current_locus = old_locus;
8102 :
8103 2214 : for(;;)
8104 : {
8105 2214 : m = gfc_match_name (name);
8106 2214 : if (m == MATCH_NO)
8107 0 : goto syntax;
8108 2214 : else if (m == MATCH_ERROR)
8109 : return m;
8110 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
8111 : return MATCH_ERROR;
8112 :
8113 2214 : if (!gfc_add_interface (sym))
8114 : return MATCH_ERROR;
8115 :
8116 2213 : if (gfc_match_eos () == MATCH_YES)
8117 : break;
8118 655 : if (gfc_match_char (',') != MATCH_YES)
8119 0 : goto syntax;
8120 : }
8121 :
8122 : return MATCH_YES;
8123 :
8124 0 : syntax:
8125 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8126 0 : return MATCH_ERROR;
8127 : }
8128 :
8129 :
8130 : /* General matcher for PROCEDURE declarations. */
8131 :
8132 : static match match_procedure_in_type (void);
8133 :
8134 : match
8135 6323 : gfc_match_procedure (void)
8136 : {
8137 6323 : match m;
8138 :
8139 6323 : switch (gfc_current_state ())
8140 : {
8141 1170 : case COMP_NONE:
8142 1170 : case COMP_PROGRAM:
8143 1170 : case COMP_MODULE:
8144 1170 : case COMP_SUBMODULE:
8145 1170 : case COMP_SUBROUTINE:
8146 1170 : case COMP_FUNCTION:
8147 1170 : case COMP_BLOCK:
8148 1170 : m = match_procedure_decl ();
8149 1170 : break;
8150 1561 : case COMP_INTERFACE:
8151 1561 : m = match_procedure_in_interface ();
8152 1561 : break;
8153 427 : case COMP_DERIVED:
8154 427 : m = match_ppc_decl ();
8155 427 : break;
8156 3165 : case COMP_DERIVED_CONTAINS:
8157 3165 : m = match_procedure_in_type ();
8158 3165 : break;
8159 : default:
8160 : return MATCH_NO;
8161 : }
8162 :
8163 6323 : if (m != MATCH_YES)
8164 : return m;
8165 :
8166 6267 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8167 4 : return MATCH_ERROR;
8168 :
8169 : return m;
8170 : }
8171 :
8172 :
8173 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8174 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8175 : parser-state-stack to find out whether we're in a module. */
8176 :
8177 : static void
8178 61674 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8179 : {
8180 61674 : bool in_module;
8181 :
8182 123348 : in_module = (gfc_state_stack->previous
8183 61674 : && (gfc_state_stack->previous->state == COMP_MODULE
8184 50181 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8185 :
8186 61674 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8187 61674 : }
8188 :
8189 :
8190 : /* Match a function declaration. */
8191 :
8192 : match
8193 126109 : gfc_match_function_decl (void)
8194 : {
8195 126109 : char name[GFC_MAX_SYMBOL_LEN + 1];
8196 126109 : gfc_symbol *sym, *result;
8197 126109 : locus old_loc;
8198 126109 : match m;
8199 126109 : match suffix_match;
8200 126109 : match found_match; /* Status returned by match func. */
8201 :
8202 126109 : if (gfc_current_state () != COMP_NONE
8203 79136 : && gfc_current_state () != COMP_INTERFACE
8204 51369 : && gfc_current_state () != COMP_CONTAINS)
8205 : return MATCH_NO;
8206 :
8207 126109 : gfc_clear_ts (¤t_ts);
8208 :
8209 126109 : old_loc = gfc_current_locus;
8210 :
8211 126109 : m = gfc_match_prefix (¤t_ts);
8212 126109 : if (m != MATCH_YES)
8213 : {
8214 9700 : gfc_current_locus = old_loc;
8215 9700 : return m;
8216 : }
8217 :
8218 116409 : if (gfc_match ("function% %n", name) != MATCH_YES)
8219 : {
8220 97300 : gfc_current_locus = old_loc;
8221 97300 : return MATCH_NO;
8222 : }
8223 :
8224 19109 : if (get_proc_name (name, &sym, false))
8225 : return MATCH_ERROR;
8226 :
8227 19104 : if (add_hidden_procptr_result (sym))
8228 20 : sym = sym->result;
8229 :
8230 19104 : if (current_attr.module_procedure)
8231 : {
8232 298 : sym->attr.module_procedure = 1;
8233 298 : if (gfc_current_state () == COMP_INTERFACE)
8234 212 : gfc_current_ns->has_import_set = 1;
8235 : }
8236 :
8237 19104 : gfc_new_block = sym;
8238 :
8239 19104 : m = gfc_match_formal_arglist (sym, 0, 0);
8240 19104 : if (m == MATCH_NO)
8241 : {
8242 6 : gfc_error ("Expected formal argument list in function "
8243 : "definition at %C");
8244 6 : m = MATCH_ERROR;
8245 6 : goto cleanup;
8246 : }
8247 19098 : else if (m == MATCH_ERROR)
8248 0 : goto cleanup;
8249 :
8250 19098 : result = NULL;
8251 :
8252 : /* According to the draft, the bind(c) and result clause can
8253 : come in either order after the formal_arg_list (i.e., either
8254 : can be first, both can exist together or by themselves or neither
8255 : one). Therefore, the match_result can't match the end of the
8256 : string, and check for the bind(c) or result clause in either order. */
8257 19098 : found_match = gfc_match_eos ();
8258 :
8259 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8260 : must have been marked BIND(C) with a BIND(C) attribute and that is
8261 : not allowed for procedures. */
8262 19098 : if (sym->attr.is_bind_c == 1)
8263 : {
8264 3 : sym->attr.is_bind_c = 0;
8265 :
8266 3 : if (gfc_state_stack->previous
8267 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8268 : {
8269 1 : locus loc;
8270 1 : loc = sym->old_symbol != NULL
8271 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8272 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8273 : "variables or common blocks", &loc);
8274 : }
8275 : }
8276 :
8277 19098 : if (found_match != MATCH_YES)
8278 : {
8279 : /* If we haven't found the end-of-statement, look for a suffix. */
8280 7777 : suffix_match = gfc_match_suffix (sym, &result);
8281 7777 : if (suffix_match == MATCH_YES)
8282 : /* Need to get the eos now. */
8283 7769 : found_match = gfc_match_eos ();
8284 : else
8285 : found_match = suffix_match;
8286 : }
8287 :
8288 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8289 : subprogram and a binding label is specified, it shall be the
8290 : same as the binding label specified in the corresponding module
8291 : procedure interface body. */
8292 19098 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8293 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8294 3 : && sym->binding_label && sym->old_symbol->binding_label
8295 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8296 : {
8297 1 : const char *null = "NULL", *s1, *s2;
8298 1 : s1 = sym->binding_label;
8299 1 : if (!s1) s1 = null;
8300 1 : s2 = sym->old_symbol->binding_label;
8301 1 : if (!s2) s2 = null;
8302 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8303 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8304 1 : return MATCH_ERROR;
8305 : }
8306 :
8307 19097 : if(found_match != MATCH_YES)
8308 : m = MATCH_ERROR;
8309 : else
8310 : {
8311 : /* Make changes to the symbol. */
8312 19089 : m = MATCH_ERROR;
8313 :
8314 19089 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8315 0 : goto cleanup;
8316 :
8317 19089 : if (!gfc_missing_attr (&sym->attr, NULL))
8318 0 : goto cleanup;
8319 :
8320 19089 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8321 : {
8322 1 : if(!sym->attr.module_procedure)
8323 1 : goto cleanup;
8324 : else
8325 0 : gfc_error_check ();
8326 : }
8327 :
8328 : /* Delay matching the function characteristics until after the
8329 : specification block by signalling kind=-1. */
8330 19088 : sym->declared_at = old_loc;
8331 19088 : if (current_ts.type != BT_UNKNOWN)
8332 6746 : current_ts.kind = -1;
8333 : else
8334 12342 : current_ts.kind = 0;
8335 :
8336 19088 : if (result == NULL)
8337 : {
8338 13395 : if (current_ts.type != BT_UNKNOWN
8339 13395 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8340 1 : goto cleanup;
8341 13394 : sym->result = sym;
8342 : }
8343 : else
8344 : {
8345 5693 : if (current_ts.type != BT_UNKNOWN
8346 5693 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8347 0 : goto cleanup;
8348 5693 : sym->result = result;
8349 : }
8350 :
8351 : /* Warn if this procedure has the same name as an intrinsic. */
8352 19087 : do_warn_intrinsic_shadow (sym, true);
8353 :
8354 19087 : return MATCH_YES;
8355 : }
8356 :
8357 16 : cleanup:
8358 16 : gfc_current_locus = old_loc;
8359 16 : return m;
8360 : }
8361 :
8362 :
8363 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8364 : pass the name of the entry, rather than the gfc_current_block name, and
8365 : to return false upon finding an existing global entry. */
8366 :
8367 : static bool
8368 539 : add_global_entry (const char *name, const char *binding_label, bool sub,
8369 : locus *where)
8370 : {
8371 539 : gfc_gsymbol *s;
8372 539 : enum gfc_symbol_type type;
8373 :
8374 539 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8375 :
8376 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8377 : name is a global identifier. */
8378 539 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8379 : {
8380 516 : s = gfc_get_gsymbol (name, false);
8381 :
8382 516 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8383 : {
8384 2 : gfc_global_used (s, where);
8385 2 : return false;
8386 : }
8387 : else
8388 : {
8389 514 : s->type = type;
8390 514 : s->sym_name = name;
8391 514 : s->where = *where;
8392 514 : s->defined = 1;
8393 514 : s->ns = gfc_current_ns;
8394 : }
8395 : }
8396 :
8397 : /* Don't add the symbol multiple times. */
8398 537 : if (binding_label
8399 537 : && (!gfc_notification_std (GFC_STD_F2008)
8400 0 : || strcmp (name, binding_label) != 0))
8401 : {
8402 23 : s = gfc_get_gsymbol (binding_label, true);
8403 :
8404 23 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8405 : {
8406 1 : gfc_global_used (s, where);
8407 1 : return false;
8408 : }
8409 : else
8410 : {
8411 22 : s->type = type;
8412 22 : s->sym_name = name;
8413 22 : s->binding_label = binding_label;
8414 22 : s->where = *where;
8415 22 : s->defined = 1;
8416 22 : s->ns = gfc_current_ns;
8417 : }
8418 : }
8419 :
8420 : return true;
8421 : }
8422 :
8423 :
8424 : /* Match an ENTRY statement. */
8425 :
8426 : match
8427 805 : gfc_match_entry (void)
8428 : {
8429 805 : gfc_symbol *proc;
8430 805 : gfc_symbol *result;
8431 805 : gfc_symbol *entry;
8432 805 : char name[GFC_MAX_SYMBOL_LEN + 1];
8433 805 : gfc_compile_state state;
8434 805 : match m;
8435 805 : gfc_entry_list *el;
8436 805 : locus old_loc;
8437 805 : bool module_procedure;
8438 805 : char peek_char;
8439 805 : match is_bind_c;
8440 :
8441 805 : m = gfc_match_name (name);
8442 805 : if (m != MATCH_YES)
8443 : return m;
8444 :
8445 805 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8446 : return MATCH_ERROR;
8447 :
8448 805 : state = gfc_current_state ();
8449 805 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8450 : {
8451 3 : switch (state)
8452 : {
8453 0 : case COMP_PROGRAM:
8454 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8455 0 : break;
8456 0 : case COMP_MODULE:
8457 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8458 0 : break;
8459 0 : case COMP_SUBMODULE:
8460 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8461 0 : break;
8462 0 : case COMP_BLOCK_DATA:
8463 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8464 : "a BLOCK DATA");
8465 0 : break;
8466 0 : case COMP_INTERFACE:
8467 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8468 : "an INTERFACE");
8469 0 : break;
8470 1 : case COMP_STRUCTURE:
8471 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8472 : "a STRUCTURE block");
8473 1 : break;
8474 0 : case COMP_DERIVED:
8475 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8476 : "a DERIVED TYPE block");
8477 0 : break;
8478 0 : case COMP_IF:
8479 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8480 : "an IF-THEN block");
8481 0 : break;
8482 0 : case COMP_DO:
8483 0 : case COMP_DO_CONCURRENT:
8484 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8485 : "a DO block");
8486 0 : break;
8487 0 : case COMP_SELECT:
8488 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8489 : "a SELECT block");
8490 0 : break;
8491 0 : case COMP_FORALL:
8492 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8493 : "a FORALL block");
8494 0 : break;
8495 0 : case COMP_WHERE:
8496 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8497 : "a WHERE block");
8498 0 : break;
8499 0 : case COMP_CONTAINS:
8500 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8501 : "a contained subprogram");
8502 0 : break;
8503 2 : default:
8504 2 : gfc_error ("Unexpected ENTRY statement at %C");
8505 : }
8506 3 : return MATCH_ERROR;
8507 : }
8508 :
8509 802 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8510 802 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8511 : {
8512 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8513 1 : return MATCH_ERROR;
8514 : }
8515 :
8516 1602 : module_procedure = gfc_current_ns->parent != NULL
8517 260 : && gfc_current_ns->parent->proc_name
8518 801 : && gfc_current_ns->parent->proc_name->attr.flavor
8519 260 : == FL_MODULE;
8520 :
8521 801 : if (gfc_current_ns->parent != NULL
8522 260 : && gfc_current_ns->parent->proc_name
8523 260 : && !module_procedure)
8524 : {
8525 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8526 : "contained procedure");
8527 0 : return MATCH_ERROR;
8528 : }
8529 :
8530 : /* Module function entries need special care in get_proc_name
8531 : because previous references within the function will have
8532 : created symbols attached to the current namespace. */
8533 801 : if (get_proc_name (name, &entry,
8534 : gfc_current_ns->parent != NULL
8535 801 : && module_procedure))
8536 : return MATCH_ERROR;
8537 :
8538 799 : proc = gfc_current_block ();
8539 :
8540 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8541 : must have been marked BIND(C) with a BIND(C) attribute and that is
8542 : not allowed for procedures. */
8543 799 : if (entry->attr.is_bind_c == 1)
8544 : {
8545 0 : locus loc;
8546 :
8547 0 : entry->attr.is_bind_c = 0;
8548 :
8549 0 : loc = entry->old_symbol != NULL
8550 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8551 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8552 : "variables or common blocks", &loc);
8553 : }
8554 :
8555 : /* Check what next non-whitespace character is so we can tell if there
8556 : is the required parens if we have a BIND(C). */
8557 799 : old_loc = gfc_current_locus;
8558 799 : gfc_gobble_whitespace ();
8559 799 : peek_char = gfc_peek_ascii_char ();
8560 :
8561 799 : if (state == COMP_SUBROUTINE)
8562 : {
8563 138 : m = gfc_match_formal_arglist (entry, 0, 1);
8564 138 : if (m != MATCH_YES)
8565 : return MATCH_ERROR;
8566 :
8567 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8568 : never be an internal procedure. */
8569 138 : is_bind_c = gfc_match_bind_c (entry, true);
8570 138 : if (is_bind_c == MATCH_ERROR)
8571 : return MATCH_ERROR;
8572 138 : if (is_bind_c == MATCH_YES)
8573 : {
8574 22 : if (peek_char != '(')
8575 : {
8576 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8577 0 : return MATCH_ERROR;
8578 : }
8579 :
8580 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8581 22 : &(entry->declared_at), 1))
8582 : return MATCH_ERROR;
8583 :
8584 : }
8585 :
8586 138 : if (!gfc_current_ns->parent
8587 138 : && !add_global_entry (name, entry->binding_label, true,
8588 : &old_loc))
8589 : return MATCH_ERROR;
8590 :
8591 : /* An entry in a subroutine. */
8592 135 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8593 135 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8594 3 : return MATCH_ERROR;
8595 : }
8596 : else
8597 : {
8598 : /* An entry in a function.
8599 : We need to take special care because writing
8600 : ENTRY f()
8601 : as
8602 : ENTRY f
8603 : is allowed, whereas
8604 : ENTRY f() RESULT (r)
8605 : can't be written as
8606 : ENTRY f RESULT (r). */
8607 661 : if (gfc_match_eos () == MATCH_YES)
8608 : {
8609 24 : gfc_current_locus = old_loc;
8610 : /* Match the empty argument list, and add the interface to
8611 : the symbol. */
8612 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8613 : }
8614 : else
8615 637 : m = gfc_match_formal_arglist (entry, 0, 0);
8616 :
8617 661 : if (m != MATCH_YES)
8618 : return MATCH_ERROR;
8619 :
8620 660 : result = NULL;
8621 :
8622 660 : if (gfc_match_eos () == MATCH_YES)
8623 : {
8624 411 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8625 411 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8626 2 : return MATCH_ERROR;
8627 :
8628 409 : entry->result = entry;
8629 : }
8630 : else
8631 : {
8632 249 : m = gfc_match_suffix (entry, &result);
8633 249 : if (m == MATCH_NO)
8634 0 : gfc_syntax_error (ST_ENTRY);
8635 249 : if (m != MATCH_YES)
8636 : return MATCH_ERROR;
8637 :
8638 249 : if (result)
8639 : {
8640 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8641 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8642 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8643 0 : return MATCH_ERROR;
8644 212 : entry->result = result;
8645 : }
8646 : else
8647 : {
8648 37 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8649 37 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8650 0 : return MATCH_ERROR;
8651 37 : entry->result = entry;
8652 : }
8653 : }
8654 :
8655 658 : if (!gfc_current_ns->parent
8656 658 : && !add_global_entry (name, entry->binding_label, false,
8657 : &old_loc))
8658 : return MATCH_ERROR;
8659 : }
8660 :
8661 790 : if (gfc_match_eos () != MATCH_YES)
8662 : {
8663 0 : gfc_syntax_error (ST_ENTRY);
8664 0 : return MATCH_ERROR;
8665 : }
8666 :
8667 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8668 790 : if (proc->attr.elemental && entry->attr.is_bind_c)
8669 : {
8670 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8671 : "elemental procedure", &entry->declared_at);
8672 2 : return MATCH_ERROR;
8673 : }
8674 :
8675 788 : entry->attr.recursive = proc->attr.recursive;
8676 788 : entry->attr.elemental = proc->attr.elemental;
8677 788 : entry->attr.pure = proc->attr.pure;
8678 :
8679 788 : el = gfc_get_entry_list ();
8680 788 : el->sym = entry;
8681 788 : el->next = gfc_current_ns->entries;
8682 788 : gfc_current_ns->entries = el;
8683 788 : if (el->next)
8684 85 : el->id = el->next->id + 1;
8685 : else
8686 703 : el->id = 1;
8687 :
8688 788 : new_st.op = EXEC_ENTRY;
8689 788 : new_st.ext.entry = el;
8690 :
8691 788 : return MATCH_YES;
8692 : }
8693 :
8694 :
8695 : /* Match a subroutine statement, including optional prefixes. */
8696 :
8697 : match
8698 796380 : gfc_match_subroutine (void)
8699 : {
8700 796380 : char name[GFC_MAX_SYMBOL_LEN + 1];
8701 796380 : gfc_symbol *sym;
8702 796380 : match m;
8703 796380 : match is_bind_c;
8704 796380 : char peek_char;
8705 796380 : bool allow_binding_name;
8706 796380 : locus loc;
8707 :
8708 796380 : if (gfc_current_state () != COMP_NONE
8709 755191 : && gfc_current_state () != COMP_INTERFACE
8710 733291 : && gfc_current_state () != COMP_CONTAINS)
8711 : return MATCH_NO;
8712 :
8713 104090 : m = gfc_match_prefix (NULL);
8714 104090 : if (m != MATCH_YES)
8715 : return m;
8716 :
8717 94400 : loc = gfc_current_locus;
8718 94400 : m = gfc_match ("subroutine% %n", name);
8719 94400 : if (m != MATCH_YES)
8720 : return m;
8721 :
8722 42624 : if (get_proc_name (name, &sym, false))
8723 : return MATCH_ERROR;
8724 :
8725 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8726 : the symbol existed before. */
8727 42612 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8728 : &gfc_current_locus);
8729 :
8730 42612 : if (current_attr.module_procedure)
8731 : {
8732 368 : sym->attr.module_procedure = 1;
8733 368 : if (gfc_current_state () == COMP_INTERFACE)
8734 264 : gfc_current_ns->has_import_set = 1;
8735 : }
8736 :
8737 42612 : if (add_hidden_procptr_result (sym))
8738 9 : sym = sym->result;
8739 :
8740 42612 : gfc_new_block = sym;
8741 :
8742 : /* Check what next non-whitespace character is so we can tell if there
8743 : is the required parens if we have a BIND(C). */
8744 42612 : gfc_gobble_whitespace ();
8745 42612 : peek_char = gfc_peek_ascii_char ();
8746 :
8747 42612 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8748 : return MATCH_ERROR;
8749 :
8750 42609 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8751 : return MATCH_ERROR;
8752 :
8753 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8754 : must have been marked BIND(C) with a BIND(C) attribute and that is
8755 : not allowed for procedures. */
8756 42609 : if (sym->attr.is_bind_c == 1)
8757 : {
8758 4 : sym->attr.is_bind_c = 0;
8759 :
8760 4 : if (gfc_state_stack->previous
8761 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8762 : {
8763 2 : locus loc;
8764 2 : loc = sym->old_symbol != NULL
8765 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8766 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8767 : "variables or common blocks", &loc);
8768 : }
8769 : }
8770 :
8771 : /* C binding names are not allowed for internal procedures. */
8772 42609 : if (gfc_current_state () == COMP_CONTAINS
8773 25813 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8774 : allow_binding_name = false;
8775 : else
8776 27835 : allow_binding_name = true;
8777 :
8778 : /* Here, we are just checking if it has the bind(c) attribute, and if
8779 : so, then we need to make sure it's all correct. If it doesn't,
8780 : we still need to continue matching the rest of the subroutine line. */
8781 42609 : gfc_gobble_whitespace ();
8782 42609 : loc = gfc_current_locus;
8783 42609 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8784 42609 : if (is_bind_c == MATCH_ERROR)
8785 : {
8786 : /* There was an attempt at the bind(c), but it was wrong. An
8787 : error message should have been printed w/in the gfc_match_bind_c
8788 : so here we'll just return the MATCH_ERROR. */
8789 : return MATCH_ERROR;
8790 : }
8791 :
8792 42596 : if (is_bind_c == MATCH_YES)
8793 : {
8794 3969 : gfc_formal_arglist *arg;
8795 :
8796 : /* The following is allowed in the Fortran 2008 draft. */
8797 3969 : if (gfc_current_state () == COMP_CONTAINS
8798 1297 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8799 4380 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8800 : "at %L may not be specified for an internal "
8801 : "procedure", &gfc_current_locus))
8802 : return MATCH_ERROR;
8803 :
8804 3966 : if (peek_char != '(')
8805 : {
8806 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8807 1 : return MATCH_ERROR;
8808 : }
8809 :
8810 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8811 : subprogram and a binding label is specified, it shall be the
8812 : same as the binding label specified in the corresponding module
8813 : procedure interface body. */
8814 3965 : if (sym->attr.module_procedure && sym->old_symbol
8815 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8816 3 : && sym->binding_label && sym->old_symbol->binding_label
8817 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8818 : {
8819 1 : const char *null = "NULL", *s1, *s2;
8820 1 : s1 = sym->binding_label;
8821 1 : if (!s1) s1 = null;
8822 1 : s2 = sym->old_symbol->binding_label;
8823 1 : if (!s2) s2 = null;
8824 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8825 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8826 1 : return MATCH_ERROR;
8827 : }
8828 :
8829 : /* Scan the dummy arguments for an alternate return. */
8830 12241 : for (arg = sym->formal; arg; arg = arg->next)
8831 8278 : if (!arg->sym)
8832 : {
8833 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8834 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8835 1 : return MATCH_ERROR;
8836 : }
8837 :
8838 3963 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8839 : return MATCH_ERROR;
8840 : }
8841 :
8842 42589 : if (gfc_match_eos () != MATCH_YES)
8843 : {
8844 1 : gfc_syntax_error (ST_SUBROUTINE);
8845 1 : return MATCH_ERROR;
8846 : }
8847 :
8848 42588 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8849 : {
8850 4 : if(!sym->attr.module_procedure)
8851 : return MATCH_ERROR;
8852 : else
8853 3 : gfc_error_check ();
8854 : }
8855 :
8856 : /* Warn if it has the same name as an intrinsic. */
8857 42587 : do_warn_intrinsic_shadow (sym, false);
8858 :
8859 42587 : return MATCH_YES;
8860 : }
8861 :
8862 :
8863 : /* Check that the NAME identifier in a BIND attribute or statement
8864 : is conform to C identifier rules. */
8865 :
8866 : match
8867 1164 : check_bind_name_identifier (char **name)
8868 : {
8869 1164 : char *n = *name, *p;
8870 :
8871 : /* Remove leading spaces. */
8872 1190 : while (*n == ' ')
8873 26 : n++;
8874 :
8875 : /* On an empty string, free memory and set name to NULL. */
8876 1164 : if (*n == '\0')
8877 : {
8878 42 : free (*name);
8879 42 : *name = NULL;
8880 42 : return MATCH_YES;
8881 : }
8882 :
8883 : /* Remove trailing spaces. */
8884 1122 : p = n + strlen(n) - 1;
8885 1138 : while (*p == ' ')
8886 16 : *(p--) = '\0';
8887 :
8888 : /* Insert the identifier into the symbol table. */
8889 1122 : p = xstrdup (n);
8890 1122 : free (*name);
8891 1122 : *name = p;
8892 :
8893 : /* Now check that identifier is valid under C rules. */
8894 1122 : if (ISDIGIT (*p))
8895 : {
8896 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8897 2 : return MATCH_ERROR;
8898 : }
8899 :
8900 12392 : for (; *p; p++)
8901 11275 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8902 : {
8903 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8904 3 : return MATCH_ERROR;
8905 : }
8906 :
8907 : return MATCH_YES;
8908 : }
8909 :
8910 :
8911 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8912 : given, and set the binding label in either the given symbol (if not
8913 : NULL), or in the current_ts. The symbol may be NULL because we may
8914 : encounter the BIND(C) before the declaration itself. Return
8915 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8916 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8917 : or MATCH_YES if the specifier was correct and the binding label and
8918 : bind(c) fields were set correctly for the given symbol or the
8919 : current_ts. If allow_binding_name is false, no binding name may be
8920 : given. */
8921 :
8922 : match
8923 51075 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8924 : {
8925 51075 : char *binding_label = NULL;
8926 51075 : gfc_expr *e = NULL;
8927 :
8928 : /* Initialize the flag that specifies whether we encountered a NAME=
8929 : specifier or not. */
8930 51075 : has_name_equals = 0;
8931 :
8932 : /* This much we have to be able to match, in this order, if
8933 : there is a bind(c) label. */
8934 51075 : if (gfc_match (" bind ( c ") != MATCH_YES)
8935 : return MATCH_NO;
8936 :
8937 : /* Now see if there is a binding label, or if we've reached the
8938 : end of the bind(c) attribute without one. */
8939 6928 : if (gfc_match_char (',') == MATCH_YES)
8940 : {
8941 1171 : if (gfc_match (" name = ") != MATCH_YES)
8942 : {
8943 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8944 : "at %C");
8945 : /* should give an error message here */
8946 1 : return MATCH_ERROR;
8947 : }
8948 :
8949 1170 : has_name_equals = 1;
8950 :
8951 1170 : if (gfc_match_init_expr (&e) != MATCH_YES)
8952 : {
8953 2 : gfc_free_expr (e);
8954 2 : return MATCH_ERROR;
8955 : }
8956 :
8957 1168 : if (!gfc_simplify_expr(e, 0))
8958 : {
8959 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8960 0 : gfc_free_expr (e);
8961 0 : return MATCH_ERROR;
8962 : }
8963 :
8964 1168 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8965 1165 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
8966 : {
8967 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
8968 : "default character kind");
8969 4 : gfc_free_expr(e);
8970 4 : return MATCH_ERROR;
8971 : }
8972 :
8973 : // Get a C string from the Fortran string constant
8974 2328 : binding_label = gfc_widechar_to_char (e->value.character.string,
8975 1164 : e->value.character.length);
8976 1164 : gfc_free_expr(e);
8977 :
8978 : // Check that it is valid (old gfc_match_name_C)
8979 1164 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
8980 : return MATCH_ERROR;
8981 : }
8982 :
8983 : /* Get the required right paren. */
8984 6916 : if (gfc_match_char (')') != MATCH_YES)
8985 : {
8986 1 : gfc_error ("Missing closing paren for binding label at %C");
8987 1 : return MATCH_ERROR;
8988 : }
8989 :
8990 6915 : if (has_name_equals && !allow_binding_name)
8991 : {
8992 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
8993 6 : return MATCH_ERROR;
8994 : }
8995 :
8996 6909 : if (has_name_equals && sym != NULL && sym->attr.dummy)
8997 : {
8998 2 : gfc_error ("For dummy procedure %s, no binding name is "
8999 : "allowed in BIND(C) at %C", sym->name);
9000 2 : return MATCH_ERROR;
9001 : }
9002 :
9003 :
9004 : /* Save the binding label to the symbol. If sym is null, we're
9005 : probably matching the typespec attributes of a declaration and
9006 : haven't gotten the name yet, and therefore, no symbol yet. */
9007 6907 : if (binding_label)
9008 : {
9009 1110 : if (sym != NULL)
9010 1001 : sym->binding_label = binding_label;
9011 : else
9012 109 : curr_binding_label = binding_label;
9013 : }
9014 5797 : else if (allow_binding_name)
9015 : {
9016 : /* No binding label, but if symbol isn't null, we
9017 : can set the label for it here.
9018 : If name="" or allow_binding_name is false, no C binding name is
9019 : created. */
9020 5368 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
9021 5201 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
9022 : }
9023 :
9024 6907 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
9025 720 : && current_interface.type == INTERFACE_ABSTRACT)
9026 : {
9027 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
9028 1 : return MATCH_ERROR;
9029 : }
9030 :
9031 : return MATCH_YES;
9032 : }
9033 :
9034 :
9035 : /* Return nonzero if we're currently compiling a contained procedure. */
9036 :
9037 : static int
9038 61986 : contained_procedure (void)
9039 : {
9040 61986 : gfc_state_data *s = gfc_state_stack;
9041 :
9042 61986 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
9043 61080 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
9044 36096 : return 1;
9045 :
9046 : return 0;
9047 : }
9048 :
9049 : /* Set the kind of each enumerator. The kind is selected such that it is
9050 : interoperable with the corresponding C enumeration type, making
9051 : sure that -fshort-enums is honored. */
9052 :
9053 : static void
9054 158 : set_enum_kind(void)
9055 : {
9056 158 : enumerator_history *current_history = NULL;
9057 158 : int kind;
9058 158 : int i;
9059 :
9060 158 : if (max_enum == NULL || enum_history == NULL)
9061 : return;
9062 :
9063 150 : if (!flag_short_enums)
9064 : return;
9065 :
9066 : i = 0;
9067 48 : do
9068 : {
9069 48 : kind = gfc_integer_kinds[i++].kind;
9070 : }
9071 48 : while (kind < gfc_c_int_kind
9072 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
9073 : kind) != ARITH_OK);
9074 :
9075 24 : current_history = enum_history;
9076 96 : while (current_history != NULL)
9077 : {
9078 72 : current_history->sym->ts.kind = kind;
9079 72 : current_history = current_history->next;
9080 : }
9081 : }
9082 :
9083 :
9084 : /* Match any of the various end-block statements. Returns the type of
9085 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
9086 : and END BLOCK statements cannot be replaced by a single END statement. */
9087 :
9088 : match
9089 182493 : gfc_match_end (gfc_statement *st)
9090 : {
9091 182493 : char name[GFC_MAX_SYMBOL_LEN + 1];
9092 182493 : gfc_compile_state state;
9093 182493 : locus old_loc;
9094 182493 : const char *block_name;
9095 182493 : const char *target;
9096 182493 : int eos_ok;
9097 182493 : match m;
9098 182493 : gfc_namespace *parent_ns, *ns, *prev_ns;
9099 182493 : gfc_namespace **nsp;
9100 182493 : bool abbreviated_modproc_decl = false;
9101 182493 : bool got_matching_end = false;
9102 :
9103 182493 : old_loc = gfc_current_locus;
9104 182493 : if (gfc_match ("end") != MATCH_YES)
9105 : return MATCH_NO;
9106 :
9107 177445 : state = gfc_current_state ();
9108 96808 : block_name = gfc_current_block () == NULL
9109 177445 : ? NULL : gfc_current_block ()->name;
9110 :
9111 177445 : switch (state)
9112 : {
9113 2875 : case COMP_ASSOCIATE:
9114 2875 : case COMP_BLOCK:
9115 2875 : case COMP_CHANGE_TEAM:
9116 2875 : if (startswith (block_name, "block@"))
9117 : block_name = NULL;
9118 : break;
9119 :
9120 17157 : case COMP_CONTAINS:
9121 17157 : case COMP_DERIVED_CONTAINS:
9122 17157 : case COMP_OMP_BEGIN_METADIRECTIVE:
9123 17157 : state = gfc_state_stack->previous->state;
9124 15617 : block_name = gfc_state_stack->previous->sym == NULL
9125 17157 : ? NULL : gfc_state_stack->previous->sym->name;
9126 17157 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
9127 17157 : && gfc_state_stack->previous->sym->abr_modproc_decl;
9128 : break;
9129 :
9130 : case COMP_OMP_METADIRECTIVE:
9131 : {
9132 : /* Metadirectives can be nested, so we need to drill down to the
9133 : first state that is not COMP_OMP_METADIRECTIVE. */
9134 : gfc_state_data *state_data = gfc_state_stack;
9135 :
9136 85 : do
9137 : {
9138 85 : state_data = state_data->previous;
9139 85 : state = state_data->state;
9140 77 : block_name = (state_data->sym == NULL
9141 85 : ? NULL : state_data->sym->name);
9142 170 : abbreviated_modproc_decl = (state_data->sym
9143 85 : && state_data->sym->abr_modproc_decl);
9144 : }
9145 85 : while (state == COMP_OMP_METADIRECTIVE);
9146 :
9147 83 : if (block_name && startswith (block_name, "block@"))
9148 : block_name = NULL;
9149 : }
9150 : break;
9151 :
9152 : default:
9153 : break;
9154 : }
9155 :
9156 83 : if (!abbreviated_modproc_decl)
9157 177444 : abbreviated_modproc_decl = gfc_current_block ()
9158 177444 : && gfc_current_block ()->abr_modproc_decl;
9159 :
9160 177445 : switch (state)
9161 : {
9162 27664 : case COMP_NONE:
9163 27664 : case COMP_PROGRAM:
9164 27664 : *st = ST_END_PROGRAM;
9165 27664 : target = " program";
9166 27664 : eos_ok = 1;
9167 27664 : break;
9168 :
9169 42765 : case COMP_SUBROUTINE:
9170 42765 : *st = ST_END_SUBROUTINE;
9171 42765 : if (!abbreviated_modproc_decl)
9172 : target = " subroutine";
9173 : else
9174 135 : target = " procedure";
9175 42765 : eos_ok = !contained_procedure ();
9176 42765 : break;
9177 :
9178 19221 : case COMP_FUNCTION:
9179 19221 : *st = ST_END_FUNCTION;
9180 19221 : if (!abbreviated_modproc_decl)
9181 : target = " function";
9182 : else
9183 117 : target = " procedure";
9184 19221 : eos_ok = !contained_procedure ();
9185 19221 : break;
9186 :
9187 87 : case COMP_BLOCK_DATA:
9188 87 : *st = ST_END_BLOCK_DATA;
9189 87 : target = " block data";
9190 87 : eos_ok = 1;
9191 87 : break;
9192 :
9193 9682 : case COMP_MODULE:
9194 9682 : *st = ST_END_MODULE;
9195 9682 : target = " module";
9196 9682 : eos_ok = 1;
9197 9682 : break;
9198 :
9199 239 : case COMP_SUBMODULE:
9200 239 : *st = ST_END_SUBMODULE;
9201 239 : target = " submodule";
9202 239 : eos_ok = 1;
9203 239 : break;
9204 :
9205 10565 : case COMP_INTERFACE:
9206 10565 : *st = ST_END_INTERFACE;
9207 10565 : target = " interface";
9208 10565 : eos_ok = 0;
9209 10565 : break;
9210 :
9211 257 : case COMP_MAP:
9212 257 : *st = ST_END_MAP;
9213 257 : target = " map";
9214 257 : eos_ok = 0;
9215 257 : break;
9216 :
9217 132 : case COMP_UNION:
9218 132 : *st = ST_END_UNION;
9219 132 : target = " union";
9220 132 : eos_ok = 0;
9221 132 : break;
9222 :
9223 313 : case COMP_STRUCTURE:
9224 313 : *st = ST_END_STRUCTURE;
9225 313 : target = " structure";
9226 313 : eos_ok = 0;
9227 313 : break;
9228 :
9229 12745 : case COMP_DERIVED:
9230 12745 : case COMP_DERIVED_CONTAINS:
9231 12745 : *st = ST_END_TYPE;
9232 12745 : target = " type";
9233 12745 : eos_ok = 0;
9234 12745 : break;
9235 :
9236 1466 : case COMP_ASSOCIATE:
9237 1466 : *st = ST_END_ASSOCIATE;
9238 1466 : target = " associate";
9239 1466 : eos_ok = 0;
9240 1466 : break;
9241 :
9242 1365 : case COMP_BLOCK:
9243 1365 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9244 1365 : *st = ST_END_BLOCK;
9245 1365 : target = " block";
9246 1365 : eos_ok = 0;
9247 1365 : break;
9248 :
9249 14765 : case COMP_IF:
9250 14765 : *st = ST_ENDIF;
9251 14765 : target = " if";
9252 14765 : eos_ok = 0;
9253 14765 : break;
9254 :
9255 30414 : case COMP_DO:
9256 30414 : case COMP_DO_CONCURRENT:
9257 30414 : *st = ST_ENDDO;
9258 30414 : target = " do";
9259 30414 : eos_ok = 0;
9260 30414 : break;
9261 :
9262 54 : case COMP_CRITICAL:
9263 54 : *st = ST_END_CRITICAL;
9264 54 : target = " critical";
9265 54 : eos_ok = 0;
9266 54 : break;
9267 :
9268 4589 : case COMP_SELECT:
9269 4589 : case COMP_SELECT_TYPE:
9270 4589 : case COMP_SELECT_RANK:
9271 4589 : *st = ST_END_SELECT;
9272 4589 : target = " select";
9273 4589 : eos_ok = 0;
9274 4589 : break;
9275 :
9276 508 : case COMP_FORALL:
9277 508 : *st = ST_END_FORALL;
9278 508 : target = " forall";
9279 508 : eos_ok = 0;
9280 508 : break;
9281 :
9282 373 : case COMP_WHERE:
9283 373 : *st = ST_END_WHERE;
9284 373 : target = " where";
9285 373 : eos_ok = 0;
9286 373 : break;
9287 :
9288 158 : case COMP_ENUM:
9289 158 : *st = ST_END_ENUM;
9290 158 : target = " enum";
9291 158 : eos_ok = 0;
9292 158 : last_initializer = NULL;
9293 158 : set_enum_kind ();
9294 158 : gfc_free_enum_history ();
9295 158 : break;
9296 :
9297 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9298 0 : *st = ST_OMP_END_METADIRECTIVE;
9299 0 : target = " metadirective";
9300 0 : eos_ok = 0;
9301 0 : break;
9302 :
9303 74 : case COMP_CHANGE_TEAM:
9304 74 : *st = ST_END_TEAM;
9305 74 : target = " team";
9306 74 : eos_ok = 0;
9307 74 : break;
9308 :
9309 9 : default:
9310 9 : gfc_error ("Unexpected END statement at %C");
9311 9 : goto cleanup;
9312 : }
9313 :
9314 177436 : old_loc = gfc_current_locus;
9315 177436 : if (gfc_match_eos () == MATCH_YES)
9316 : {
9317 20603 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9318 : {
9319 8051 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9320 : "instead of %s statement at %L",
9321 : abbreviated_modproc_decl ? "END PROCEDURE"
9322 4013 : : gfc_ascii_statement(*st), &old_loc))
9323 4 : goto cleanup;
9324 : }
9325 9 : else if (!eos_ok)
9326 : {
9327 : /* We would have required END [something]. */
9328 9 : gfc_error ("%s statement expected at %L",
9329 : gfc_ascii_statement (*st), &old_loc);
9330 9 : goto cleanup;
9331 : }
9332 :
9333 20590 : return MATCH_YES;
9334 : }
9335 :
9336 : /* Verify that we've got the sort of end-block that we're expecting. */
9337 156833 : if (gfc_match (target) != MATCH_YES)
9338 : {
9339 331 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9340 165 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9341 166 : goto cleanup;
9342 : }
9343 : else
9344 156667 : got_matching_end = true;
9345 :
9346 156667 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9347 : /* Emit errors of stat and errmsg parsing now to finish the block and
9348 : continue analysis of compilation unit. */
9349 2 : gfc_error_check ();
9350 :
9351 156667 : old_loc = gfc_current_locus;
9352 : /* If we're at the end, make sure a block name wasn't required. */
9353 156667 : if (gfc_match_eos () == MATCH_YES)
9354 : {
9355 103549 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9356 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9357 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9358 : && *st != ST_END_TEAM)
9359 : return MATCH_YES;
9360 :
9361 53112 : if (!block_name)
9362 : return MATCH_YES;
9363 :
9364 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9365 : block_name, gfc_ascii_statement (*st), &old_loc);
9366 :
9367 8 : return MATCH_ERROR;
9368 : }
9369 :
9370 : /* END INTERFACE has a special handler for its several possible endings. */
9371 53118 : if (*st == ST_END_INTERFACE)
9372 636 : return gfc_match_end_interface ();
9373 :
9374 : /* We haven't hit the end of statement, so what is left must be an
9375 : end-name. */
9376 52482 : m = gfc_match_space ();
9377 52482 : if (m == MATCH_YES)
9378 52482 : m = gfc_match_name (name);
9379 :
9380 52482 : if (m == MATCH_NO)
9381 0 : gfc_error ("Expected terminating name at %C");
9382 52482 : if (m != MATCH_YES)
9383 0 : goto cleanup;
9384 :
9385 52482 : if (block_name == NULL)
9386 15 : goto syntax;
9387 :
9388 : /* We have to pick out the declared submodule name from the composite
9389 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9390 52467 : if (state == COMP_SUBMODULE)
9391 118 : block_name = strchr (block_name, '.') + 1;
9392 :
9393 52467 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9394 : {
9395 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9396 : gfc_ascii_statement (*st));
9397 8 : goto cleanup;
9398 : }
9399 : /* Procedure pointer as function result. */
9400 52459 : else if (strcmp (block_name, "ppr@") == 0
9401 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9402 : {
9403 0 : gfc_error ("Expected label %qs for %s statement at %C",
9404 0 : gfc_current_block ()->ns->proc_name->name,
9405 : gfc_ascii_statement (*st));
9406 0 : goto cleanup;
9407 : }
9408 :
9409 52459 : if (gfc_match_eos () == MATCH_YES)
9410 : return MATCH_YES;
9411 :
9412 0 : syntax:
9413 15 : gfc_syntax_error (*st);
9414 :
9415 211 : cleanup:
9416 211 : gfc_current_locus = old_loc;
9417 :
9418 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9419 : Remove it from the parent namespace's sibling list. */
9420 :
9421 211 : if (state == COMP_BLOCK && !got_matching_end)
9422 : {
9423 7 : parent_ns = gfc_current_ns->parent;
9424 :
9425 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9426 :
9427 7 : prev_ns = NULL;
9428 7 : ns = *nsp;
9429 14 : while (ns)
9430 : {
9431 7 : if (ns == gfc_current_ns)
9432 : {
9433 7 : if (prev_ns == NULL)
9434 7 : *nsp = NULL;
9435 : else
9436 0 : prev_ns->sibling = ns->sibling;
9437 : }
9438 7 : prev_ns = ns;
9439 7 : ns = ns->sibling;
9440 : }
9441 :
9442 : /* The namespace can still be referenced by parser state and code nodes;
9443 : let normal block unwinding/freeing own its lifetime. */
9444 7 : gfc_current_ns = parent_ns;
9445 7 : gfc_state_stack = gfc_state_stack->previous;
9446 7 : state = gfc_current_state ();
9447 : }
9448 :
9449 : return MATCH_ERROR;
9450 : }
9451 :
9452 :
9453 :
9454 : /***************** Attribute declaration statements ****************/
9455 :
9456 : /* Set the attribute of a single variable. */
9457 :
9458 : static match
9459 10260 : attr_decl1 (void)
9460 : {
9461 10260 : char name[GFC_MAX_SYMBOL_LEN + 1];
9462 10260 : gfc_array_spec *as;
9463 :
9464 : /* Workaround -Wmaybe-uninitialized false positive during
9465 : profiledbootstrap by initializing them. */
9466 10260 : gfc_symbol *sym = NULL;
9467 10260 : locus var_locus;
9468 10260 : match m;
9469 :
9470 10260 : as = NULL;
9471 :
9472 10260 : m = gfc_match_name (name);
9473 10260 : if (m != MATCH_YES)
9474 0 : goto cleanup;
9475 :
9476 10260 : if (find_special (name, &sym, false))
9477 : return MATCH_ERROR;
9478 :
9479 10260 : if (!check_function_name (name))
9480 : {
9481 7 : m = MATCH_ERROR;
9482 7 : goto cleanup;
9483 : }
9484 :
9485 10253 : var_locus = gfc_current_locus;
9486 :
9487 : /* Deal with possible array specification for certain attributes. */
9488 10253 : if (current_attr.dimension
9489 8674 : || current_attr.codimension
9490 8652 : || current_attr.allocatable
9491 8228 : || current_attr.pointer
9492 7517 : || current_attr.target)
9493 : {
9494 2962 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9495 : !current_attr.dimension
9496 1383 : && !current_attr.pointer
9497 3634 : && !current_attr.target);
9498 2962 : if (m == MATCH_ERROR)
9499 2 : goto cleanup;
9500 :
9501 2960 : if (current_attr.dimension && m == MATCH_NO)
9502 : {
9503 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9504 : "statement", &var_locus);
9505 0 : m = MATCH_ERROR;
9506 0 : goto cleanup;
9507 : }
9508 :
9509 2960 : if (current_attr.dimension && sym->value)
9510 : {
9511 1 : gfc_error ("Dimensions specified for %s at %L after its "
9512 : "initialization", sym->name, &var_locus);
9513 1 : m = MATCH_ERROR;
9514 1 : goto cleanup;
9515 : }
9516 :
9517 2959 : if (current_attr.codimension && m == MATCH_NO)
9518 : {
9519 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9520 : "statement", &var_locus);
9521 0 : m = MATCH_ERROR;
9522 0 : goto cleanup;
9523 : }
9524 :
9525 2959 : if ((current_attr.allocatable || current_attr.pointer)
9526 1135 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9527 : {
9528 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9529 0 : m = MATCH_ERROR;
9530 0 : goto cleanup;
9531 : }
9532 : }
9533 :
9534 10250 : if (sym->ts.type == BT_CLASS
9535 200 : && sym->ts.u.derived
9536 200 : && sym->ts.u.derived->attr.is_class)
9537 : {
9538 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9539 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9540 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9541 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9542 177 : if (CLASS_DATA (sym)->as)
9543 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9544 : }
9545 8673 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9546 18902 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9547 : {
9548 22 : m = MATCH_ERROR;
9549 22 : goto cleanup;
9550 : }
9551 10228 : if (!gfc_set_array_spec (sym, as, &var_locus))
9552 : {
9553 18 : m = MATCH_ERROR;
9554 18 : goto cleanup;
9555 : }
9556 :
9557 10210 : if (sym->attr.cray_pointee && sym->as != NULL)
9558 : {
9559 : /* Fix the array spec. */
9560 2 : m = gfc_mod_pointee_as (sym->as);
9561 2 : if (m == MATCH_ERROR)
9562 0 : goto cleanup;
9563 : }
9564 :
9565 10210 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9566 : {
9567 0 : m = MATCH_ERROR;
9568 0 : goto cleanup;
9569 : }
9570 :
9571 5713 : if ((current_attr.external || current_attr.intrinsic)
9572 6134 : && sym->attr.flavor != FL_PROCEDURE
9573 16312 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9574 : {
9575 0 : m = MATCH_ERROR;
9576 0 : goto cleanup;
9577 : }
9578 :
9579 10210 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9580 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9581 136 : && !current_attr.external)
9582 : {
9583 136 : sym->attr.pointer = 0;
9584 136 : sym->attr.allocatable = 0;
9585 136 : sym->attr.dimension = 0;
9586 136 : sym->attr.codimension = 0;
9587 136 : gfc_free_array_spec (sym->as);
9588 136 : sym->as = NULL;
9589 : }
9590 10074 : else if (sym->ts.type == BT_CLASS
9591 10074 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9592 : {
9593 0 : m = MATCH_ERROR;
9594 0 : goto cleanup;
9595 : }
9596 :
9597 10210 : add_hidden_procptr_result (sym);
9598 :
9599 10210 : return MATCH_YES;
9600 :
9601 50 : cleanup:
9602 50 : gfc_free_array_spec (as);
9603 50 : return m;
9604 : }
9605 :
9606 :
9607 : /* Generic attribute declaration subroutine. Used for attributes that
9608 : just have a list of names. */
9609 :
9610 : static match
9611 6597 : attr_decl (void)
9612 : {
9613 6597 : match m;
9614 :
9615 : /* Gobble the optional double colon, by simply ignoring the result
9616 : of gfc_match(). */
9617 6597 : gfc_match (" ::");
9618 :
9619 10260 : for (;;)
9620 : {
9621 10260 : m = attr_decl1 ();
9622 10260 : if (m != MATCH_YES)
9623 : break;
9624 :
9625 10210 : if (gfc_match_eos () == MATCH_YES)
9626 : {
9627 : m = MATCH_YES;
9628 : break;
9629 : }
9630 :
9631 3663 : if (gfc_match_char (',') != MATCH_YES)
9632 : {
9633 0 : gfc_error ("Unexpected character in variable list at %C");
9634 0 : m = MATCH_ERROR;
9635 0 : break;
9636 : }
9637 : }
9638 :
9639 6597 : return m;
9640 : }
9641 :
9642 :
9643 : /* This routine matches Cray Pointer declarations of the form:
9644 : pointer ( <pointer>, <pointee> )
9645 : or
9646 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9647 : The pointer, if already declared, should be an integer. Otherwise, we
9648 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9649 : be either a scalar, or an array declaration. No space is allocated for
9650 : the pointee. For the statement
9651 : pointer (ipt, ar(10))
9652 : any subsequent uses of ar will be translated (in C-notation) as
9653 : ar(i) => ((<type> *) ipt)(i)
9654 : After gimplification, pointee variable will disappear in the code. */
9655 :
9656 : static match
9657 334 : cray_pointer_decl (void)
9658 : {
9659 334 : match m;
9660 334 : gfc_array_spec *as = NULL;
9661 334 : gfc_symbol *cptr; /* Pointer symbol. */
9662 334 : gfc_symbol *cpte; /* Pointee symbol. */
9663 334 : locus var_locus;
9664 334 : bool done = false;
9665 :
9666 334 : while (!done)
9667 : {
9668 347 : if (gfc_match_char ('(') != MATCH_YES)
9669 : {
9670 1 : gfc_error ("Expected %<(%> at %C");
9671 1 : return MATCH_ERROR;
9672 : }
9673 :
9674 : /* Match pointer. */
9675 346 : var_locus = gfc_current_locus;
9676 346 : gfc_clear_attr (¤t_attr);
9677 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9678 346 : current_ts.type = BT_INTEGER;
9679 346 : current_ts.kind = gfc_index_integer_kind;
9680 :
9681 346 : m = gfc_match_symbol (&cptr, 0);
9682 346 : if (m != MATCH_YES)
9683 : {
9684 2 : gfc_error ("Expected variable name at %C");
9685 2 : return m;
9686 : }
9687 :
9688 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9689 : return MATCH_ERROR;
9690 :
9691 341 : gfc_set_sym_referenced (cptr);
9692 :
9693 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9694 : {
9695 327 : cptr->ts.type = BT_INTEGER;
9696 327 : cptr->ts.kind = gfc_index_integer_kind;
9697 : }
9698 14 : else if (cptr->ts.type != BT_INTEGER)
9699 : {
9700 1 : gfc_error ("Cray pointer at %C must be an integer");
9701 1 : return MATCH_ERROR;
9702 : }
9703 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9704 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9705 : " memory addresses require %d bytes",
9706 : cptr->ts.kind, gfc_index_integer_kind);
9707 :
9708 340 : if (gfc_match_char (',') != MATCH_YES)
9709 : {
9710 2 : gfc_error ("Expected \",\" at %C");
9711 2 : return MATCH_ERROR;
9712 : }
9713 :
9714 : /* Match Pointee. */
9715 338 : var_locus = gfc_current_locus;
9716 338 : gfc_clear_attr (¤t_attr);
9717 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9718 338 : current_ts.type = BT_UNKNOWN;
9719 338 : current_ts.kind = 0;
9720 :
9721 338 : m = gfc_match_symbol (&cpte, 0);
9722 338 : if (m != MATCH_YES)
9723 : {
9724 2 : gfc_error ("Expected variable name at %C");
9725 2 : return m;
9726 : }
9727 :
9728 : /* Check for an optional array spec. */
9729 336 : m = gfc_match_array_spec (&as, true, false);
9730 336 : if (m == MATCH_ERROR)
9731 : {
9732 0 : gfc_free_array_spec (as);
9733 0 : return m;
9734 : }
9735 336 : else if (m == MATCH_NO)
9736 : {
9737 226 : gfc_free_array_spec (as);
9738 226 : as = NULL;
9739 : }
9740 :
9741 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9742 : return MATCH_ERROR;
9743 :
9744 329 : gfc_set_sym_referenced (cpte);
9745 :
9746 329 : if (cpte->as == NULL)
9747 : {
9748 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9749 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9750 : }
9751 82 : else if (as != NULL)
9752 : {
9753 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9754 1 : gfc_free_array_spec (as);
9755 1 : return MATCH_ERROR;
9756 : }
9757 :
9758 328 : as = NULL;
9759 :
9760 328 : if (cpte->as != NULL)
9761 : {
9762 : /* Fix array spec. */
9763 190 : m = gfc_mod_pointee_as (cpte->as);
9764 190 : if (m == MATCH_ERROR)
9765 : return m;
9766 : }
9767 :
9768 : /* Point the Pointee at the Pointer. */
9769 328 : cpte->cp_pointer = cptr;
9770 :
9771 328 : if (gfc_match_char (')') != MATCH_YES)
9772 : {
9773 2 : gfc_error ("Expected \")\" at %C");
9774 2 : return MATCH_ERROR;
9775 : }
9776 326 : m = gfc_match_char (',');
9777 326 : if (m != MATCH_YES)
9778 313 : done = true; /* Stop searching for more declarations. */
9779 :
9780 : }
9781 :
9782 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9783 313 : || gfc_match_eos () != MATCH_YES)
9784 : {
9785 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9786 0 : return MATCH_ERROR;
9787 : }
9788 : return MATCH_YES;
9789 : }
9790 :
9791 :
9792 : match
9793 3117 : gfc_match_external (void)
9794 : {
9795 :
9796 3117 : gfc_clear_attr (¤t_attr);
9797 3117 : current_attr.external = 1;
9798 :
9799 3117 : return attr_decl ();
9800 : }
9801 :
9802 :
9803 : match
9804 208 : gfc_match_intent (void)
9805 : {
9806 208 : sym_intent intent;
9807 :
9808 : /* This is not allowed within a BLOCK construct! */
9809 208 : if (gfc_current_state () == COMP_BLOCK)
9810 : {
9811 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9812 2 : return MATCH_ERROR;
9813 : }
9814 :
9815 206 : intent = match_intent_spec ();
9816 206 : if (intent == INTENT_UNKNOWN)
9817 : return MATCH_ERROR;
9818 :
9819 206 : gfc_clear_attr (¤t_attr);
9820 206 : current_attr.intent = intent;
9821 :
9822 206 : return attr_decl ();
9823 : }
9824 :
9825 :
9826 : match
9827 1477 : gfc_match_intrinsic (void)
9828 : {
9829 :
9830 1477 : gfc_clear_attr (¤t_attr);
9831 1477 : current_attr.intrinsic = 1;
9832 :
9833 1477 : return attr_decl ();
9834 : }
9835 :
9836 :
9837 : match
9838 220 : gfc_match_optional (void)
9839 : {
9840 : /* This is not allowed within a BLOCK construct! */
9841 220 : if (gfc_current_state () == COMP_BLOCK)
9842 : {
9843 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9844 2 : return MATCH_ERROR;
9845 : }
9846 :
9847 218 : gfc_clear_attr (¤t_attr);
9848 218 : current_attr.optional = 1;
9849 :
9850 218 : return attr_decl ();
9851 : }
9852 :
9853 :
9854 : match
9855 903 : gfc_match_pointer (void)
9856 : {
9857 903 : gfc_gobble_whitespace ();
9858 903 : if (gfc_peek_ascii_char () == '(')
9859 : {
9860 335 : if (!flag_cray_pointer)
9861 : {
9862 1 : gfc_error ("Cray pointer declaration at %C requires "
9863 : "%<-fcray-pointer%> flag");
9864 1 : return MATCH_ERROR;
9865 : }
9866 334 : return cray_pointer_decl ();
9867 : }
9868 : else
9869 : {
9870 568 : gfc_clear_attr (¤t_attr);
9871 568 : current_attr.pointer = 1;
9872 :
9873 568 : return attr_decl ();
9874 : }
9875 : }
9876 :
9877 :
9878 : match
9879 162 : gfc_match_allocatable (void)
9880 : {
9881 162 : gfc_clear_attr (¤t_attr);
9882 162 : current_attr.allocatable = 1;
9883 :
9884 162 : return attr_decl ();
9885 : }
9886 :
9887 :
9888 : match
9889 23 : gfc_match_codimension (void)
9890 : {
9891 23 : gfc_clear_attr (¤t_attr);
9892 23 : current_attr.codimension = 1;
9893 :
9894 23 : return attr_decl ();
9895 : }
9896 :
9897 :
9898 : match
9899 80 : gfc_match_contiguous (void)
9900 : {
9901 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9902 : return MATCH_ERROR;
9903 :
9904 79 : gfc_clear_attr (¤t_attr);
9905 79 : current_attr.contiguous = 1;
9906 :
9907 79 : return attr_decl ();
9908 : }
9909 :
9910 :
9911 : match
9912 648 : gfc_match_dimension (void)
9913 : {
9914 648 : gfc_clear_attr (¤t_attr);
9915 648 : current_attr.dimension = 1;
9916 :
9917 648 : return attr_decl ();
9918 : }
9919 :
9920 :
9921 : match
9922 99 : gfc_match_target (void)
9923 : {
9924 99 : gfc_clear_attr (¤t_attr);
9925 99 : current_attr.target = 1;
9926 :
9927 99 : return attr_decl ();
9928 : }
9929 :
9930 :
9931 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9932 : statement. */
9933 :
9934 : static match
9935 1720 : access_attr_decl (gfc_statement st)
9936 : {
9937 1720 : char name[GFC_MAX_SYMBOL_LEN + 1];
9938 1720 : interface_type type;
9939 1720 : gfc_user_op *uop;
9940 1720 : gfc_symbol *sym, *dt_sym;
9941 1720 : gfc_intrinsic_op op;
9942 1720 : match m;
9943 1720 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9944 :
9945 1720 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9946 0 : goto done;
9947 :
9948 2867 : for (;;)
9949 : {
9950 2867 : m = gfc_match_generic_spec (&type, name, &op);
9951 2867 : if (m == MATCH_NO)
9952 0 : goto syntax;
9953 2867 : if (m == MATCH_ERROR)
9954 0 : goto done;
9955 :
9956 2867 : switch (type)
9957 : {
9958 0 : case INTERFACE_NAMELESS:
9959 0 : case INTERFACE_ABSTRACT:
9960 0 : goto syntax;
9961 :
9962 2791 : case INTERFACE_GENERIC:
9963 2791 : case INTERFACE_DTIO:
9964 :
9965 2791 : if (gfc_get_symbol (name, NULL, &sym))
9966 0 : goto done;
9967 :
9968 2791 : if (type == INTERFACE_DTIO
9969 26 : && gfc_current_ns->proc_name
9970 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9971 26 : && sym->attr.flavor == FL_UNKNOWN)
9972 2 : sym->attr.flavor = FL_PROCEDURE;
9973 :
9974 2791 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9975 4 : goto done;
9976 :
9977 329 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9978 2843 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9979 0 : goto done;
9980 :
9981 : break;
9982 :
9983 72 : case INTERFACE_INTRINSIC_OP:
9984 72 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9985 : {
9986 72 : gfc_intrinsic_op other_op;
9987 :
9988 72 : gfc_current_ns->operator_access[op] = access;
9989 :
9990 : /* Handle the case if there is another op with the same
9991 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9992 72 : other_op = gfc_equivalent_op (op);
9993 :
9994 72 : if (other_op != INTRINSIC_NONE)
9995 21 : gfc_current_ns->operator_access[other_op] = access;
9996 : }
9997 : else
9998 : {
9999 0 : gfc_error ("Access specification of the %s operator at %C has "
10000 : "already been specified", gfc_op2string (op));
10001 0 : goto done;
10002 : }
10003 :
10004 : break;
10005 :
10006 4 : case INTERFACE_USER_OP:
10007 4 : uop = gfc_get_uop (name);
10008 :
10009 4 : if (uop->access == ACCESS_UNKNOWN)
10010 : {
10011 3 : uop->access = access;
10012 : }
10013 : else
10014 : {
10015 1 : gfc_error ("Access specification of the .%s. operator at %C "
10016 : "has already been specified", uop->name);
10017 1 : goto done;
10018 : }
10019 :
10020 3 : break;
10021 : }
10022 :
10023 2862 : if (gfc_match_char (',') == MATCH_NO)
10024 : break;
10025 : }
10026 :
10027 1715 : if (gfc_match_eos () != MATCH_YES)
10028 0 : goto syntax;
10029 : return MATCH_YES;
10030 :
10031 0 : syntax:
10032 0 : gfc_syntax_error (st);
10033 :
10034 : done:
10035 : return MATCH_ERROR;
10036 : }
10037 :
10038 :
10039 : match
10040 23 : gfc_match_protected (void)
10041 : {
10042 23 : gfc_symbol *sym;
10043 23 : match m;
10044 23 : char c;
10045 :
10046 : /* PROTECTED has already been seen, but must be followed by whitespace
10047 : or ::. */
10048 23 : c = gfc_peek_ascii_char ();
10049 23 : if (!gfc_is_whitespace (c) && c != ':')
10050 : return MATCH_NO;
10051 :
10052 22 : if (!gfc_current_ns->proc_name
10053 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
10054 : {
10055 3 : gfc_error ("PROTECTED at %C only allowed in specification "
10056 : "part of a module");
10057 3 : return MATCH_ERROR;
10058 :
10059 : }
10060 :
10061 19 : gfc_match (" ::");
10062 :
10063 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
10064 : return MATCH_ERROR;
10065 :
10066 : /* PROTECTED has an entity-list. */
10067 18 : if (gfc_match_eos () == MATCH_YES)
10068 0 : goto syntax;
10069 :
10070 26 : for(;;)
10071 : {
10072 26 : m = gfc_match_symbol (&sym, 0);
10073 26 : switch (m)
10074 : {
10075 26 : case MATCH_YES:
10076 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
10077 : return MATCH_ERROR;
10078 25 : goto next_item;
10079 :
10080 : case MATCH_NO:
10081 : break;
10082 :
10083 : case MATCH_ERROR:
10084 : return MATCH_ERROR;
10085 : }
10086 :
10087 25 : next_item:
10088 25 : if (gfc_match_eos () == MATCH_YES)
10089 : break;
10090 8 : if (gfc_match_char (',') != MATCH_YES)
10091 0 : goto syntax;
10092 : }
10093 :
10094 : return MATCH_YES;
10095 :
10096 0 : syntax:
10097 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
10098 0 : return MATCH_ERROR;
10099 : }
10100 :
10101 :
10102 : /* The PRIVATE statement is a bit weird in that it can be an attribute
10103 : declaration, but also works as a standalone statement inside of a
10104 : type declaration or a module. */
10105 :
10106 : match
10107 28676 : gfc_match_private (gfc_statement *st)
10108 : {
10109 28676 : gfc_state_data *prev;
10110 :
10111 28676 : if (gfc_match ("private") != MATCH_YES)
10112 : return MATCH_NO;
10113 :
10114 : /* Try matching PRIVATE without an access-list. */
10115 1586 : if (gfc_match_eos () == MATCH_YES)
10116 : {
10117 1299 : prev = gfc_state_stack->previous;
10118 1299 : if (gfc_current_state () != COMP_MODULE
10119 366 : && !(gfc_current_state () == COMP_DERIVED
10120 333 : && prev && prev->state == COMP_MODULE)
10121 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10122 32 : && prev->previous && prev->previous->state == COMP_MODULE))
10123 : {
10124 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10125 : "specification part of a module");
10126 2 : return MATCH_ERROR;
10127 : }
10128 :
10129 1297 : *st = ST_PRIVATE;
10130 1297 : return MATCH_YES;
10131 : }
10132 :
10133 : /* At this point in free-form source code, PRIVATE must be followed
10134 : by whitespace or ::. */
10135 287 : if (gfc_current_form == FORM_FREE)
10136 : {
10137 285 : char c = gfc_peek_ascii_char ();
10138 285 : if (!gfc_is_whitespace (c) && c != ':')
10139 : return MATCH_NO;
10140 : }
10141 :
10142 286 : prev = gfc_state_stack->previous;
10143 286 : if (gfc_current_state () != COMP_MODULE
10144 1 : && !(gfc_current_state () == COMP_DERIVED
10145 0 : && prev && prev->state == COMP_MODULE)
10146 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10147 0 : && prev->previous && prev->previous->state == COMP_MODULE))
10148 : {
10149 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10150 : "specification part of a module");
10151 1 : return MATCH_ERROR;
10152 : }
10153 :
10154 285 : *st = ST_ATTR_DECL;
10155 285 : return access_attr_decl (ST_PRIVATE);
10156 : }
10157 :
10158 :
10159 : match
10160 1833 : gfc_match_public (gfc_statement *st)
10161 : {
10162 1833 : if (gfc_match ("public") != MATCH_YES)
10163 : return MATCH_NO;
10164 :
10165 : /* Try matching PUBLIC without an access-list. */
10166 1482 : if (gfc_match_eos () == MATCH_YES)
10167 : {
10168 45 : if (gfc_current_state () != COMP_MODULE)
10169 : {
10170 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10171 : "specification part of a module");
10172 2 : return MATCH_ERROR;
10173 : }
10174 :
10175 43 : *st = ST_PUBLIC;
10176 43 : return MATCH_YES;
10177 : }
10178 :
10179 : /* At this point in free-form source code, PUBLIC must be followed
10180 : by whitespace or ::. */
10181 1437 : if (gfc_current_form == FORM_FREE)
10182 : {
10183 1435 : char c = gfc_peek_ascii_char ();
10184 1435 : if (!gfc_is_whitespace (c) && c != ':')
10185 : return MATCH_NO;
10186 : }
10187 :
10188 1436 : if (gfc_current_state () != COMP_MODULE)
10189 : {
10190 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10191 : "specification part of a module");
10192 1 : return MATCH_ERROR;
10193 : }
10194 :
10195 1435 : *st = ST_ATTR_DECL;
10196 1435 : return access_attr_decl (ST_PUBLIC);
10197 : }
10198 :
10199 :
10200 : /* Workhorse for gfc_match_parameter. */
10201 :
10202 : static match
10203 7643 : do_parm (void)
10204 : {
10205 7643 : gfc_symbol *sym;
10206 7643 : gfc_expr *init;
10207 7643 : gfc_charlen *saved_cl_list;
10208 7643 : match m;
10209 7643 : bool t;
10210 :
10211 7643 : saved_cl_list = gfc_current_ns->cl_list;
10212 :
10213 7643 : m = gfc_match_symbol (&sym, 0);
10214 7643 : if (m == MATCH_NO)
10215 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10216 :
10217 7643 : if (m != MATCH_YES)
10218 : return m;
10219 :
10220 7643 : if (gfc_match_char ('=') == MATCH_NO)
10221 : {
10222 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10223 0 : return MATCH_ERROR;
10224 : }
10225 :
10226 7643 : m = gfc_match_init_expr (&init);
10227 7643 : if (m == MATCH_NO)
10228 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10229 7643 : if (m != MATCH_YES)
10230 : return m;
10231 :
10232 7642 : if (sym->ts.type == BT_UNKNOWN
10233 7642 : && !gfc_set_default_type (sym, 1, NULL))
10234 : {
10235 1 : m = MATCH_ERROR;
10236 1 : goto cleanup;
10237 : }
10238 :
10239 7641 : if (!gfc_check_assign_symbol (sym, NULL, init)
10240 7641 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10241 : {
10242 1 : m = MATCH_ERROR;
10243 1 : goto cleanup;
10244 : }
10245 :
10246 7640 : if (sym->value)
10247 : {
10248 1 : gfc_error ("Initializing already initialized variable at %C");
10249 1 : m = MATCH_ERROR;
10250 1 : goto cleanup;
10251 : }
10252 :
10253 7639 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus,
10254 : saved_cl_list);
10255 7639 : return (t) ? MATCH_YES : MATCH_ERROR;
10256 :
10257 3 : cleanup:
10258 3 : gfc_free_expr (init);
10259 3 : return m;
10260 : }
10261 :
10262 :
10263 : /* Match a parameter statement, with the weird syntax that these have. */
10264 :
10265 : match
10266 6930 : gfc_match_parameter (void)
10267 : {
10268 6930 : const char *term = " )%t";
10269 6930 : match m;
10270 :
10271 6930 : if (gfc_match_char ('(') == MATCH_NO)
10272 : {
10273 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10274 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10275 : return MATCH_NO;
10276 6929 : term = " %t";
10277 : }
10278 :
10279 7643 : for (;;)
10280 : {
10281 7643 : m = do_parm ();
10282 7643 : if (m != MATCH_YES)
10283 : break;
10284 :
10285 7639 : if (gfc_match (term) == MATCH_YES)
10286 : break;
10287 :
10288 714 : if (gfc_match_char (',') != MATCH_YES)
10289 : {
10290 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10291 0 : m = MATCH_ERROR;
10292 0 : break;
10293 : }
10294 : }
10295 :
10296 : return m;
10297 : }
10298 :
10299 :
10300 : match
10301 8 : gfc_match_automatic (void)
10302 : {
10303 8 : gfc_symbol *sym;
10304 8 : match m;
10305 8 : bool seen_symbol = false;
10306 :
10307 8 : if (!flag_dec_static)
10308 : {
10309 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10310 : "%<-fdec-static%>",
10311 : "AUTOMATIC"
10312 : );
10313 2 : return MATCH_ERROR;
10314 : }
10315 :
10316 6 : gfc_match (" ::");
10317 :
10318 6 : for (;;)
10319 : {
10320 6 : m = gfc_match_symbol (&sym, 0);
10321 6 : switch (m)
10322 : {
10323 : case MATCH_NO:
10324 : break;
10325 :
10326 : case MATCH_ERROR:
10327 : return MATCH_ERROR;
10328 :
10329 4 : case MATCH_YES:
10330 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10331 : return MATCH_ERROR;
10332 : seen_symbol = true;
10333 : break;
10334 : }
10335 :
10336 4 : if (gfc_match_eos () == MATCH_YES)
10337 : break;
10338 0 : if (gfc_match_char (',') != MATCH_YES)
10339 0 : goto syntax;
10340 : }
10341 :
10342 4 : if (!seen_symbol)
10343 : {
10344 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10345 2 : return MATCH_ERROR;
10346 : }
10347 :
10348 : return MATCH_YES;
10349 :
10350 0 : syntax:
10351 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10352 0 : return MATCH_ERROR;
10353 : }
10354 :
10355 :
10356 : match
10357 7 : gfc_match_static (void)
10358 : {
10359 7 : gfc_symbol *sym;
10360 7 : match m;
10361 7 : bool seen_symbol = false;
10362 :
10363 7 : if (!flag_dec_static)
10364 : {
10365 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10366 : "%<-fdec-static%>",
10367 : "STATIC");
10368 2 : return MATCH_ERROR;
10369 : }
10370 :
10371 5 : gfc_match (" ::");
10372 :
10373 5 : for (;;)
10374 : {
10375 5 : m = gfc_match_symbol (&sym, 0);
10376 5 : switch (m)
10377 : {
10378 : case MATCH_NO:
10379 : break;
10380 :
10381 : case MATCH_ERROR:
10382 : return MATCH_ERROR;
10383 :
10384 3 : case MATCH_YES:
10385 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10386 : &gfc_current_locus))
10387 : return MATCH_ERROR;
10388 : seen_symbol = true;
10389 : break;
10390 : }
10391 :
10392 3 : if (gfc_match_eos () == MATCH_YES)
10393 : break;
10394 0 : if (gfc_match_char (',') != MATCH_YES)
10395 0 : goto syntax;
10396 : }
10397 :
10398 3 : if (!seen_symbol)
10399 : {
10400 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10401 2 : return MATCH_ERROR;
10402 : }
10403 :
10404 : return MATCH_YES;
10405 :
10406 0 : syntax:
10407 0 : gfc_error ("Syntax error in STATIC statement at %C");
10408 0 : return MATCH_ERROR;
10409 : }
10410 :
10411 :
10412 : /* Save statements have a special syntax. */
10413 :
10414 : match
10415 272 : gfc_match_save (void)
10416 : {
10417 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10418 272 : gfc_common_head *c;
10419 272 : gfc_symbol *sym;
10420 272 : match m;
10421 :
10422 272 : if (gfc_match_eos () == MATCH_YES)
10423 : {
10424 150 : if (gfc_current_ns->seen_save)
10425 : {
10426 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10427 : "follows previous SAVE statement"))
10428 : return MATCH_ERROR;
10429 : }
10430 :
10431 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10432 149 : return MATCH_YES;
10433 : }
10434 :
10435 122 : if (gfc_current_ns->save_all)
10436 : {
10437 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10438 : "blanket SAVE statement"))
10439 : return MATCH_ERROR;
10440 : }
10441 :
10442 121 : gfc_match (" ::");
10443 :
10444 183 : for (;;)
10445 : {
10446 183 : m = gfc_match_symbol (&sym, 0);
10447 183 : switch (m)
10448 : {
10449 181 : case MATCH_YES:
10450 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10451 : &gfc_current_locus))
10452 : return MATCH_ERROR;
10453 179 : goto next_item;
10454 :
10455 : case MATCH_NO:
10456 : break;
10457 :
10458 : case MATCH_ERROR:
10459 : return MATCH_ERROR;
10460 : }
10461 :
10462 2 : m = gfc_match (" / %n /", &n);
10463 2 : if (m == MATCH_ERROR)
10464 : return MATCH_ERROR;
10465 2 : if (m == MATCH_NO)
10466 0 : goto syntax;
10467 :
10468 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10469 : saved-entity-list that does not specify a common-block-name. */
10470 2 : if (gfc_current_state () == COMP_BLOCK)
10471 : {
10472 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10473 : "in a BLOCK construct", n);
10474 1 : return MATCH_ERROR;
10475 : }
10476 :
10477 1 : c = gfc_get_common (n, 0);
10478 1 : c->saved = 1;
10479 :
10480 1 : gfc_current_ns->seen_save = 1;
10481 :
10482 180 : next_item:
10483 180 : if (gfc_match_eos () == MATCH_YES)
10484 : break;
10485 62 : if (gfc_match_char (',') != MATCH_YES)
10486 0 : goto syntax;
10487 : }
10488 :
10489 : return MATCH_YES;
10490 :
10491 0 : syntax:
10492 0 : if (gfc_current_ns->seen_save)
10493 : {
10494 0 : gfc_error ("Syntax error in SAVE statement at %C");
10495 0 : return MATCH_ERROR;
10496 : }
10497 : else
10498 : return MATCH_NO;
10499 : }
10500 :
10501 :
10502 : match
10503 93 : gfc_match_value (void)
10504 : {
10505 93 : gfc_symbol *sym;
10506 93 : match m;
10507 :
10508 : /* This is not allowed within a BLOCK construct! */
10509 93 : if (gfc_current_state () == COMP_BLOCK)
10510 : {
10511 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10512 2 : return MATCH_ERROR;
10513 : }
10514 :
10515 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10516 : return MATCH_ERROR;
10517 :
10518 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10519 : {
10520 : return MATCH_ERROR;
10521 : }
10522 :
10523 90 : if (gfc_match_eos () == MATCH_YES)
10524 0 : goto syntax;
10525 :
10526 116 : for(;;)
10527 : {
10528 116 : m = gfc_match_symbol (&sym, 0);
10529 116 : switch (m)
10530 : {
10531 116 : case MATCH_YES:
10532 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10533 : return MATCH_ERROR;
10534 109 : goto next_item;
10535 :
10536 : case MATCH_NO:
10537 : break;
10538 :
10539 : case MATCH_ERROR:
10540 : return MATCH_ERROR;
10541 : }
10542 :
10543 109 : next_item:
10544 109 : if (gfc_match_eos () == MATCH_YES)
10545 : break;
10546 26 : if (gfc_match_char (',') != MATCH_YES)
10547 0 : goto syntax;
10548 : }
10549 :
10550 : return MATCH_YES;
10551 :
10552 0 : syntax:
10553 0 : gfc_error ("Syntax error in VALUE statement at %C");
10554 0 : return MATCH_ERROR;
10555 : }
10556 :
10557 :
10558 : match
10559 45 : gfc_match_volatile (void)
10560 : {
10561 45 : gfc_symbol *sym;
10562 45 : char *name;
10563 45 : match m;
10564 :
10565 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10566 : return MATCH_ERROR;
10567 :
10568 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10569 : {
10570 : return MATCH_ERROR;
10571 : }
10572 :
10573 44 : if (gfc_match_eos () == MATCH_YES)
10574 1 : goto syntax;
10575 :
10576 48 : for(;;)
10577 : {
10578 : /* VOLATILE is special because it can be added to host-associated
10579 : symbols locally. Except for coarrays. */
10580 48 : m = gfc_match_symbol (&sym, 1);
10581 48 : switch (m)
10582 : {
10583 48 : case MATCH_YES:
10584 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10585 48 : strcpy (name, sym->name);
10586 48 : if (!check_function_name (name))
10587 : return MATCH_ERROR;
10588 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10589 : for variable in a BLOCK which is defined outside of the BLOCK. */
10590 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10591 : {
10592 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10593 : "%C, which is use-/host-associated", sym->name);
10594 2 : return MATCH_ERROR;
10595 : }
10596 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10597 : return MATCH_ERROR;
10598 42 : goto next_item;
10599 :
10600 : case MATCH_NO:
10601 : break;
10602 :
10603 : case MATCH_ERROR:
10604 : return MATCH_ERROR;
10605 : }
10606 :
10607 42 : next_item:
10608 42 : if (gfc_match_eos () == MATCH_YES)
10609 : break;
10610 5 : if (gfc_match_char (',') != MATCH_YES)
10611 0 : goto syntax;
10612 : }
10613 :
10614 : return MATCH_YES;
10615 :
10616 1 : syntax:
10617 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10618 1 : return MATCH_ERROR;
10619 : }
10620 :
10621 :
10622 : match
10623 11 : gfc_match_asynchronous (void)
10624 : {
10625 11 : gfc_symbol *sym;
10626 11 : char *name;
10627 11 : match m;
10628 :
10629 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10630 : return MATCH_ERROR;
10631 :
10632 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10633 : {
10634 : return MATCH_ERROR;
10635 : }
10636 :
10637 10 : if (gfc_match_eos () == MATCH_YES)
10638 0 : goto syntax;
10639 :
10640 10 : for(;;)
10641 : {
10642 : /* ASYNCHRONOUS is special because it can be added to host-associated
10643 : symbols locally. */
10644 10 : m = gfc_match_symbol (&sym, 1);
10645 10 : switch (m)
10646 : {
10647 10 : case MATCH_YES:
10648 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10649 10 : strcpy (name, sym->name);
10650 10 : if (!check_function_name (name))
10651 : return MATCH_ERROR;
10652 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10653 : return MATCH_ERROR;
10654 7 : goto next_item;
10655 :
10656 : case MATCH_NO:
10657 : break;
10658 :
10659 : case MATCH_ERROR:
10660 : return MATCH_ERROR;
10661 : }
10662 :
10663 7 : next_item:
10664 7 : if (gfc_match_eos () == MATCH_YES)
10665 : break;
10666 0 : if (gfc_match_char (',') != MATCH_YES)
10667 0 : goto syntax;
10668 : }
10669 :
10670 : return MATCH_YES;
10671 :
10672 0 : syntax:
10673 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10674 0 : return MATCH_ERROR;
10675 : }
10676 :
10677 :
10678 : /* Match a module procedure statement in a submodule. */
10679 :
10680 : match
10681 753793 : gfc_match_submod_proc (void)
10682 : {
10683 753793 : char name[GFC_MAX_SYMBOL_LEN + 1];
10684 753793 : gfc_symbol *sym, *fsym;
10685 753793 : match m;
10686 753793 : gfc_formal_arglist *formal, *head, *tail;
10687 :
10688 753793 : if (gfc_current_state () != COMP_CONTAINS
10689 15203 : || !(gfc_state_stack->previous
10690 15203 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10691 15203 : || gfc_state_stack->previous->state == COMP_MODULE)))
10692 : return MATCH_NO;
10693 :
10694 7586 : m = gfc_match (" module% procedure% %n", name);
10695 7586 : if (m != MATCH_YES)
10696 : return m;
10697 :
10698 254 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10699 : "at %C"))
10700 : return MATCH_ERROR;
10701 :
10702 254 : if (get_proc_name (name, &sym, false))
10703 : return MATCH_ERROR;
10704 :
10705 : /* Make sure that the result field is appropriately filled. */
10706 254 : if (sym->tlink && sym->tlink->attr.function)
10707 : {
10708 117 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10709 : {
10710 67 : sym->result = sym->tlink->result;
10711 67 : if (!sym->result->attr.use_assoc)
10712 : {
10713 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10714 : sym->result->name);
10715 20 : st->n.sym = sym->result;
10716 20 : sym->result->refs++;
10717 : }
10718 : }
10719 : else
10720 50 : sym->result = sym;
10721 : }
10722 :
10723 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10724 : the symbol existed before. */
10725 254 : sym->declared_at = gfc_current_locus;
10726 :
10727 254 : if (!sym->attr.module_procedure)
10728 : return MATCH_ERROR;
10729 :
10730 : /* Signal match_end to expect "end procedure". */
10731 252 : sym->abr_modproc_decl = 1;
10732 :
10733 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10734 252 : sym->attr.if_source = IFSRC_DECL;
10735 :
10736 252 : gfc_new_block = sym;
10737 :
10738 : /* Make a new formal arglist with the symbols in the procedure
10739 : namespace. */
10740 252 : head = tail = NULL;
10741 575 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10742 : {
10743 323 : if (formal == sym->formal)
10744 226 : head = tail = gfc_get_formal_arglist ();
10745 : else
10746 : {
10747 97 : tail->next = gfc_get_formal_arglist ();
10748 97 : tail = tail->next;
10749 : }
10750 :
10751 323 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10752 0 : goto cleanup;
10753 :
10754 323 : tail->sym = fsym;
10755 323 : gfc_set_sym_referenced (fsym);
10756 : }
10757 :
10758 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10759 : interface declaration is cleared. This allows us to add the
10760 : explicit interface as is done for other type of procedure. */
10761 252 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10762 : &gfc_current_locus))
10763 : return MATCH_ERROR;
10764 :
10765 252 : if (gfc_match_eos () != MATCH_YES)
10766 : {
10767 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10768 : undone, such that the st->n.sym->formal points to the original symbol;
10769 : if now this namespace is finalized, the formal namespace is freed,
10770 : but it might be still needed in the parent namespace. */
10771 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10772 1 : st->n.sym = NULL;
10773 1 : gfc_free_symbol (sym->tlink);
10774 1 : sym->tlink = NULL;
10775 1 : sym->refs--;
10776 1 : gfc_syntax_error (ST_MODULE_PROC);
10777 1 : return MATCH_ERROR;
10778 : }
10779 :
10780 : return MATCH_YES;
10781 :
10782 0 : cleanup:
10783 0 : gfc_free_formal_arglist (head);
10784 0 : return MATCH_ERROR;
10785 : }
10786 :
10787 :
10788 : /* Match a module procedure statement. Note that we have to modify
10789 : symbols in the parent's namespace because the current one was there
10790 : to receive symbols that are in an interface's formal argument list. */
10791 :
10792 : match
10793 1601 : gfc_match_modproc (void)
10794 : {
10795 1601 : char name[GFC_MAX_SYMBOL_LEN + 1];
10796 1601 : gfc_symbol *sym;
10797 1601 : match m;
10798 1601 : locus old_locus;
10799 1601 : gfc_namespace *module_ns;
10800 1601 : gfc_interface *old_interface_head, *interface;
10801 :
10802 1601 : if (gfc_state_stack->previous == NULL
10803 1599 : || (gfc_state_stack->state != COMP_INTERFACE
10804 5 : && (gfc_state_stack->state != COMP_CONTAINS
10805 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10806 1594 : || current_interface.type == INTERFACE_NAMELESS
10807 1594 : || current_interface.type == INTERFACE_ABSTRACT)
10808 : {
10809 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10810 : "interface");
10811 8 : return MATCH_ERROR;
10812 : }
10813 :
10814 1593 : module_ns = gfc_current_ns->parent;
10815 1599 : for (; module_ns; module_ns = module_ns->parent)
10816 1599 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10817 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10818 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10819 12 : && !module_ns->proc_name->attr.contained))
10820 : break;
10821 :
10822 1593 : if (module_ns == NULL)
10823 : return MATCH_ERROR;
10824 :
10825 : /* Store the current state of the interface. We will need it if we
10826 : end up with a syntax error and need to recover. */
10827 1593 : old_interface_head = gfc_current_interface_head ();
10828 :
10829 : /* Check if the F2008 optional double colon appears. */
10830 1593 : gfc_gobble_whitespace ();
10831 1593 : old_locus = gfc_current_locus;
10832 1593 : if (gfc_match ("::") == MATCH_YES)
10833 : {
10834 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10835 : "MODULE PROCEDURE statement at %L", &old_locus))
10836 : return MATCH_ERROR;
10837 : }
10838 : else
10839 1568 : gfc_current_locus = old_locus;
10840 :
10841 1948 : for (;;)
10842 : {
10843 1948 : bool last = false;
10844 1948 : old_locus = gfc_current_locus;
10845 :
10846 1948 : m = gfc_match_name (name);
10847 1948 : if (m == MATCH_NO)
10848 1 : goto syntax;
10849 1947 : if (m != MATCH_YES)
10850 : return MATCH_ERROR;
10851 :
10852 : /* Check for syntax error before starting to add symbols to the
10853 : current namespace. */
10854 1947 : if (gfc_match_eos () == MATCH_YES)
10855 : last = true;
10856 :
10857 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10858 2 : goto syntax;
10859 :
10860 : /* Now we're sure the syntax is valid, we process this item
10861 : further. */
10862 1945 : if (gfc_get_symbol (name, module_ns, &sym))
10863 : return MATCH_ERROR;
10864 :
10865 1945 : if (sym->attr.intrinsic)
10866 : {
10867 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10868 : "PROCEDURE", &old_locus);
10869 1 : return MATCH_ERROR;
10870 : }
10871 :
10872 1944 : if (sym->attr.proc != PROC_MODULE
10873 1944 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10874 : return MATCH_ERROR;
10875 :
10876 1941 : if (!gfc_add_interface (sym))
10877 : return MATCH_ERROR;
10878 :
10879 1938 : sym->attr.mod_proc = 1;
10880 1938 : sym->declared_at = old_locus;
10881 :
10882 1938 : if (last)
10883 : break;
10884 : }
10885 :
10886 : return MATCH_YES;
10887 :
10888 3 : syntax:
10889 : /* Restore the previous state of the interface. */
10890 3 : interface = gfc_current_interface_head ();
10891 3 : gfc_set_current_interface_head (old_interface_head);
10892 :
10893 : /* Free the new interfaces. */
10894 10 : while (interface != old_interface_head)
10895 : {
10896 4 : gfc_interface *i = interface->next;
10897 4 : free (interface);
10898 4 : interface = i;
10899 : }
10900 :
10901 : /* And issue a syntax error. */
10902 3 : gfc_syntax_error (ST_MODULE_PROC);
10903 3 : return MATCH_ERROR;
10904 : }
10905 :
10906 :
10907 : /* Check a derived type that is being extended. */
10908 :
10909 : static gfc_symbol*
10910 1477 : check_extended_derived_type (char *name)
10911 : {
10912 1477 : gfc_symbol *extended;
10913 :
10914 1477 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10915 : {
10916 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10917 0 : return NULL;
10918 : }
10919 :
10920 1477 : extended = gfc_find_dt_in_generic (extended);
10921 :
10922 : /* F08:C428. */
10923 1477 : if (!extended)
10924 : {
10925 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10926 2 : return NULL;
10927 : }
10928 :
10929 1475 : if (extended->attr.flavor != FL_DERIVED)
10930 : {
10931 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10932 : "derived type", name);
10933 0 : return NULL;
10934 : }
10935 :
10936 1475 : if (extended->attr.is_bind_c)
10937 : {
10938 1 : gfc_error ("%qs cannot be extended at %C because it "
10939 : "is BIND(C)", extended->name);
10940 1 : return NULL;
10941 : }
10942 :
10943 1474 : if (extended->attr.sequence)
10944 : {
10945 1 : gfc_error ("%qs cannot be extended at %C because it "
10946 : "is a SEQUENCE type", extended->name);
10947 1 : return NULL;
10948 : }
10949 :
10950 : return extended;
10951 : }
10952 :
10953 :
10954 : /* Match the optional attribute specifiers for a type declaration.
10955 : Return MATCH_ERROR if an error is encountered in one of the handled
10956 : attributes (public, private, bind(c)), MATCH_NO if what's found is
10957 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10958 : checking on attribute conflicts needs to be done. */
10959 :
10960 : static match
10961 19097 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10962 : {
10963 : /* See if the derived type is marked as private. */
10964 19097 : if (gfc_match (" , private") == MATCH_YES)
10965 : {
10966 15 : if (gfc_current_state () != COMP_MODULE)
10967 : {
10968 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
10969 : "specification part of a module");
10970 1 : return MATCH_ERROR;
10971 : }
10972 :
10973 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10974 : return MATCH_ERROR;
10975 : }
10976 19082 : else if (gfc_match (" , public") == MATCH_YES)
10977 : {
10978 546 : if (gfc_current_state () != COMP_MODULE)
10979 : {
10980 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
10981 : "specification part of a module");
10982 0 : return MATCH_ERROR;
10983 : }
10984 :
10985 546 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10986 : return MATCH_ERROR;
10987 : }
10988 18536 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
10989 : {
10990 : /* If the type is defined to be bind(c) it then needs to make
10991 : sure that all fields are interoperable. This will
10992 : need to be a semantic check on the finished derived type.
10993 : See 15.2.3 (lines 9-12) of F2003 draft. */
10994 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10995 : return MATCH_ERROR;
10996 :
10997 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10998 : }
10999 18129 : else if (gfc_match (" , abstract") == MATCH_YES)
11000 : {
11001 331 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
11002 : return MATCH_ERROR;
11003 :
11004 330 : if (!gfc_add_abstract (attr, &gfc_current_locus))
11005 : return MATCH_ERROR;
11006 : }
11007 17798 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
11008 : {
11009 1478 : if (!gfc_add_extension (attr, &gfc_current_locus))
11010 : return MATCH_ERROR;
11011 : }
11012 : else
11013 16320 : return MATCH_NO;
11014 :
11015 : /* If we get here, something matched. */
11016 : return MATCH_YES;
11017 : }
11018 :
11019 :
11020 : /* Common function for type declaration blocks similar to derived types, such
11021 : as STRUCTURES and MAPs. Unlike derived types, a structure type
11022 : does NOT have a generic symbol matching the name given by the user.
11023 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
11024 : for the creation of an independent symbol.
11025 : Other parameters are a message to prefix errors with, the name of the new
11026 : type to be created, and the flavor to add to the resulting symbol. */
11027 :
11028 : static bool
11029 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
11030 : gfc_symbol **result)
11031 : {
11032 717 : gfc_symbol *sym;
11033 717 : locus where;
11034 :
11035 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
11036 :
11037 717 : if (decl)
11038 717 : where = *decl;
11039 : else
11040 0 : where = gfc_current_locus;
11041 :
11042 717 : if (gfc_get_symbol (name, NULL, &sym))
11043 : return false;
11044 :
11045 717 : if (!sym)
11046 : {
11047 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
11048 : return false;
11049 : }
11050 :
11051 717 : if (sym->components != NULL || sym->attr.zero_comp)
11052 : {
11053 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
11054 : sym->name, &sym->declared_at);
11055 3 : return false;
11056 : }
11057 :
11058 714 : sym->declared_at = where;
11059 :
11060 714 : if (sym->attr.flavor != fl
11061 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
11062 : return false;
11063 :
11064 714 : if (!sym->hash_value)
11065 : /* Set the hash for the compound name for this type. */
11066 713 : sym->hash_value = gfc_hash_value (sym);
11067 :
11068 : /* Normally the type is expected to have been completely parsed by the time
11069 : a field declaration with this type is seen. For unions, maps, and nested
11070 : structure declarations, we need to indicate that it is okay that we
11071 : haven't seen any components yet. This will be updated after the structure
11072 : is fully parsed. */
11073 714 : sym->attr.zero_comp = 0;
11074 :
11075 : /* Structures always act like derived-types with the SEQUENCE attribute */
11076 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
11077 :
11078 714 : if (result) *result = sym;
11079 :
11080 : return true;
11081 : }
11082 :
11083 :
11084 : /* Match the opening of a MAP block. Like a struct within a union in C;
11085 : behaves identical to STRUCTURE blocks. */
11086 :
11087 : match
11088 259 : gfc_match_map (void)
11089 : {
11090 : /* Counter used to give unique internal names to map structures. */
11091 259 : static unsigned int gfc_map_id = 0;
11092 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
11093 259 : gfc_symbol *sym;
11094 259 : locus old_loc;
11095 :
11096 259 : old_loc = gfc_current_locus;
11097 :
11098 259 : if (gfc_match_eos () != MATCH_YES)
11099 : {
11100 1 : gfc_error ("Junk after MAP statement at %C");
11101 1 : gfc_current_locus = old_loc;
11102 1 : return MATCH_ERROR;
11103 : }
11104 :
11105 : /* Map blocks are anonymous so we make up unique names for the symbol table
11106 : which are invalid Fortran identifiers. */
11107 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
11108 :
11109 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
11110 : return MATCH_ERROR;
11111 :
11112 258 : gfc_new_block = sym;
11113 :
11114 258 : return MATCH_YES;
11115 : }
11116 :
11117 :
11118 : /* Match the opening of a UNION block. */
11119 :
11120 : match
11121 133 : gfc_match_union (void)
11122 : {
11123 : /* Counter used to give unique internal names to union types. */
11124 133 : static unsigned int gfc_union_id = 0;
11125 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
11126 133 : gfc_symbol *sym;
11127 133 : locus old_loc;
11128 :
11129 133 : old_loc = gfc_current_locus;
11130 :
11131 133 : if (gfc_match_eos () != MATCH_YES)
11132 : {
11133 1 : gfc_error ("Junk after UNION statement at %C");
11134 1 : gfc_current_locus = old_loc;
11135 1 : return MATCH_ERROR;
11136 : }
11137 :
11138 : /* Unions are anonymous so we make up unique names for the symbol table
11139 : which are invalid Fortran identifiers. */
11140 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
11141 :
11142 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
11143 : return MATCH_ERROR;
11144 :
11145 132 : gfc_new_block = sym;
11146 :
11147 132 : return MATCH_YES;
11148 : }
11149 :
11150 :
11151 : /* Match the beginning of a STRUCTURE declaration. This is similar to
11152 : matching the beginning of a derived type declaration with a few
11153 : twists. The resulting type symbol has no access control or other
11154 : interesting attributes. */
11155 :
11156 : match
11157 336 : gfc_match_structure_decl (void)
11158 : {
11159 : /* Counter used to give unique internal names to anonymous structures. */
11160 336 : static unsigned int gfc_structure_id = 0;
11161 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
11162 336 : gfc_symbol *sym;
11163 336 : match m;
11164 336 : locus where;
11165 :
11166 336 : if (!flag_dec_structure)
11167 : {
11168 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11169 : "%<-fdec-structure%>",
11170 : "STRUCTURE");
11171 3 : return MATCH_ERROR;
11172 : }
11173 :
11174 333 : name[0] = '\0';
11175 :
11176 333 : m = gfc_match (" /%n/", name);
11177 333 : if (m != MATCH_YES)
11178 : {
11179 : /* Non-nested structure declarations require a structure name. */
11180 24 : if (!gfc_comp_struct (gfc_current_state ()))
11181 : {
11182 4 : gfc_error ("Structure name expected in non-nested structure "
11183 : "declaration at %C");
11184 4 : return MATCH_ERROR;
11185 : }
11186 : /* This is an anonymous structure; make up a unique name for it
11187 : (upper-case letters never make it to symbol names from the source).
11188 : The important thing is initializing the type variable
11189 : and setting gfc_new_symbol, which is immediately used by
11190 : parse_structure () and variable_decl () to add components of
11191 : this type. */
11192 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11193 : }
11194 :
11195 329 : where = gfc_current_locus;
11196 : /* No field list allowed after non-nested structure declaration. */
11197 329 : if (!gfc_comp_struct (gfc_current_state ())
11198 296 : && gfc_match_eos () != MATCH_YES)
11199 : {
11200 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11201 1 : return MATCH_ERROR;
11202 : }
11203 :
11204 : /* Make sure the name is not the name of an intrinsic type. */
11205 328 : if (gfc_is_intrinsic_typename (name))
11206 : {
11207 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11208 : " intrinsic type", name);
11209 1 : return MATCH_ERROR;
11210 : }
11211 :
11212 : /* Store the actual type symbol for the structure with an upper-case first
11213 : letter (an invalid Fortran identifier). */
11214 :
11215 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11216 : return MATCH_ERROR;
11217 :
11218 324 : gfc_new_block = sym;
11219 324 : return MATCH_YES;
11220 : }
11221 :
11222 :
11223 : /* This function does some work to determine which matcher should be used to
11224 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11225 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11226 : * and [parameterized] derived type declarations. */
11227 :
11228 : match
11229 521227 : gfc_match_type (gfc_statement *st)
11230 : {
11231 521227 : char name[GFC_MAX_SYMBOL_LEN + 1];
11232 521227 : match m;
11233 521227 : locus old_loc;
11234 :
11235 : /* Requires -fdec. */
11236 521227 : if (!flag_dec)
11237 : return MATCH_NO;
11238 :
11239 2483 : m = gfc_match ("type");
11240 2483 : if (m != MATCH_YES)
11241 : return m;
11242 : /* If we already have an error in the buffer, it is probably from failing to
11243 : * match a derived type data declaration. Let it happen. */
11244 20 : else if (gfc_error_flag_test ())
11245 : return MATCH_NO;
11246 :
11247 20 : old_loc = gfc_current_locus;
11248 20 : *st = ST_NONE;
11249 :
11250 : /* If we see an attribute list before anything else it's definitely a derived
11251 : * type declaration. */
11252 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11253 8 : goto derived;
11254 :
11255 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11256 : * be something like "TYPE *" or "TYPE <fmt>". */
11257 12 : m = gfc_match_name (name);
11258 12 : if (m != MATCH_YES)
11259 : {
11260 : /* Let print match if it can, otherwise throw an error from
11261 : * gfc_match_derived_decl. */
11262 7 : gfc_current_locus = old_loc;
11263 7 : if (gfc_match_print () == MATCH_YES)
11264 : {
11265 7 : *st = ST_WRITE;
11266 7 : return MATCH_YES;
11267 : }
11268 0 : goto derived;
11269 : }
11270 :
11271 : /* Check for EOS. */
11272 5 : if (gfc_match_eos () == MATCH_YES)
11273 : {
11274 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11275 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11276 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11277 : * symbol which can be printed. */
11278 3 : gfc_current_locus = old_loc;
11279 3 : m = gfc_match_derived_decl ();
11280 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11281 : {
11282 2 : *st = ST_DERIVED_DECL;
11283 2 : return m;
11284 : }
11285 : }
11286 : else
11287 : {
11288 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11289 : like <type name(parameter)>. */
11290 2 : gfc_gobble_whitespace ();
11291 2 : bool paren = gfc_peek_ascii_char () == '(';
11292 2 : if (paren)
11293 : {
11294 1 : if (strcmp ("is", name) == 0)
11295 1 : goto typeis;
11296 : else
11297 0 : goto derived;
11298 : }
11299 : }
11300 :
11301 : /* Treat TYPE... like PRINT... */
11302 2 : gfc_current_locus = old_loc;
11303 2 : *st = ST_WRITE;
11304 2 : return gfc_match_print ();
11305 :
11306 8 : derived:
11307 8 : gfc_current_locus = old_loc;
11308 8 : *st = ST_DERIVED_DECL;
11309 8 : return gfc_match_derived_decl ();
11310 :
11311 1 : typeis:
11312 1 : gfc_current_locus = old_loc;
11313 1 : *st = ST_TYPE_IS;
11314 1 : return gfc_match_type_is ();
11315 : }
11316 :
11317 :
11318 : /* Match the beginning of a derived type declaration. If a type name
11319 : was the result of a function, then it is possible to have a symbol
11320 : already to be known as a derived type yet have no components. */
11321 :
11322 : match
11323 16327 : gfc_match_derived_decl (void)
11324 : {
11325 16327 : char name[GFC_MAX_SYMBOL_LEN + 1];
11326 16327 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11327 16327 : symbol_attribute attr;
11328 16327 : gfc_symbol *sym, *gensym;
11329 16327 : gfc_symbol *extended;
11330 16327 : match m;
11331 16327 : match is_type_attr_spec = MATCH_NO;
11332 16327 : bool seen_attr = false;
11333 16327 : gfc_interface *intr = NULL, *head;
11334 16327 : bool parameterized_type = false;
11335 16327 : bool seen_colons = false;
11336 :
11337 16327 : if (gfc_comp_struct (gfc_current_state ()))
11338 : return MATCH_NO;
11339 :
11340 16323 : name[0] = '\0';
11341 16323 : parent[0] = '\0';
11342 16323 : gfc_clear_attr (&attr);
11343 16323 : extended = NULL;
11344 :
11345 19097 : do
11346 : {
11347 19097 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11348 19097 : if (is_type_attr_spec == MATCH_ERROR)
11349 : return MATCH_ERROR;
11350 19094 : if (is_type_attr_spec == MATCH_YES)
11351 2774 : seen_attr = true;
11352 19094 : } while (is_type_attr_spec == MATCH_YES);
11353 :
11354 : /* Deal with derived type extensions. The extension attribute has
11355 : been added to 'attr' but now the parent type must be found and
11356 : checked. */
11357 16320 : if (parent[0])
11358 1477 : extended = check_extended_derived_type (parent);
11359 :
11360 16320 : if (parent[0] && !extended)
11361 : return MATCH_ERROR;
11362 :
11363 16316 : m = gfc_match (" ::");
11364 16316 : if (m == MATCH_YES)
11365 : {
11366 : seen_colons = true;
11367 : }
11368 10336 : else if (seen_attr)
11369 : {
11370 5 : gfc_error ("Expected :: in TYPE definition at %C");
11371 5 : return MATCH_ERROR;
11372 : }
11373 :
11374 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11375 : But, we need to simply return for TYPE(. */
11376 10331 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11377 : {
11378 10283 : char c = gfc_peek_ascii_char ();
11379 10283 : if (c == '(')
11380 : return m;
11381 10202 : if (!gfc_is_whitespace (c))
11382 : {
11383 4 : gfc_error ("Mangled derived type definition at %C");
11384 4 : return MATCH_NO;
11385 : }
11386 : }
11387 :
11388 16226 : m = gfc_match (" %n ", name);
11389 16226 : if (m != MATCH_YES)
11390 : return m;
11391 :
11392 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11393 : derived type named 'is'.
11394 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11395 : and checking if this is a(n intrinsic) typename. This picks up
11396 : misplaced TYPE IS statements such as in select_type_1.f03. */
11397 16214 : if (gfc_peek_ascii_char () == '(')
11398 : {
11399 3872 : if (gfc_current_state () == COMP_SELECT_TYPE
11400 440 : || (!seen_colons && !strcmp (name, "is")))
11401 : return MATCH_NO;
11402 : parameterized_type = true;
11403 : }
11404 :
11405 12780 : m = gfc_match_eos ();
11406 12780 : if (m != MATCH_YES && !parameterized_type)
11407 : return m;
11408 :
11409 : /* Make sure the name is not the name of an intrinsic type. */
11410 12777 : if (gfc_is_intrinsic_typename (name))
11411 : {
11412 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11413 : "type", name);
11414 18 : return MATCH_ERROR;
11415 : }
11416 :
11417 12759 : if (gfc_get_symbol (name, NULL, &gensym))
11418 : return MATCH_ERROR;
11419 :
11420 12759 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11421 : {
11422 5 : if (gensym->ts.u.derived)
11423 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11424 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11425 : else
11426 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11427 : gensym->name);
11428 5 : return MATCH_ERROR;
11429 : }
11430 :
11431 12754 : if (!gensym->attr.generic
11432 12754 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11433 : return MATCH_ERROR;
11434 :
11435 12750 : if (!gensym->attr.function
11436 12750 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11437 : return MATCH_ERROR;
11438 :
11439 12749 : if (gensym->attr.dummy)
11440 : {
11441 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11442 : name, &gensym->declared_at);
11443 1 : return MATCH_ERROR;
11444 : }
11445 :
11446 12748 : sym = gfc_find_dt_in_generic (gensym);
11447 :
11448 12748 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11449 : {
11450 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11451 : "defined", sym->name);
11452 1 : return MATCH_ERROR;
11453 : }
11454 :
11455 12747 : if (!sym)
11456 : {
11457 : /* Use upper case to save the actual derived-type symbol. */
11458 12657 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11459 12657 : sym->name = gfc_get_string ("%s", gensym->name);
11460 12657 : head = gensym->generic;
11461 12657 : intr = gfc_get_interface ();
11462 12657 : intr->sym = sym;
11463 12657 : intr->where = gfc_current_locus;
11464 12657 : intr->sym->declared_at = gfc_current_locus;
11465 12657 : intr->next = head;
11466 12657 : gensym->generic = intr;
11467 12657 : gensym->attr.if_source = IFSRC_DECL;
11468 : }
11469 :
11470 : /* The symbol may already have the derived attribute without the
11471 : components. The ways this can happen is via a function
11472 : definition, an INTRINSIC statement or a subtype in another
11473 : derived type that is a pointer. The first part of the AND clause
11474 : is true if the symbol is not the return value of a function. */
11475 12747 : if (sym->attr.flavor != FL_DERIVED
11476 12747 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11477 : return MATCH_ERROR;
11478 :
11479 12747 : if (attr.access != ACCESS_UNKNOWN
11480 12747 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11481 : return MATCH_ERROR;
11482 12747 : else if (sym->attr.access == ACCESS_UNKNOWN
11483 12191 : && gensym->attr.access != ACCESS_UNKNOWN
11484 13075 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11485 : sym->name, NULL))
11486 : return MATCH_ERROR;
11487 :
11488 12747 : if (sym->attr.access != ACCESS_UNKNOWN
11489 884 : && gensym->attr.access == ACCESS_UNKNOWN)
11490 556 : gensym->attr.access = sym->attr.access;
11491 :
11492 : /* See if the derived type was labeled as bind(c). */
11493 12747 : if (attr.is_bind_c != 0)
11494 404 : sym->attr.is_bind_c = attr.is_bind_c;
11495 :
11496 : /* Construct the f2k_derived namespace if it is not yet there. */
11497 12747 : if (!sym->f2k_derived)
11498 12747 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11499 :
11500 12747 : if (parameterized_type)
11501 : {
11502 : /* Ignore error or mismatches by going to the end of the statement
11503 : in order to avoid the component declarations causing problems. */
11504 438 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11505 438 : if (m != MATCH_YES)
11506 4 : gfc_error_recovery ();
11507 : else
11508 434 : sym->attr.pdt_template = 1;
11509 438 : m = gfc_match_eos ();
11510 438 : if (m != MATCH_YES)
11511 : {
11512 1 : gfc_error_recovery ();
11513 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11514 : }
11515 : }
11516 :
11517 12747 : if (extended && !sym->components)
11518 : {
11519 1473 : gfc_component *p;
11520 1473 : gfc_formal_arglist *f, *g, *h;
11521 :
11522 : /* Add the extended derived type as the first component. */
11523 1473 : gfc_add_component (sym, parent, &p);
11524 1473 : extended->refs++;
11525 1473 : gfc_set_sym_referenced (extended);
11526 :
11527 1473 : p->ts.type = BT_DERIVED;
11528 1473 : p->ts.u.derived = extended;
11529 1473 : p->initializer = gfc_default_initializer (&p->ts);
11530 :
11531 : /* Set extension level. */
11532 1473 : if (extended->attr.extension == 255)
11533 : {
11534 : /* Since the extension field is 8 bit wide, we can only have
11535 : up to 255 extension levels. */
11536 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11537 : extended->name, &extended->declared_at);
11538 0 : return MATCH_ERROR;
11539 : }
11540 1473 : sym->attr.extension = extended->attr.extension + 1;
11541 :
11542 : /* Provide the links between the extended type and its extension. */
11543 1473 : if (!extended->f2k_derived)
11544 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11545 :
11546 : /* Copy the extended type-param-name-list from the extended type,
11547 : append those of the extension and add the whole lot to the
11548 : extension. */
11549 1473 : if (extended->attr.pdt_template)
11550 : {
11551 34 : g = h = NULL;
11552 34 : sym->attr.pdt_template = 1;
11553 99 : for (f = extended->formal; f; f = f->next)
11554 : {
11555 65 : if (f == extended->formal)
11556 : {
11557 34 : g = gfc_get_formal_arglist ();
11558 34 : h = g;
11559 : }
11560 : else
11561 : {
11562 31 : g->next = gfc_get_formal_arglist ();
11563 31 : g = g->next;
11564 : }
11565 65 : g->sym = f->sym;
11566 : }
11567 34 : g->next = sym->formal;
11568 34 : sym->formal = h;
11569 : }
11570 : }
11571 :
11572 12747 : if (!sym->hash_value)
11573 : /* Set the hash for the compound name for this type. */
11574 12747 : sym->hash_value = gfc_hash_value (sym);
11575 :
11576 : /* Take over the ABSTRACT attribute. */
11577 12747 : sym->attr.abstract = attr.abstract;
11578 :
11579 12747 : gfc_new_block = sym;
11580 :
11581 12747 : return MATCH_YES;
11582 : }
11583 :
11584 :
11585 : /* Cray Pointees can be declared as:
11586 : pointer (ipt, a (n,m,...,*)) */
11587 :
11588 : match
11589 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11590 : {
11591 240 : as->cray_pointee = true; /* This will be useful to know later. */
11592 240 : if (as->type == AS_ASSUMED_SIZE)
11593 72 : as->cp_was_assumed = true;
11594 168 : else if (as->type == AS_ASSUMED_SHAPE)
11595 : {
11596 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11597 0 : return MATCH_ERROR;
11598 : }
11599 : return MATCH_YES;
11600 : }
11601 :
11602 :
11603 : /* Match the enum definition statement, here we are trying to match
11604 : the first line of enum definition statement.
11605 : Returns MATCH_YES if match is found. */
11606 :
11607 : match
11608 158 : gfc_match_enum (void)
11609 : {
11610 158 : match m;
11611 :
11612 158 : m = gfc_match_eos ();
11613 158 : if (m != MATCH_YES)
11614 : return m;
11615 :
11616 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11617 0 : return MATCH_ERROR;
11618 :
11619 : return MATCH_YES;
11620 : }
11621 :
11622 :
11623 : /* Returns an initializer whose value is one higher than the value of the
11624 : LAST_INITIALIZER argument. If the argument is NULL, the
11625 : initializers value will be set to zero. The initializer's kind
11626 : will be set to gfc_c_int_kind.
11627 :
11628 : If -fshort-enums is given, the appropriate kind will be selected
11629 : later after all enumerators have been parsed. A warning is issued
11630 : here if an initializer exceeds gfc_c_int_kind. */
11631 :
11632 : static gfc_expr *
11633 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11634 : {
11635 377 : gfc_expr *result;
11636 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11637 :
11638 377 : mpz_init (result->value.integer);
11639 :
11640 377 : if (last_initializer != NULL)
11641 : {
11642 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11643 266 : result->where = last_initializer->where;
11644 :
11645 266 : if (gfc_check_integer_range (result->value.integer,
11646 : gfc_c_int_kind) != ARITH_OK)
11647 : {
11648 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11649 0 : return NULL;
11650 : }
11651 : }
11652 : else
11653 : {
11654 : /* Control comes here, if it's the very first enumerator and no
11655 : initializer has been given. It will be initialized to zero. */
11656 111 : mpz_set_si (result->value.integer, 0);
11657 : }
11658 :
11659 : return result;
11660 : }
11661 :
11662 :
11663 : /* Match a variable name with an optional initializer. When this
11664 : subroutine is called, a variable is expected to be parsed next.
11665 : Depending on what is happening at the moment, updates either the
11666 : symbol table or the current interface. */
11667 :
11668 : static match
11669 549 : enumerator_decl (void)
11670 : {
11671 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11672 549 : gfc_expr *initializer;
11673 549 : gfc_array_spec *as = NULL;
11674 549 : gfc_charlen *saved_cl_list;
11675 549 : gfc_symbol *sym;
11676 549 : locus var_locus;
11677 549 : match m;
11678 549 : bool t;
11679 549 : locus old_locus;
11680 :
11681 549 : initializer = NULL;
11682 549 : saved_cl_list = gfc_current_ns->cl_list;
11683 549 : old_locus = gfc_current_locus;
11684 :
11685 : /* When we get here, we've just matched a list of attributes and
11686 : maybe a type and a double colon. The next thing we expect to see
11687 : is the name of the symbol. */
11688 549 : m = gfc_match_name (name);
11689 549 : if (m != MATCH_YES)
11690 1 : goto cleanup;
11691 :
11692 548 : var_locus = gfc_current_locus;
11693 :
11694 : /* OK, we've successfully matched the declaration. Now put the
11695 : symbol in the current namespace. If we fail to create the symbol,
11696 : bail out. */
11697 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11698 : {
11699 1 : m = MATCH_ERROR;
11700 1 : goto cleanup;
11701 : }
11702 :
11703 : /* The double colon must be present in order to have initializers.
11704 : Otherwise the statement is ambiguous with an assignment statement. */
11705 547 : if (colon_seen)
11706 : {
11707 471 : if (gfc_match_char ('=') == MATCH_YES)
11708 : {
11709 170 : m = gfc_match_init_expr (&initializer);
11710 170 : if (m == MATCH_NO)
11711 : {
11712 0 : gfc_error ("Expected an initialization expression at %C");
11713 0 : m = MATCH_ERROR;
11714 : }
11715 :
11716 170 : if (m != MATCH_YES)
11717 2 : goto cleanup;
11718 : }
11719 : }
11720 :
11721 : /* If we do not have an initializer, the initialization value of the
11722 : previous enumerator (stored in last_initializer) is incremented
11723 : by 1 and is used to initialize the current enumerator. */
11724 545 : if (initializer == NULL)
11725 377 : initializer = enum_initializer (last_initializer, old_locus);
11726 :
11727 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11728 : {
11729 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11730 : &var_locus);
11731 2 : m = MATCH_ERROR;
11732 2 : goto cleanup;
11733 : }
11734 :
11735 : /* Store this current initializer, for the next enumerator variable
11736 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11737 : use last_initializer below. */
11738 543 : last_initializer = initializer;
11739 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
11740 : saved_cl_list);
11741 :
11742 : /* Maintain enumerator history. */
11743 543 : gfc_find_symbol (name, NULL, 0, &sym);
11744 543 : create_enum_history (sym, last_initializer);
11745 :
11746 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11747 :
11748 6 : cleanup:
11749 : /* Free stuff up and return. */
11750 6 : gfc_free_expr (initializer);
11751 :
11752 6 : return m;
11753 : }
11754 :
11755 :
11756 : /* Match the enumerator definition statement. */
11757 :
11758 : match
11759 797901 : gfc_match_enumerator_def (void)
11760 : {
11761 797901 : match m;
11762 797901 : bool t;
11763 :
11764 797901 : gfc_clear_ts (¤t_ts);
11765 :
11766 797901 : m = gfc_match (" enumerator");
11767 797901 : if (m != MATCH_YES)
11768 : return m;
11769 :
11770 269 : m = gfc_match (" :: ");
11771 269 : if (m == MATCH_ERROR)
11772 : return m;
11773 :
11774 269 : colon_seen = (m == MATCH_YES);
11775 :
11776 269 : if (gfc_current_state () != COMP_ENUM)
11777 : {
11778 4 : gfc_error ("ENUM definition statement expected before %C");
11779 4 : gfc_free_enum_history ();
11780 4 : return MATCH_ERROR;
11781 : }
11782 :
11783 265 : (¤t_ts)->type = BT_INTEGER;
11784 265 : (¤t_ts)->kind = gfc_c_int_kind;
11785 :
11786 265 : gfc_clear_attr (¤t_attr);
11787 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11788 265 : if (!t)
11789 : {
11790 0 : m = MATCH_ERROR;
11791 0 : goto cleanup;
11792 : }
11793 :
11794 549 : for (;;)
11795 : {
11796 549 : m = enumerator_decl ();
11797 549 : if (m == MATCH_ERROR)
11798 : {
11799 6 : gfc_free_enum_history ();
11800 6 : goto cleanup;
11801 : }
11802 543 : if (m == MATCH_NO)
11803 : break;
11804 :
11805 542 : if (gfc_match_eos () == MATCH_YES)
11806 256 : goto cleanup;
11807 286 : if (gfc_match_char (',') != MATCH_YES)
11808 : break;
11809 : }
11810 :
11811 3 : if (gfc_current_state () == COMP_ENUM)
11812 : {
11813 3 : gfc_free_enum_history ();
11814 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11815 3 : m = MATCH_ERROR;
11816 : }
11817 :
11818 0 : cleanup:
11819 265 : gfc_free_array_spec (current_as);
11820 265 : current_as = NULL;
11821 265 : return m;
11822 :
11823 : }
11824 :
11825 :
11826 : /* Match binding attributes. */
11827 :
11828 : static match
11829 4605 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11830 : {
11831 4605 : bool found_passing = false;
11832 4605 : bool seen_ptr = false;
11833 4605 : match m = MATCH_YES;
11834 :
11835 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11836 : this case the defaults are in there. */
11837 4605 : ba->access = ACCESS_UNKNOWN;
11838 4605 : ba->pass_arg = NULL;
11839 4605 : ba->pass_arg_num = 0;
11840 4605 : ba->nopass = 0;
11841 4605 : ba->non_overridable = 0;
11842 4605 : ba->deferred = 0;
11843 4605 : ba->ppc = ppc;
11844 :
11845 : /* If we find a comma, we believe there are binding attributes. */
11846 4605 : m = gfc_match_char (',');
11847 4605 : if (m == MATCH_NO)
11848 2385 : goto done;
11849 :
11850 2763 : do
11851 : {
11852 : /* Access specifier. */
11853 :
11854 2763 : m = gfc_match (" public");
11855 2763 : if (m == MATCH_ERROR)
11856 0 : goto error;
11857 2763 : if (m == MATCH_YES)
11858 : {
11859 250 : if (ba->access != ACCESS_UNKNOWN)
11860 : {
11861 0 : gfc_error ("Duplicate access-specifier at %C");
11862 0 : goto error;
11863 : }
11864 :
11865 250 : ba->access = ACCESS_PUBLIC;
11866 250 : continue;
11867 : }
11868 :
11869 2513 : m = gfc_match (" private");
11870 2513 : if (m == MATCH_ERROR)
11871 0 : goto error;
11872 2513 : if (m == MATCH_YES)
11873 : {
11874 163 : if (ba->access != ACCESS_UNKNOWN)
11875 : {
11876 1 : gfc_error ("Duplicate access-specifier at %C");
11877 1 : goto error;
11878 : }
11879 :
11880 162 : ba->access = ACCESS_PRIVATE;
11881 162 : continue;
11882 : }
11883 :
11884 : /* If inside GENERIC, the following is not allowed. */
11885 2350 : if (!generic)
11886 : {
11887 :
11888 : /* NOPASS flag. */
11889 2349 : m = gfc_match (" nopass");
11890 2349 : if (m == MATCH_ERROR)
11891 0 : goto error;
11892 2349 : if (m == MATCH_YES)
11893 : {
11894 701 : if (found_passing)
11895 : {
11896 1 : gfc_error ("Binding attributes already specify passing,"
11897 : " illegal NOPASS at %C");
11898 1 : goto error;
11899 : }
11900 :
11901 700 : found_passing = true;
11902 700 : ba->nopass = 1;
11903 700 : continue;
11904 : }
11905 :
11906 : /* PASS possibly including argument. */
11907 1648 : m = gfc_match (" pass");
11908 1648 : if (m == MATCH_ERROR)
11909 0 : goto error;
11910 1648 : if (m == MATCH_YES)
11911 : {
11912 901 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11913 :
11914 901 : if (found_passing)
11915 : {
11916 2 : gfc_error ("Binding attributes already specify passing,"
11917 : " illegal PASS at %C");
11918 2 : goto error;
11919 : }
11920 :
11921 899 : m = gfc_match (" ( %n )", arg);
11922 899 : if (m == MATCH_ERROR)
11923 0 : goto error;
11924 899 : if (m == MATCH_YES)
11925 490 : ba->pass_arg = gfc_get_string ("%s", arg);
11926 899 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11927 :
11928 899 : found_passing = true;
11929 899 : ba->nopass = 0;
11930 899 : continue;
11931 899 : }
11932 :
11933 747 : if (ppc)
11934 : {
11935 : /* POINTER flag. */
11936 425 : m = gfc_match (" pointer");
11937 425 : if (m == MATCH_ERROR)
11938 0 : goto error;
11939 425 : if (m == MATCH_YES)
11940 : {
11941 425 : if (seen_ptr)
11942 : {
11943 1 : gfc_error ("Duplicate POINTER attribute at %C");
11944 1 : goto error;
11945 : }
11946 :
11947 424 : seen_ptr = true;
11948 424 : continue;
11949 : }
11950 : }
11951 : else
11952 : {
11953 : /* NON_OVERRIDABLE flag. */
11954 322 : m = gfc_match (" non_overridable");
11955 322 : if (m == MATCH_ERROR)
11956 0 : goto error;
11957 322 : if (m == MATCH_YES)
11958 : {
11959 62 : if (ba->non_overridable)
11960 : {
11961 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11962 1 : goto error;
11963 : }
11964 :
11965 61 : ba->non_overridable = 1;
11966 61 : continue;
11967 : }
11968 :
11969 : /* DEFERRED flag. */
11970 260 : m = gfc_match (" deferred");
11971 260 : if (m == MATCH_ERROR)
11972 0 : goto error;
11973 260 : if (m == MATCH_YES)
11974 : {
11975 260 : if (ba->deferred)
11976 : {
11977 1 : gfc_error ("Duplicate DEFERRED at %C");
11978 1 : goto error;
11979 : }
11980 :
11981 259 : ba->deferred = 1;
11982 259 : continue;
11983 : }
11984 : }
11985 :
11986 : }
11987 :
11988 : /* Nothing matching found. */
11989 1 : if (generic)
11990 1 : gfc_error ("Expected access-specifier at %C");
11991 : else
11992 0 : gfc_error ("Expected binding attribute at %C");
11993 1 : goto error;
11994 : }
11995 2755 : while (gfc_match_char (',') == MATCH_YES);
11996 :
11997 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11998 2212 : if (ba->non_overridable && ba->deferred)
11999 : {
12000 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
12001 1 : goto error;
12002 : }
12003 :
12004 : m = MATCH_YES;
12005 :
12006 4596 : done:
12007 4596 : if (ba->access == ACCESS_UNKNOWN)
12008 4185 : ba->access = ppc ? gfc_current_block()->component_access
12009 : : gfc_typebound_default_access;
12010 :
12011 4596 : if (ppc && !seen_ptr)
12012 : {
12013 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
12014 : " at %C");
12015 2 : goto error;
12016 : }
12017 :
12018 : return m;
12019 :
12020 : error:
12021 : return MATCH_ERROR;
12022 : }
12023 :
12024 :
12025 : /* Match a PROCEDURE specific binding inside a derived type. */
12026 :
12027 : static match
12028 3165 : match_procedure_in_type (void)
12029 : {
12030 3165 : char name[GFC_MAX_SYMBOL_LEN + 1];
12031 3165 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
12032 3165 : char* target = NULL, *ifc = NULL;
12033 3165 : gfc_typebound_proc tb;
12034 3165 : bool seen_colons;
12035 3165 : bool seen_attrs;
12036 3165 : match m;
12037 3165 : gfc_symtree* stree;
12038 3165 : gfc_namespace* ns;
12039 3165 : gfc_symbol* block;
12040 3165 : int num;
12041 :
12042 : /* Check current state. */
12043 3165 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
12044 3165 : block = gfc_state_stack->previous->sym;
12045 3165 : gcc_assert (block);
12046 :
12047 : /* Try to match PROCEDURE(interface). */
12048 3165 : if (gfc_match (" (") == MATCH_YES)
12049 : {
12050 261 : m = gfc_match_name (target_buf);
12051 261 : if (m == MATCH_ERROR)
12052 : return m;
12053 261 : if (m != MATCH_YES)
12054 : {
12055 1 : gfc_error ("Interface-name expected after %<(%> at %C");
12056 1 : return MATCH_ERROR;
12057 : }
12058 :
12059 260 : if (gfc_match (" )") != MATCH_YES)
12060 : {
12061 1 : gfc_error ("%<)%> expected at %C");
12062 1 : return MATCH_ERROR;
12063 : }
12064 :
12065 : ifc = target_buf;
12066 : }
12067 :
12068 : /* Construct the data structure. */
12069 3163 : memset (&tb, 0, sizeof (tb));
12070 3163 : tb.where = gfc_current_locus;
12071 :
12072 : /* Match binding attributes. */
12073 3163 : m = match_binding_attributes (&tb, false, false);
12074 3163 : if (m == MATCH_ERROR)
12075 : return m;
12076 3156 : seen_attrs = (m == MATCH_YES);
12077 :
12078 : /* Check that attribute DEFERRED is given if an interface is specified. */
12079 3156 : if (tb.deferred && !ifc)
12080 : {
12081 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
12082 1 : return MATCH_ERROR;
12083 : }
12084 3155 : if (ifc && !tb.deferred)
12085 : {
12086 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
12087 1 : return MATCH_ERROR;
12088 : }
12089 :
12090 : /* Match the colons. */
12091 3154 : m = gfc_match (" ::");
12092 3154 : if (m == MATCH_ERROR)
12093 : return m;
12094 3154 : seen_colons = (m == MATCH_YES);
12095 3154 : if (seen_attrs && !seen_colons)
12096 : {
12097 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
12098 4 : return MATCH_ERROR;
12099 : }
12100 :
12101 : /* Match the binding names. */
12102 19 : for(num=1;;num++)
12103 : {
12104 3169 : m = gfc_match_name (name);
12105 3169 : if (m == MATCH_ERROR)
12106 : return m;
12107 3169 : if (m == MATCH_NO)
12108 : {
12109 5 : gfc_error ("Expected binding name at %C");
12110 5 : return MATCH_ERROR;
12111 : }
12112 :
12113 3164 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
12114 : return MATCH_ERROR;
12115 :
12116 : /* Try to match the '=> target', if it's there. */
12117 3163 : target = ifc;
12118 3163 : m = gfc_match (" =>");
12119 3163 : if (m == MATCH_ERROR)
12120 : return m;
12121 3163 : if (m == MATCH_YES)
12122 : {
12123 1248 : if (tb.deferred)
12124 : {
12125 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
12126 1 : return MATCH_ERROR;
12127 : }
12128 :
12129 1247 : if (!seen_colons)
12130 : {
12131 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
12132 : " at %C");
12133 1 : return MATCH_ERROR;
12134 : }
12135 :
12136 1246 : m = gfc_match_name (target_buf);
12137 1246 : if (m == MATCH_ERROR)
12138 : return m;
12139 1246 : if (m == MATCH_NO)
12140 : {
12141 2 : gfc_error ("Expected binding target after %<=>%> at %C");
12142 2 : return MATCH_ERROR;
12143 : }
12144 : target = target_buf;
12145 : }
12146 :
12147 : /* If no target was found, it has the same name as the binding. */
12148 1915 : if (!target)
12149 1660 : target = name;
12150 :
12151 : /* Get the namespace to insert the symbols into. */
12152 3159 : ns = block->f2k_derived;
12153 3159 : gcc_assert (ns);
12154 :
12155 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
12156 3159 : if (tb.deferred && !block->attr.abstract)
12157 : {
12158 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
12159 : "is not ABSTRACT", block->name);
12160 1 : return MATCH_ERROR;
12161 : }
12162 :
12163 : /* See if we already have a binding with this name in the symtree which
12164 : would be an error. If a GENERIC already targeted this binding, it may
12165 : be already there but then typebound is still NULL. */
12166 3158 : stree = gfc_find_symtree (ns->tb_sym_root, name);
12167 3158 : if (stree && stree->n.tb)
12168 : {
12169 2 : gfc_error ("There is already a procedure with binding name %qs for "
12170 : "the derived type %qs at %C", name, block->name);
12171 2 : return MATCH_ERROR;
12172 : }
12173 :
12174 : /* Insert it and set attributes. */
12175 :
12176 3061 : if (!stree)
12177 : {
12178 3061 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12179 3061 : gcc_assert (stree);
12180 : }
12181 3156 : stree->n.tb = gfc_get_typebound_proc (&tb);
12182 :
12183 3156 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12184 : false))
12185 : return MATCH_ERROR;
12186 3156 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12187 3156 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12188 3156 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12189 :
12190 3156 : if (gfc_match_eos () == MATCH_YES)
12191 : return MATCH_YES;
12192 20 : if (gfc_match_char (',') != MATCH_YES)
12193 1 : goto syntax;
12194 : }
12195 :
12196 1 : syntax:
12197 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12198 1 : return MATCH_ERROR;
12199 : }
12200 :
12201 :
12202 : /* Match a GENERIC statement.
12203 : F2018 15.4.3.3 GENERIC statement
12204 :
12205 : A GENERIC statement specifies a generic identifier for one or more specific
12206 : procedures, in the same way as a generic interface block that does not contain
12207 : interface bodies.
12208 :
12209 : R1510 generic-stmt is:
12210 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12211 :
12212 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12213 : procedure that was specified previously in any accessible interface with the
12214 : same generic identifier.
12215 :
12216 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12217 :
12218 : For GENERIC statements outside of a derived type, use is made of the existing,
12219 : typebound matching functions to obtain access-spec and generic-spec. After
12220 : this the standard INTERFACE machinery is used. */
12221 :
12222 : static match
12223 100 : match_generic_stmt (void)
12224 : {
12225 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12226 : /* Allow space for OPERATOR(...). */
12227 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12228 : /* Generics other than uops */
12229 100 : gfc_symbol* generic_spec = NULL;
12230 : /* Generic uops */
12231 100 : gfc_user_op *generic_uop = NULL;
12232 : /* For the matching calls */
12233 100 : gfc_typebound_proc tbattr;
12234 100 : gfc_namespace* ns = gfc_current_ns;
12235 100 : interface_type op_type;
12236 100 : gfc_intrinsic_op op;
12237 100 : match m;
12238 100 : gfc_symtree* st;
12239 : /* The specific-procedure-list */
12240 100 : gfc_interface *generic = NULL;
12241 : /* The head of the specific-procedure-list */
12242 100 : gfc_interface **generic_tail = NULL;
12243 :
12244 100 : memset (&tbattr, 0, sizeof (tbattr));
12245 100 : tbattr.where = gfc_current_locus;
12246 :
12247 : /* See if we get an access-specifier. */
12248 100 : m = match_binding_attributes (&tbattr, true, false);
12249 100 : tbattr.where = gfc_current_locus;
12250 100 : if (m == MATCH_ERROR)
12251 0 : goto error;
12252 :
12253 : /* Now the colons, those are required. */
12254 100 : if (gfc_match (" ::") != MATCH_YES)
12255 : {
12256 0 : gfc_error ("Expected %<::%> at %C");
12257 0 : goto error;
12258 : }
12259 :
12260 : /* Match the generic-spec name; depending on type (operator / generic) format
12261 : it for future error messages in 'generic_spec_name'. */
12262 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12263 100 : if (m == MATCH_ERROR)
12264 : return MATCH_ERROR;
12265 100 : if (m == MATCH_NO)
12266 : {
12267 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12268 0 : goto error;
12269 : }
12270 :
12271 100 : switch (op_type)
12272 : {
12273 63 : case INTERFACE_GENERIC:
12274 63 : case INTERFACE_DTIO:
12275 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12276 63 : break;
12277 :
12278 22 : case INTERFACE_USER_OP:
12279 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12280 22 : break;
12281 :
12282 13 : case INTERFACE_INTRINSIC_OP:
12283 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12284 : gfc_op2string (op));
12285 13 : break;
12286 :
12287 2 : case INTERFACE_NAMELESS:
12288 2 : gfc_error ("Malformed GENERIC statement at %C");
12289 2 : goto error;
12290 0 : break;
12291 :
12292 0 : default:
12293 0 : gcc_unreachable ();
12294 : }
12295 :
12296 : /* Match the required =>. */
12297 98 : if (gfc_match (" =>") != MATCH_YES)
12298 : {
12299 1 : gfc_error ("Expected %<=>%> at %C");
12300 1 : goto error;
12301 : }
12302 :
12303 :
12304 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12305 : {
12306 1 : gfc_error ("The access specification at %L not in a module",
12307 : &tbattr.where);
12308 1 : goto error;
12309 : }
12310 :
12311 : /* Try to find existing generic-spec with this name for this operator;
12312 : if there is something, check that it is another generic-spec and then
12313 : extend it rather than building a new symbol. Otherwise, create a new
12314 : one with the right attributes. */
12315 :
12316 96 : switch (op_type)
12317 : {
12318 61 : case INTERFACE_DTIO:
12319 61 : case INTERFACE_GENERIC:
12320 61 : st = gfc_find_symtree (ns->sym_root, name);
12321 61 : generic_spec = st ? st->n.sym : NULL;
12322 61 : if (generic_spec)
12323 : {
12324 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12325 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12326 : {
12327 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12328 : "name of an entity declared at %L that is not a "
12329 : "procedure", name, &generic_spec->declared_at);
12330 1 : goto error;
12331 : }
12332 :
12333 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12334 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12335 : {
12336 0 : gfc_error ("There's already a non-generic procedure with "
12337 : "name %qs at %C", generic_spec->name);
12338 0 : goto error;
12339 : }
12340 :
12341 24 : if (tbattr.access != ACCESS_UNKNOWN)
12342 : {
12343 2 : if (generic_spec->attr.access != tbattr.access)
12344 : {
12345 1 : gfc_error ("The access specification at %L conflicts with "
12346 : "that already given to %qs", &tbattr.where,
12347 : generic_spec->name);
12348 1 : goto error;
12349 : }
12350 : else
12351 : {
12352 1 : gfc_error ("The access specification at %L repeats that "
12353 : "already given to %qs", &tbattr.where,
12354 : generic_spec->name);
12355 1 : goto error;
12356 : }
12357 : }
12358 :
12359 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12360 : {
12361 1 : gfc_error ("The generic-spec in the generic statement at %C "
12362 : "has a type from the declaration at %L",
12363 : &generic_spec->declared_at);
12364 1 : goto error;
12365 : }
12366 : }
12367 :
12368 : /* Now create the generic_spec if it doesn't already exist and provide
12369 : is with the appropriate attributes. */
12370 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12371 : {
12372 45 : if (!generic_spec)
12373 : {
12374 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12375 36 : gfc_set_sym_referenced (generic_spec);
12376 36 : generic_spec->attr.access = tbattr.access;
12377 : }
12378 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12379 0 : generic_spec->attr.access = tbattr.access;
12380 45 : generic_spec->refs++;
12381 45 : generic_spec->attr.generic = 1;
12382 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12383 :
12384 45 : generic_spec->declared_at = gfc_current_locus;
12385 : }
12386 :
12387 : /* Prepare to add the specific procedures. */
12388 57 : generic = generic_spec->generic;
12389 57 : generic_tail = &generic_spec->generic;
12390 57 : break;
12391 :
12392 22 : case INTERFACE_USER_OP:
12393 22 : st = gfc_find_symtree (ns->uop_root, name);
12394 22 : generic_uop = st ? st->n.uop : NULL;
12395 2 : if (generic_uop)
12396 : {
12397 2 : if (generic_uop->access != ACCESS_UNKNOWN
12398 2 : && tbattr.access != ACCESS_UNKNOWN)
12399 : {
12400 2 : if (generic_uop->access != tbattr.access)
12401 : {
12402 1 : gfc_error ("The user operator at %L must have the same "
12403 : "access specification as already defined user "
12404 : "operator %qs", &tbattr.where, generic_spec_name);
12405 1 : goto error;
12406 : }
12407 : else
12408 : {
12409 1 : gfc_error ("The user operator at %L repeats the access "
12410 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12411 1 : goto error;
12412 : }
12413 : }
12414 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12415 0 : generic_uop->access = tbattr.access;
12416 : }
12417 : else
12418 : {
12419 20 : generic_uop = gfc_get_uop (name);
12420 20 : generic_uop->access = tbattr.access;
12421 : }
12422 :
12423 : /* Prepare to add the specific procedures. */
12424 20 : generic = generic_uop->op;
12425 20 : generic_tail = &generic_uop->op;
12426 20 : break;
12427 :
12428 13 : case INTERFACE_INTRINSIC_OP:
12429 13 : generic = ns->op[op];
12430 13 : generic_tail = &ns->op[op];
12431 13 : break;
12432 :
12433 0 : default:
12434 0 : gcc_unreachable ();
12435 : }
12436 :
12437 : /* Now, match all following names in the specific-procedure-list. */
12438 154 : do
12439 : {
12440 154 : m = gfc_match_name (name);
12441 154 : if (m == MATCH_ERROR)
12442 0 : goto error;
12443 154 : if (m == MATCH_NO)
12444 : {
12445 0 : gfc_error ("Expected specific procedure name at %C");
12446 0 : goto error;
12447 : }
12448 :
12449 154 : if (op_type == INTERFACE_GENERIC
12450 95 : && !strcmp (generic_spec->name, name))
12451 : {
12452 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12453 : "with that of the generic-spec", name);
12454 2 : goto error;
12455 : }
12456 :
12457 152 : generic = *generic_tail;
12458 242 : for (; generic; generic = generic->next)
12459 : {
12460 90 : if (!strcmp (generic->sym->name, name))
12461 : {
12462 0 : gfc_error ("%qs already defined as a specific procedure for the"
12463 : " generic %qs at %C", name, generic_spec->name);
12464 0 : goto error;
12465 : }
12466 : }
12467 :
12468 152 : gfc_find_sym_tree (name, ns, 1, &st);
12469 152 : if (!st)
12470 : {
12471 : /* This might be a procedure that has not yet been parsed. If
12472 : so gfc_fixup_sibling_symbols will replace this symbol with
12473 : that of the procedure. */
12474 75 : gfc_get_sym_tree (name, ns, &st, false);
12475 75 : st->n.sym->refs++;
12476 : }
12477 :
12478 152 : generic = gfc_get_interface();
12479 152 : generic->next = *generic_tail;
12480 152 : *generic_tail = generic;
12481 152 : generic->where = gfc_current_locus;
12482 152 : generic->sym = st->n.sym;
12483 : }
12484 152 : while (gfc_match (" ,") == MATCH_YES);
12485 :
12486 88 : if (gfc_match_eos () != MATCH_YES)
12487 : {
12488 0 : gfc_error ("Junk after GENERIC statement at %C");
12489 0 : goto error;
12490 : }
12491 :
12492 88 : gfc_commit_symbols ();
12493 88 : return MATCH_YES;
12494 :
12495 : error:
12496 : return MATCH_ERROR;
12497 : }
12498 :
12499 :
12500 : /* Match a GENERIC procedure binding inside a derived type. */
12501 :
12502 : static match
12503 916 : match_typebound_generic (void)
12504 : {
12505 916 : char name[GFC_MAX_SYMBOL_LEN + 1];
12506 916 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12507 916 : gfc_symbol* block;
12508 916 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12509 916 : gfc_typebound_proc* tb;
12510 916 : gfc_namespace* ns;
12511 916 : interface_type op_type;
12512 916 : gfc_intrinsic_op op;
12513 916 : match m;
12514 :
12515 : /* Check current state. */
12516 916 : if (gfc_current_state () == COMP_DERIVED)
12517 : {
12518 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12519 0 : return MATCH_ERROR;
12520 : }
12521 916 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12522 : return MATCH_NO;
12523 916 : block = gfc_state_stack->previous->sym;
12524 916 : ns = block->f2k_derived;
12525 916 : gcc_assert (block && ns);
12526 :
12527 916 : memset (&tbattr, 0, sizeof (tbattr));
12528 916 : tbattr.where = gfc_current_locus;
12529 :
12530 : /* See if we get an access-specifier. */
12531 916 : m = match_binding_attributes (&tbattr, true, false);
12532 916 : if (m == MATCH_ERROR)
12533 1 : goto error;
12534 :
12535 : /* Now the colons, those are required. */
12536 915 : if (gfc_match (" ::") != MATCH_YES)
12537 : {
12538 0 : gfc_error ("Expected %<::%> at %C");
12539 0 : goto error;
12540 : }
12541 :
12542 : /* Match the binding name; depending on type (operator / generic) format
12543 : it for future error messages into bind_name. */
12544 :
12545 915 : m = gfc_match_generic_spec (&op_type, name, &op);
12546 915 : if (m == MATCH_ERROR)
12547 : return MATCH_ERROR;
12548 915 : if (m == MATCH_NO)
12549 : {
12550 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12551 0 : goto error;
12552 : }
12553 :
12554 915 : switch (op_type)
12555 : {
12556 456 : case INTERFACE_GENERIC:
12557 456 : case INTERFACE_DTIO:
12558 456 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12559 456 : break;
12560 :
12561 29 : case INTERFACE_USER_OP:
12562 29 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12563 29 : break;
12564 :
12565 429 : case INTERFACE_INTRINSIC_OP:
12566 429 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12567 : gfc_op2string (op));
12568 429 : break;
12569 :
12570 1 : case INTERFACE_NAMELESS:
12571 1 : gfc_error ("Malformed GENERIC statement at %C");
12572 1 : goto error;
12573 0 : break;
12574 :
12575 0 : default:
12576 0 : gcc_unreachable ();
12577 : }
12578 :
12579 : /* Match the required =>. */
12580 914 : if (gfc_match (" =>") != MATCH_YES)
12581 : {
12582 0 : gfc_error ("Expected %<=>%> at %C");
12583 0 : goto error;
12584 : }
12585 :
12586 : /* Try to find existing GENERIC binding with this name / for this operator;
12587 : if there is something, check that it is another GENERIC and then extend
12588 : it rather than building a new node. Otherwise, create it and put it
12589 : at the right position. */
12590 :
12591 914 : switch (op_type)
12592 : {
12593 485 : case INTERFACE_DTIO:
12594 485 : case INTERFACE_USER_OP:
12595 485 : case INTERFACE_GENERIC:
12596 485 : {
12597 485 : const bool is_op = (op_type == INTERFACE_USER_OP);
12598 485 : gfc_symtree* st;
12599 :
12600 485 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12601 485 : tb = st ? st->n.tb : NULL;
12602 : break;
12603 : }
12604 :
12605 429 : case INTERFACE_INTRINSIC_OP:
12606 429 : tb = ns->tb_op[op];
12607 429 : break;
12608 :
12609 0 : default:
12610 0 : gcc_unreachable ();
12611 : }
12612 :
12613 440 : if (tb)
12614 : {
12615 9 : if (!tb->is_generic)
12616 : {
12617 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12618 1 : gfc_error ("There's already a non-generic procedure with binding name"
12619 : " %qs for the derived type %qs at %C",
12620 : bind_name, block->name);
12621 1 : goto error;
12622 : }
12623 :
12624 8 : if (tb->access != tbattr.access)
12625 : {
12626 2 : gfc_error ("Binding at %C must have the same access as already"
12627 : " defined binding %qs", bind_name);
12628 2 : goto error;
12629 : }
12630 : }
12631 : else
12632 : {
12633 905 : tb = gfc_get_typebound_proc (NULL);
12634 905 : tb->where = gfc_current_locus;
12635 905 : tb->access = tbattr.access;
12636 905 : tb->is_generic = 1;
12637 905 : tb->u.generic = NULL;
12638 :
12639 905 : switch (op_type)
12640 : {
12641 476 : case INTERFACE_DTIO:
12642 476 : case INTERFACE_GENERIC:
12643 476 : case INTERFACE_USER_OP:
12644 476 : {
12645 476 : const bool is_op = (op_type == INTERFACE_USER_OP);
12646 476 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12647 : &ns->tb_sym_root, name);
12648 476 : gcc_assert (st);
12649 476 : st->n.tb = tb;
12650 :
12651 476 : break;
12652 : }
12653 :
12654 429 : case INTERFACE_INTRINSIC_OP:
12655 429 : ns->tb_op[op] = tb;
12656 429 : break;
12657 :
12658 0 : default:
12659 0 : gcc_unreachable ();
12660 : }
12661 : }
12662 :
12663 : /* Now, match all following names as specific targets. */
12664 1062 : do
12665 : {
12666 1062 : gfc_symtree* target_st;
12667 1062 : gfc_tbp_generic* target;
12668 :
12669 1062 : m = gfc_match_name (name);
12670 1062 : if (m == MATCH_ERROR)
12671 0 : goto error;
12672 1062 : if (m == MATCH_NO)
12673 : {
12674 1 : gfc_error ("Expected specific binding name at %C");
12675 1 : goto error;
12676 : }
12677 :
12678 1061 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12679 :
12680 : /* See if this is a duplicate specification. */
12681 1290 : for (target = tb->u.generic; target; target = target->next)
12682 230 : if (target_st == target->specific_st)
12683 : {
12684 1 : gfc_error ("%qs already defined as specific binding for the"
12685 : " generic %qs at %C", name, bind_name);
12686 1 : goto error;
12687 : }
12688 :
12689 1060 : target = gfc_get_tbp_generic ();
12690 1060 : target->specific_st = target_st;
12691 1060 : target->specific = NULL;
12692 1060 : target->next = tb->u.generic;
12693 1060 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12694 1060 : || (op_type == INTERFACE_INTRINSIC_OP));
12695 1060 : tb->u.generic = target;
12696 : }
12697 1060 : while (gfc_match (" ,") == MATCH_YES);
12698 :
12699 : /* Here should be the end. */
12700 909 : if (gfc_match_eos () != MATCH_YES)
12701 : {
12702 1 : gfc_error ("Junk after GENERIC binding at %C");
12703 1 : goto error;
12704 : }
12705 :
12706 : return MATCH_YES;
12707 :
12708 : error:
12709 : return MATCH_ERROR;
12710 : }
12711 :
12712 :
12713 : match
12714 1016 : gfc_match_generic ()
12715 : {
12716 1016 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12717 1014 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12718 100 : return match_generic_stmt ();
12719 : else
12720 916 : return match_typebound_generic ();
12721 : }
12722 :
12723 :
12724 : /* Match a FINAL declaration inside a derived type. */
12725 :
12726 : match
12727 454 : gfc_match_final_decl (void)
12728 : {
12729 454 : char name[GFC_MAX_SYMBOL_LEN + 1];
12730 454 : gfc_symbol* sym;
12731 454 : match m;
12732 454 : gfc_namespace* module_ns;
12733 454 : bool first, last;
12734 454 : gfc_symbol* block;
12735 :
12736 454 : if (gfc_current_form == FORM_FREE)
12737 : {
12738 454 : char c = gfc_peek_ascii_char ();
12739 454 : if (!gfc_is_whitespace (c) && c != ':')
12740 : return MATCH_NO;
12741 : }
12742 :
12743 453 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12744 : {
12745 1 : if (gfc_current_form == FORM_FIXED)
12746 : return MATCH_NO;
12747 :
12748 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12749 : "CONTAINS section");
12750 1 : return MATCH_ERROR;
12751 : }
12752 :
12753 452 : block = gfc_state_stack->previous->sym;
12754 452 : gcc_assert (block);
12755 :
12756 452 : if (gfc_state_stack->previous->previous
12757 452 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12758 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12759 : {
12760 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12761 : " specification part of a MODULE");
12762 0 : return MATCH_ERROR;
12763 : }
12764 :
12765 452 : module_ns = gfc_current_ns;
12766 452 : gcc_assert (module_ns);
12767 452 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12768 :
12769 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12770 452 : if (gfc_match (" ::") == MATCH_ERROR)
12771 : return MATCH_ERROR;
12772 :
12773 : /* Match the sequence of procedure names. */
12774 : first = true;
12775 : last = false;
12776 538 : do
12777 : {
12778 538 : gfc_finalizer* f;
12779 :
12780 538 : if (first && gfc_match_eos () == MATCH_YES)
12781 : {
12782 2 : gfc_error ("Empty FINAL at %C");
12783 2 : return MATCH_ERROR;
12784 : }
12785 :
12786 536 : m = gfc_match_name (name);
12787 536 : if (m == MATCH_NO)
12788 : {
12789 1 : gfc_error ("Expected module procedure name at %C");
12790 1 : return MATCH_ERROR;
12791 : }
12792 535 : else if (m != MATCH_YES)
12793 : return MATCH_ERROR;
12794 :
12795 535 : if (gfc_match_eos () == MATCH_YES)
12796 : last = true;
12797 87 : if (!last && gfc_match_char (',') != MATCH_YES)
12798 : {
12799 1 : gfc_error ("Expected %<,%> at %C");
12800 1 : return MATCH_ERROR;
12801 : }
12802 :
12803 534 : if (gfc_get_symbol (name, module_ns, &sym))
12804 : {
12805 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12806 0 : return MATCH_ERROR;
12807 : }
12808 :
12809 : /* Mark the symbol as module procedure. */
12810 534 : if (sym->attr.proc != PROC_MODULE
12811 534 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12812 : return MATCH_ERROR;
12813 :
12814 : /* Check if we already have this symbol in the list, this is an error. */
12815 715 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12816 182 : if (f->proc_sym == sym)
12817 : {
12818 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12819 : name);
12820 1 : return MATCH_ERROR;
12821 : }
12822 :
12823 : /* Add this symbol to the list of finalizers. */
12824 533 : gcc_assert (block->f2k_derived);
12825 533 : sym->refs++;
12826 533 : f = XCNEW (gfc_finalizer);
12827 533 : f->proc_sym = sym;
12828 533 : f->proc_tree = NULL;
12829 533 : f->where = gfc_current_locus;
12830 533 : f->next = block->f2k_derived->finalizers;
12831 533 : block->f2k_derived->finalizers = f;
12832 :
12833 533 : first = false;
12834 : }
12835 533 : while (!last);
12836 :
12837 : return MATCH_YES;
12838 : }
12839 :
12840 :
12841 : const ext_attr_t ext_attr_list[] = {
12842 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12843 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12844 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12845 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12846 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12847 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12848 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12849 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12850 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12851 : { "weak", EXT_ATTR_WEAK, NULL },
12852 : { NULL, EXT_ATTR_LAST, NULL }
12853 : };
12854 :
12855 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12856 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12857 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12858 :
12859 : TODO: We should support all GCC attributes using the same syntax for
12860 : the attribute list, i.e. the list in C
12861 : __attributes(( attribute-list ))
12862 : matches then
12863 : !GCC$ ATTRIBUTES attribute-list ::
12864 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12865 : saved into a TREE.
12866 :
12867 : As there is absolutely no risk of confusion, we should never return
12868 : MATCH_NO. */
12869 : match
12870 2976 : gfc_match_gcc_attributes (void)
12871 : {
12872 2976 : symbol_attribute attr;
12873 2976 : char name[GFC_MAX_SYMBOL_LEN + 1];
12874 2976 : unsigned id;
12875 2976 : gfc_symbol *sym;
12876 2976 : match m;
12877 :
12878 2976 : gfc_clear_attr (&attr);
12879 2976 : for(;;)
12880 : {
12881 2976 : char ch;
12882 :
12883 2976 : if (gfc_match_name (name) != MATCH_YES)
12884 : return MATCH_ERROR;
12885 :
12886 17941 : for (id = 0; id < EXT_ATTR_LAST; id++)
12887 17941 : if (strcmp (name, ext_attr_list[id].name) == 0)
12888 : break;
12889 :
12890 2976 : if (id == EXT_ATTR_LAST)
12891 : {
12892 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12893 0 : return MATCH_ERROR;
12894 : }
12895 :
12896 2976 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12897 : return MATCH_ERROR;
12898 :
12899 2976 : gfc_gobble_whitespace ();
12900 2976 : ch = gfc_next_ascii_char ();
12901 2976 : if (ch == ':')
12902 : {
12903 : /* This is the successful exit condition for the loop. */
12904 2976 : if (gfc_next_ascii_char () == ':')
12905 : break;
12906 : }
12907 :
12908 0 : if (ch == ',')
12909 0 : continue;
12910 :
12911 0 : goto syntax;
12912 0 : }
12913 :
12914 2976 : if (gfc_match_eos () == MATCH_YES)
12915 0 : goto syntax;
12916 :
12917 2991 : for(;;)
12918 : {
12919 2991 : m = gfc_match_name (name);
12920 2991 : if (m != MATCH_YES)
12921 : return m;
12922 :
12923 2991 : if (find_special (name, &sym, true))
12924 : return MATCH_ERROR;
12925 :
12926 2991 : sym->attr.ext_attr |= attr.ext_attr;
12927 :
12928 2991 : if (gfc_match_eos () == MATCH_YES)
12929 : break;
12930 :
12931 15 : if (gfc_match_char (',') != MATCH_YES)
12932 0 : goto syntax;
12933 : }
12934 :
12935 : return MATCH_YES;
12936 :
12937 0 : syntax:
12938 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
12939 0 : return MATCH_ERROR;
12940 : }
12941 :
12942 :
12943 : /* Match a !GCC$ UNROLL statement of the form:
12944 : !GCC$ UNROLL n
12945 :
12946 : The parameter n is the number of times we are supposed to unroll.
12947 :
12948 : When we come here, we have already matched the !GCC$ UNROLL string. */
12949 : match
12950 19 : gfc_match_gcc_unroll (void)
12951 : {
12952 19 : int value;
12953 :
12954 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
12955 19 : if (gfc_match_small_int (&value) == MATCH_YES)
12956 : {
12957 19 : if (value < 0 || value > USHRT_MAX)
12958 : {
12959 2 : gfc_error ("%<GCC unroll%> directive requires a"
12960 : " non-negative integral constant"
12961 : " less than or equal to %u at %C",
12962 : USHRT_MAX
12963 : );
12964 2 : return MATCH_ERROR;
12965 : }
12966 17 : if (gfc_match_eos () == MATCH_YES)
12967 : {
12968 17 : directive_unroll = value == 0 ? 1 : value;
12969 17 : return MATCH_YES;
12970 : }
12971 : }
12972 :
12973 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
12974 0 : return MATCH_ERROR;
12975 : }
12976 :
12977 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
12978 :
12979 : The parameter b is name of a middle-end built-in.
12980 : FLAGS is optional and must be one of:
12981 : - (inbranch)
12982 : - (notinbranch)
12983 :
12984 : IF('target') is optional and TARGET is a name of a multilib ABI.
12985 :
12986 : When we come here, we have already matched the !GCC$ builtin string. */
12987 :
12988 : match
12989 3393069 : gfc_match_gcc_builtin (void)
12990 : {
12991 3393069 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
12992 3393069 : char target[GFC_MAX_SYMBOL_LEN + 1];
12993 :
12994 3393069 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
12995 : return MATCH_ERROR;
12996 :
12997 3393069 : gfc_simd_clause clause = SIMD_NONE;
12998 3393069 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
12999 : clause = SIMD_NOTINBRANCH;
13000 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
13001 15 : clause = SIMD_INBRANCH;
13002 :
13003 3393069 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
13004 : {
13005 3393039 : if (strcmp (target, "fastmath") == 0)
13006 : {
13007 0 : if (!fast_math_flags_set_p (&global_options))
13008 : return MATCH_YES;
13009 : }
13010 : else
13011 : {
13012 3393039 : const char *abi = targetm.get_multilib_abi_name ();
13013 3393039 : if (abi == NULL || strcmp (abi, target) != 0)
13014 : return MATCH_YES;
13015 : }
13016 : }
13017 :
13018 1674572 : if (gfc_vectorized_builtins == NULL)
13019 31016 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
13020 :
13021 1674572 : char *r = XNEWVEC (char, strlen (builtin) + 32);
13022 1674572 : sprintf (r, "__builtin_%s", builtin);
13023 :
13024 1674572 : bool existed;
13025 1674572 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
13026 1674572 : value |= clause;
13027 1674572 : if (existed)
13028 23 : free (r);
13029 :
13030 : return MATCH_YES;
13031 : }
13032 :
13033 : /* Match an !GCC$ IVDEP statement.
13034 : When we come here, we have already matched the !GCC$ IVDEP string. */
13035 :
13036 : match
13037 3 : gfc_match_gcc_ivdep (void)
13038 : {
13039 3 : if (gfc_match_eos () == MATCH_YES)
13040 : {
13041 3 : directive_ivdep = true;
13042 3 : return MATCH_YES;
13043 : }
13044 :
13045 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
13046 0 : return MATCH_ERROR;
13047 : }
13048 :
13049 : /* Match an !GCC$ VECTOR statement.
13050 : When we come here, we have already matched the !GCC$ VECTOR string. */
13051 :
13052 : match
13053 3 : gfc_match_gcc_vector (void)
13054 : {
13055 3 : if (gfc_match_eos () == MATCH_YES)
13056 : {
13057 3 : directive_vector = true;
13058 3 : directive_novector = false;
13059 3 : return MATCH_YES;
13060 : }
13061 :
13062 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
13063 0 : return MATCH_ERROR;
13064 : }
13065 :
13066 : /* Match an !GCC$ NOVECTOR statement.
13067 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
13068 :
13069 : match
13070 3 : gfc_match_gcc_novector (void)
13071 : {
13072 3 : if (gfc_match_eos () == MATCH_YES)
13073 : {
13074 3 : directive_novector = true;
13075 3 : directive_vector = false;
13076 3 : return MATCH_YES;
13077 : }
13078 :
13079 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
13080 0 : return MATCH_ERROR;
13081 : }
|
