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 : /********************* DATA statement subroutines *********************/
135 :
136 : static bool in_match_data = false;
137 :
138 : bool
139 9065 : gfc_in_match_data (void)
140 : {
141 9065 : return in_match_data;
142 : }
143 :
144 : static void
145 4840 : set_in_match_data (bool set_value)
146 : {
147 4840 : in_match_data = set_value;
148 2420 : }
149 :
150 : /* Free a gfc_data_variable structure and everything beneath it. */
151 :
152 : static void
153 5663 : free_variable (gfc_data_variable *p)
154 : {
155 5663 : gfc_data_variable *q;
156 :
157 8752 : for (; p; p = q)
158 : {
159 3089 : q = p->next;
160 3089 : gfc_free_expr (p->expr);
161 3089 : gfc_free_iterator (&p->iter, 0);
162 3089 : free_variable (p->list);
163 3089 : free (p);
164 : }
165 5663 : }
166 :
167 :
168 : /* Free a gfc_data_value structure and everything beneath it. */
169 :
170 : static void
171 2574 : free_value (gfc_data_value *p)
172 : {
173 2574 : gfc_data_value *q;
174 :
175 10886 : for (; p; p = q)
176 : {
177 8312 : q = p->next;
178 8312 : mpz_clear (p->repeat);
179 8312 : gfc_free_expr (p->expr);
180 8312 : free (p);
181 : }
182 2574 : }
183 :
184 :
185 : /* Free a list of gfc_data structures. */
186 :
187 : void
188 516756 : gfc_free_data (gfc_data *p)
189 : {
190 516756 : gfc_data *q;
191 :
192 519330 : for (; p; p = q)
193 : {
194 2574 : q = p->next;
195 2574 : free_variable (p->var);
196 2574 : free_value (p->value);
197 2574 : free (p);
198 : }
199 516756 : }
200 :
201 :
202 : /* Free all data in a namespace. */
203 :
204 : static void
205 41 : gfc_free_data_all (gfc_namespace *ns)
206 : {
207 41 : gfc_data *d;
208 :
209 47 : for (;ns->data;)
210 : {
211 6 : d = ns->data->next;
212 6 : free (ns->data);
213 6 : ns->data = d;
214 : }
215 41 : }
216 :
217 : /* Reject data parsed since the last restore point was marked. */
218 :
219 : void
220 8931118 : gfc_reject_data (gfc_namespace *ns)
221 : {
222 8931118 : gfc_data *d;
223 :
224 8931120 : while (ns->data && ns->data != ns->old_data)
225 : {
226 2 : d = ns->data->next;
227 2 : free (ns->data);
228 2 : ns->data = d;
229 : }
230 8931118 : }
231 :
232 : static match var_element (gfc_data_variable *);
233 :
234 : /* Match a list of variables terminated by an iterator and a right
235 : parenthesis. */
236 :
237 : static match
238 154 : var_list (gfc_data_variable *parent)
239 : {
240 154 : gfc_data_variable *tail, var;
241 154 : match m;
242 :
243 154 : m = var_element (&var);
244 154 : if (m == MATCH_ERROR)
245 : return MATCH_ERROR;
246 154 : if (m == MATCH_NO)
247 0 : goto syntax;
248 :
249 154 : tail = gfc_get_data_variable ();
250 154 : *tail = var;
251 :
252 154 : parent->list = tail;
253 :
254 156 : for (;;)
255 : {
256 155 : if (gfc_match_char (',') != MATCH_YES)
257 0 : goto syntax;
258 :
259 155 : m = gfc_match_iterator (&parent->iter, 1);
260 155 : if (m == MATCH_YES)
261 : break;
262 1 : if (m == MATCH_ERROR)
263 : return MATCH_ERROR;
264 :
265 1 : m = var_element (&var);
266 1 : if (m == MATCH_ERROR)
267 : return MATCH_ERROR;
268 1 : if (m == MATCH_NO)
269 0 : goto syntax;
270 :
271 1 : tail->next = gfc_get_data_variable ();
272 1 : tail = tail->next;
273 :
274 1 : *tail = var;
275 : }
276 :
277 154 : if (gfc_match_char (')') != MATCH_YES)
278 0 : goto syntax;
279 : return MATCH_YES;
280 :
281 0 : syntax:
282 0 : gfc_syntax_error (ST_DATA);
283 0 : return MATCH_ERROR;
284 : }
285 :
286 :
287 : /* Match a single element in a data variable list, which can be a
288 : variable-iterator list. */
289 :
290 : static match
291 3047 : var_element (gfc_data_variable *new_var)
292 : {
293 3047 : match m;
294 3047 : gfc_symbol *sym;
295 :
296 3047 : memset (new_var, 0, sizeof (gfc_data_variable));
297 :
298 3047 : if (gfc_match_char ('(') == MATCH_YES)
299 154 : return var_list (new_var);
300 :
301 2893 : m = gfc_match_variable (&new_var->expr, 0);
302 2893 : if (m != MATCH_YES)
303 : return m;
304 :
305 2889 : if (new_var->expr->expr_type == EXPR_CONSTANT
306 2 : && new_var->expr->symtree == NULL)
307 : {
308 2 : gfc_error ("Inquiry parameter cannot appear in a "
309 : "data-stmt-object-list at %C");
310 2 : return MATCH_ERROR;
311 : }
312 :
313 2887 : sym = new_var->expr->symtree->n.sym;
314 :
315 : /* Symbol should already have an associated type. */
316 2887 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
317 : return MATCH_ERROR;
318 :
319 2886 : if (!sym->attr.function && gfc_current_ns->parent
320 148 : && gfc_current_ns->parent == sym->ns)
321 : {
322 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
323 : "statement at %C", sym->name);
324 1 : return MATCH_ERROR;
325 : }
326 :
327 2885 : if (gfc_current_state () != COMP_BLOCK_DATA
328 2732 : && sym->attr.in_common
329 2914 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
330 : "common block variable %qs in DATA statement at %C",
331 : sym->name))
332 : return MATCH_ERROR;
333 :
334 2883 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
335 : return MATCH_ERROR;
336 :
337 : return MATCH_YES;
338 : }
339 :
340 :
341 : /* Match the top-level list of data variables. */
342 :
343 : static match
344 2517 : top_var_list (gfc_data *d)
345 : {
346 2517 : gfc_data_variable var, *tail, *new_var;
347 2517 : match m;
348 :
349 2517 : tail = NULL;
350 :
351 2892 : for (;;)
352 : {
353 2892 : m = var_element (&var);
354 2892 : if (m == MATCH_NO)
355 0 : goto syntax;
356 2892 : if (m == MATCH_ERROR)
357 : return MATCH_ERROR;
358 :
359 2877 : new_var = gfc_get_data_variable ();
360 2877 : *new_var = var;
361 2877 : if (new_var->expr)
362 2751 : new_var->expr->where = gfc_current_locus;
363 :
364 2877 : if (tail == NULL)
365 2502 : d->var = new_var;
366 : else
367 375 : tail->next = new_var;
368 :
369 2877 : tail = new_var;
370 :
371 2877 : if (gfc_match_char ('/') == MATCH_YES)
372 : break;
373 378 : if (gfc_match_char (',') != MATCH_YES)
374 3 : goto syntax;
375 : }
376 :
377 : return MATCH_YES;
378 :
379 3 : syntax:
380 3 : gfc_syntax_error (ST_DATA);
381 3 : gfc_free_data_all (gfc_current_ns);
382 3 : return MATCH_ERROR;
383 : }
384 :
385 :
386 : static match
387 8713 : match_data_constant (gfc_expr **result)
388 : {
389 8713 : char name[GFC_MAX_SYMBOL_LEN + 1];
390 8713 : gfc_symbol *sym, *dt_sym = NULL;
391 8713 : gfc_expr *expr;
392 8713 : match m;
393 8713 : locus old_loc;
394 8713 : gfc_symtree *symtree;
395 :
396 8713 : m = gfc_match_literal_constant (&expr, 1);
397 8713 : if (m == MATCH_YES)
398 : {
399 8368 : *result = expr;
400 8368 : return MATCH_YES;
401 : }
402 :
403 345 : if (m == MATCH_ERROR)
404 : return MATCH_ERROR;
405 :
406 337 : m = gfc_match_null (result);
407 337 : if (m != MATCH_NO)
408 : return m;
409 :
410 329 : old_loc = gfc_current_locus;
411 :
412 : /* Should this be a structure component, try to match it
413 : before matching a name. */
414 329 : m = gfc_match_rvalue (result);
415 329 : if (m == MATCH_ERROR)
416 : return m;
417 :
418 329 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
419 : {
420 4 : if (!gfc_simplify_expr (*result, 0))
421 0 : m = MATCH_ERROR;
422 4 : return m;
423 : }
424 319 : else if (m == MATCH_YES)
425 : {
426 : /* If a parameter inquiry ends up here, symtree is NULL but **result
427 : contains the right constant expression. Check here. */
428 319 : if ((*result)->symtree == NULL
429 37 : && (*result)->expr_type == EXPR_CONSTANT
430 37 : && ((*result)->ts.type == BT_INTEGER
431 1 : || (*result)->ts.type == BT_REAL))
432 : return m;
433 :
434 : /* F2018:R845 data-stmt-constant is initial-data-target.
435 : A data-stmt-constant shall be ... initial-data-target if and
436 : only if the corresponding data-stmt-object has the POINTER
437 : attribute. ... If data-stmt-constant is initial-data-target
438 : the corresponding data statement object shall be
439 : data-pointer-initialization compatible (7.5.4.6) with the initial
440 : data target; the data statement object is initially associated
441 : with the target. */
442 283 : if ((*result)->symtree
443 282 : && (*result)->symtree->n.sym->attr.save
444 218 : && (*result)->symtree->n.sym->attr.target)
445 : return m;
446 250 : gfc_free_expr (*result);
447 : }
448 :
449 256 : gfc_current_locus = old_loc;
450 :
451 256 : m = gfc_match_name (name);
452 256 : if (m != MATCH_YES)
453 : return m;
454 :
455 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
456 : return MATCH_ERROR;
457 :
458 250 : sym = symtree->n.sym;
459 :
460 250 : if (sym && sym->attr.generic)
461 60 : dt_sym = gfc_find_dt_in_generic (sym);
462 :
463 60 : if (sym == NULL
464 250 : || (sym->attr.flavor != FL_PARAMETER
465 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
466 : {
467 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
468 : name);
469 5 : *result = NULL;
470 5 : return MATCH_ERROR;
471 : }
472 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
473 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
474 :
475 : /* Check to see if the value is an initialization array expression. */
476 185 : if (sym->value->expr_type == EXPR_ARRAY)
477 : {
478 67 : gfc_current_locus = old_loc;
479 :
480 67 : m = gfc_match_init_expr (result);
481 67 : if (m == MATCH_ERROR)
482 : return m;
483 :
484 66 : if (m == MATCH_YES)
485 : {
486 66 : if (!gfc_simplify_expr (*result, 0))
487 0 : m = MATCH_ERROR;
488 :
489 66 : if ((*result)->expr_type == EXPR_CONSTANT)
490 : return m;
491 : else
492 : {
493 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
494 2 : return MATCH_ERROR;
495 : }
496 : }
497 : }
498 :
499 118 : *result = gfc_copy_expr (sym->value);
500 118 : return MATCH_YES;
501 : }
502 :
503 :
504 : /* Match a list of values in a DATA statement. The leading '/' has
505 : already been seen at this point. */
506 :
507 : static match
508 2560 : top_val_list (gfc_data *data)
509 : {
510 2560 : gfc_data_value *new_val, *tail;
511 2560 : gfc_expr *expr;
512 2560 : match m;
513 :
514 2560 : tail = NULL;
515 :
516 8349 : for (;;)
517 : {
518 8349 : m = match_data_constant (&expr);
519 8349 : if (m == MATCH_NO)
520 3 : goto syntax;
521 8346 : if (m == MATCH_ERROR)
522 : return MATCH_ERROR;
523 :
524 8324 : new_val = gfc_get_data_value ();
525 8324 : mpz_init (new_val->repeat);
526 :
527 8324 : if (tail == NULL)
528 2535 : data->value = new_val;
529 : else
530 5789 : tail->next = new_val;
531 :
532 8324 : tail = new_val;
533 :
534 8324 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
535 : {
536 8119 : tail->expr = expr;
537 8119 : mpz_set_ui (tail->repeat, 1);
538 : }
539 : else
540 : {
541 205 : mpz_set (tail->repeat, expr->value.integer);
542 205 : gfc_free_expr (expr);
543 :
544 205 : m = match_data_constant (&tail->expr);
545 205 : if (m == MATCH_NO)
546 0 : goto syntax;
547 205 : if (m == MATCH_ERROR)
548 : return MATCH_ERROR;
549 : }
550 :
551 8320 : if (gfc_match_char ('/') == MATCH_YES)
552 : break;
553 5790 : if (gfc_match_char (',') == MATCH_NO)
554 1 : goto syntax;
555 : }
556 :
557 : return MATCH_YES;
558 :
559 4 : syntax:
560 4 : gfc_syntax_error (ST_DATA);
561 4 : gfc_free_data_all (gfc_current_ns);
562 4 : return MATCH_ERROR;
563 : }
564 :
565 :
566 : /* Matches an old style initialization. */
567 :
568 : static match
569 70 : match_old_style_init (const char *name)
570 : {
571 70 : match m;
572 70 : gfc_symtree *st;
573 70 : gfc_symbol *sym;
574 70 : gfc_data *newdata, *nd;
575 :
576 : /* Set up data structure to hold initializers. */
577 70 : gfc_find_sym_tree (name, NULL, 0, &st);
578 70 : sym = st->n.sym;
579 :
580 70 : newdata = gfc_get_data ();
581 70 : newdata->var = gfc_get_data_variable ();
582 70 : newdata->var->expr = gfc_get_variable_expr (st);
583 70 : newdata->var->expr->where = sym->declared_at;
584 70 : newdata->where = gfc_current_locus;
585 :
586 : /* Match initial value list. This also eats the terminal '/'. */
587 70 : m = top_val_list (newdata);
588 70 : if (m != MATCH_YES)
589 : {
590 1 : free (newdata);
591 1 : return m;
592 : }
593 :
594 : /* Check that a BOZ did not creep into an old-style initialization. */
595 137 : for (nd = newdata; nd; nd = nd->next)
596 : {
597 69 : if (nd->value->expr->ts.type == BT_BOZ
598 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
599 : "initialization"), &nd->value->expr->where))
600 : return MATCH_ERROR;
601 :
602 68 : if (nd->var->expr->ts.type != BT_INTEGER
603 27 : && nd->var->expr->ts.type != BT_REAL
604 21 : && nd->value->expr->ts.type == BT_BOZ)
605 : {
606 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
607 : "a %qs variable in an old-style initialization"),
608 0 : &nd->value->expr->where,
609 : gfc_typename (&nd->value->expr->ts));
610 0 : return MATCH_ERROR;
611 : }
612 : }
613 :
614 68 : if (gfc_pure (NULL))
615 : {
616 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
617 1 : free (newdata);
618 1 : return MATCH_ERROR;
619 : }
620 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
621 :
622 : /* Mark the variable as having appeared in a data statement. */
623 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
624 : {
625 2 : free (newdata);
626 2 : return MATCH_ERROR;
627 : }
628 :
629 : /* Chain in namespace list of DATA initializers. */
630 65 : newdata->next = gfc_current_ns->data;
631 65 : gfc_current_ns->data = newdata;
632 :
633 65 : return m;
634 : }
635 :
636 :
637 : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
638 : we are matching a DATA statement and are therefore issuing an error
639 : if we encounter something unexpected, if not, we're trying to match
640 : an old-style initialization expression of the form INTEGER I /2/. */
641 :
642 : match
643 2422 : gfc_match_data (void)
644 : {
645 2422 : gfc_data *new_data;
646 2422 : gfc_expr *e;
647 2422 : gfc_ref *ref;
648 2422 : match m;
649 2422 : char c;
650 :
651 : /* DATA has been matched. In free form source code, the next character
652 : needs to be whitespace or '(' from an implied do-loop. Check that
653 : here. */
654 2422 : c = gfc_peek_ascii_char ();
655 2422 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
656 : return MATCH_NO;
657 :
658 : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
659 2421 : if ((gfc_current_state () == COMP_FUNCTION
660 2421 : || gfc_current_state () == COMP_SUBROUTINE)
661 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
662 : {
663 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
664 1 : return MATCH_ERROR;
665 : }
666 :
667 2420 : set_in_match_data (true);
668 :
669 2614 : for (;;)
670 : {
671 2517 : new_data = gfc_get_data ();
672 2517 : new_data->where = gfc_current_locus;
673 :
674 2517 : m = top_var_list (new_data);
675 2517 : if (m != MATCH_YES)
676 18 : goto cleanup;
677 :
678 2499 : if (new_data->var->iter.var
679 117 : && new_data->var->iter.var->ts.type == BT_INTEGER
680 74 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
681 68 : && new_data->var->list
682 68 : && new_data->var->list->expr
683 55 : && new_data->var->list->expr->ts.type == BT_CHARACTER
684 3 : && new_data->var->list->expr->ref
685 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
686 : {
687 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
688 : "statement", &new_data->var->list->expr->where);
689 1 : goto cleanup;
690 : }
691 :
692 : /* Check for an entity with an allocatable component, which is not
693 : allowed. */
694 2498 : e = new_data->var->expr;
695 2498 : if (e)
696 : {
697 2382 : bool invalid;
698 :
699 2382 : invalid = false;
700 3606 : for (ref = e->ref; ref; ref = ref->next)
701 1224 : if ((ref->type == REF_COMPONENT
702 140 : && ref->u.c.component->attr.allocatable)
703 1222 : || (ref->type == REF_ARRAY
704 1034 : && e->symtree->n.sym->attr.pointer != 1
705 1031 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
706 1224 : invalid = true;
707 :
708 2382 : if (invalid)
709 : {
710 2 : gfc_error ("Allocatable component or deferred-shaped array "
711 : "near %C in DATA statement");
712 2 : goto cleanup;
713 : }
714 :
715 : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
716 : as a data-stmt-object shall not be an object designator in which
717 : a pointer appears other than as the entire rightmost part-ref. */
718 2380 : if (!e->ref && e->ts.type == BT_DERIVED
719 43 : && e->symtree->n.sym->attr.pointer)
720 4 : goto partref;
721 :
722 2376 : ref = e->ref;
723 2376 : if (e->symtree->n.sym->ts.type == BT_DERIVED
724 125 : && e->symtree->n.sym->attr.pointer
725 1 : && ref->type == REF_COMPONENT)
726 1 : goto partref;
727 :
728 3591 : for (; ref; ref = ref->next)
729 1217 : if (ref->type == REF_COMPONENT
730 135 : && ref->u.c.component->attr.pointer
731 27 : && ref->next)
732 1 : goto partref;
733 : }
734 :
735 2490 : m = top_val_list (new_data);
736 2490 : if (m != MATCH_YES)
737 29 : goto cleanup;
738 :
739 2461 : new_data->next = gfc_current_ns->data;
740 2461 : gfc_current_ns->data = new_data;
741 :
742 : /* A BOZ literal constant cannot appear in a structure constructor.
743 : Check for that here for a data statement value. */
744 2461 : if (new_data->value->expr->ts.type == BT_DERIVED
745 37 : && new_data->value->expr->value.constructor)
746 : {
747 35 : gfc_constructor *c;
748 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
749 106 : for (; c; c = gfc_constructor_next (c))
750 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
751 : {
752 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
753 : "structure constructor", &c->expr->where);
754 0 : return MATCH_ERROR;
755 : }
756 : }
757 :
758 2461 : if (gfc_match_eos () == MATCH_YES)
759 : break;
760 :
761 97 : gfc_match_char (','); /* Optional comma */
762 97 : }
763 :
764 2364 : set_in_match_data (false);
765 :
766 2364 : if (gfc_pure (NULL))
767 : {
768 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
769 0 : return MATCH_ERROR;
770 : }
771 2364 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
772 :
773 2364 : return MATCH_YES;
774 :
775 6 : partref:
776 :
777 6 : gfc_error ("part-ref with pointer attribute near %L is not "
778 : "rightmost part-ref of data-stmt-object",
779 : &e->where);
780 :
781 56 : cleanup:
782 56 : set_in_match_data (false);
783 56 : gfc_free_data (new_data);
784 56 : return MATCH_ERROR;
785 : }
786 :
787 :
788 : /************************ Declaration statements *********************/
789 :
790 :
791 : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
792 : list). The difference here is the expression is a list of constants
793 : and is surrounded by '/'.
794 : The typespec ts must match the typespec of the variable which the
795 : clist is initializing.
796 : The arrayspec tells whether this should match a list of constants
797 : corresponding to array elements or a scalar (as == NULL). */
798 :
799 : static match
800 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
801 : {
802 74 : gfc_constructor_base array_head = NULL;
803 74 : gfc_expr *expr = NULL;
804 74 : match m = MATCH_ERROR;
805 74 : locus where;
806 74 : mpz_t repeat, cons_size, as_size;
807 74 : bool scalar;
808 74 : int cmp;
809 :
810 74 : gcc_assert (ts);
811 :
812 : /* We have already matched '/' - now look for a constant list, as with
813 : top_val_list from decl.cc, but append the result to an array. */
814 74 : if (gfc_match ("/") == MATCH_YES)
815 : {
816 1 : gfc_error ("Empty old style initializer list at %C");
817 1 : return MATCH_ERROR;
818 : }
819 :
820 73 : where = gfc_current_locus;
821 73 : scalar = !as || !as->rank;
822 :
823 42 : if (!scalar && !spec_size (as, &as_size))
824 : {
825 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
826 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
827 : /* Nothing to cleanup yet. */
828 1 : return MATCH_ERROR;
829 : }
830 :
831 72 : mpz_init_set_ui (repeat, 0);
832 :
833 143 : for (;;)
834 : {
835 143 : m = match_data_constant (&expr);
836 143 : if (m != MATCH_YES)
837 3 : expr = NULL; /* match_data_constant may set expr to garbage */
838 3 : if (m == MATCH_NO)
839 2 : goto syntax;
840 141 : if (m == MATCH_ERROR)
841 1 : goto cleanup;
842 :
843 : /* Found r in repeat spec r*c; look for the constant to repeat. */
844 140 : if ( gfc_match_char ('*') == MATCH_YES)
845 : {
846 18 : if (scalar)
847 : {
848 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
849 1 : goto cleanup;
850 : }
851 17 : if (expr->ts.type != BT_INTEGER)
852 : {
853 1 : gfc_error ("Repeat spec must be an integer at %C");
854 1 : goto cleanup;
855 : }
856 16 : mpz_set (repeat, expr->value.integer);
857 16 : gfc_free_expr (expr);
858 16 : expr = NULL;
859 :
860 16 : m = match_data_constant (&expr);
861 16 : if (m == MATCH_NO)
862 : {
863 1 : m = MATCH_ERROR;
864 1 : gfc_error ("Expected data constant after repeat spec at %C");
865 : }
866 16 : if (m != MATCH_YES)
867 1 : goto cleanup;
868 : }
869 : /* No repeat spec, we matched the data constant itself. */
870 : else
871 122 : mpz_set_ui (repeat, 1);
872 :
873 137 : if (!scalar)
874 : {
875 : /* Add the constant initializer as many times as repeated. */
876 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
877 : {
878 : /* Make sure types of elements match */
879 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
880 12 : && !gfc_convert_type (expr, ts, 1))
881 0 : goto cleanup;
882 :
883 144 : gfc_constructor_append_expr (&array_head,
884 : gfc_copy_expr (expr), &gfc_current_locus);
885 : }
886 :
887 107 : gfc_free_expr (expr);
888 107 : expr = NULL;
889 : }
890 :
891 : /* For scalar initializers quit after one element. */
892 : else
893 : {
894 30 : if(gfc_match_char ('/') != MATCH_YES)
895 : {
896 1 : gfc_error ("End of scalar initializer expected at %C");
897 1 : goto cleanup;
898 : }
899 : break;
900 : }
901 :
902 107 : if (gfc_match_char ('/') == MATCH_YES)
903 : break;
904 72 : if (gfc_match_char (',') == MATCH_NO)
905 1 : goto syntax;
906 : }
907 :
908 : /* If we break early from here out, we encountered an error. */
909 64 : m = MATCH_ERROR;
910 :
911 : /* Set up expr as an array constructor. */
912 64 : if (!scalar)
913 : {
914 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
915 35 : expr->ts = *ts;
916 35 : expr->value.constructor = array_head;
917 :
918 : /* Validate sizes. We built expr ourselves, so cons_size will be
919 : constant (we fail above for non-constant expressions).
920 : We still need to verify that the sizes match. */
921 35 : gcc_assert (gfc_array_size (expr, &cons_size));
922 35 : cmp = mpz_cmp (cons_size, as_size);
923 35 : if (cmp < 0)
924 2 : gfc_error ("Not enough elements in array initializer at %C");
925 33 : else if (cmp > 0)
926 3 : gfc_error ("Too many elements in array initializer at %C");
927 35 : mpz_clear (cons_size);
928 35 : if (cmp)
929 5 : goto cleanup;
930 :
931 : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
932 30 : expr->rank = as->rank;
933 30 : expr->corank = as->corank;
934 30 : expr->shape = gfc_get_shape (as->rank);
935 66 : for (int i = 0; i < as->rank; ++i)
936 36 : spec_dimen_size (as, i, &expr->shape[i]);
937 : }
938 :
939 : /* Make sure scalar types match. */
940 29 : else if (!gfc_compare_types (&expr->ts, ts)
941 29 : && !gfc_convert_type (expr, ts, 1))
942 2 : goto cleanup;
943 :
944 57 : if (expr->ts.u.cl)
945 1 : expr->ts.u.cl->length_from_typespec = 1;
946 :
947 57 : *result = expr;
948 57 : m = MATCH_YES;
949 57 : goto done;
950 :
951 3 : syntax:
952 3 : m = MATCH_ERROR;
953 3 : gfc_error ("Syntax error in old style initializer list at %C");
954 :
955 15 : cleanup:
956 15 : if (expr)
957 10 : expr->value.constructor = NULL;
958 15 : gfc_free_expr (expr);
959 15 : gfc_constructor_free (array_head);
960 :
961 72 : done:
962 72 : mpz_clear (repeat);
963 72 : if (!scalar)
964 41 : mpz_clear (as_size);
965 : return m;
966 : }
967 :
968 :
969 : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
970 :
971 : static bool
972 114 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
973 : {
974 114 : if ((from->type == AS_ASSUMED_RANK && to->corank)
975 112 : || (to->type == AS_ASSUMED_RANK && from->corank))
976 : {
977 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
978 5 : return false;
979 : }
980 :
981 109 : if (to->rank == 0 && from->rank > 0)
982 : {
983 48 : to->rank = from->rank;
984 48 : to->type = from->type;
985 48 : to->cray_pointee = from->cray_pointee;
986 48 : to->cp_was_assumed = from->cp_was_assumed;
987 :
988 152 : for (int i = to->corank - 1; i >= 0; i--)
989 : {
990 : /* Do not exceed the limits on lower[] and upper[]. gfortran
991 : cleans up elsewhere. */
992 104 : int j = from->rank + i;
993 104 : if (j >= GFC_MAX_DIMENSIONS)
994 : break;
995 :
996 104 : to->lower[j] = to->lower[i];
997 104 : to->upper[j] = to->upper[i];
998 : }
999 115 : for (int i = 0; i < from->rank; i++)
1000 : {
1001 67 : if (copy)
1002 : {
1003 43 : to->lower[i] = gfc_copy_expr (from->lower[i]);
1004 43 : to->upper[i] = gfc_copy_expr (from->upper[i]);
1005 : }
1006 : else
1007 : {
1008 24 : to->lower[i] = from->lower[i];
1009 24 : to->upper[i] = from->upper[i];
1010 : }
1011 : }
1012 : }
1013 61 : else if (to->corank == 0 && from->corank > 0)
1014 : {
1015 34 : to->corank = from->corank;
1016 34 : to->cotype = from->cotype;
1017 :
1018 104 : for (int i = 0; i < from->corank; i++)
1019 : {
1020 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1021 : cleans up elsewhere. */
1022 71 : int k = from->rank + i;
1023 71 : int j = to->rank + i;
1024 71 : if (j >= GFC_MAX_DIMENSIONS)
1025 : break;
1026 :
1027 70 : if (copy)
1028 : {
1029 37 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1030 37 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1031 : }
1032 : else
1033 : {
1034 33 : to->lower[j] = from->lower[k];
1035 33 : to->upper[j] = from->upper[k];
1036 : }
1037 : }
1038 : }
1039 :
1040 109 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1041 : {
1042 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1043 : "allowed dimensions of %d",
1044 : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1045 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1046 1 : return false;
1047 : }
1048 : return true;
1049 : }
1050 :
1051 :
1052 : /* Match an intent specification. Since this can only happen after an
1053 : INTENT word, a legal intent-spec must follow. */
1054 :
1055 : static sym_intent
1056 26895 : match_intent_spec (void)
1057 : {
1058 :
1059 26895 : if (gfc_match (" ( in out )") == MATCH_YES)
1060 : return INTENT_INOUT;
1061 23890 : if (gfc_match (" ( in )") == MATCH_YES)
1062 : return INTENT_IN;
1063 3577 : if (gfc_match (" ( out )") == MATCH_YES)
1064 : return INTENT_OUT;
1065 :
1066 2 : gfc_error ("Bad INTENT specification at %C");
1067 2 : return INTENT_UNKNOWN;
1068 : }
1069 :
1070 :
1071 : /* Matches a character length specification, which is either a
1072 : specification expression, '*', or ':'. */
1073 :
1074 : static match
1075 27401 : char_len_param_value (gfc_expr **expr, bool *deferred)
1076 : {
1077 27401 : match m;
1078 27401 : gfc_expr *p;
1079 :
1080 27401 : *expr = NULL;
1081 27401 : *deferred = false;
1082 :
1083 27401 : if (gfc_match_char ('*') == MATCH_YES)
1084 : return MATCH_YES;
1085 :
1086 20919 : if (gfc_match_char (':') == MATCH_YES)
1087 : {
1088 3289 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1089 : return MATCH_ERROR;
1090 :
1091 3287 : *deferred = true;
1092 :
1093 3287 : return MATCH_YES;
1094 : }
1095 :
1096 17630 : m = gfc_match_expr (expr);
1097 :
1098 17630 : if (m == MATCH_NO || m == MATCH_ERROR)
1099 : return m;
1100 :
1101 17625 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1102 : return MATCH_ERROR;
1103 :
1104 : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1105 17619 : p = gfc_copy_expr (*expr);
1106 17619 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1107 14589 : gfc_replace_expr (*expr, p);
1108 : else
1109 3030 : gfc_free_expr (p);
1110 :
1111 17619 : if ((*expr)->expr_type == EXPR_FUNCTION)
1112 : {
1113 1015 : if ((*expr)->ts.type == BT_INTEGER
1114 1014 : || ((*expr)->ts.type == BT_UNKNOWN
1115 1014 : && strcmp((*expr)->symtree->name, "null") != 0))
1116 : return MATCH_YES;
1117 :
1118 2 : goto syntax;
1119 : }
1120 16604 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1121 : {
1122 : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1123 : processor dependent and its value is greater than or equal to zero.
1124 : F2008, 4.4.3.2: If the character length parameter value evaluates
1125 : to a negative value, the length of character entities declared
1126 : is zero. */
1127 :
1128 14518 : if ((*expr)->ts.type == BT_INTEGER)
1129 : {
1130 14500 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1131 4 : mpz_set_si ((*expr)->value.integer, 0);
1132 : }
1133 : else
1134 18 : goto syntax;
1135 : }
1136 2086 : else if ((*expr)->expr_type == EXPR_ARRAY)
1137 8 : goto syntax;
1138 2078 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1139 : {
1140 1511 : bool t;
1141 1511 : gfc_expr *e;
1142 :
1143 1511 : e = gfc_copy_expr (*expr);
1144 :
1145 : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1146 : which causes an ICE if gfc_reduce_init_expr() is called. */
1147 1511 : if (e->ref && e->ref->type == REF_ARRAY
1148 8 : && e->ref->u.ar.type == AR_UNKNOWN
1149 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1150 2 : goto syntax;
1151 :
1152 1509 : t = gfc_reduce_init_expr (e);
1153 :
1154 1509 : if (!t && e->ts.type == BT_UNKNOWN
1155 7 : && e->symtree->n.sym->attr.untyped == 1
1156 7 : && (flag_implicit_none
1157 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1158 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1159 : {
1160 7 : gfc_free_expr (e);
1161 7 : goto syntax;
1162 : }
1163 :
1164 1502 : if ((e->ref && e->ref->type == REF_ARRAY
1165 4 : && e->ref->u.ar.type != AR_ELEMENT)
1166 1501 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1167 : {
1168 2 : gfc_free_expr (e);
1169 2 : goto syntax;
1170 : }
1171 :
1172 1500 : gfc_free_expr (e);
1173 : }
1174 :
1175 16567 : if (gfc_seen_div0)
1176 52 : m = MATCH_ERROR;
1177 :
1178 : return m;
1179 :
1180 39 : syntax:
1181 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1182 39 : return MATCH_ERROR;
1183 : }
1184 :
1185 :
1186 : /* A character length is a '*' followed by a literal integer or a
1187 : char_len_param_value in parenthesis. */
1188 :
1189 : static match
1190 62024 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1191 : {
1192 62024 : int length;
1193 62024 : match m;
1194 :
1195 62024 : *deferred = false;
1196 62024 : m = gfc_match_char ('*');
1197 62024 : if (m != MATCH_YES)
1198 : return m;
1199 :
1200 2641 : m = gfc_match_small_literal_int (&length, NULL);
1201 2641 : if (m == MATCH_ERROR)
1202 : return m;
1203 :
1204 2641 : if (m == MATCH_YES)
1205 : {
1206 2137 : if (obsolescent_check
1207 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1208 : return MATCH_ERROR;
1209 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1210 2137 : return m;
1211 : }
1212 :
1213 504 : if (gfc_match_char ('(') == MATCH_NO)
1214 0 : goto syntax;
1215 :
1216 504 : m = char_len_param_value (expr, deferred);
1217 504 : if (m != MATCH_YES && gfc_matching_function)
1218 : {
1219 0 : gfc_undo_symbols ();
1220 0 : m = MATCH_YES;
1221 : }
1222 :
1223 1 : if (m == MATCH_ERROR)
1224 : return m;
1225 503 : if (m == MATCH_NO)
1226 0 : goto syntax;
1227 :
1228 503 : if (gfc_match_char (')') == MATCH_NO)
1229 : {
1230 0 : gfc_free_expr (*expr);
1231 0 : *expr = NULL;
1232 0 : goto syntax;
1233 : }
1234 :
1235 503 : if (obsolescent_check
1236 503 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1237 : return MATCH_ERROR;
1238 :
1239 : return MATCH_YES;
1240 :
1241 0 : syntax:
1242 0 : gfc_error ("Syntax error in character length specification at %C");
1243 0 : return MATCH_ERROR;
1244 : }
1245 :
1246 :
1247 : /* Special subroutine for finding a symbol. Check if the name is found
1248 : in the current name space. If not, and we're compiling a function or
1249 : subroutine and the parent compilation unit is an interface, then check
1250 : to see if the name we've been given is the name of the interface
1251 : (located in another namespace). */
1252 :
1253 : static int
1254 277974 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1255 : {
1256 277974 : gfc_state_data *s;
1257 277974 : gfc_symtree *st;
1258 277974 : int i;
1259 :
1260 277974 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1261 277974 : if (i == 0)
1262 : {
1263 277974 : *result = st ? st->n.sym : NULL;
1264 277974 : goto end;
1265 : }
1266 :
1267 0 : if (gfc_current_state () != COMP_SUBROUTINE
1268 0 : && gfc_current_state () != COMP_FUNCTION)
1269 0 : goto end;
1270 :
1271 0 : s = gfc_state_stack->previous;
1272 0 : if (s == NULL)
1273 0 : goto end;
1274 :
1275 0 : if (s->state != COMP_INTERFACE)
1276 0 : goto end;
1277 0 : if (s->sym == NULL)
1278 0 : goto end; /* Nameless interface. */
1279 :
1280 0 : if (strcmp (name, s->sym->name) == 0)
1281 : {
1282 0 : *result = s->sym;
1283 0 : return 0;
1284 : }
1285 :
1286 0 : end:
1287 : return i;
1288 : }
1289 :
1290 :
1291 : /* Special subroutine for getting a symbol node associated with a
1292 : procedure name, used in SUBROUTINE and FUNCTION statements. The
1293 : symbol is created in the parent using with symtree node in the
1294 : child unit pointing to the symbol. If the current namespace has no
1295 : parent, then the symbol is just created in the current unit. */
1296 :
1297 : static int
1298 62478 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1299 : {
1300 62478 : gfc_symtree *st;
1301 62478 : gfc_symbol *sym;
1302 62478 : int rc = 0;
1303 :
1304 : /* Module functions have to be left in their own namespace because
1305 : they have potentially (almost certainly!) already been referenced.
1306 : In this sense, they are rather like external functions. This is
1307 : fixed up in resolve.cc(resolve_entries), where the symbol name-
1308 : space is set to point to the master function, so that the fake
1309 : result mechanism can work. */
1310 62478 : if (module_fcn_entry)
1311 : {
1312 : /* Present if entry is declared to be a module procedure. */
1313 260 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1314 :
1315 260 : if (*result == NULL)
1316 217 : rc = gfc_get_symbol (name, NULL, result);
1317 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1318 43 : && (*result)->ts.type == BT_UNKNOWN
1319 86 : && sym->attr.flavor == FL_UNKNOWN)
1320 : /* Pick up the typespec for the entry, if declared in the function
1321 : body. Note that this symbol is FL_UNKNOWN because it will
1322 : only have appeared in a type declaration. The local symtree
1323 : is set to point to the module symbol and a unique symtree
1324 : to the local version. This latter ensures a correct clearing
1325 : of the symbols. */
1326 : {
1327 : /* If the ENTRY proceeds its specification, we need to ensure
1328 : that this does not raise a "has no IMPLICIT type" error. */
1329 43 : if (sym->ts.type == BT_UNKNOWN)
1330 23 : sym->attr.untyped = 1;
1331 :
1332 43 : (*result)->ts = sym->ts;
1333 :
1334 : /* Put the symbol in the procedure namespace so that, should
1335 : the ENTRY precede its specification, the specification
1336 : can be applied. */
1337 43 : (*result)->ns = gfc_current_ns;
1338 :
1339 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1340 43 : st->n.sym = *result;
1341 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1342 43 : sym->refs++;
1343 43 : st->n.sym = sym;
1344 : }
1345 : }
1346 : else
1347 62218 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1348 :
1349 62478 : if (rc)
1350 : return rc;
1351 :
1352 62477 : sym = *result;
1353 62477 : if (sym->attr.proc == PROC_ST_FUNCTION)
1354 : return rc;
1355 :
1356 62476 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1357 : {
1358 : /* Create a partially populated interface symbol to carry the
1359 : characteristics of the procedure and the result. */
1360 443 : sym->tlink = gfc_new_symbol (name, sym->ns);
1361 443 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1362 443 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1363 443 : if (sym->attr.dimension)
1364 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1365 :
1366 : /* Ideally, at this point, a copy would be made of the formal
1367 : arguments and their namespace. However, this does not appear
1368 : to be necessary, albeit at the expense of not being able to
1369 : use gfc_compare_interfaces directly. */
1370 :
1371 443 : if (sym->result && sym->result != sym)
1372 : {
1373 105 : sym->tlink->result = sym->result;
1374 105 : sym->result = NULL;
1375 : }
1376 338 : else if (sym->result)
1377 : {
1378 90 : sym->tlink->result = sym->tlink;
1379 : }
1380 : }
1381 62033 : else if (sym && !sym->gfc_new
1382 23863 : && gfc_current_state () != COMP_INTERFACE)
1383 : {
1384 : /* Trap another encompassed procedure with the same name. All
1385 : these conditions are necessary to avoid picking up an entry
1386 : whose name clashes with that of the encompassing procedure;
1387 : this is handled using gsymbols to register unique, globally
1388 : accessible names. */
1389 22855 : if (sym->attr.flavor != 0
1390 20829 : && sym->attr.proc != 0
1391 2316 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1392 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1393 : {
1394 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1395 : name, &sym->declared_at);
1396 7 : return true;
1397 : }
1398 22848 : if (sym->attr.flavor != 0
1399 20822 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1400 : {
1401 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1402 : name, &sym->declared_at);
1403 1 : return true;
1404 : }
1405 :
1406 22847 : if (sym->attr.external && sym->attr.procedure
1407 2 : && gfc_current_state () == COMP_CONTAINS)
1408 : {
1409 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1410 : "procedure defined at %L",
1411 : name, &sym->declared_at);
1412 1 : return true;
1413 : }
1414 :
1415 : /* Trap a procedure with a name the same as interface in the
1416 : encompassing scope. */
1417 22846 : if (sym->attr.generic != 0
1418 60 : && (sym->attr.subroutine || sym->attr.function)
1419 1 : && !sym->attr.mod_proc)
1420 : {
1421 1 : gfc_error_now ("Name %qs at %C is already defined"
1422 : " as a generic interface at %L",
1423 : name, &sym->declared_at);
1424 1 : return true;
1425 : }
1426 :
1427 : /* Trap declarations of attributes in encompassing scope. The
1428 : signature for this is that ts.kind is nonzero for no-CLASS
1429 : entity. For a CLASS entity, ts.kind is zero. */
1430 22845 : if ((sym->ts.kind != 0
1431 22502 : || sym->ts.type == BT_CLASS
1432 22501 : || sym->ts.type == BT_DERIVED)
1433 367 : && !sym->attr.implicit_type
1434 366 : && sym->attr.proc == 0
1435 348 : && gfc_current_ns->parent != NULL
1436 138 : && sym->attr.access == 0
1437 136 : && !module_fcn_entry)
1438 : {
1439 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1440 : "from a previous declaration", name);
1441 5 : return true;
1442 : }
1443 : }
1444 :
1445 : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1446 : subroutine-stmt of a module subprogram or of a nonabstract interface
1447 : body that is declared in the scoping unit of a module or submodule. */
1448 62461 : if (sym->attr.external
1449 92 : && (sym->attr.subroutine || sym->attr.function)
1450 91 : && sym->attr.if_source == IFSRC_IFBODY
1451 91 : && !current_attr.module_procedure
1452 3 : && sym->attr.proc == PROC_MODULE
1453 3 : && gfc_state_stack->state == COMP_CONTAINS)
1454 : {
1455 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1456 : "clashes with internal procedure defined at %C",
1457 : name, &sym->declared_at);
1458 1 : return true;
1459 : }
1460 :
1461 62460 : if (sym && !sym->gfc_new
1462 24290 : && sym->attr.flavor != FL_UNKNOWN
1463 21883 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1464 217 : && gfc_state_stack->state == COMP_CONTAINS
1465 212 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1466 : {
1467 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1468 : name, &sym->declared_at);
1469 1 : return true;
1470 : }
1471 :
1472 62459 : if (gfc_current_ns->parent == NULL || *result == NULL)
1473 : return rc;
1474 :
1475 : /* Module function entries will already have a symtree in
1476 : the current namespace but will need one at module level. */
1477 50517 : if (module_fcn_entry)
1478 : {
1479 : /* Present if entry is declared to be a module procedure. */
1480 258 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1481 258 : if (st == NULL)
1482 217 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1483 : }
1484 : else
1485 50259 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1486 :
1487 50517 : st->n.sym = sym;
1488 50517 : sym->refs++;
1489 :
1490 : /* See if the procedure should be a module procedure. */
1491 :
1492 50517 : if (((sym->ns->proc_name != NULL
1493 50517 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1494 20620 : && sym->attr.proc != PROC_MODULE)
1495 50517 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1496 68408 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1497 : rc = 2;
1498 :
1499 : return rc;
1500 : }
1501 :
1502 :
1503 : /* Verify that the given symbol representing a parameter is C
1504 : interoperable, by checking to see if it was marked as such after
1505 : its declaration. If the given symbol is not interoperable, a
1506 : warning is reported, thus removing the need to return the status to
1507 : the calling function. The standard does not require the user use
1508 : one of the iso_c_binding named constants to declare an
1509 : interoperable parameter, but we can't be sure if the param is C
1510 : interop or not if the user doesn't. For example, integer(4) may be
1511 : legal Fortran, but doesn't have meaning in C. It may interop with
1512 : a number of the C types, which causes a problem because the
1513 : compiler can't know which one. This code is almost certainly not
1514 : portable, and the user will get what they deserve if the C type
1515 : across platforms isn't always interoperable with integer(4). If
1516 : the user had used something like integer(c_int) or integer(c_long),
1517 : the compiler could have automatically handled the varying sizes
1518 : across platforms. */
1519 :
1520 : bool
1521 16361 : gfc_verify_c_interop_param (gfc_symbol *sym)
1522 : {
1523 16361 : int is_c_interop = 0;
1524 16361 : bool retval = true;
1525 :
1526 : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1527 : Don't repeat the checks here. */
1528 16361 : if (sym->attr.implicit_type)
1529 : return true;
1530 :
1531 : /* For subroutines or functions that are passed to a BIND(C) procedure,
1532 : they're interoperable if they're BIND(C) and their params are all
1533 : interoperable. */
1534 16361 : if (sym->attr.flavor == FL_PROCEDURE)
1535 : {
1536 4 : if (sym->attr.is_bind_c == 0)
1537 : {
1538 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1539 : "attribute to be C interoperable", sym->name,
1540 : &(sym->declared_at));
1541 0 : return false;
1542 : }
1543 : else
1544 : {
1545 4 : if (sym->attr.is_c_interop == 1)
1546 : /* We've already checked this procedure; don't check it again. */
1547 : return true;
1548 : else
1549 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1550 4 : sym->common_block);
1551 : }
1552 : }
1553 :
1554 : /* See if we've stored a reference to a procedure that owns sym. */
1555 16357 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1556 : {
1557 16357 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1558 : {
1559 16318 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1560 16318 : bool f2018_added = false;
1561 :
1562 16318 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1563 :
1564 : /* F2018:18.3.6 has the following text:
1565 : "(5) any dummy argument without the VALUE attribute corresponds to
1566 : a formal parameter of the prototype that is of a pointer type, and
1567 : either
1568 : • the dummy argument is interoperable with an entity of the
1569 : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1570 : the formal parameter (this is equivalent to the F2008 text),
1571 : • the dummy argument is a nonallocatable nonpointer variable of
1572 : type CHARACTER with assumed character length and the formal
1573 : parameter is a pointer to CFI_cdesc_t,
1574 : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1575 : or a pointer without the CONTIGUOUS attribute, and the formal
1576 : parameter is a pointer to CFI_cdesc_t, or
1577 : • the dummy argument is assumed-type and not allocatable,
1578 : assumed-shape, assumed-rank, or a pointer, and the formal
1579 : parameter is a pointer to void," */
1580 3720 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1581 : {
1582 2354 : bool as_ar = (sym->as
1583 2354 : && (sym->as->type == AS_ASSUMED_SHAPE
1584 2109 : || sym->as->type == AS_ASSUMED_RANK));
1585 4708 : bool cond1 = (sym->ts.type == BT_CHARACTER
1586 1564 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1587 904 : && !sym->attr.allocatable
1588 3240 : && !sym->attr.pointer);
1589 4708 : bool cond2 = (sym->attr.allocatable
1590 2257 : || as_ar
1591 3370 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1592 4708 : bool cond3 = (sym->ts.type == BT_ASSUMED
1593 0 : && !sym->attr.allocatable
1594 0 : && !sym->attr.pointer
1595 2354 : && !as_ar);
1596 2354 : f2018_added = cond1 || cond2 || cond3;
1597 : }
1598 :
1599 16318 : if (is_c_interop != 1 && !f2018_added)
1600 : {
1601 : /* Make personalized messages to give better feedback. */
1602 1828 : if (sym->ts.type == BT_DERIVED)
1603 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1604 : "BIND(C) procedure %qs but is not C interoperable "
1605 : "because derived type %qs is not C interoperable",
1606 : sym->name, &(sym->declared_at),
1607 1 : sym->ns->proc_name->name,
1608 1 : sym->ts.u.derived->name);
1609 1827 : else if (sym->ts.type == BT_CLASS)
1610 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1611 : "BIND(C) procedure %qs but is not C interoperable "
1612 : "because it is polymorphic",
1613 : sym->name, &(sym->declared_at),
1614 6 : sym->ns->proc_name->name);
1615 1821 : else if (warn_c_binding_type)
1616 39 : gfc_warning (OPT_Wc_binding_type,
1617 : "Variable %qs at %L is a dummy argument of the "
1618 : "BIND(C) procedure %qs but may not be C "
1619 : "interoperable",
1620 : sym->name, &(sym->declared_at),
1621 39 : sym->ns->proc_name->name);
1622 : }
1623 :
1624 : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1625 16318 : if (sym->attr.pointer && sym->attr.contiguous)
1626 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1627 : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1628 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1629 :
1630 : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1631 : procedure that are default-initialized are not permitted. */
1632 15680 : if ((sym->attr.pointer || sym->attr.allocatable)
1633 1037 : && sym->ts.type == BT_DERIVED
1634 16696 : && gfc_has_default_initializer (sym->ts.u.derived))
1635 : {
1636 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1637 : "attribute at %L is not permitted in BIND(C) "
1638 : "procedure %qs", sym->name,
1639 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1640 4 : &sym->declared_at, sym->ns->proc_name->name);
1641 4 : retval = false;
1642 : }
1643 :
1644 : /* Character strings are only C interoperable if they have a
1645 : length of 1. However, as an argument they are also interoperable
1646 : when passed as descriptor (which requires len=: or len=*). */
1647 16318 : if (sym->ts.type == BT_CHARACTER)
1648 : {
1649 2338 : gfc_charlen *cl = sym->ts.u.cl;
1650 :
1651 2338 : if (sym->attr.allocatable || sym->attr.pointer)
1652 : {
1653 : /* F2018, 18.3.6 (6). */
1654 193 : if (!sym->ts.deferred)
1655 : {
1656 64 : if (sym->attr.allocatable)
1657 32 : gfc_error ("Allocatable character dummy argument %qs "
1658 : "at %L must have deferred length as "
1659 : "procedure %qs is BIND(C)", sym->name,
1660 32 : &sym->declared_at, sym->ns->proc_name->name);
1661 : else
1662 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1663 : "must have deferred length as procedure %qs "
1664 : "is BIND(C)", sym->name, &sym->declared_at,
1665 32 : sym->ns->proc_name->name);
1666 : retval = false;
1667 : }
1668 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1669 : "Deferred-length character dummy "
1670 : "argument %qs at %L of procedure "
1671 : "%qs with BIND(C) attribute",
1672 : sym->name, &sym->declared_at,
1673 129 : sym->ns->proc_name->name))
1674 102 : retval = false;
1675 : }
1676 2145 : else if (sym->attr.value
1677 354 : && (!cl || !cl->length
1678 354 : || cl->length->expr_type != EXPR_CONSTANT
1679 354 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1680 : {
1681 1 : gfc_error ("Character dummy argument %qs at %L must be "
1682 : "of length 1 as it has the VALUE attribute",
1683 : sym->name, &sym->declared_at);
1684 1 : retval = false;
1685 : }
1686 2144 : else if (!cl || !cl->length)
1687 : {
1688 : /* Assumed length; F2018, 18.3.6 (5)(2).
1689 : Uses the CFI array descriptor - also for scalars and
1690 : explicit-size/assumed-size arrays. */
1691 957 : if (!gfc_notify_std (GFC_STD_F2018,
1692 : "Assumed-length character dummy argument "
1693 : "%qs at %L of procedure %qs with BIND(C) "
1694 : "attribute", sym->name, &sym->declared_at,
1695 957 : sym->ns->proc_name->name))
1696 102 : retval = false;
1697 : }
1698 1187 : else if (cl->length->expr_type != EXPR_CONSTANT
1699 873 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1700 : {
1701 : /* F2018, 18.3.6, (5), item 4. */
1702 653 : if (!sym->attr.dimension
1703 645 : || sym->as->type == AS_ASSUMED_SIZE
1704 639 : || sym->as->type == AS_EXPLICIT)
1705 : {
1706 20 : gfc_error ("Character dummy argument %qs at %L must be "
1707 : "of constant length of one or assumed length, "
1708 : "unless it has assumed shape or assumed rank, "
1709 : "as procedure %qs has the BIND(C) attribute",
1710 : sym->name, &sym->declared_at,
1711 20 : sym->ns->proc_name->name);
1712 20 : retval = false;
1713 : }
1714 : /* else: valid only since F2018 - and an assumed-shape/rank
1715 : array; however, gfc_notify_std is already called when
1716 : those array types are used. Thus, silently accept F200x. */
1717 : }
1718 : }
1719 :
1720 : /* We have to make sure that any param to a bind(c) routine does
1721 : not have the allocatable, pointer, or optional attributes,
1722 : according to J3/04-007, section 5.1. */
1723 16318 : if (sym->attr.allocatable == 1
1724 16717 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1725 : "ALLOCATABLE attribute in procedure %qs "
1726 : "with BIND(C)", sym->name,
1727 : &(sym->declared_at),
1728 399 : sym->ns->proc_name->name))
1729 : retval = false;
1730 :
1731 16318 : if (sym->attr.pointer == 1
1732 16956 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1733 : "POINTER attribute in procedure %qs "
1734 : "with BIND(C)", sym->name,
1735 : &(sym->declared_at),
1736 638 : sym->ns->proc_name->name))
1737 : retval = false;
1738 :
1739 16318 : if (sym->attr.optional == 1 && sym->attr.value)
1740 : {
1741 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1742 : "and the VALUE attribute because procedure %qs "
1743 : "is BIND(C)", sym->name, &(sym->declared_at),
1744 9 : sym->ns->proc_name->name);
1745 9 : retval = false;
1746 : }
1747 16309 : else if (sym->attr.optional == 1
1748 17253 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1749 : "at %L with OPTIONAL attribute in "
1750 : "procedure %qs which is BIND(C)",
1751 : sym->name, &(sym->declared_at),
1752 944 : sym->ns->proc_name->name))
1753 : retval = false;
1754 :
1755 : /* Make sure that if it has the dimension attribute, that it is
1756 : either assumed size or explicit shape. Deferred shape is already
1757 : covered by the pointer/allocatable attribute. */
1758 5399 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1759 17648 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1760 : "at %L as dummy argument to the BIND(C) "
1761 : "procedure %qs at %L", sym->name,
1762 : &(sym->declared_at),
1763 : sym->ns->proc_name->name,
1764 1330 : &(sym->ns->proc_name->declared_at)))
1765 : retval = false;
1766 : }
1767 : }
1768 :
1769 : return retval;
1770 : }
1771 :
1772 :
1773 :
1774 : /* Function called by variable_decl() that adds a name to the symbol table. */
1775 :
1776 : static bool
1777 257289 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1778 : gfc_array_spec **as, locus *var_locus)
1779 : {
1780 257289 : symbol_attribute attr;
1781 257289 : gfc_symbol *sym;
1782 257289 : int upper;
1783 257289 : gfc_symtree *st, *host_st = NULL;
1784 :
1785 : /* Symbols in a submodule are host associated from the parent module or
1786 : submodules. Therefore, they can be overridden by declarations in the
1787 : submodule scope. Deal with this by attaching the existing symbol to
1788 : a new symtree and recycling the old symtree with a new symbol... */
1789 257289 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1790 257289 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1791 3 : && gfc_current_ns->parent)
1792 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1793 :
1794 257289 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1795 12 : && st->n.sym != NULL
1796 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1797 : {
1798 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1799 12 : s->n.sym = st->n.sym;
1800 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1801 :
1802 12 : st->n.sym = sym;
1803 12 : sym->refs++;
1804 12 : gfc_set_sym_referenced (sym);
1805 12 : }
1806 : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1807 : current scope are not violated by local redeclarations. Note that there is
1808 : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1809 : only set for these standards. */
1810 257277 : else if (host_st && host_st->n.sym
1811 2 : && host_st->n.sym != gfc_current_ns->proc_name
1812 2 : && !(st && st->n.sym
1813 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1814 : {
1815 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1816 : "statement and must not be re-declared", name, var_locus,
1817 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1818 2 : return false;
1819 : }
1820 : /* ...Otherwise generate a new symtree and new symbol. */
1821 257275 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1822 : return false;
1823 :
1824 : /* Check if the name has already been defined as a type. The
1825 : first letter of the symtree will be in upper case then. Of
1826 : course, this is only necessary if the upper case letter is
1827 : actually different. */
1828 :
1829 257287 : upper = TOUPPER(name[0]);
1830 257287 : if (upper != name[0])
1831 : {
1832 256649 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1833 256649 : gfc_symtree *st;
1834 :
1835 256649 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1836 256649 : strcpy (u_name, name);
1837 256649 : u_name[0] = upper;
1838 :
1839 256649 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1840 :
1841 : /* STRUCTURE types can alias symbol names */
1842 256649 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1843 : {
1844 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1845 : &st->n.sym->declared_at);
1846 1 : return false;
1847 : }
1848 : }
1849 :
1850 : /* Start updating the symbol table. Add basic type attribute if present. */
1851 257286 : if (current_ts.type != BT_UNKNOWN
1852 257286 : && (sym->attr.implicit_type == 0
1853 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1854 514390 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1855 : {
1856 : /* Duplicate-type rejection can leave a fresh CHARACTER length node on
1857 : the namespace list before it is attached to any surviving symbol.
1858 : Drop only that unattached node; shared constant charlen nodes are
1859 : already reachable from earlier declarations. PR82721. */
1860 27 : if (current_ts.type == BT_CHARACTER && cl && elem == 1)
1861 : {
1862 1 : discard_pending_charlen (cl);
1863 1 : gfc_clear_ts (¤t_ts);
1864 : }
1865 26 : else if (current_ts.type == BT_CHARACTER && cl && cl != current_ts.u.cl)
1866 0 : discard_pending_charlen (cl);
1867 27 : return false;
1868 : }
1869 :
1870 257259 : if (sym->ts.type == BT_CHARACTER)
1871 : {
1872 28575 : if (elem > 1)
1873 4083 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1874 : else
1875 24492 : sym->ts.u.cl = cl;
1876 28575 : sym->ts.deferred = cl_deferred;
1877 : }
1878 :
1879 : /* Add dimension attribute if present. */
1880 257259 : if (!gfc_set_array_spec (sym, *as, var_locus))
1881 : return false;
1882 257257 : *as = NULL;
1883 :
1884 : /* Add attribute to symbol. The copy is so that we can reset the
1885 : dimension attribute. */
1886 257257 : attr = current_attr;
1887 257257 : attr.dimension = 0;
1888 257257 : attr.codimension = 0;
1889 :
1890 257257 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1891 : return false;
1892 :
1893 : /* Finish any work that may need to be done for the binding label,
1894 : if it's a bind(c). The bind(c) attr is found before the symbol
1895 : is made, and before the symbol name (for data decls), so the
1896 : current_ts is holding the binding label, or nothing if the
1897 : name= attr wasn't given. Therefore, test here if we're dealing
1898 : with a bind(c) and make sure the binding label is set correctly. */
1899 257243 : if (sym->attr.is_bind_c == 1)
1900 : {
1901 1300 : if (!sym->binding_label)
1902 : {
1903 : /* Set the binding label and verify that if a NAME= was specified
1904 : then only one identifier was in the entity-decl-list. */
1905 136 : if (!set_binding_label (&sym->binding_label, sym->name,
1906 : num_idents_on_line))
1907 : return false;
1908 : }
1909 : }
1910 :
1911 : /* See if we know we're in a common block, and if it's a bind(c)
1912 : common then we need to make sure we're an interoperable type. */
1913 257241 : if (sym->attr.in_common == 1)
1914 : {
1915 : /* Test the common block object. */
1916 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1917 6 : && sym->ts.is_c_interop != 1)
1918 : {
1919 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1920 : "must be declared with a C interoperable "
1921 : "kind since common block %qs is BIND(C)",
1922 : sym->name, sym->common_block->name,
1923 0 : sym->common_block->name);
1924 0 : gfc_clear_error ();
1925 : }
1926 : }
1927 :
1928 257241 : sym->attr.implied_index = 0;
1929 :
1930 : /* Use the parameter expressions for a parameterized derived type. */
1931 257241 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1932 36182 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1933 1055 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1934 :
1935 257241 : if (sym->ts.type == BT_CLASS)
1936 10857 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1937 :
1938 : return true;
1939 : }
1940 :
1941 :
1942 : /* Set character constant to the given length. The constant will be padded or
1943 : truncated. If we're inside an array constructor without a typespec, we
1944 : additionally check that all elements have the same length; check_len -1
1945 : means no checking. */
1946 :
1947 : void
1948 14019 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1949 : gfc_charlen_t check_len)
1950 : {
1951 14019 : gfc_char_t *s;
1952 14019 : gfc_charlen_t slen;
1953 :
1954 14019 : if (expr->ts.type != BT_CHARACTER)
1955 : return;
1956 :
1957 14017 : if (expr->expr_type != EXPR_CONSTANT)
1958 : {
1959 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1960 1 : return;
1961 : }
1962 :
1963 14016 : slen = expr->value.character.length;
1964 14016 : if (len != slen)
1965 : {
1966 2141 : s = gfc_get_wide_string (len + 1);
1967 2141 : memcpy (s, expr->value.character.string,
1968 2141 : MIN (len, slen) * sizeof (gfc_char_t));
1969 2141 : if (len > slen)
1970 1850 : gfc_wide_memset (&s[slen], ' ', len - slen);
1971 :
1972 2141 : if (warn_character_truncation && slen > len)
1973 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1974 : "CHARACTER expression at %L is being truncated "
1975 : "(%ld/%ld)", &expr->where,
1976 : (long) slen, (long) len);
1977 :
1978 : /* Apply the standard by 'hand' otherwise it gets cleared for
1979 : initializers. */
1980 2141 : if (check_len != -1 && slen != check_len)
1981 : {
1982 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
1983 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
1984 : "at %L must have the same length (%ld/%ld)",
1985 : &expr->where, (long) slen,
1986 : (long) check_len);
1987 : else
1988 3 : gfc_notify_std (GFC_STD_LEGACY,
1989 : "The CHARACTER elements of the array constructor "
1990 : "at %L must have the same length (%ld/%ld)",
1991 : &expr->where, (long) slen,
1992 : (long) check_len);
1993 : }
1994 :
1995 2141 : s[len] = '\0';
1996 2141 : free (expr->value.character.string);
1997 2141 : expr->value.character.string = s;
1998 2141 : expr->value.character.length = len;
1999 : /* If explicit representation was given, clear it
2000 : as it is no longer needed after padding. */
2001 2141 : if (expr->representation.length)
2002 : {
2003 45 : expr->representation.length = 0;
2004 45 : free (expr->representation.string);
2005 45 : expr->representation.string = NULL;
2006 : }
2007 : }
2008 : }
2009 :
2010 :
2011 : /* Function to create and update the enumerator history
2012 : using the information passed as arguments.
2013 : Pointer "max_enum" is also updated, to point to
2014 : enum history node containing largest initializer.
2015 :
2016 : SYM points to the symbol node of enumerator.
2017 : INIT points to its enumerator value. */
2018 :
2019 : static void
2020 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
2021 : {
2022 543 : enumerator_history *new_enum_history;
2023 543 : gcc_assert (sym != NULL && init != NULL);
2024 :
2025 543 : new_enum_history = XCNEW (enumerator_history);
2026 :
2027 543 : new_enum_history->sym = sym;
2028 543 : new_enum_history->initializer = init;
2029 543 : new_enum_history->next = NULL;
2030 :
2031 543 : if (enum_history == NULL)
2032 : {
2033 160 : enum_history = new_enum_history;
2034 160 : max_enum = enum_history;
2035 : }
2036 : else
2037 : {
2038 383 : new_enum_history->next = enum_history;
2039 383 : enum_history = new_enum_history;
2040 :
2041 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2042 383 : new_enum_history->initializer->value.integer) < 0)
2043 381 : max_enum = new_enum_history;
2044 : }
2045 543 : }
2046 :
2047 :
2048 : /* Function to free enum kind history. */
2049 :
2050 : void
2051 175 : gfc_free_enum_history (void)
2052 : {
2053 175 : enumerator_history *current = enum_history;
2054 175 : enumerator_history *next;
2055 :
2056 718 : while (current != NULL)
2057 : {
2058 543 : next = current->next;
2059 543 : free (current);
2060 543 : current = next;
2061 : }
2062 175 : max_enum = NULL;
2063 175 : enum_history = NULL;
2064 175 : }
2065 :
2066 :
2067 : /* Function to fix initializer character length if the length of the
2068 : symbol or component is constant. */
2069 :
2070 : static bool
2071 2722 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2072 : {
2073 2722 : if (!gfc_specification_expr (ts->u.cl->length))
2074 : return false;
2075 :
2076 2722 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2077 :
2078 : /* resolve_charlen will complain later on if the length
2079 : is too large. Just skip the initialization in that case. */
2080 2722 : if (mpz_cmp (ts->u.cl->length->value.integer,
2081 2722 : gfc_integer_kinds[k].huge) <= 0)
2082 : {
2083 2721 : HOST_WIDE_INT len
2084 2721 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2085 :
2086 2721 : if (init->expr_type == EXPR_CONSTANT)
2087 1987 : gfc_set_constant_character_len (len, init, -1);
2088 734 : else if (init->expr_type == EXPR_ARRAY)
2089 : {
2090 733 : gfc_constructor *cons;
2091 :
2092 : /* Build a new charlen to prevent simplification from
2093 : deleting the length before it is resolved. */
2094 733 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2095 733 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2096 733 : cons = gfc_constructor_first (init->value.constructor);
2097 4971 : for (; cons; cons = gfc_constructor_next (cons))
2098 3505 : gfc_set_constant_character_len (len, cons->expr, -1);
2099 : }
2100 : }
2101 :
2102 : return true;
2103 : }
2104 :
2105 :
2106 : /* Function called by variable_decl() that adds an initialization
2107 : expression to a symbol. */
2108 :
2109 : static bool
2110 264725 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
2111 : {
2112 264725 : symbol_attribute attr;
2113 264725 : gfc_symbol *sym;
2114 264725 : gfc_expr *init;
2115 :
2116 264725 : init = *initp;
2117 264725 : if (find_special (name, &sym, false))
2118 : return false;
2119 :
2120 264725 : attr = sym->attr;
2121 :
2122 : /* If this symbol is confirming an implicit parameter type,
2123 : then an initialization expression is not allowed. */
2124 264725 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2125 : {
2126 1 : if (*initp != NULL)
2127 : {
2128 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2129 : sym->name);
2130 0 : return false;
2131 : }
2132 : else
2133 : return true;
2134 : }
2135 :
2136 264724 : if (init == NULL)
2137 : {
2138 : /* An initializer is required for PARAMETER declarations. */
2139 232750 : if (attr.flavor == FL_PARAMETER)
2140 : {
2141 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2142 1 : return false;
2143 : }
2144 : }
2145 : else
2146 : {
2147 : /* If a variable appears in a DATA block, it cannot have an
2148 : initializer. */
2149 31974 : if (sym->attr.data)
2150 : {
2151 0 : gfc_error ("Variable %qs at %C with an initializer already "
2152 : "appears in a DATA statement", sym->name);
2153 0 : return false;
2154 : }
2155 :
2156 : /* Check if the assignment can happen. This has to be put off
2157 : until later for derived type variables and procedure pointers. */
2158 30832 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2159 30809 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2160 30759 : && !sym->attr.proc_pointer
2161 62647 : && !gfc_check_assign_symbol (sym, NULL, init))
2162 : return false;
2163 :
2164 31943 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2165 3408 : && init->ts.type == BT_CHARACTER)
2166 : {
2167 : /* Update symbol character length according initializer. */
2168 3244 : if (!gfc_check_assign_symbol (sym, NULL, init))
2169 : return false;
2170 :
2171 3244 : if (sym->ts.u.cl->length == NULL)
2172 : {
2173 838 : gfc_charlen_t clen;
2174 : /* If there are multiple CHARACTER variables declared on the
2175 : same line, we don't want them to share the same length. */
2176 838 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2177 :
2178 838 : if (sym->attr.flavor == FL_PARAMETER)
2179 : {
2180 829 : if (init->expr_type == EXPR_CONSTANT)
2181 : {
2182 546 : clen = init->value.character.length;
2183 546 : sym->ts.u.cl->length
2184 546 : = gfc_get_int_expr (gfc_charlen_int_kind,
2185 : NULL, clen);
2186 : }
2187 283 : else if (init->expr_type == EXPR_ARRAY)
2188 : {
2189 283 : if (init->ts.u.cl && init->ts.u.cl->length)
2190 : {
2191 271 : const gfc_expr *length = init->ts.u.cl->length;
2192 271 : if (length->expr_type != EXPR_CONSTANT)
2193 : {
2194 1 : gfc_error ("Cannot initialize parameter array "
2195 : "at %L "
2196 : "with variable length elements",
2197 : &sym->declared_at);
2198 1 : return false;
2199 : }
2200 270 : clen = mpz_get_si (length->value.integer);
2201 270 : }
2202 12 : else if (init->value.constructor)
2203 : {
2204 12 : gfc_constructor *c;
2205 12 : c = gfc_constructor_first (init->value.constructor);
2206 12 : clen = c->expr->value.character.length;
2207 : }
2208 : else
2209 0 : gcc_unreachable ();
2210 282 : sym->ts.u.cl->length
2211 282 : = gfc_get_int_expr (gfc_charlen_int_kind,
2212 : NULL, clen);
2213 : }
2214 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2215 0 : sym->ts.u.cl->length =
2216 0 : gfc_copy_expr (init->ts.u.cl->length);
2217 : }
2218 : }
2219 : /* Update initializer character length according to symbol. */
2220 2406 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2221 2406 : && !fix_initializer_charlen (&sym->ts, init))
2222 : return false;
2223 : }
2224 :
2225 31942 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2226 3766 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2227 : {
2228 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2229 : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2230 3 : return false;
2231 : }
2232 :
2233 : /* If sym is implied-shape, set its upper bounds from init. */
2234 31939 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2235 3763 : && sym->as->type == AS_IMPLIED_SHAPE)
2236 : {
2237 1038 : int dim;
2238 :
2239 1038 : if (init->rank == 0)
2240 : {
2241 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2242 : " with scalar", &sym->declared_at);
2243 1 : return false;
2244 : }
2245 :
2246 : /* The shape may be NULL for EXPR_ARRAY, set it. */
2247 1037 : if (init->shape == NULL)
2248 : {
2249 5 : if (init->expr_type != EXPR_ARRAY)
2250 : {
2251 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2252 2 : return false;
2253 : }
2254 :
2255 3 : init->shape = gfc_get_shape (1);
2256 3 : if (!gfc_array_size (init, &init->shape[0]))
2257 : {
2258 1 : gfc_error ("Cannot determine shape of initializer at %L",
2259 : &init->where);
2260 1 : free (init->shape);
2261 1 : init->shape = NULL;
2262 1 : return false;
2263 : }
2264 : }
2265 :
2266 2169 : for (dim = 0; dim < sym->as->rank; ++dim)
2267 : {
2268 1136 : int k;
2269 1136 : gfc_expr *e, *lower;
2270 :
2271 1136 : lower = sym->as->lower[dim];
2272 :
2273 : /* If the lower bound is an array element from another
2274 : parameterized array, then it is marked with EXPR_VARIABLE and
2275 : is an initialization expression. Try to reduce it. */
2276 1136 : if (lower->expr_type == EXPR_VARIABLE)
2277 7 : gfc_reduce_init_expr (lower);
2278 :
2279 1136 : if (lower->expr_type == EXPR_CONSTANT)
2280 : {
2281 : /* All dimensions must be without upper bound. */
2282 1135 : gcc_assert (!sym->as->upper[dim]);
2283 :
2284 1135 : k = lower->ts.kind;
2285 1135 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2286 1135 : mpz_add (e->value.integer, lower->value.integer,
2287 1135 : init->shape[dim]);
2288 1135 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2289 1135 : sym->as->upper[dim] = e;
2290 : }
2291 : else
2292 : {
2293 1 : gfc_error ("Non-constant lower bound in implied-shape"
2294 : " declaration at %L", &lower->where);
2295 1 : return false;
2296 : }
2297 : }
2298 :
2299 1033 : sym->as->type = AS_EXPLICIT;
2300 : }
2301 :
2302 : /* Ensure that explicit bounds are simplified. */
2303 31934 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2304 3758 : && sym->as->type == AS_EXPLICIT)
2305 : {
2306 8348 : for (int dim = 0; dim < sym->as->rank; ++dim)
2307 : {
2308 4602 : gfc_expr *e;
2309 :
2310 4602 : e = sym->as->lower[dim];
2311 4602 : if (e->expr_type != EXPR_CONSTANT)
2312 12 : gfc_reduce_init_expr (e);
2313 :
2314 4602 : e = sym->as->upper[dim];
2315 4602 : if (e->expr_type != EXPR_CONSTANT)
2316 106 : gfc_reduce_init_expr (e);
2317 : }
2318 : }
2319 :
2320 : /* Need to check if the expression we initialized this
2321 : to was one of the iso_c_binding named constants. If so,
2322 : and we're a parameter (constant), let it be iso_c.
2323 : For example:
2324 : integer(c_int), parameter :: my_int = c_int
2325 : integer(my_int) :: my_int_2
2326 : If we mark my_int as iso_c (since we can see it's value
2327 : is equal to one of the named constants), then my_int_2
2328 : will be considered C interoperable. */
2329 31934 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2330 : {
2331 27388 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2332 27388 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2333 : /* attr bits needed for module files. */
2334 27388 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2335 27388 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2336 27388 : if (init->ts.is_iso_c)
2337 113 : sym->ts.f90_type = init->ts.f90_type;
2338 : }
2339 :
2340 : /* Catch the case: type(t), parameter :: x = z'1'. */
2341 31934 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2342 : {
2343 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2344 : "literal constant", name, &sym->declared_at);
2345 1 : return false;
2346 : }
2347 :
2348 : /* Add initializer. Make sure we keep the ranks sane. */
2349 31933 : if (sym->attr.dimension && init->rank == 0)
2350 : {
2351 1238 : mpz_t size;
2352 1238 : gfc_expr *array;
2353 1238 : int n;
2354 1238 : if (sym->attr.flavor == FL_PARAMETER
2355 438 : && gfc_is_constant_expr (init)
2356 438 : && (init->expr_type == EXPR_CONSTANT
2357 31 : || init->expr_type == EXPR_STRUCTURE)
2358 1676 : && spec_size (sym->as, &size))
2359 : {
2360 434 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2361 : &init->where);
2362 434 : if (init->ts.type == BT_DERIVED)
2363 31 : array->ts.u.derived = init->ts.u.derived;
2364 67549 : for (n = 0; n < (int)mpz_get_si (size); n++)
2365 133937 : gfc_constructor_append_expr (&array->value.constructor,
2366 : n == 0
2367 : ? init
2368 66822 : : gfc_copy_expr (init),
2369 : &init->where);
2370 :
2371 434 : array->shape = gfc_get_shape (sym->as->rank);
2372 994 : for (n = 0; n < sym->as->rank; n++)
2373 560 : spec_dimen_size (sym->as, n, &array->shape[n]);
2374 :
2375 434 : init = array;
2376 434 : mpz_clear (size);
2377 : }
2378 1238 : init->rank = sym->as->rank;
2379 1238 : init->corank = sym->as->corank;
2380 : }
2381 :
2382 31933 : sym->value = init;
2383 31933 : if (sym->attr.save == SAVE_NONE)
2384 27478 : sym->attr.save = SAVE_IMPLICIT;
2385 31933 : *initp = NULL;
2386 : }
2387 :
2388 : return true;
2389 : }
2390 :
2391 :
2392 : /* Function called by variable_decl() that adds a name to a structure
2393 : being built. */
2394 :
2395 : static bool
2396 17786 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2397 : gfc_array_spec **as)
2398 : {
2399 17786 : gfc_state_data *s;
2400 17786 : gfc_component *c;
2401 :
2402 : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2403 : constructing, it must have the pointer attribute. */
2404 17786 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2405 3365 : && current_ts.u.derived == gfc_current_block ()
2406 267 : && current_attr.pointer == 0)
2407 : {
2408 106 : if (current_attr.allocatable
2409 106 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2410 : "must have the POINTER attribute"))
2411 : {
2412 : return false;
2413 : }
2414 105 : else if (current_attr.allocatable == 0)
2415 : {
2416 0 : gfc_error ("Component at %C must have the POINTER attribute");
2417 0 : return false;
2418 : }
2419 : }
2420 :
2421 : /* F03:C437. */
2422 17785 : if (current_ts.type == BT_CLASS
2423 830 : && !(current_attr.pointer || current_attr.allocatable))
2424 : {
2425 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2426 : "or pointer", name);
2427 5 : return false;
2428 : }
2429 :
2430 17780 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2431 : {
2432 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2433 : {
2434 0 : gfc_error ("Array component of structure at %C must have explicit "
2435 : "or deferred shape");
2436 0 : return false;
2437 : }
2438 : }
2439 :
2440 : /* If we are in a nested union/map definition, gfc_add_component will not
2441 : properly find repeated components because:
2442 : (i) gfc_add_component does a flat search, where components of unions
2443 : and maps are implicity chained so nested components may conflict.
2444 : (ii) Unions and maps are not linked as components of their parent
2445 : structures until after they are parsed.
2446 : For (i) we use gfc_find_component which searches recursively, and for (ii)
2447 : we search each block directly from the parse stack until we find the top
2448 : level structure. */
2449 :
2450 17780 : s = gfc_state_stack;
2451 17780 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2452 : {
2453 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2454 : {
2455 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2456 1434 : if (c != NULL)
2457 : {
2458 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2459 : name, &c->loc);
2460 0 : return false;
2461 : }
2462 : /* Break after we've searched the entire chain. */
2463 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2464 : break;
2465 1000 : s = s->previous;
2466 : }
2467 : }
2468 :
2469 17780 : if (!gfc_add_component (gfc_current_block(), name, &c))
2470 : return false;
2471 :
2472 17774 : c->ts = current_ts;
2473 17774 : if (c->ts.type == BT_CHARACTER)
2474 1926 : c->ts.u.cl = cl;
2475 :
2476 17774 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2477 14415 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2478 2106 : && saved_kind_expr != NULL)
2479 194 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2480 :
2481 17774 : c->attr = current_attr;
2482 :
2483 17774 : c->initializer = *init;
2484 17774 : *init = NULL;
2485 :
2486 : /* Update initializer character length according to component. */
2487 1926 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2488 1526 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2489 1462 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2490 18093 : && !fix_initializer_charlen (&c->ts, c->initializer))
2491 : return false;
2492 :
2493 17774 : c->as = *as;
2494 17774 : if (c->as != NULL)
2495 : {
2496 4660 : if (c->as->corank)
2497 107 : c->attr.codimension = 1;
2498 4660 : if (c->as->rank)
2499 4585 : c->attr.dimension = 1;
2500 : }
2501 17774 : *as = NULL;
2502 :
2503 17774 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2504 :
2505 : /* Check array components. */
2506 17774 : if (!c->attr.dimension)
2507 13189 : goto scalar;
2508 :
2509 4585 : if (c->attr.pointer)
2510 : {
2511 682 : if (c->as->type != AS_DEFERRED)
2512 : {
2513 5 : gfc_error ("Pointer array component of structure at %C must have a "
2514 : "deferred shape");
2515 5 : return false;
2516 : }
2517 : }
2518 3903 : else if (c->attr.allocatable)
2519 : {
2520 2305 : const char *err = G_("Allocatable component of structure at %C must have "
2521 : "a deferred shape");
2522 2305 : if (c->as->type != AS_DEFERRED)
2523 : {
2524 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2525 : {
2526 : /* Issue an immediate error and allow this component to pass for
2527 : the sake of clean error recovery. Set the error flag for the
2528 : containing derived type so that finalizers are not built. */
2529 4 : gfc_error_now (err);
2530 4 : s->sym->error = 1;
2531 4 : c->as->type = AS_DEFERRED;
2532 : }
2533 : else
2534 : {
2535 10 : gfc_error (err);
2536 10 : return false;
2537 : }
2538 : }
2539 : }
2540 : else
2541 : {
2542 1598 : if (c->as->type != AS_EXPLICIT)
2543 : {
2544 7 : gfc_error ("Array component of structure at %C must have an "
2545 : "explicit shape");
2546 7 : return false;
2547 : }
2548 : }
2549 :
2550 1591 : scalar:
2551 17752 : if (c->ts.type == BT_CLASS)
2552 822 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2553 :
2554 16930 : if (c->attr.pdt_kind || c->attr.pdt_len)
2555 : {
2556 582 : gfc_symbol *sym;
2557 582 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2558 : 0, &sym);
2559 582 : if (sym == NULL)
2560 : {
2561 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2562 : "in the type parameter name list at %L",
2563 0 : c->name, &gfc_current_block ()->declared_at);
2564 0 : return false;
2565 : }
2566 582 : sym->ts = c->ts;
2567 582 : sym->attr.pdt_kind = c->attr.pdt_kind;
2568 582 : sym->attr.pdt_len = c->attr.pdt_len;
2569 582 : if (c->initializer)
2570 232 : sym->value = gfc_copy_expr (c->initializer);
2571 582 : sym->attr.flavor = FL_VARIABLE;
2572 : }
2573 :
2574 16930 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2575 2534 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2576 129 : && decl_type_param_list)
2577 129 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2578 :
2579 : return true;
2580 : }
2581 :
2582 :
2583 : /* Match a 'NULL()', and possibly take care of some side effects. */
2584 :
2585 : match
2586 1681 : gfc_match_null (gfc_expr **result)
2587 : {
2588 1681 : gfc_symbol *sym;
2589 1681 : match m, m2 = MATCH_NO;
2590 :
2591 1681 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2592 : return MATCH_ERROR;
2593 :
2594 1681 : if (m == MATCH_NO)
2595 : {
2596 505 : locus old_loc;
2597 505 : char name[GFC_MAX_SYMBOL_LEN + 1];
2598 :
2599 505 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2600 499 : return m2;
2601 :
2602 6 : old_loc = gfc_current_locus;
2603 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2604 : return MATCH_ERROR;
2605 6 : if (m2 != MATCH_YES
2606 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2607 : return MATCH_ERROR;
2608 6 : if (m2 == MATCH_NO)
2609 : {
2610 0 : gfc_current_locus = old_loc;
2611 0 : return MATCH_NO;
2612 : }
2613 : }
2614 :
2615 : /* The NULL symbol now has to be/become an intrinsic function. */
2616 1182 : if (gfc_get_symbol ("null", NULL, &sym))
2617 : {
2618 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2619 0 : return MATCH_ERROR;
2620 : }
2621 :
2622 1182 : gfc_intrinsic_symbol (sym);
2623 :
2624 1182 : if (sym->attr.proc != PROC_INTRINSIC
2625 830 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2626 2011 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2627 829 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2628 0 : return MATCH_ERROR;
2629 :
2630 1182 : *result = gfc_get_null_expr (&gfc_current_locus);
2631 :
2632 : /* Invalid per F2008, C512. */
2633 1182 : if (m2 == MATCH_YES)
2634 : {
2635 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2636 6 : return MATCH_ERROR;
2637 : }
2638 :
2639 : return MATCH_YES;
2640 : }
2641 :
2642 :
2643 : /* Match the initialization expr for a data pointer or procedure pointer. */
2644 :
2645 : static match
2646 1345 : match_pointer_init (gfc_expr **init, int procptr)
2647 : {
2648 1345 : match m;
2649 :
2650 1345 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2651 : {
2652 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2653 : "a PURE procedure");
2654 1 : return MATCH_ERROR;
2655 : }
2656 1344 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2657 :
2658 : /* Match NULL() initialization. */
2659 1344 : m = gfc_match_null (init);
2660 1344 : if (m != MATCH_NO)
2661 : return m;
2662 :
2663 : /* Match non-NULL initialization. */
2664 170 : gfc_matching_ptr_assignment = !procptr;
2665 170 : gfc_matching_procptr_assignment = procptr;
2666 170 : m = gfc_match_rvalue (init);
2667 170 : gfc_matching_ptr_assignment = 0;
2668 170 : gfc_matching_procptr_assignment = 0;
2669 170 : if (m == MATCH_ERROR)
2670 : return MATCH_ERROR;
2671 169 : else if (m == MATCH_NO)
2672 : {
2673 2 : gfc_error ("Error in pointer initialization at %C");
2674 2 : return MATCH_ERROR;
2675 : }
2676 :
2677 167 : if (!procptr && !gfc_resolve_expr (*init))
2678 : return MATCH_ERROR;
2679 :
2680 166 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2681 : "initialization at %C"))
2682 : return MATCH_ERROR;
2683 :
2684 : return MATCH_YES;
2685 : }
2686 :
2687 :
2688 : static bool
2689 284824 : check_function_name (char *name)
2690 : {
2691 : /* In functions that have a RESULT variable defined, the function name always
2692 : refers to function calls. Therefore, the name is not allowed to appear in
2693 : specification statements. When checking this, be careful about
2694 : 'hidden' procedure pointer results ('ppr@'). */
2695 :
2696 284824 : if (gfc_current_state () == COMP_FUNCTION)
2697 : {
2698 45419 : gfc_symbol *block = gfc_current_block ();
2699 45419 : if (block && block->result && block->result != block
2700 15049 : && strcmp (block->result->name, "ppr@") != 0
2701 14990 : && strcmp (block->name, name) == 0)
2702 : {
2703 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2704 : "from appearing in a specification statement",
2705 : block->result->name, &block->result->declared_at, name);
2706 9 : return false;
2707 : }
2708 : }
2709 :
2710 : return true;
2711 : }
2712 :
2713 :
2714 : /* Match a variable name with an optional initializer. When this
2715 : subroutine is called, a variable is expected to be parsed next.
2716 : Depending on what is happening at the moment, updates either the
2717 : symbol table or the current interface. */
2718 :
2719 : static match
2720 274758 : variable_decl (int elem)
2721 : {
2722 274758 : char name[GFC_MAX_SYMBOL_LEN + 1];
2723 274758 : static unsigned int fill_id = 0;
2724 274758 : gfc_expr *initializer, *char_len;
2725 274758 : gfc_array_spec *as;
2726 274758 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2727 274758 : gfc_charlen *cl;
2728 274758 : bool cl_deferred;
2729 274758 : locus var_locus;
2730 274758 : match m;
2731 274758 : bool t;
2732 274758 : gfc_symbol *sym;
2733 274758 : char c;
2734 :
2735 274758 : initializer = NULL;
2736 274758 : as = NULL;
2737 274758 : cp_as = NULL;
2738 :
2739 : /* When we get here, we've just matched a list of attributes and
2740 : maybe a type and a double colon. The next thing we expect to see
2741 : is the name of the symbol. */
2742 :
2743 : /* If we are parsing a structure with legacy support, we allow the symbol
2744 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2745 274758 : m = MATCH_NO;
2746 274758 : gfc_gobble_whitespace ();
2747 274758 : var_locus = gfc_current_locus;
2748 274758 : c = gfc_peek_ascii_char ();
2749 274758 : if (c == '%')
2750 : {
2751 12 : gfc_next_ascii_char (); /* Burn % character. */
2752 12 : m = gfc_match ("fill");
2753 12 : if (m == MATCH_YES)
2754 : {
2755 11 : if (gfc_current_state () != COMP_STRUCTURE)
2756 : {
2757 2 : if (flag_dec_structure)
2758 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2759 : else
2760 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2761 : "%<-fdec-structure%>", "%FILL");
2762 2 : m = MATCH_ERROR;
2763 2 : goto cleanup;
2764 : }
2765 :
2766 9 : if (attr_seen)
2767 : {
2768 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2769 1 : m = MATCH_ERROR;
2770 1 : goto cleanup;
2771 : }
2772 :
2773 : /* %FILL components are given invalid fortran names. */
2774 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2775 : }
2776 : else
2777 : {
2778 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2779 1 : return MATCH_ERROR;
2780 : }
2781 : }
2782 : else
2783 : {
2784 274746 : m = gfc_match_name (name);
2785 274745 : if (m != MATCH_YES)
2786 10 : goto cleanup;
2787 : }
2788 :
2789 : /* Now we could see the optional array spec. or character length. */
2790 274743 : m = gfc_match_array_spec (&as, true, true);
2791 274742 : if (m == MATCH_ERROR)
2792 57 : goto cleanup;
2793 :
2794 274685 : if (m == MATCH_NO)
2795 214547 : as = gfc_copy_array_spec (current_as);
2796 60138 : else if (current_as
2797 60138 : && !merge_array_spec (current_as, as, true))
2798 : {
2799 4 : m = MATCH_ERROR;
2800 4 : goto cleanup;
2801 : }
2802 :
2803 274681 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2804 : &gfc_current_locus);
2805 274681 : if (flag_cray_pointer)
2806 3063 : cp_as = gfc_copy_array_spec (as);
2807 :
2808 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2809 : determine (and check) whether it can be implied-shape. If it
2810 : was parsed as assumed-size, change it because PARAMETERs cannot
2811 : be assumed-size.
2812 :
2813 : An explicit-shape-array cannot appear under several conditions.
2814 : That check is done here as well. */
2815 274681 : if (as)
2816 : {
2817 82645 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2818 : {
2819 2 : m = MATCH_ERROR;
2820 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2821 : name, &var_locus);
2822 2 : goto cleanup;
2823 : }
2824 :
2825 82643 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2826 6459 : && current_attr.flavor == FL_PARAMETER)
2827 990 : as->type = AS_IMPLIED_SHAPE;
2828 :
2829 82643 : if (as->type == AS_IMPLIED_SHAPE
2830 82643 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2831 : &var_locus))
2832 : {
2833 1 : m = MATCH_ERROR;
2834 1 : goto cleanup;
2835 : }
2836 :
2837 82642 : gfc_seen_div0 = false;
2838 :
2839 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2840 : constant expressions shall appear only in a subprogram, derived
2841 : type definition, BLOCK construct, or interface body. */
2842 82642 : if (as->type == AS_EXPLICIT
2843 41355 : && gfc_current_state () != COMP_BLOCK
2844 : && gfc_current_state () != COMP_DERIVED
2845 : && gfc_current_state () != COMP_FUNCTION
2846 : && gfc_current_state () != COMP_INTERFACE
2847 : && gfc_current_state () != COMP_SUBROUTINE)
2848 : {
2849 : gfc_expr *e;
2850 49356 : bool not_constant = false;
2851 :
2852 49356 : for (int i = 0; i < as->rank; i++)
2853 : {
2854 28126 : e = gfc_copy_expr (as->lower[i]);
2855 28126 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2856 : {
2857 0 : m = MATCH_ERROR;
2858 0 : goto cleanup;
2859 : }
2860 :
2861 28126 : gfc_simplify_expr (e, 0);
2862 28126 : if (e && (e->expr_type != EXPR_CONSTANT))
2863 : {
2864 : not_constant = true;
2865 : break;
2866 : }
2867 28126 : gfc_free_expr (e);
2868 :
2869 28126 : e = gfc_copy_expr (as->upper[i]);
2870 28126 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2871 : {
2872 4 : m = MATCH_ERROR;
2873 4 : goto cleanup;
2874 : }
2875 :
2876 28122 : gfc_simplify_expr (e, 0);
2877 28122 : if (e && (e->expr_type != EXPR_CONSTANT))
2878 : {
2879 : not_constant = true;
2880 : break;
2881 : }
2882 28109 : gfc_free_expr (e);
2883 : }
2884 :
2885 21243 : if (not_constant && e->ts.type != BT_INTEGER)
2886 : {
2887 4 : gfc_error ("Explicit array shape at %C must be constant of "
2888 : "INTEGER type and not %s type",
2889 : gfc_basic_typename (e->ts.type));
2890 4 : m = MATCH_ERROR;
2891 4 : goto cleanup;
2892 : }
2893 9 : if (not_constant)
2894 : {
2895 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2896 9 : m = MATCH_ERROR;
2897 9 : goto cleanup;
2898 : }
2899 : }
2900 82625 : if (as->type == AS_EXPLICIT)
2901 : {
2902 99104 : for (int i = 0; i < as->rank; i++)
2903 : {
2904 57766 : gfc_expr *e, *n;
2905 57766 : e = as->lower[i];
2906 57766 : if (e->expr_type != EXPR_CONSTANT)
2907 : {
2908 452 : n = gfc_copy_expr (e);
2909 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2910 : {
2911 0 : m = MATCH_ERROR;
2912 0 : goto cleanup;
2913 : }
2914 :
2915 452 : if (n->expr_type == EXPR_CONSTANT)
2916 22 : gfc_replace_expr (e, n);
2917 : else
2918 430 : gfc_free_expr (n);
2919 : }
2920 57766 : e = as->upper[i];
2921 57766 : if (e->expr_type != EXPR_CONSTANT)
2922 : {
2923 6603 : n = gfc_copy_expr (e);
2924 6603 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2925 : {
2926 0 : m = MATCH_ERROR;
2927 0 : goto cleanup;
2928 : }
2929 :
2930 6603 : if (n->expr_type == EXPR_CONSTANT)
2931 45 : gfc_replace_expr (e, n);
2932 : else
2933 6558 : gfc_free_expr (n);
2934 : }
2935 : /* For an explicit-shape spec with constant bounds, ensure
2936 : that the effective upper bound is not lower than the
2937 : respective lower bound minus one. Otherwise adjust it so
2938 : that the extent is trivially derived to be zero. */
2939 57766 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2940 57336 : && as->upper[i]->expr_type == EXPR_CONSTANT
2941 51202 : && as->lower[i]->ts.type == BT_INTEGER
2942 51202 : && as->upper[i]->ts.type == BT_INTEGER
2943 51197 : && mpz_cmp (as->upper[i]->value.integer,
2944 51197 : as->lower[i]->value.integer) < 0)
2945 1212 : mpz_sub_ui (as->upper[i]->value.integer,
2946 : as->lower[i]->value.integer, 1);
2947 : }
2948 : }
2949 : }
2950 :
2951 274661 : char_len = NULL;
2952 274661 : cl = NULL;
2953 274661 : cl_deferred = false;
2954 :
2955 274661 : if (current_ts.type == BT_CHARACTER)
2956 : {
2957 30542 : switch (match_char_length (&char_len, &cl_deferred, false))
2958 : {
2959 435 : case MATCH_YES:
2960 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2961 :
2962 435 : cl->length = char_len;
2963 435 : break;
2964 :
2965 : /* Non-constant lengths need to be copied after the first
2966 : element. Also copy assumed lengths. */
2967 30106 : case MATCH_NO:
2968 30106 : if (elem > 1
2969 3852 : && (current_ts.u.cl->length == NULL
2970 2657 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2971 : {
2972 1250 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2973 1250 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
2974 : }
2975 : else
2976 28856 : cl = current_ts.u.cl;
2977 :
2978 30106 : cl_deferred = current_ts.deferred;
2979 :
2980 30106 : break;
2981 :
2982 1 : case MATCH_ERROR:
2983 1 : goto cleanup;
2984 : }
2985 : }
2986 :
2987 : /* The dummy arguments and result of the abbreviated form of MODULE
2988 : PROCEDUREs, used in SUBMODULES should not be redefined. */
2989 274660 : if (gfc_current_ns->proc_name
2990 270164 : && gfc_current_ns->proc_name->abr_modproc_decl)
2991 : {
2992 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2993 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2994 : {
2995 2 : m = MATCH_ERROR;
2996 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
2997 : "in the corresponding interface for MODULE "
2998 : "PROCEDURE %qs", sym->name, &var_locus,
2999 2 : gfc_current_ns->proc_name->name);
3000 2 : goto cleanup;
3001 : }
3002 : }
3003 :
3004 : /* %FILL components may not have initializers. */
3005 274658 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
3006 : {
3007 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
3008 : &var_locus);
3009 1 : m = MATCH_ERROR;
3010 1 : goto cleanup;
3011 : }
3012 :
3013 : /* If this symbol has already shown up in a Cray Pointer declaration,
3014 : and this is not a component declaration,
3015 : then we want to set the type & bail out. */
3016 274657 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
3017 : {
3018 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3019 2959 : if (sym != NULL && sym->attr.cray_pointee)
3020 : {
3021 101 : m = MATCH_YES;
3022 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
3023 : {
3024 1 : m = MATCH_ERROR;
3025 1 : goto cleanup;
3026 : }
3027 :
3028 : /* Check to see if we have an array specification. */
3029 100 : if (cp_as != NULL)
3030 : {
3031 49 : if (sym->as != NULL)
3032 : {
3033 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3034 1 : gfc_free_array_spec (cp_as);
3035 1 : m = MATCH_ERROR;
3036 1 : goto cleanup;
3037 : }
3038 : else
3039 : {
3040 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3041 0 : gfc_internal_error ("Cannot set pointee array spec.");
3042 :
3043 : /* Fix the array spec. */
3044 48 : m = gfc_mod_pointee_as (sym->as);
3045 48 : if (m == MATCH_ERROR)
3046 0 : goto cleanup;
3047 : }
3048 : }
3049 99 : goto cleanup;
3050 : }
3051 : else
3052 : {
3053 2858 : gfc_free_array_spec (cp_as);
3054 : }
3055 : }
3056 :
3057 : /* Procedure pointer as function result. */
3058 274556 : if (gfc_current_state () == COMP_FUNCTION
3059 44059 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3060 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3061 7 : strcpy (name, "ppr@");
3062 :
3063 274556 : if (gfc_current_state () == COMP_FUNCTION
3064 44059 : && strcmp (name, gfc_current_block ()->name) == 0
3065 7503 : && gfc_current_block ()->result
3066 7503 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3067 16 : strcpy (name, "ppr@");
3068 :
3069 : /* OK, we've successfully matched the declaration. Now put the
3070 : symbol in the current namespace, because it might be used in the
3071 : optional initialization expression for this symbol, e.g. this is
3072 : perfectly legal:
3073 :
3074 : integer, parameter :: i = huge(i)
3075 :
3076 : This is only true for parameters or variables of a basic type.
3077 : For components of derived types, it is not true, so we don't
3078 : create a symbol for those yet. If we fail to create the symbol,
3079 : bail out. */
3080 274556 : if (!gfc_comp_struct (gfc_current_state ())
3081 256741 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3082 : {
3083 48 : m = MATCH_ERROR;
3084 48 : goto cleanup;
3085 : }
3086 :
3087 274508 : if (!check_function_name (name))
3088 : {
3089 0 : m = MATCH_ERROR;
3090 0 : goto cleanup;
3091 : }
3092 :
3093 : /* We allow old-style initializations of the form
3094 : integer i /2/, j(4) /3*3, 1/
3095 : (if no colon has been seen). These are different from data
3096 : statements in that initializers are only allowed to apply to the
3097 : variable immediately preceding, i.e.
3098 : integer i, j /1, 2/
3099 : is not allowed. Therefore we have to do some work manually, that
3100 : could otherwise be left to the matchers for DATA statements. */
3101 :
3102 274508 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3103 : {
3104 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3105 : "initialization at %C"))
3106 : return MATCH_ERROR;
3107 :
3108 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3109 : but not components of derived types. */
3110 146 : else if (gfc_current_state () == COMP_DERIVED)
3111 : {
3112 2 : gfc_error ("Invalid old style initialization for derived type "
3113 : "component at %C");
3114 2 : m = MATCH_ERROR;
3115 2 : goto cleanup;
3116 : }
3117 :
3118 : /* For structure components, read the initializer as a special
3119 : expression and let the rest of this function apply the initializer
3120 : as usual. */
3121 144 : else if (gfc_comp_struct (gfc_current_state ()))
3122 : {
3123 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3124 74 : if (m == MATCH_NO)
3125 : gfc_error ("Syntax error in old style initialization of %s at %C",
3126 : name);
3127 74 : if (m != MATCH_YES)
3128 14 : goto cleanup;
3129 : }
3130 :
3131 : /* Otherwise we treat the old style initialization just like a
3132 : DATA declaration for the current variable. */
3133 : else
3134 70 : return match_old_style_init (name);
3135 : }
3136 :
3137 : /* The double colon must be present in order to have initializers.
3138 : Otherwise the statement is ambiguous with an assignment statement. */
3139 274422 : if (colon_seen)
3140 : {
3141 229437 : if (gfc_match (" =>") == MATCH_YES)
3142 : {
3143 1191 : if (!current_attr.pointer)
3144 : {
3145 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3146 0 : m = MATCH_ERROR;
3147 0 : goto cleanup;
3148 : }
3149 :
3150 1191 : m = match_pointer_init (&initializer, 0);
3151 1191 : if (m != MATCH_YES)
3152 10 : goto cleanup;
3153 :
3154 : /* The target of a pointer initialization must have the SAVE
3155 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3156 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3157 1181 : if (initializer->expr_type == EXPR_VARIABLE
3158 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3159 25 : && (gfc_current_state () == COMP_PROGRAM
3160 : || gfc_current_state () == COMP_MODULE
3161 25 : || gfc_current_state () == COMP_SUBMODULE))
3162 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3163 : }
3164 228246 : else if (gfc_match_char ('=') == MATCH_YES)
3165 : {
3166 25698 : if (current_attr.pointer)
3167 : {
3168 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3169 : "not %<=%>");
3170 0 : m = MATCH_ERROR;
3171 0 : goto cleanup;
3172 : }
3173 :
3174 25698 : if (gfc_comp_struct (gfc_current_state ())
3175 2418 : && gfc_current_block ()->attr.pdt_template)
3176 : {
3177 255 : m = gfc_match_expr (&initializer);
3178 255 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3179 115 : initializer->ts = current_ts;
3180 : }
3181 : else
3182 25443 : m = gfc_match_init_expr (&initializer);
3183 :
3184 25698 : if (m == MATCH_NO)
3185 : {
3186 1 : gfc_error ("Expected an initialization expression at %C");
3187 1 : m = MATCH_ERROR;
3188 : }
3189 :
3190 9870 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3191 25700 : && !gfc_comp_struct (gfc_state_stack->state))
3192 : {
3193 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3194 : "a PURE procedure");
3195 1 : m = MATCH_ERROR;
3196 : }
3197 :
3198 25698 : if (current_attr.flavor != FL_PARAMETER
3199 9870 : && !gfc_comp_struct (gfc_state_stack->state))
3200 7452 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3201 :
3202 25698 : if (m != MATCH_YES)
3203 160 : goto cleanup;
3204 : }
3205 : }
3206 :
3207 274252 : if (initializer != NULL && current_attr.allocatable
3208 3 : && gfc_comp_struct (gfc_current_state ()))
3209 : {
3210 2 : gfc_error ("Initialization of allocatable component at %C is not "
3211 : "allowed");
3212 2 : m = MATCH_ERROR;
3213 2 : goto cleanup;
3214 : }
3215 :
3216 274250 : if (gfc_current_state () == COMP_DERIVED
3217 16773 : && initializer && initializer->ts.type == BT_HOLLERITH)
3218 : {
3219 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3220 : "constant at %L is not allowed", &initializer->where);
3221 1 : m = MATCH_ERROR;
3222 1 : goto cleanup;
3223 : }
3224 :
3225 274249 : if (gfc_current_state () == COMP_DERIVED
3226 16772 : && gfc_current_block ()->attr.pdt_template)
3227 : {
3228 1102 : gfc_symbol *param;
3229 1102 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3230 : 0, ¶m);
3231 1102 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3232 : {
3233 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3234 : "not appear in the type parameter list at %L",
3235 1 : &gfc_current_block ()->declared_at);
3236 1 : m = MATCH_ERROR;
3237 4 : goto cleanup;
3238 : }
3239 1101 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3240 : {
3241 1 : gfc_error ("The component at %C that appears in the type parameter "
3242 : "list at %L has neither the KIND nor LEN attribute",
3243 1 : &gfc_current_block ()->declared_at);
3244 1 : m = MATCH_ERROR;
3245 1 : goto cleanup;
3246 : }
3247 1100 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3248 : {
3249 1 : gfc_error ("The component at %C which is a type parameter must be "
3250 : "a scalar");
3251 1 : m = MATCH_ERROR;
3252 1 : goto cleanup;
3253 : }
3254 1099 : else if (param && initializer)
3255 : {
3256 233 : if (initializer->ts.type == BT_BOZ)
3257 : {
3258 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3259 : "initializer", &initializer->where);
3260 1 : m = MATCH_ERROR;
3261 1 : goto cleanup;
3262 : }
3263 232 : param->value = gfc_copy_expr (initializer);
3264 : }
3265 : }
3266 :
3267 : /* Before adding a possible initializer, do a simple check for compatibility
3268 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3269 : good thing. */
3270 27836 : if (current_ts.type == BT_DERIVED && initializer
3271 275645 : && (gfc_numeric_ts (&initializer->ts)
3272 1398 : || initializer->ts.type == BT_LOGICAL
3273 1398 : || initializer->ts.type == BT_CHARACTER))
3274 : {
3275 2 : gfc_error ("Incompatible initialization between a derived type "
3276 : "entity and an entity with %qs type at %C",
3277 : gfc_typename (initializer));
3278 2 : m = MATCH_ERROR;
3279 2 : goto cleanup;
3280 : }
3281 :
3282 :
3283 : /* Add the initializer. Note that it is fine if initializer is
3284 : NULL here, because we sometimes also need to check if a
3285 : declaration *must* have an initialization expression. */
3286 274243 : if (!gfc_comp_struct (gfc_current_state ()))
3287 256457 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
3288 : else
3289 : {
3290 17786 : if (current_ts.type == BT_DERIVED
3291 2534 : && !current_attr.pointer && !initializer)
3292 1987 : initializer = gfc_default_initializer (¤t_ts);
3293 17786 : t = build_struct (name, cl, &initializer, &as);
3294 :
3295 : /* If we match a nested structure definition we expect to see the
3296 : * body even if the variable declarations blow up, so we need to keep
3297 : * the structure declaration around. */
3298 17786 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3299 34 : gfc_commit_symbol (gfc_new_block);
3300 : }
3301 :
3302 274391 : m = (t) ? MATCH_YES : MATCH_ERROR;
3303 :
3304 274685 : cleanup:
3305 : /* Free stuff up and return. */
3306 274685 : gfc_seen_div0 = false;
3307 274685 : gfc_free_expr (initializer);
3308 274685 : gfc_free_array_spec (as);
3309 :
3310 274685 : return m;
3311 : }
3312 :
3313 :
3314 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3315 : This assumes that the byte size is equal to the kind number for
3316 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3317 :
3318 : static match
3319 106073 : gfc_match_old_kind_spec (gfc_typespec *ts)
3320 : {
3321 106073 : match m;
3322 106073 : int original_kind;
3323 :
3324 106073 : if (gfc_match_char ('*') != MATCH_YES)
3325 : return MATCH_NO;
3326 :
3327 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3328 1150 : if (m != MATCH_YES)
3329 : return MATCH_ERROR;
3330 :
3331 1150 : original_kind = ts->kind;
3332 :
3333 : /* Massage the kind numbers for complex types. */
3334 1150 : if (ts->type == BT_COMPLEX)
3335 : {
3336 79 : if (ts->kind % 2)
3337 : {
3338 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3339 : gfc_basic_typename (ts->type), original_kind);
3340 0 : return MATCH_ERROR;
3341 : }
3342 79 : ts->kind /= 2;
3343 :
3344 : }
3345 :
3346 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3347 0 : ts->kind = 8;
3348 :
3349 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3350 : {
3351 858 : if (ts->kind == 4)
3352 : {
3353 224 : if (flag_real4_kind == 8)
3354 24 : ts->kind = 8;
3355 224 : if (flag_real4_kind == 10)
3356 24 : ts->kind = 10;
3357 224 : if (flag_real4_kind == 16)
3358 24 : ts->kind = 16;
3359 : }
3360 634 : else if (ts->kind == 8)
3361 : {
3362 629 : if (flag_real8_kind == 4)
3363 24 : ts->kind = 4;
3364 629 : if (flag_real8_kind == 10)
3365 24 : ts->kind = 10;
3366 629 : if (flag_real8_kind == 16)
3367 24 : ts->kind = 16;
3368 : }
3369 : }
3370 :
3371 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3372 : {
3373 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3374 : gfc_basic_typename (ts->type), original_kind);
3375 8 : return MATCH_ERROR;
3376 : }
3377 :
3378 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3379 : "Nonstandard type declaration %s*%d at %C",
3380 : gfc_basic_typename(ts->type), original_kind))
3381 : return MATCH_ERROR;
3382 :
3383 : return MATCH_YES;
3384 : }
3385 :
3386 :
3387 : /* Match a kind specification. Since kinds are generally optional, we
3388 : usually return MATCH_NO if something goes wrong. If a "kind="
3389 : string is found, then we know we have an error. */
3390 :
3391 : match
3392 155692 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3393 : {
3394 155692 : locus where, loc;
3395 155692 : gfc_expr *e;
3396 155692 : match m, n;
3397 155692 : char c;
3398 :
3399 155692 : m = MATCH_NO;
3400 155692 : n = MATCH_YES;
3401 155692 : e = NULL;
3402 155692 : saved_kind_expr = NULL;
3403 :
3404 155692 : where = loc = gfc_current_locus;
3405 :
3406 155692 : if (kind_expr_only)
3407 0 : goto kind_expr;
3408 :
3409 155692 : if (gfc_match_char ('(') == MATCH_NO)
3410 : return MATCH_NO;
3411 :
3412 : /* Also gobbles optional text. */
3413 48181 : if (gfc_match (" kind = ") == MATCH_YES)
3414 48181 : m = MATCH_ERROR;
3415 :
3416 48181 : loc = gfc_current_locus;
3417 :
3418 48181 : kind_expr:
3419 :
3420 48181 : n = gfc_match_init_expr (&e);
3421 :
3422 48181 : if (gfc_derived_parameter_expr (e))
3423 : {
3424 160 : ts->kind = 0;
3425 160 : saved_kind_expr = gfc_copy_expr (e);
3426 160 : goto close_brackets;
3427 : }
3428 :
3429 48021 : if (n != MATCH_YES)
3430 : {
3431 345 : if (gfc_matching_function)
3432 : {
3433 : /* The function kind expression might include use associated or
3434 : imported parameters and try again after the specification
3435 : expressions..... */
3436 317 : if (gfc_match_char (')') != MATCH_YES)
3437 : {
3438 1 : gfc_error ("Missing right parenthesis at %C");
3439 1 : m = MATCH_ERROR;
3440 1 : goto no_match;
3441 : }
3442 :
3443 316 : gfc_free_expr (e);
3444 316 : gfc_undo_symbols ();
3445 316 : return MATCH_YES;
3446 : }
3447 : else
3448 : {
3449 : /* ....or else, the match is real. */
3450 28 : if (n == MATCH_NO)
3451 0 : gfc_error ("Expected initialization expression at %C");
3452 28 : if (n != MATCH_YES)
3453 28 : return MATCH_ERROR;
3454 : }
3455 : }
3456 :
3457 47676 : if (e->rank != 0)
3458 : {
3459 0 : gfc_error ("Expected scalar initialization expression at %C");
3460 0 : m = MATCH_ERROR;
3461 0 : goto no_match;
3462 : }
3463 :
3464 47676 : if (gfc_extract_int (e, &ts->kind, 1))
3465 : {
3466 0 : m = MATCH_ERROR;
3467 0 : goto no_match;
3468 : }
3469 :
3470 : /* Before throwing away the expression, let's see if we had a
3471 : C interoperable kind (and store the fact). */
3472 47676 : if (e->ts.is_c_interop == 1)
3473 : {
3474 : /* Mark this as C interoperable if being declared with one
3475 : of the named constants from iso_c_binding. */
3476 17647 : ts->is_c_interop = e->ts.is_iso_c;
3477 17647 : ts->f90_type = e->ts.f90_type;
3478 17647 : if (e->symtree)
3479 17646 : ts->interop_kind = e->symtree->n.sym;
3480 : }
3481 :
3482 47676 : gfc_free_expr (e);
3483 47676 : e = NULL;
3484 :
3485 : /* Ignore errors to this point, if we've gotten here. This means
3486 : we ignore the m=MATCH_ERROR from above. */
3487 47676 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3488 : {
3489 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3490 : gfc_basic_typename (ts->type));
3491 7 : gfc_current_locus = where;
3492 7 : return MATCH_ERROR;
3493 : }
3494 :
3495 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3496 : if, e.g., c_double is used for COMPLEX as the standard
3497 : explicitly says that the kind type parameter for complex and real
3498 : variable is the same, i.e. c_float == c_float_complex. */
3499 47669 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3500 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3501 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3502 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3503 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3504 : gfc_basic_typename (ts->type));
3505 :
3506 47656 : close_brackets:
3507 :
3508 47829 : gfc_gobble_whitespace ();
3509 47829 : if ((c = gfc_next_ascii_char ()) != ')'
3510 47829 : && (ts->type != BT_CHARACTER || c != ','))
3511 : {
3512 0 : if (ts->type == BT_CHARACTER)
3513 0 : gfc_error ("Missing right parenthesis or comma at %C");
3514 : else
3515 0 : gfc_error ("Missing right parenthesis at %C");
3516 0 : m = MATCH_ERROR;
3517 0 : goto no_match;
3518 : }
3519 : else
3520 : /* All tests passed. */
3521 47829 : m = MATCH_YES;
3522 :
3523 47829 : if(m == MATCH_ERROR)
3524 : gfc_current_locus = where;
3525 :
3526 47829 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3527 0 : ts->kind = 8;
3528 :
3529 47829 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3530 : {
3531 13824 : if (ts->kind == 4)
3532 : {
3533 4442 : if (flag_real4_kind == 8)
3534 54 : ts->kind = 8;
3535 4442 : if (flag_real4_kind == 10)
3536 54 : ts->kind = 10;
3537 4442 : if (flag_real4_kind == 16)
3538 54 : ts->kind = 16;
3539 : }
3540 9382 : else if (ts->kind == 8)
3541 : {
3542 6401 : if (flag_real8_kind == 4)
3543 48 : ts->kind = 4;
3544 6401 : if (flag_real8_kind == 10)
3545 48 : ts->kind = 10;
3546 6401 : if (flag_real8_kind == 16)
3547 48 : ts->kind = 16;
3548 : }
3549 : }
3550 :
3551 : /* Return what we know from the test(s). */
3552 : return m;
3553 :
3554 1 : no_match:
3555 1 : gfc_free_expr (e);
3556 1 : gfc_current_locus = where;
3557 1 : return m;
3558 : }
3559 :
3560 :
3561 : static match
3562 4685 : match_char_kind (int * kind, int * is_iso_c)
3563 : {
3564 4685 : locus where;
3565 4685 : gfc_expr *e;
3566 4685 : match m, n;
3567 4685 : bool fail;
3568 :
3569 4685 : m = MATCH_NO;
3570 4685 : e = NULL;
3571 4685 : where = gfc_current_locus;
3572 :
3573 4685 : n = gfc_match_init_expr (&e);
3574 :
3575 4685 : if (n != MATCH_YES && gfc_matching_function)
3576 : {
3577 : /* The expression might include use-associated or imported
3578 : parameters and try again after the specification
3579 : expressions. */
3580 7 : gfc_free_expr (e);
3581 7 : gfc_undo_symbols ();
3582 7 : return MATCH_YES;
3583 : }
3584 :
3585 7 : if (n == MATCH_NO)
3586 2 : gfc_error ("Expected initialization expression at %C");
3587 4678 : if (n != MATCH_YES)
3588 : return MATCH_ERROR;
3589 :
3590 4671 : if (e->rank != 0)
3591 : {
3592 0 : gfc_error ("Expected scalar initialization expression at %C");
3593 0 : m = MATCH_ERROR;
3594 0 : goto no_match;
3595 : }
3596 :
3597 4671 : if (gfc_derived_parameter_expr (e))
3598 : {
3599 14 : saved_kind_expr = e;
3600 14 : *kind = 0;
3601 14 : return MATCH_YES;
3602 : }
3603 :
3604 4657 : fail = gfc_extract_int (e, kind, 1);
3605 4657 : *is_iso_c = e->ts.is_iso_c;
3606 4657 : if (fail)
3607 : {
3608 0 : m = MATCH_ERROR;
3609 0 : goto no_match;
3610 : }
3611 :
3612 4657 : gfc_free_expr (e);
3613 :
3614 : /* Ignore errors to this point, if we've gotten here. This means
3615 : we ignore the m=MATCH_ERROR from above. */
3616 4657 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3617 : {
3618 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3619 14 : m = MATCH_ERROR;
3620 : }
3621 : else
3622 : /* All tests passed. */
3623 : m = MATCH_YES;
3624 :
3625 14 : if (m == MATCH_ERROR)
3626 14 : gfc_current_locus = where;
3627 :
3628 : /* Return what we know from the test(s). */
3629 : return m;
3630 :
3631 0 : no_match:
3632 0 : gfc_free_expr (e);
3633 0 : gfc_current_locus = where;
3634 0 : return m;
3635 : }
3636 :
3637 :
3638 : /* Match the various kind/length specifications in a CHARACTER
3639 : declaration. We don't return MATCH_NO. */
3640 :
3641 : match
3642 31482 : gfc_match_char_spec (gfc_typespec *ts)
3643 : {
3644 31482 : int kind, seen_length, is_iso_c;
3645 31482 : gfc_charlen *cl;
3646 31482 : gfc_expr *len;
3647 31482 : match m;
3648 31482 : bool deferred;
3649 :
3650 31482 : len = NULL;
3651 31482 : seen_length = 0;
3652 31482 : kind = 0;
3653 31482 : is_iso_c = 0;
3654 31482 : deferred = false;
3655 :
3656 : /* Try the old-style specification first. */
3657 31482 : old_char_selector = 0;
3658 :
3659 31482 : m = match_char_length (&len, &deferred, true);
3660 31482 : if (m != MATCH_NO)
3661 : {
3662 2205 : if (m == MATCH_YES)
3663 2205 : old_char_selector = 1;
3664 2205 : seen_length = 1;
3665 2205 : goto done;
3666 : }
3667 :
3668 29277 : m = gfc_match_char ('(');
3669 29277 : if (m != MATCH_YES)
3670 : {
3671 1848 : m = MATCH_YES; /* Character without length is a single char. */
3672 1848 : goto done;
3673 : }
3674 :
3675 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3676 27429 : if (gfc_match (" kind =") == MATCH_YES)
3677 : {
3678 3264 : m = match_char_kind (&kind, &is_iso_c);
3679 :
3680 3264 : if (m == MATCH_ERROR)
3681 16 : goto done;
3682 3248 : if (m == MATCH_NO)
3683 : goto syntax;
3684 :
3685 3248 : if (gfc_match (" , len =") == MATCH_NO)
3686 516 : goto rparen;
3687 :
3688 2732 : m = char_len_param_value (&len, &deferred);
3689 2732 : if (m == MATCH_NO)
3690 0 : goto syntax;
3691 2732 : if (m == MATCH_ERROR)
3692 2 : goto done;
3693 2730 : seen_length = 1;
3694 :
3695 2730 : goto rparen;
3696 : }
3697 :
3698 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3699 24165 : if (gfc_match (" len =") == MATCH_YES)
3700 : {
3701 13831 : m = char_len_param_value (&len, &deferred);
3702 13831 : if (m == MATCH_NO)
3703 2 : goto syntax;
3704 13829 : if (m == MATCH_ERROR)
3705 8 : goto done;
3706 13821 : seen_length = 1;
3707 :
3708 13821 : if (gfc_match_char (')') == MATCH_YES)
3709 12542 : goto done;
3710 :
3711 1279 : if (gfc_match (" , kind =") != MATCH_YES)
3712 0 : goto syntax;
3713 :
3714 1279 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3715 2 : goto done;
3716 :
3717 1277 : goto rparen;
3718 : }
3719 :
3720 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3721 10334 : m = char_len_param_value (&len, &deferred);
3722 10334 : if (m == MATCH_NO)
3723 0 : goto syntax;
3724 10334 : if (m == MATCH_ERROR)
3725 44 : goto done;
3726 10290 : seen_length = 1;
3727 :
3728 10290 : m = gfc_match_char (')');
3729 10290 : if (m == MATCH_YES)
3730 10146 : goto done;
3731 :
3732 144 : if (gfc_match_char (',') != MATCH_YES)
3733 2 : goto syntax;
3734 :
3735 142 : gfc_match (" kind ="); /* Gobble optional text. */
3736 :
3737 142 : m = match_char_kind (&kind, &is_iso_c);
3738 142 : if (m == MATCH_ERROR)
3739 3 : goto done;
3740 : if (m == MATCH_NO)
3741 : goto syntax;
3742 :
3743 4662 : rparen:
3744 : /* Require a right-paren at this point. */
3745 4662 : m = gfc_match_char (')');
3746 4662 : if (m == MATCH_YES)
3747 4662 : goto done;
3748 :
3749 0 : syntax:
3750 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3751 4 : m = MATCH_ERROR;
3752 4 : gfc_free_expr (len);
3753 4 : return m;
3754 :
3755 31478 : done:
3756 : /* Deal with character functions after USE and IMPORT statements. */
3757 31478 : if (gfc_matching_function)
3758 : {
3759 1417 : gfc_free_expr (len);
3760 1417 : gfc_undo_symbols ();
3761 1417 : return MATCH_YES;
3762 : }
3763 :
3764 30061 : if (m != MATCH_YES)
3765 : {
3766 65 : gfc_free_expr (len);
3767 65 : return m;
3768 : }
3769 :
3770 : /* Do some final massaging of the length values. */
3771 29996 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3772 :
3773 29996 : if (seen_length == 0)
3774 2312 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3775 : else
3776 : {
3777 : /* If gfortran ends up here, then len may be reducible to a constant.
3778 : Try to do that here. If it does not reduce, simply assign len to
3779 : charlen. A complication occurs with user-defined generic functions,
3780 : which are not resolved. Use a private namespace to deal with
3781 : generic functions. */
3782 :
3783 27684 : if (len && len->expr_type != EXPR_CONSTANT)
3784 : {
3785 3042 : gfc_namespace *old_ns;
3786 3042 : gfc_expr *e;
3787 :
3788 3042 : old_ns = gfc_current_ns;
3789 3042 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3790 :
3791 3042 : e = gfc_copy_expr (len);
3792 3042 : gfc_push_suppress_errors ();
3793 3042 : gfc_reduce_init_expr (e);
3794 3042 : gfc_pop_suppress_errors ();
3795 3042 : if (e->expr_type == EXPR_CONSTANT)
3796 : {
3797 294 : gfc_replace_expr (len, e);
3798 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3799 7 : mpz_set_ui (len->value.integer, 0);
3800 : }
3801 : else
3802 2748 : gfc_free_expr (e);
3803 :
3804 3042 : gfc_free_namespace (gfc_current_ns);
3805 3042 : gfc_current_ns = old_ns;
3806 : }
3807 :
3808 27684 : cl->length = len;
3809 : }
3810 :
3811 29996 : ts->u.cl = cl;
3812 29996 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3813 29996 : ts->deferred = deferred;
3814 :
3815 : /* We have to know if it was a C interoperable kind so we can
3816 : do accurate type checking of bind(c) procs, etc. */
3817 29996 : if (kind != 0)
3818 : /* Mark this as C interoperable if being declared with one
3819 : of the named constants from iso_c_binding. */
3820 4568 : ts->is_c_interop = is_iso_c;
3821 25428 : else if (len != NULL)
3822 : /* Here, we might have parsed something such as: character(c_char)
3823 : In this case, the parsing code above grabs the c_char when
3824 : looking for the length (line 1690, roughly). it's the last
3825 : testcase for parsing the kind params of a character variable.
3826 : However, it's not actually the length. this seems like it
3827 : could be an error.
3828 : To see if the user used a C interop kind, test the expr
3829 : of the so called length, and see if it's C interoperable. */
3830 16404 : ts->is_c_interop = len->ts.is_iso_c;
3831 :
3832 : return MATCH_YES;
3833 : }
3834 :
3835 :
3836 : /* Matches a RECORD declaration. */
3837 :
3838 : static match
3839 946210 : match_record_decl (char *name)
3840 : {
3841 946210 : locus old_loc;
3842 946210 : old_loc = gfc_current_locus;
3843 946210 : match m;
3844 :
3845 946210 : m = gfc_match (" record /");
3846 946210 : if (m == MATCH_YES)
3847 : {
3848 353 : if (!flag_dec_structure)
3849 : {
3850 6 : gfc_current_locus = old_loc;
3851 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3852 : "%<-fdec-structure%>");
3853 6 : return MATCH_ERROR;
3854 : }
3855 347 : m = gfc_match (" %n/", name);
3856 347 : if (m == MATCH_YES)
3857 : return MATCH_YES;
3858 : }
3859 :
3860 945860 : gfc_current_locus = old_loc;
3861 945860 : if (flag_dec_structure
3862 945860 : && (gfc_match (" record% ") == MATCH_YES
3863 8026 : || gfc_match (" record%t") == MATCH_YES))
3864 6 : gfc_error ("Structure name expected after RECORD at %C");
3865 945860 : if (m == MATCH_NO)
3866 : return MATCH_NO;
3867 :
3868 : return MATCH_ERROR;
3869 : }
3870 :
3871 :
3872 : /* In parsing a PDT, it is possible that one of the type parameters has the
3873 : same name as a previously declared symbol that is not a type parameter.
3874 : Intercept this now by looking for the symtree in f2k_derived. */
3875 :
3876 : static bool
3877 860 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3878 : {
3879 860 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3880 : return false;
3881 :
3882 695 : if (!(e->symtree->n.sym->attr.pdt_len
3883 115 : || e->symtree->n.sym->attr.pdt_kind))
3884 : {
3885 37 : gfc_symtree *st;
3886 37 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3887 : e->symtree->n.sym->name);
3888 37 : if (st && st->n.sym
3889 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3890 : {
3891 30 : gfc_expr *new_expr;
3892 30 : gfc_set_sym_referenced (st->n.sym);
3893 30 : new_expr = gfc_get_expr ();
3894 30 : new_expr->ts = st->n.sym->ts;
3895 30 : new_expr->expr_type = EXPR_VARIABLE;
3896 30 : new_expr->symtree = st;
3897 30 : new_expr->where = e->where;
3898 30 : gfc_replace_expr (e, new_expr);
3899 : }
3900 : }
3901 :
3902 : return false;
3903 : }
3904 :
3905 :
3906 : void
3907 637 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3908 : {
3909 637 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3910 : return;
3911 605 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3912 : }
3913 :
3914 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3915 : of expressions to substitute into the possibly parameterized expression
3916 : 'e'. Using a list is inefficient but should not be too bad since the
3917 : number of type parameters is not likely to be large. */
3918 : static bool
3919 3132 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3920 : int* f)
3921 : {
3922 3132 : gfc_actual_arglist *param;
3923 3132 : gfc_expr *copy;
3924 :
3925 3132 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
3926 : return false;
3927 :
3928 1387 : gcc_assert (e->symtree);
3929 1387 : if (e->symtree->n.sym->attr.pdt_kind
3930 1020 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
3931 504 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
3932 : {
3933 1375 : for (param = type_param_spec_list; param; param = param->next)
3934 1328 : if (!strcmp (e->symtree->n.sym->name, param->name))
3935 : break;
3936 :
3937 929 : if (param && param->expr)
3938 : {
3939 881 : copy = gfc_copy_expr (param->expr);
3940 881 : gfc_replace_expr (e, copy);
3941 : /* Catch variables declared without a value expression. */
3942 881 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
3943 21 : e->ts = e->symtree->n.sym->ts;
3944 : }
3945 : }
3946 :
3947 : return false;
3948 : }
3949 :
3950 :
3951 : static bool
3952 925 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3953 : {
3954 925 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3955 : }
3956 :
3957 :
3958 : bool
3959 1767 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3960 : {
3961 1767 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3962 1767 : type_param_spec_list = param_list;
3963 1767 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3964 1767 : type_param_spec_list = old_param_spec_list;
3965 1767 : return res;
3966 : }
3967 :
3968 : /* Determines the instance of a parameterized derived type to be used by
3969 : matching determining the values of the kind parameters and using them
3970 : in the name of the instance. If the instance exists, it is used, otherwise
3971 : a new derived type is created. */
3972 : match
3973 2639 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3974 : gfc_actual_arglist **ext_param_list)
3975 : {
3976 : /* The PDT template symbol. */
3977 2639 : gfc_symbol *pdt = *sym;
3978 : /* The symbol for the parameter in the template f2k_namespace. */
3979 2639 : gfc_symbol *param;
3980 : /* The hoped for instance of the PDT. */
3981 2639 : gfc_symbol *instance = NULL;
3982 : /* The list of parameters appearing in the PDT declaration. */
3983 2639 : gfc_formal_arglist *type_param_name_list;
3984 : /* Used to store the parameter specification list during recursive calls. */
3985 2639 : gfc_actual_arglist *old_param_spec_list;
3986 : /* Pointers to the parameter specification being used. */
3987 2639 : gfc_actual_arglist *actual_param;
3988 2639 : gfc_actual_arglist *tail = NULL;
3989 : /* Used to build up the name of the PDT instance. */
3990 2639 : char *name;
3991 2639 : bool name_seen = (param_list == NULL);
3992 2639 : bool assumed_seen = false;
3993 2639 : bool deferred_seen = false;
3994 2639 : bool spec_error = false;
3995 2639 : bool alloc_seen = false;
3996 2639 : bool ptr_seen = false;
3997 2639 : int i;
3998 2639 : gfc_expr *kind_expr;
3999 2639 : gfc_component *c1, *c2;
4000 2639 : match m;
4001 2639 : gfc_symtree *s = NULL;
4002 :
4003 2639 : type_param_spec_list = NULL;
4004 :
4005 2639 : type_param_name_list = pdt->formal;
4006 2639 : actual_param = param_list;
4007 :
4008 : /* Prevent a PDT component of the same type as the template from being
4009 : converted into an instance. Doing this results in the component being
4010 : lost. */
4011 2639 : if (gfc_current_state () == COMP_DERIVED
4012 100 : && !(gfc_state_stack->previous
4013 100 : && gfc_state_stack->previous->state == COMP_DERIVED)
4014 100 : && gfc_current_block ()->attr.pdt_template)
4015 : {
4016 99 : if (ext_param_list)
4017 99 : *ext_param_list = gfc_copy_actual_arglist (param_list);
4018 99 : return MATCH_YES;
4019 : }
4020 :
4021 2540 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
4022 :
4023 : /* Run through the parameter name list and pick up the actual
4024 : parameter values or use the default values in the PDT declaration. */
4025 5953 : for (; type_param_name_list;
4026 3413 : type_param_name_list = type_param_name_list->next)
4027 : {
4028 3481 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4029 : {
4030 3091 : if (actual_param->spec_type == SPEC_ASSUMED)
4031 : spec_error = deferred_seen;
4032 : else
4033 3091 : spec_error = assumed_seen;
4034 :
4035 3091 : if (spec_error)
4036 : {
4037 : gfc_error ("The type parameter spec list at %C cannot contain "
4038 : "both ASSUMED and DEFERRED parameters");
4039 : goto error_return;
4040 : }
4041 : }
4042 :
4043 3091 : if (actual_param && actual_param->name)
4044 3481 : name_seen = true;
4045 3481 : param = type_param_name_list->sym;
4046 :
4047 3481 : if (!param || !param->name)
4048 2 : continue;
4049 :
4050 3479 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4051 : /* An error should already have been thrown in resolve.cc
4052 : (resolve_fl_derived0). */
4053 3479 : if (!pdt->attr.use_assoc && !c1)
4054 8 : goto error_return;
4055 :
4056 : /* Resolution PDT class components of derived types are handled here.
4057 : They can arrive without a parameter list and no KIND parameters. */
4058 3471 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4059 14 : continue;
4060 :
4061 3457 : kind_expr = NULL;
4062 3457 : if (!name_seen)
4063 : {
4064 2021 : if (!actual_param && !(c1 && c1->initializer))
4065 : {
4066 2 : gfc_error ("The type parameter spec list at %C does not contain "
4067 : "enough parameter expressions");
4068 2 : goto error_return;
4069 : }
4070 2019 : else if (!actual_param && c1 && c1->initializer)
4071 5 : kind_expr = gfc_copy_expr (c1->initializer);
4072 2014 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4073 1813 : kind_expr = gfc_copy_expr (actual_param->expr);
4074 : }
4075 : else
4076 : {
4077 : actual_param = param_list;
4078 1896 : for (;actual_param; actual_param = actual_param->next)
4079 1512 : if (actual_param->name
4080 1492 : && strcmp (actual_param->name, param->name) == 0)
4081 : break;
4082 1436 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4083 891 : kind_expr = gfc_copy_expr (actual_param->expr);
4084 : else
4085 : {
4086 545 : if (c1->initializer)
4087 481 : kind_expr = gfc_copy_expr (c1->initializer);
4088 64 : else if (!(actual_param && param->attr.pdt_len))
4089 : {
4090 9 : gfc_error ("The derived parameter %qs at %C does not "
4091 : "have a default value", param->name);
4092 9 : goto error_return;
4093 : }
4094 : }
4095 : }
4096 :
4097 3190 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4098 252 : && kind_expr->ts.type != BT_INTEGER
4099 118 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4100 : {
4101 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4102 : "type and not %s", &kind_expr->where,
4103 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4104 12 : goto error_return;
4105 : }
4106 :
4107 : /* Store the current parameter expressions in a temporary actual
4108 : arglist 'list' so that they can be substituted in the corresponding
4109 : expressions in the PDT instance. */
4110 3434 : if (type_param_spec_list == NULL)
4111 : {
4112 2503 : type_param_spec_list = gfc_get_actual_arglist ();
4113 2503 : tail = type_param_spec_list;
4114 : }
4115 : else
4116 : {
4117 931 : tail->next = gfc_get_actual_arglist ();
4118 931 : tail = tail->next;
4119 : }
4120 3434 : tail->name = param->name;
4121 :
4122 3434 : if (kind_expr)
4123 : {
4124 : /* Try simplification even for LEN expressions. */
4125 3178 : bool ok;
4126 3178 : gfc_resolve_expr (kind_expr);
4127 :
4128 3178 : if (c1->attr.pdt_kind
4129 1624 : && kind_expr->expr_type != EXPR_CONSTANT
4130 28 : && type_param_spec_list)
4131 28 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4132 :
4133 3178 : ok = gfc_simplify_expr (kind_expr, 1);
4134 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4135 : initializer so allow for this. */
4136 3178 : if (kind_expr->ts.type != BT_INTEGER
4137 135 : && kind_expr->ts.type != BT_PROCEDURE)
4138 : {
4139 29 : gfc_error ("The parameter expression at %C must be of "
4140 : "INTEGER type and not %s type",
4141 : gfc_basic_typename (kind_expr->ts.type));
4142 29 : goto error_return;
4143 : }
4144 3149 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4145 : {
4146 4 : gfc_error ("The parameter expression at %C does not "
4147 : "simplify to an INTEGER constant");
4148 4 : goto error_return;
4149 : }
4150 :
4151 3145 : tail->expr = gfc_copy_expr (kind_expr);
4152 : }
4153 :
4154 3401 : if (actual_param)
4155 3019 : tail->spec_type = actual_param->spec_type;
4156 :
4157 3401 : if (!param->attr.pdt_kind)
4158 : {
4159 1802 : if (!name_seen && actual_param)
4160 1083 : actual_param = actual_param->next;
4161 1802 : if (kind_expr)
4162 : {
4163 1548 : gfc_free_expr (kind_expr);
4164 1548 : kind_expr = NULL;
4165 : }
4166 1802 : continue;
4167 : }
4168 :
4169 1599 : if (actual_param
4170 1261 : && (actual_param->spec_type == SPEC_ASSUMED
4171 1261 : || actual_param->spec_type == SPEC_DEFERRED))
4172 : {
4173 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4174 : "ASSUMED or DEFERRED", param->name);
4175 2 : goto error_return;
4176 : }
4177 :
4178 1597 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4179 : {
4180 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4181 : "reduce to a constant expression", param->name);
4182 2 : goto error_return;
4183 : }
4184 :
4185 : /* This can come about during the parsing of nested pdt_templates. An
4186 : error arises because the KIND parameter expression has not been
4187 : provided. Use the template instead of an incorrect instance. */
4188 1595 : if (kind_expr->expr_type != EXPR_CONSTANT
4189 1595 : || kind_expr->ts.type != BT_INTEGER)
4190 : {
4191 0 : gfc_free_actual_arglist (type_param_spec_list);
4192 0 : free (name);
4193 0 : return MATCH_YES;
4194 : }
4195 :
4196 1595 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4197 1595 : char *old_name = name;
4198 1595 : name = xasprintf ("%s_%s", old_name, kind_value);
4199 1595 : free (old_name);
4200 1595 : free (kind_value);
4201 :
4202 1595 : if (!name_seen && actual_param)
4203 882 : actual_param = actual_param->next;
4204 1595 : gfc_free_expr (kind_expr);
4205 : }
4206 :
4207 2472 : if (!name_seen && actual_param)
4208 : {
4209 2 : gfc_error ("The type parameter spec list at %C contains too many "
4210 : "parameter expressions");
4211 2 : goto error_return;
4212 : }
4213 :
4214 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4215 : build it, using 'pdt' as a template. */
4216 2470 : if (gfc_get_symbol (name, pdt->ns, &instance))
4217 : {
4218 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4219 0 : goto error_return;
4220 : }
4221 :
4222 : /* If we are in an interface body, the instance will not have been imported.
4223 : Make sure that it is imported implicitly. */
4224 2470 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4225 2470 : if (gfc_current_ns->proc_name
4226 2423 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4227 93 : && s && s->import_only && pdt->attr.imported)
4228 : {
4229 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4230 2 : if (!s)
4231 : {
4232 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4233 : &gfc_current_locus);
4234 1 : s->n.sym = instance;
4235 : }
4236 2 : s->n.sym->attr.imported = 1;
4237 2 : s->import_only = 1;
4238 : }
4239 :
4240 2470 : m = MATCH_YES;
4241 :
4242 2470 : if (instance->attr.flavor == FL_DERIVED
4243 1964 : && instance->attr.pdt_type
4244 1964 : && instance->components)
4245 : {
4246 1964 : instance->refs++;
4247 1964 : if (ext_param_list)
4248 924 : *ext_param_list = type_param_spec_list;
4249 1964 : *sym = instance;
4250 1964 : gfc_commit_symbols ();
4251 1964 : free (name);
4252 1964 : return m;
4253 : }
4254 :
4255 : /* Start building the new instance of the parameterized type. */
4256 506 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4257 506 : if (pdt->attr.use_assoc)
4258 41 : instance->module = pdt->module;
4259 506 : instance->attr.pdt_template = 0;
4260 506 : instance->attr.pdt_type = 1;
4261 506 : instance->declared_at = gfc_current_locus;
4262 :
4263 : /* In resolution, the finalizers are copied, according to the type of the
4264 : argument, to the instance finalizers. However, they are retained by the
4265 : template and procedures are freed there. */
4266 506 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4267 : {
4268 12 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4269 12 : instance->template_sym = pdt;
4270 12 : *instance->f2k_derived = *pdt->f2k_derived;
4271 : }
4272 :
4273 : /* Add the components, replacing the parameters in all expressions
4274 : with the expressions for their values in 'type_param_spec_list'. */
4275 506 : c1 = pdt->components;
4276 506 : tail = type_param_spec_list;
4277 1883 : for (; c1; c1 = c1->next)
4278 : {
4279 1379 : gfc_add_component (instance, c1->name, &c2);
4280 :
4281 1379 : c2->ts = c1->ts;
4282 1379 : c2->attr = c1->attr;
4283 1379 : if (c1->tb)
4284 : {
4285 6 : c2->tb = gfc_get_tbp ();
4286 6 : *c2->tb = *c1->tb;
4287 : }
4288 :
4289 : /* The order of declaration of the type_specs might not be the
4290 : same as that of the components. */
4291 1379 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4292 : {
4293 981 : for (tail = type_param_spec_list; tail; tail = tail->next)
4294 971 : if (strcmp (c1->name, tail->name) == 0)
4295 : break;
4296 : }
4297 :
4298 : /* Deal with type extension by recursively calling this function
4299 : to obtain the instance of the extended type. */
4300 1379 : if (gfc_current_state () != COMP_DERIVED
4301 1377 : && c1 == pdt->components
4302 505 : && c1->ts.type == BT_DERIVED
4303 42 : && c1->ts.u.derived
4304 1421 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4305 : {
4306 42 : if (c1->ts.u.derived->attr.pdt_template)
4307 : {
4308 35 : gfc_formal_arglist *f;
4309 :
4310 35 : old_param_spec_list = type_param_spec_list;
4311 :
4312 : /* Obtain a spec list appropriate to the extended type..*/
4313 35 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4314 35 : type_param_spec_list = actual_param;
4315 67 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4316 32 : actual_param = actual_param->next;
4317 35 : if (actual_param)
4318 : {
4319 35 : gfc_free_actual_arglist (actual_param->next);
4320 35 : actual_param->next = NULL;
4321 : }
4322 :
4323 : /* Now obtain the PDT instance for the extended type. */
4324 35 : c2->param_list = type_param_spec_list;
4325 35 : m = gfc_get_pdt_instance (type_param_spec_list,
4326 : &c2->ts.u.derived,
4327 : &c2->param_list);
4328 35 : type_param_spec_list = old_param_spec_list;
4329 : }
4330 : else
4331 7 : c2->ts = c1->ts;
4332 :
4333 42 : c2->ts.u.derived->refs++;
4334 42 : gfc_set_sym_referenced (c2->ts.u.derived);
4335 :
4336 : /* If the component is allocatable or the parent has allocatable
4337 : components, make sure that the new instance also is marked as
4338 : having allocatable components. */
4339 42 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4340 6 : instance->attr.alloc_comp = 1;
4341 :
4342 : /* Set extension level. */
4343 42 : if (c2->ts.u.derived->attr.extension == 255)
4344 : {
4345 : /* Since the extension field is 8 bit wide, we can only have
4346 : up to 255 extension levels. */
4347 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4348 : c2->ts.u.derived->name,
4349 : &c2->ts.u.derived->declared_at);
4350 0 : goto error_return;
4351 : }
4352 42 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4353 :
4354 42 : continue;
4355 42 : }
4356 :
4357 : /* Addressing PR82943, this will fix the issue where a function or
4358 : subroutine is declared as not a member of the PDT instance.
4359 : The reason for this is because the PDT instance did not have access
4360 : to its template's f2k_derived namespace in order to find the
4361 : typebound procedures.
4362 :
4363 : The number of references to the PDT template's f2k_derived will
4364 : ensure that f2k_derived is properly freed later on. */
4365 :
4366 1337 : if (!instance->f2k_derived && pdt->f2k_derived)
4367 : {
4368 487 : instance->f2k_derived = pdt->f2k_derived;
4369 487 : instance->f2k_derived->refs++;
4370 : }
4371 :
4372 : /* Set the component kind using the parameterized expression. */
4373 1337 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4374 462 : && c1->kind_expr != NULL)
4375 : {
4376 272 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4377 272 : gfc_insert_kind_parameter_exprs (e);
4378 272 : gfc_simplify_expr (e, 1);
4379 272 : gfc_extract_int (e, &c2->ts.kind);
4380 272 : gfc_free_expr (e);
4381 272 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4382 : {
4383 2 : gfc_error ("Kind %d not supported for type %s at %C",
4384 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4385 2 : goto error_return;
4386 : }
4387 270 : if (c2->attr.proc_pointer && c2->attr.function
4388 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4389 : {
4390 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4391 0 : c2->ts.interface->result = c2->ts.interface;
4392 0 : c2->ts.interface->ts = c2->ts;
4393 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4394 0 : c2->ts.interface->attr.function = 1;
4395 0 : c2->attr.function = 1;
4396 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4397 : }
4398 : }
4399 :
4400 : /* Set up either the KIND/LEN initializer, if constant,
4401 : or the parameterized expression. Use the template
4402 : initializer if one is not already set in this instance. */
4403 1335 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4404 : {
4405 690 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4406 574 : c2->initializer = gfc_copy_expr (tail->expr);
4407 116 : else if (tail && tail->expr)
4408 : {
4409 10 : c2->param_list = gfc_get_actual_arglist ();
4410 10 : c2->param_list->name = tail->name;
4411 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4412 10 : c2->param_list->next = NULL;
4413 : }
4414 :
4415 690 : if (!c2->initializer && c1->initializer)
4416 24 : c2->initializer = gfc_copy_expr (c1->initializer);
4417 :
4418 690 : if (c2->initializer)
4419 598 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4420 : }
4421 :
4422 : /* Copy the array spec. */
4423 1335 : c2->as = gfc_copy_array_spec (c1->as);
4424 1335 : if (c1->ts.type == BT_CLASS)
4425 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4426 :
4427 1335 : if (c1->attr.allocatable)
4428 64 : alloc_seen = true;
4429 :
4430 1335 : if (c1->attr.pointer)
4431 20 : ptr_seen = true;
4432 :
4433 : /* Determine if an array spec is parameterized. If so, substitute
4434 : in the parameter expressions for the bounds and set the pdt_array
4435 : attribute. Notice that this attribute must be unconditionally set
4436 : if this is an array of parameterized character length. */
4437 1335 : if (c1->as && c1->as->type == AS_EXPLICIT)
4438 : {
4439 : bool pdt_array = false;
4440 :
4441 : /* Are the bounds of the array parameterized? */
4442 495 : for (i = 0; i < c1->as->rank; i++)
4443 : {
4444 295 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4445 6 : pdt_array = true;
4446 295 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4447 281 : pdt_array = true;
4448 : }
4449 :
4450 : /* If they are, free the expressions for the bounds and
4451 : replace them with the template expressions with substitute
4452 : values. */
4453 481 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4454 : {
4455 281 : gfc_expr *e;
4456 281 : e = gfc_copy_expr (c1->as->lower[i]);
4457 281 : gfc_insert_kind_parameter_exprs (e);
4458 281 : if (gfc_simplify_expr (e, 1))
4459 281 : gfc_replace_expr (c2->as->lower[i], e);
4460 : else
4461 0 : gfc_free_expr (e);
4462 281 : e = gfc_copy_expr (c1->as->upper[i]);
4463 281 : gfc_insert_kind_parameter_exprs (e);
4464 281 : if (gfc_simplify_expr (e, 1))
4465 281 : gfc_replace_expr (c2->as->upper[i], e);
4466 : else
4467 0 : gfc_free_expr (e);
4468 : }
4469 :
4470 200 : c2->attr.pdt_array = 1;
4471 200 : if (c1->initializer)
4472 : {
4473 6 : c2->initializer = gfc_copy_expr (c1->initializer);
4474 6 : gfc_insert_kind_parameter_exprs (c2->initializer);
4475 6 : gfc_simplify_expr (c2->initializer, 1);
4476 : }
4477 : }
4478 :
4479 : /* Similarly, set the string length if parameterized. */
4480 1335 : if (c1->ts.type == BT_CHARACTER
4481 86 : && c1->ts.u.cl->length
4482 1420 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4483 : {
4484 85 : gfc_expr *e;
4485 85 : e = gfc_copy_expr (c1->ts.u.cl->length);
4486 85 : gfc_insert_kind_parameter_exprs (e);
4487 85 : if (gfc_simplify_expr (e, 1))
4488 85 : gfc_replace_expr (c2->ts.u.cl->length, e);
4489 : else
4490 0 : gfc_free_expr (e);
4491 85 : c2->attr.pdt_string = 1;
4492 : }
4493 :
4494 : /* Recurse into this function for PDT components. */
4495 1335 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4496 129 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4497 : {
4498 122 : gfc_actual_arglist *params;
4499 : /* The component in the template has a list of specification
4500 : expressions derived from its declaration. */
4501 122 : params = gfc_copy_actual_arglist (c1->param_list);
4502 122 : actual_param = params;
4503 : /* Substitute the template parameters with the expressions
4504 : from the specification list. */
4505 381 : for (;actual_param; actual_param = actual_param->next)
4506 : {
4507 137 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4508 137 : gfc_insert_parameter_exprs (actual_param->expr,
4509 : type_param_spec_list);
4510 : }
4511 :
4512 : /* Now obtain the PDT instance for the component. */
4513 122 : old_param_spec_list = type_param_spec_list;
4514 244 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4515 122 : &c2->param_list);
4516 122 : type_param_spec_list = old_param_spec_list;
4517 :
4518 122 : if (!(c2->attr.pointer || c2->attr.allocatable))
4519 : {
4520 82 : if (!c1->initializer
4521 57 : || c1->initializer->expr_type != EXPR_FUNCTION)
4522 81 : c2->initializer = gfc_default_initializer (&c2->ts);
4523 : else
4524 : {
4525 1 : gfc_symtree *s;
4526 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4527 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4528 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4529 1 : if (s)
4530 0 : c2->initializer->symtree = s;
4531 1 : c2->initializer->ts = c2->ts;
4532 1 : if (!s)
4533 1 : gfc_insert_parameter_exprs (c2->initializer,
4534 : type_param_spec_list);
4535 1 : gfc_simplify_expr (c2->initializer, 1);
4536 : }
4537 : }
4538 :
4539 122 : if (c2->attr.allocatable)
4540 32 : instance->attr.alloc_comp = 1;
4541 : }
4542 1213 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4543 438 : || c2->attr.pdt_array) && c1->initializer)
4544 : {
4545 30 : c2->initializer = gfc_copy_expr (c1->initializer);
4546 30 : if (c2->initializer->ts.type == BT_UNKNOWN)
4547 12 : c2->initializer->ts = c2->ts;
4548 30 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4549 : /* The template initializers are parsed using gfc_match_expr rather
4550 : than gfc_match_init_expr. Apply the missing reduction to the
4551 : PDT instance initializers. */
4552 30 : if (!gfc_reduce_init_expr (c2->initializer))
4553 : {
4554 0 : gfc_free_expr (c2->initializer);
4555 0 : goto error_return;
4556 : }
4557 30 : gfc_simplify_expr (c2->initializer, 1);
4558 : }
4559 : }
4560 :
4561 504 : if (alloc_seen)
4562 61 : instance->attr.alloc_comp = 1;
4563 504 : if (ptr_seen)
4564 20 : instance->attr.pointer_comp = 1;
4565 :
4566 :
4567 504 : gfc_commit_symbol (instance);
4568 504 : if (ext_param_list)
4569 327 : *ext_param_list = type_param_spec_list;
4570 504 : *sym = instance;
4571 504 : free (name);
4572 504 : return m;
4573 :
4574 72 : error_return:
4575 72 : gfc_free_actual_arglist (type_param_spec_list);
4576 72 : free (name);
4577 72 : return MATCH_ERROR;
4578 : }
4579 :
4580 :
4581 : /* Match a legacy nonstandard BYTE type-spec. */
4582 :
4583 : static match
4584 1162716 : match_byte_typespec (gfc_typespec *ts)
4585 : {
4586 1162716 : if (gfc_match (" byte") == MATCH_YES)
4587 : {
4588 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4589 : return MATCH_ERROR;
4590 :
4591 31 : if (gfc_current_form == FORM_FREE)
4592 : {
4593 19 : char c = gfc_peek_ascii_char ();
4594 19 : if (!gfc_is_whitespace (c) && c != ',')
4595 : return MATCH_NO;
4596 : }
4597 :
4598 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4599 : {
4600 0 : gfc_error ("BYTE type used at %C "
4601 : "is not available on the target machine");
4602 0 : return MATCH_ERROR;
4603 : }
4604 :
4605 29 : ts->type = BT_INTEGER;
4606 29 : ts->kind = 1;
4607 29 : return MATCH_YES;
4608 : }
4609 : return MATCH_NO;
4610 : }
4611 :
4612 :
4613 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4614 : structure to the matched specification. This is necessary for FUNCTION and
4615 : IMPLICIT statements.
4616 :
4617 : If implicit_flag is nonzero, then we don't check for the optional
4618 : kind specification. Not doing so is needed for matching an IMPLICIT
4619 : statement correctly. */
4620 :
4621 : match
4622 1162716 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4623 : {
4624 : /* Provide sufficient space to hold "pdtsymbol". */
4625 1162716 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4626 1162716 : gfc_symbol *sym, *dt_sym;
4627 1162716 : match m;
4628 1162716 : char c;
4629 1162716 : bool seen_deferred_kind, matched_type;
4630 1162716 : const char *dt_name;
4631 :
4632 1162716 : decl_type_param_list = NULL;
4633 :
4634 : /* A belt and braces check that the typespec is correctly being treated
4635 : as a deferred characteristic association. */
4636 2325432 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4637 80410 : && (gfc_current_block ()->result->ts.kind == -1)
4638 1174391 : && (ts->kind == -1);
4639 1162716 : gfc_clear_ts (ts);
4640 1162716 : if (seen_deferred_kind)
4641 9470 : ts->kind = -1;
4642 :
4643 : /* Clear the current binding label, in case one is given. */
4644 1162716 : curr_binding_label = NULL;
4645 :
4646 : /* Match BYTE type-spec. */
4647 1162716 : m = match_byte_typespec (ts);
4648 1162716 : if (m != MATCH_NO)
4649 : return m;
4650 :
4651 1162685 : m = gfc_match (" type (");
4652 1162685 : matched_type = (m == MATCH_YES);
4653 1162685 : if (matched_type)
4654 : {
4655 30897 : gfc_gobble_whitespace ();
4656 30897 : if (gfc_peek_ascii_char () == '*')
4657 : {
4658 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4659 : return m;
4660 5617 : if (gfc_comp_struct (gfc_current_state ()))
4661 : {
4662 2 : gfc_error ("Assumed type at %C is not allowed for components");
4663 2 : return MATCH_ERROR;
4664 : }
4665 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4666 : return MATCH_ERROR;
4667 5613 : ts->type = BT_ASSUMED;
4668 5613 : return MATCH_YES;
4669 : }
4670 :
4671 25280 : m = gfc_match ("%n", name);
4672 25280 : matched_type = (m == MATCH_YES);
4673 : }
4674 :
4675 25280 : if ((matched_type && strcmp ("integer", name) == 0)
4676 1157068 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4677 : {
4678 108315 : ts->type = BT_INTEGER;
4679 108315 : ts->kind = gfc_default_integer_kind;
4680 108315 : goto get_kind;
4681 : }
4682 :
4683 1048753 : if (flag_unsigned)
4684 : {
4685 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4686 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4687 : {
4688 1036 : ts->type = BT_UNSIGNED;
4689 1036 : ts->kind = gfc_default_integer_kind;
4690 1036 : goto get_kind;
4691 : }
4692 : }
4693 :
4694 25274 : if ((matched_type && strcmp ("character", name) == 0)
4695 1047717 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4696 : {
4697 28553 : if (matched_type
4698 28553 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4699 : "intrinsic-type-spec at %C"))
4700 : return MATCH_ERROR;
4701 :
4702 28552 : ts->type = BT_CHARACTER;
4703 28552 : if (implicit_flag == 0)
4704 28446 : m = gfc_match_char_spec (ts);
4705 : else
4706 : m = MATCH_YES;
4707 :
4708 28552 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4709 : {
4710 1 : gfc_error ("Malformed type-spec at %C");
4711 1 : return MATCH_ERROR;
4712 : }
4713 :
4714 28551 : return m;
4715 : }
4716 :
4717 25270 : if ((matched_type && strcmp ("real", name) == 0)
4718 1019164 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4719 : {
4720 29550 : ts->type = BT_REAL;
4721 29550 : ts->kind = gfc_default_real_kind;
4722 29550 : goto get_kind;
4723 : }
4724 :
4725 989614 : if ((matched_type
4726 25267 : && (strcmp ("doubleprecision", name) == 0
4727 25266 : || (strcmp ("double", name) == 0
4728 5 : && gfc_match (" precision") == MATCH_YES)))
4729 989614 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4730 : {
4731 2551 : if (matched_type
4732 2551 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4733 : "intrinsic-type-spec at %C"))
4734 : return MATCH_ERROR;
4735 :
4736 2550 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4737 : {
4738 2 : gfc_error ("Malformed type-spec at %C");
4739 2 : return MATCH_ERROR;
4740 : }
4741 :
4742 2548 : ts->type = BT_REAL;
4743 2548 : ts->kind = gfc_default_double_kind;
4744 2548 : return MATCH_YES;
4745 : }
4746 :
4747 25263 : if ((matched_type && strcmp ("complex", name) == 0)
4748 987063 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4749 : {
4750 4011 : ts->type = BT_COMPLEX;
4751 4011 : ts->kind = gfc_default_complex_kind;
4752 4011 : goto get_kind;
4753 : }
4754 :
4755 983052 : if ((matched_type
4756 25263 : && (strcmp ("doublecomplex", name) == 0
4757 25262 : || (strcmp ("double", name) == 0
4758 2 : && gfc_match (" complex") == MATCH_YES)))
4759 983052 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4760 : {
4761 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4762 : return MATCH_ERROR;
4763 :
4764 203 : if (matched_type
4765 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4766 : "intrinsic-type-spec at %C"))
4767 : return MATCH_ERROR;
4768 :
4769 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4770 : {
4771 2 : gfc_error ("Malformed type-spec at %C");
4772 2 : return MATCH_ERROR;
4773 : }
4774 :
4775 201 : ts->type = BT_COMPLEX;
4776 201 : ts->kind = gfc_default_double_kind;
4777 201 : return MATCH_YES;
4778 : }
4779 :
4780 25260 : if ((matched_type && strcmp ("logical", name) == 0)
4781 982848 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4782 : {
4783 11381 : ts->type = BT_LOGICAL;
4784 11381 : ts->kind = gfc_default_logical_kind;
4785 11381 : goto get_kind;
4786 : }
4787 :
4788 971467 : if (matched_type)
4789 : {
4790 25257 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4791 25257 : if (m == MATCH_ERROR)
4792 : return m;
4793 :
4794 25257 : gfc_gobble_whitespace ();
4795 25257 : if (gfc_peek_ascii_char () != ')')
4796 : {
4797 1 : gfc_error ("Malformed type-spec at %C");
4798 1 : return MATCH_ERROR;
4799 : }
4800 25256 : m = gfc_match_char (')'); /* Burn closing ')'. */
4801 : }
4802 :
4803 971466 : if (m != MATCH_YES)
4804 946210 : m = match_record_decl (name);
4805 :
4806 971466 : if (matched_type || m == MATCH_YES)
4807 : {
4808 25600 : ts->type = BT_DERIVED;
4809 : /* We accept record/s/ or type(s) where s is a structure, but we
4810 : * don't need all the extra derived-type stuff for structures. */
4811 25600 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4812 : {
4813 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4814 1 : return MATCH_ERROR;
4815 : }
4816 :
4817 25599 : if (sym && sym->attr.flavor == FL_DERIVED
4818 24841 : && sym->attr.pdt_template
4819 985 : && gfc_current_state () != COMP_DERIVED)
4820 : {
4821 871 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4822 871 : if (m != MATCH_YES)
4823 : return m;
4824 856 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4825 856 : ts->u.derived = sym;
4826 856 : const char* lower = gfc_dt_lower_string (sym->name);
4827 856 : size_t len = strlen (lower);
4828 : /* Reallocate with sufficient size. */
4829 856 : if (len > GFC_MAX_SYMBOL_LEN)
4830 2 : name = XALLOCAVEC (char, len + 1);
4831 856 : memcpy (name, lower, len);
4832 856 : name[len] = '\0';
4833 : }
4834 :
4835 25584 : if (sym && sym->attr.flavor == FL_STRUCT)
4836 : {
4837 361 : ts->u.derived = sym;
4838 361 : return MATCH_YES;
4839 : }
4840 : /* Actually a derived type. */
4841 : }
4842 :
4843 : else
4844 : {
4845 : /* Match nested STRUCTURE declarations; only valid within another
4846 : structure declaration. */
4847 945866 : if (flag_dec_structure
4848 8032 : && (gfc_current_state () == COMP_STRUCTURE
4849 7570 : || gfc_current_state () == COMP_MAP))
4850 : {
4851 732 : m = gfc_match (" structure");
4852 732 : if (m == MATCH_YES)
4853 : {
4854 27 : m = gfc_match_structure_decl ();
4855 27 : if (m == MATCH_YES)
4856 : {
4857 : /* gfc_new_block is updated by match_structure_decl. */
4858 26 : ts->type = BT_DERIVED;
4859 26 : ts->u.derived = gfc_new_block;
4860 26 : return MATCH_YES;
4861 : }
4862 : }
4863 706 : if (m == MATCH_ERROR)
4864 : return MATCH_ERROR;
4865 : }
4866 :
4867 : /* Match CLASS declarations. */
4868 945839 : m = gfc_match (" class ( * )");
4869 945839 : if (m == MATCH_ERROR)
4870 : return MATCH_ERROR;
4871 945839 : else if (m == MATCH_YES)
4872 : {
4873 1906 : gfc_symbol *upe;
4874 1906 : gfc_symtree *st;
4875 1906 : ts->type = BT_CLASS;
4876 1906 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4877 1906 : if (upe == NULL)
4878 : {
4879 1167 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4880 1167 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4881 1167 : st->n.sym = upe;
4882 1167 : gfc_set_sym_referenced (upe);
4883 1167 : upe->refs++;
4884 1167 : upe->ts.type = BT_VOID;
4885 1167 : upe->attr.unlimited_polymorphic = 1;
4886 : /* This is essential to force the construction of
4887 : unlimited polymorphic component class containers. */
4888 1167 : upe->attr.zero_comp = 1;
4889 1167 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4890 : &gfc_current_locus))
4891 : return MATCH_ERROR;
4892 : }
4893 : else
4894 : {
4895 739 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4896 739 : st->n.sym = upe;
4897 739 : upe->refs++;
4898 : }
4899 1906 : ts->u.derived = upe;
4900 1906 : return m;
4901 : }
4902 :
4903 943933 : m = gfc_match (" class (");
4904 :
4905 943933 : if (m == MATCH_YES)
4906 8795 : m = gfc_match ("%n", name);
4907 : else
4908 : return m;
4909 :
4910 8795 : if (m != MATCH_YES)
4911 : return m;
4912 8795 : ts->type = BT_CLASS;
4913 :
4914 8795 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4915 : return MATCH_ERROR;
4916 :
4917 8794 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4918 8794 : if (m == MATCH_ERROR)
4919 : return m;
4920 :
4921 8794 : m = gfc_match_char (')');
4922 8794 : if (m != MATCH_YES)
4923 : return m;
4924 : }
4925 :
4926 : /* This picks up function declarations with a PDT typespec. Since a
4927 : pdt_type has been generated, there is no more to do. Within the
4928 : function body, this type must be used for the typespec so that
4929 : the "being used before it is defined warning" does not arise. */
4930 34017 : if (ts->type == BT_DERIVED
4931 25223 : && sym && sym->attr.pdt_type
4932 34873 : && (gfc_current_state () == COMP_CONTAINS
4933 840 : || (gfc_current_state () == COMP_FUNCTION
4934 268 : && gfc_current_block ()->ts.type == BT_DERIVED
4935 60 : && gfc_current_block ()->ts.u.derived == sym
4936 30 : && !gfc_find_symtree (gfc_current_ns->sym_root,
4937 : sym->name))))
4938 : {
4939 42 : if (gfc_current_state () == COMP_FUNCTION)
4940 : {
4941 26 : gfc_symtree *pdt_st;
4942 26 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
4943 : sym->name);
4944 26 : pdt_st->n.sym = sym;
4945 26 : sym->refs++;
4946 : }
4947 42 : ts->u.derived = sym;
4948 42 : return MATCH_YES;
4949 : }
4950 :
4951 : /* Defer association of the derived type until the end of the
4952 : specification block. However, if the derived type can be
4953 : found, add it to the typespec. */
4954 33975 : if (gfc_matching_function)
4955 : {
4956 1035 : ts->u.derived = NULL;
4957 1035 : if (gfc_current_state () != COMP_INTERFACE
4958 1035 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4959 : {
4960 512 : sym = gfc_find_dt_in_generic (sym);
4961 512 : ts->u.derived = sym;
4962 : }
4963 1035 : return MATCH_YES;
4964 : }
4965 :
4966 : /* Search for the name but allow the components to be defined later. If
4967 : type = -1, this typespec has been seen in a function declaration but
4968 : the type could not be accessed at that point. The actual derived type is
4969 : stored in a symtree with the first letter of the name capitalized; the
4970 : symtree with the all lower-case name contains the associated
4971 : generic function. */
4972 32940 : dt_name = gfc_dt_upper_string (name);
4973 32940 : sym = NULL;
4974 32940 : dt_sym = NULL;
4975 32940 : if (ts->kind != -1)
4976 : {
4977 31736 : gfc_get_ha_symbol (name, &sym);
4978 31736 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4979 : {
4980 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4981 0 : return MATCH_ERROR;
4982 : }
4983 31736 : if (sym->generic && !dt_sym)
4984 12979 : dt_sym = gfc_find_dt_in_generic (sym);
4985 :
4986 : /* Host associated PDTs can get confused with their constructors
4987 : because they are instantiated in the template's namespace. */
4988 31736 : if (!dt_sym)
4989 : {
4990 918 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4991 : {
4992 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4993 0 : return MATCH_ERROR;
4994 : }
4995 918 : if (dt_sym && !dt_sym->attr.pdt_type)
4996 0 : dt_sym = NULL;
4997 : }
4998 : }
4999 1204 : else if (ts->kind == -1)
5000 : {
5001 2408 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
5002 1204 : || gfc_current_ns->has_import_set;
5003 1204 : gfc_find_symbol (name, NULL, iface, &sym);
5004 1204 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5005 : {
5006 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5007 0 : return MATCH_ERROR;
5008 : }
5009 1204 : if (sym && sym->generic && !dt_sym)
5010 0 : dt_sym = gfc_find_dt_in_generic (sym);
5011 :
5012 1204 : ts->kind = 0;
5013 1204 : if (sym == NULL)
5014 : return MATCH_NO;
5015 : }
5016 :
5017 32923 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
5018 32221 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
5019 32921 : || sym->attr.subroutine)
5020 : {
5021 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
5022 : "entity at %L, which has the same name", name,
5023 : &sym->declared_at);
5024 2 : return MATCH_ERROR;
5025 : }
5026 :
5027 32921 : if (dt_sym && decl_type_param_list
5028 889 : && dt_sym->attr.flavor == FL_DERIVED
5029 889 : && !dt_sym->attr.pdt_type
5030 231 : && !dt_sym->attr.pdt_template)
5031 : {
5032 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5033 : "list at %C may not appear", dt_sym->name);
5034 1 : return MATCH_ERROR;
5035 : }
5036 :
5037 32920 : if (sym && sym->attr.flavor == FL_DERIVED
5038 : && sym->attr.pdt_template
5039 : && gfc_current_state () != COMP_DERIVED)
5040 : {
5041 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5042 : if (m != MATCH_YES)
5043 : return m;
5044 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5045 : ts->u.derived = sym;
5046 : strcpy (name, gfc_dt_lower_string (sym->name));
5047 : }
5048 :
5049 32920 : gfc_save_symbol_data (sym);
5050 32920 : gfc_set_sym_referenced (sym);
5051 32920 : if (!sym->attr.generic
5052 32920 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5053 : return MATCH_ERROR;
5054 :
5055 32920 : if (!sym->attr.function
5056 32920 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5057 : return MATCH_ERROR;
5058 :
5059 32920 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5060 32788 : && dt_sym->attr.pdt_template
5061 241 : && gfc_current_state () != COMP_DERIVED)
5062 : {
5063 121 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5064 121 : if (m != MATCH_YES)
5065 : return m;
5066 121 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5067 : }
5068 :
5069 32920 : if (!dt_sym)
5070 : {
5071 132 : gfc_interface *intr, *head;
5072 :
5073 : /* Use upper case to save the actual derived-type symbol. */
5074 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5075 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5076 132 : head = sym->generic;
5077 132 : intr = gfc_get_interface ();
5078 132 : intr->sym = dt_sym;
5079 132 : intr->where = gfc_current_locus;
5080 132 : intr->next = head;
5081 132 : sym->generic = intr;
5082 132 : sym->attr.if_source = IFSRC_DECL;
5083 : }
5084 : else
5085 32788 : gfc_save_symbol_data (dt_sym);
5086 :
5087 32920 : gfc_set_sym_referenced (dt_sym);
5088 :
5089 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5090 33052 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5091 : return MATCH_ERROR;
5092 :
5093 32920 : ts->u.derived = dt_sym;
5094 :
5095 32920 : return MATCH_YES;
5096 :
5097 154293 : get_kind:
5098 154293 : if (matched_type
5099 154293 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5100 : "intrinsic-type-spec at %C"))
5101 : return MATCH_ERROR;
5102 :
5103 : /* For all types except double, derived and character, look for an
5104 : optional kind specifier. MATCH_NO is actually OK at this point. */
5105 154290 : if (implicit_flag == 1)
5106 : {
5107 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5108 : return MATCH_ERROR;
5109 :
5110 223 : return MATCH_YES;
5111 : }
5112 :
5113 154067 : if (gfc_current_form == FORM_FREE)
5114 : {
5115 140316 : c = gfc_peek_ascii_char ();
5116 140316 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5117 69768 : && c != ':' && c != ',')
5118 : {
5119 167 : if (matched_type && c == ')')
5120 : {
5121 3 : gfc_next_ascii_char ();
5122 3 : return MATCH_YES;
5123 : }
5124 164 : gfc_error ("Malformed type-spec at %C");
5125 164 : return MATCH_NO;
5126 : }
5127 : }
5128 :
5129 153900 : m = gfc_match_kind_spec (ts, false);
5130 153900 : if (m == MATCH_ERROR)
5131 : return MATCH_ERROR;
5132 :
5133 153864 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5134 : {
5135 106033 : m = gfc_match_old_kind_spec (ts);
5136 106033 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5137 : return MATCH_ERROR;
5138 : }
5139 :
5140 153856 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5141 : {
5142 0 : gfc_error ("Malformed type-spec at %C");
5143 0 : return MATCH_ERROR;
5144 : }
5145 :
5146 : /* Defer association of the KIND expression of function results
5147 : until after USE and IMPORT statements. */
5148 4464 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5149 158293 : || gfc_matching_function)
5150 7073 : return MATCH_YES;
5151 :
5152 146783 : if (m == MATCH_NO)
5153 149494 : m = MATCH_YES; /* No kind specifier found. */
5154 :
5155 : return m;
5156 : }
5157 :
5158 :
5159 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5160 : already matched in parse.cc, or we would not end up here in the
5161 : first place. So the only thing we need to check, is if there is
5162 : trailing garbage. If not, the match is successful. */
5163 :
5164 : match
5165 23380 : gfc_match_implicit_none (void)
5166 : {
5167 23380 : char c;
5168 23380 : match m;
5169 23380 : char name[GFC_MAX_SYMBOL_LEN + 1];
5170 23380 : bool type = false;
5171 23380 : bool external = false;
5172 23380 : locus cur_loc = gfc_current_locus;
5173 :
5174 23380 : if (gfc_current_ns->seen_implicit_none
5175 23378 : || gfc_current_ns->has_implicit_none_export)
5176 : {
5177 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5178 4 : return MATCH_ERROR;
5179 : }
5180 :
5181 23376 : gfc_gobble_whitespace ();
5182 23376 : c = gfc_peek_ascii_char ();
5183 23376 : if (c == '(')
5184 : {
5185 1065 : (void) gfc_next_ascii_char ();
5186 1065 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5187 : return MATCH_ERROR;
5188 :
5189 1064 : gfc_gobble_whitespace ();
5190 1064 : if (gfc_peek_ascii_char () == ')')
5191 : {
5192 1 : (void) gfc_next_ascii_char ();
5193 1 : type = true;
5194 : }
5195 : else
5196 3165 : for(;;)
5197 : {
5198 2114 : m = gfc_match (" %n", name);
5199 2114 : if (m != MATCH_YES)
5200 : return MATCH_ERROR;
5201 :
5202 2114 : if (strcmp (name, "type") == 0)
5203 : type = true;
5204 1063 : else if (strcmp (name, "external") == 0)
5205 : external = true;
5206 : else
5207 : return MATCH_ERROR;
5208 :
5209 2114 : gfc_gobble_whitespace ();
5210 2114 : c = gfc_next_ascii_char ();
5211 2114 : if (c == ',')
5212 1051 : continue;
5213 1063 : if (c == ')')
5214 : break;
5215 : return MATCH_ERROR;
5216 : }
5217 : }
5218 : else
5219 : type = true;
5220 :
5221 23375 : if (gfc_match_eos () != MATCH_YES)
5222 : return MATCH_ERROR;
5223 :
5224 23375 : gfc_set_implicit_none (type, external, &cur_loc);
5225 :
5226 23375 : return MATCH_YES;
5227 : }
5228 :
5229 :
5230 : /* Match the letter range(s) of an IMPLICIT statement. */
5231 :
5232 : static match
5233 600 : match_implicit_range (void)
5234 : {
5235 600 : char c, c1, c2;
5236 600 : int inner;
5237 600 : locus cur_loc;
5238 :
5239 600 : cur_loc = gfc_current_locus;
5240 :
5241 600 : gfc_gobble_whitespace ();
5242 600 : c = gfc_next_ascii_char ();
5243 600 : if (c != '(')
5244 : {
5245 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5246 59 : goto bad;
5247 : }
5248 :
5249 : inner = 1;
5250 1195 : while (inner)
5251 : {
5252 722 : gfc_gobble_whitespace ();
5253 722 : c1 = gfc_next_ascii_char ();
5254 722 : if (!ISALPHA (c1))
5255 33 : goto bad;
5256 :
5257 689 : gfc_gobble_whitespace ();
5258 689 : c = gfc_next_ascii_char ();
5259 :
5260 689 : switch (c)
5261 : {
5262 201 : case ')':
5263 201 : inner = 0; /* Fall through. */
5264 :
5265 : case ',':
5266 : c2 = c1;
5267 : break;
5268 :
5269 439 : case '-':
5270 439 : gfc_gobble_whitespace ();
5271 439 : c2 = gfc_next_ascii_char ();
5272 439 : if (!ISALPHA (c2))
5273 0 : goto bad;
5274 :
5275 439 : gfc_gobble_whitespace ();
5276 439 : c = gfc_next_ascii_char ();
5277 :
5278 439 : if ((c != ',') && (c != ')'))
5279 0 : goto bad;
5280 439 : if (c == ')')
5281 272 : inner = 0;
5282 :
5283 : break;
5284 :
5285 35 : default:
5286 35 : goto bad;
5287 : }
5288 :
5289 654 : if (c1 > c2)
5290 : {
5291 0 : gfc_error ("Letters must be in alphabetic order in "
5292 : "IMPLICIT statement at %C");
5293 0 : goto bad;
5294 : }
5295 :
5296 : /* See if we can add the newly matched range to the pending
5297 : implicits from this IMPLICIT statement. We do not check for
5298 : conflicts with whatever earlier IMPLICIT statements may have
5299 : set. This is done when we've successfully finished matching
5300 : the current one. */
5301 654 : if (!gfc_add_new_implicit_range (c1, c2))
5302 0 : goto bad;
5303 : }
5304 :
5305 : return MATCH_YES;
5306 :
5307 127 : bad:
5308 127 : gfc_syntax_error (ST_IMPLICIT);
5309 :
5310 127 : gfc_current_locus = cur_loc;
5311 127 : return MATCH_ERROR;
5312 : }
5313 :
5314 :
5315 : /* Match an IMPLICIT statement, storing the types for
5316 : gfc_set_implicit() if the statement is accepted by the parser.
5317 : There is a strange looking, but legal syntactic construction
5318 : possible. It looks like:
5319 :
5320 : IMPLICIT INTEGER (a-b) (c-d)
5321 :
5322 : This is legal if "a-b" is a constant expression that happens to
5323 : equal one of the legal kinds for integers. The real problem
5324 : happens with an implicit specification that looks like:
5325 :
5326 : IMPLICIT INTEGER (a-b)
5327 :
5328 : In this case, a typespec matcher that is "greedy" (as most of the
5329 : matchers are) gobbles the character range as a kindspec, leaving
5330 : nothing left. We therefore have to go a bit more slowly in the
5331 : matching process by inhibiting the kindspec checking during
5332 : typespec matching and checking for a kind later. */
5333 :
5334 : match
5335 23806 : gfc_match_implicit (void)
5336 : {
5337 23806 : gfc_typespec ts;
5338 23806 : locus cur_loc;
5339 23806 : char c;
5340 23806 : match m;
5341 :
5342 23806 : if (gfc_current_ns->seen_implicit_none)
5343 : {
5344 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5345 : "statement");
5346 4 : return MATCH_ERROR;
5347 : }
5348 :
5349 23802 : gfc_clear_ts (&ts);
5350 :
5351 : /* We don't allow empty implicit statements. */
5352 23802 : if (gfc_match_eos () == MATCH_YES)
5353 : {
5354 0 : gfc_error ("Empty IMPLICIT statement at %C");
5355 0 : return MATCH_ERROR;
5356 : }
5357 :
5358 23831 : do
5359 : {
5360 : /* First cleanup. */
5361 23831 : gfc_clear_new_implicit ();
5362 :
5363 : /* A basic type is mandatory here. */
5364 23831 : m = gfc_match_decl_type_spec (&ts, 1);
5365 23831 : if (m == MATCH_ERROR)
5366 0 : goto error;
5367 23831 : if (m == MATCH_NO)
5368 23378 : goto syntax;
5369 :
5370 453 : cur_loc = gfc_current_locus;
5371 453 : m = match_implicit_range ();
5372 :
5373 453 : if (m == MATCH_YES)
5374 : {
5375 : /* We may have <TYPE> (<RANGE>). */
5376 326 : gfc_gobble_whitespace ();
5377 326 : c = gfc_peek_ascii_char ();
5378 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5379 : {
5380 : /* Check for CHARACTER with no length parameter. */
5381 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5382 : {
5383 32 : ts.kind = gfc_default_character_kind;
5384 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5385 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5386 : NULL, 1);
5387 : }
5388 :
5389 : /* Record the Successful match. */
5390 299 : if (!gfc_merge_new_implicit (&ts))
5391 : return MATCH_ERROR;
5392 297 : if (c == ',')
5393 28 : c = gfc_next_ascii_char ();
5394 269 : else if (gfc_match_eos () == MATCH_ERROR)
5395 0 : goto error;
5396 297 : continue;
5397 : }
5398 :
5399 27 : gfc_current_locus = cur_loc;
5400 : }
5401 :
5402 : /* Discard the (incorrectly) matched range. */
5403 154 : gfc_clear_new_implicit ();
5404 :
5405 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5406 154 : if (ts.type == BT_CHARACTER)
5407 74 : m = gfc_match_char_spec (&ts);
5408 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5409 : {
5410 76 : m = gfc_match_kind_spec (&ts, false);
5411 76 : if (m == MATCH_NO)
5412 : {
5413 40 : m = gfc_match_old_kind_spec (&ts);
5414 40 : if (m == MATCH_ERROR)
5415 0 : goto error;
5416 40 : if (m == MATCH_NO)
5417 0 : goto syntax;
5418 : }
5419 : }
5420 154 : if (m == MATCH_ERROR)
5421 7 : goto error;
5422 :
5423 147 : m = match_implicit_range ();
5424 147 : if (m == MATCH_ERROR)
5425 0 : goto error;
5426 147 : if (m == MATCH_NO)
5427 : goto syntax;
5428 :
5429 147 : gfc_gobble_whitespace ();
5430 147 : c = gfc_next_ascii_char ();
5431 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5432 0 : goto syntax;
5433 :
5434 147 : if (!gfc_merge_new_implicit (&ts))
5435 : return MATCH_ERROR;
5436 : }
5437 444 : while (c == ',');
5438 :
5439 : return MATCH_YES;
5440 :
5441 23378 : syntax:
5442 23378 : gfc_syntax_error (ST_IMPLICIT);
5443 :
5444 : error:
5445 : return MATCH_ERROR;
5446 : }
5447 :
5448 :
5449 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5450 :
5451 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5452 :
5453 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5454 :
5455 : C1211 (R1209) Each import-name shall be the name of an entity in the
5456 : host scoping unit.
5457 :
5458 : under the description of an interface block. Under F2008, IMPORT was
5459 : split out of the interface block description to 12.4.3.3 and C1210
5460 : became
5461 :
5462 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5463 : that is not a module procedure interface body.
5464 :
5465 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5466 :
5467 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5468 : or IMPORT, ONLY : import-name-list
5469 : or IMPORT, NONE
5470 : or IMPORT, ALL
5471 :
5472 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5473 : a main-program, external-subprogram, module, or block-data.
5474 :
5475 : C897 (R867) Each import-name shall be the name of an entity in the host
5476 : scoping unit.
5477 :
5478 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5479 : all IMPORT statements in that scoping unit shall have an ONLY
5480 : specifier.
5481 :
5482 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5483 :
5484 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5485 : unit, no other IMPORT statement shall appear in that scoping unit.
5486 :
5487 : C8101 Within an interface body, an entity that is accessed by host
5488 : association shall be accessible by host or use association within
5489 : the host scoping unit, or explicitly declared prior to the interface
5490 : body.
5491 :
5492 : C8102 An entity whose name appears as an import-name or which is made
5493 : accessible by an IMPORT, ALL statement shall not appear in any
5494 : context described in 19.5.1.4 that would cause the host entity
5495 : of that name to be inaccessible. */
5496 :
5497 : match
5498 3909 : gfc_match_import (void)
5499 : {
5500 3909 : char name[GFC_MAX_SYMBOL_LEN + 1];
5501 3909 : match m;
5502 3909 : gfc_symbol *sym;
5503 3909 : gfc_symtree *st;
5504 3909 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5505 3909 : importstate current_import_state = gfc_current_ns->import_state;
5506 :
5507 3909 : if (!f2018_allowed
5508 13 : && (gfc_current_ns->proc_name == NULL
5509 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5510 : {
5511 3 : gfc_error ("IMPORT statement at %C only permitted in "
5512 : "an INTERFACE body");
5513 3 : return MATCH_ERROR;
5514 : }
5515 : else if (f2018_allowed
5516 3896 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5517 4 : goto C897;
5518 :
5519 3892 : if (f2018_allowed
5520 3892 : && (current_import_state == IMPORT_ALL
5521 3892 : || current_import_state == IMPORT_NONE))
5522 2 : goto C8100;
5523 :
5524 3900 : if (gfc_current_ns->proc_name
5525 3899 : && gfc_current_ns->proc_name->attr.module_procedure)
5526 : {
5527 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5528 : "in a module procedure interface body");
5529 1 : return MATCH_ERROR;
5530 : }
5531 :
5532 3899 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5533 : return MATCH_ERROR;
5534 :
5535 3895 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5536 3895 : if (f2018_allowed)
5537 : {
5538 3889 : if (gfc_match (" , none") == MATCH_YES)
5539 : {
5540 8 : if (current_import_state == IMPORT_ONLY)
5541 0 : goto C898;
5542 8 : if (gfc_current_state () == COMP_SUBMODULE)
5543 0 : goto C899;
5544 8 : gfc_current_ns->import_state = IMPORT_NONE;
5545 : }
5546 3881 : else if (gfc_match (" , only :") == MATCH_YES)
5547 : {
5548 19 : if (current_import_state != IMPORT_NOT_SET
5549 19 : && current_import_state != IMPORT_ONLY)
5550 0 : goto C898;
5551 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5552 : }
5553 3862 : else if (gfc_match (" , all") == MATCH_YES)
5554 : {
5555 1 : if (current_import_state == IMPORT_ONLY)
5556 0 : goto C898;
5557 1 : gfc_current_ns->import_state = IMPORT_ALL;
5558 : }
5559 :
5560 3889 : if (current_import_state != IMPORT_NOT_SET
5561 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5562 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5563 0 : goto C8100;
5564 : }
5565 :
5566 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5567 3895 : if (gfc_match_eos () == MATCH_YES)
5568 : {
5569 : /* This is the F2008 variant. */
5570 227 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5571 : {
5572 218 : if (current_import_state == IMPORT_ONLY)
5573 0 : goto C898;
5574 218 : gfc_current_ns->import_state = IMPORT_F2008;
5575 : }
5576 :
5577 : /* Host variables should be imported. */
5578 227 : if (gfc_current_ns->import_state != IMPORT_NONE)
5579 219 : gfc_current_ns->has_import_set = 1;
5580 227 : return MATCH_YES;
5581 : }
5582 :
5583 3668 : if (gfc_match (" ::") == MATCH_YES
5584 3668 : && gfc_current_ns->import_state != IMPORT_ONLY)
5585 : {
5586 1160 : if (gfc_match_eos () == MATCH_YES)
5587 1 : goto expecting_list;
5588 1159 : gfc_current_ns->import_state = IMPORT_F2008;
5589 : }
5590 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5591 : {
5592 19 : if (gfc_match_eos () == MATCH_YES)
5593 0 : goto expecting_list;
5594 : }
5595 :
5596 4352 : for(;;)
5597 : {
5598 4352 : sym = NULL;
5599 4352 : m = gfc_match (" %n", name);
5600 4352 : switch (m)
5601 : {
5602 4352 : case MATCH_YES:
5603 : /* Before checking if the symbol is available from host
5604 : association into a SUBROUTINE or FUNCTION within an
5605 : INTERFACE, check if it is already in local scope. */
5606 4352 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5607 4352 : if (sym
5608 25 : && gfc_state_stack->previous
5609 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5610 : {
5611 2 : gfc_error ("import-name %qs at %C is in the "
5612 : "local scope", name);
5613 2 : return MATCH_ERROR;
5614 : }
5615 :
5616 4350 : if (gfc_current_ns->parent != NULL
5617 4350 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5618 : {
5619 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5620 0 : return MATCH_ERROR;
5621 : }
5622 4350 : else if (!sym
5623 5 : && gfc_current_ns->proc_name
5624 4 : && gfc_current_ns->proc_name->ns->parent
5625 4351 : && gfc_find_symbol (name,
5626 : gfc_current_ns->proc_name->ns->parent,
5627 : 1, &sym))
5628 : {
5629 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5630 0 : return MATCH_ERROR;
5631 : }
5632 :
5633 4350 : if (sym == NULL)
5634 : {
5635 5 : if (gfc_current_ns->proc_name
5636 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5637 : {
5638 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5639 : "at %C - does not exist.", name);
5640 1 : return MATCH_ERROR;
5641 : }
5642 : else
5643 : {
5644 : /* This might be a procedure that has not yet been parsed. If
5645 : so gfc_fixup_sibling_symbols will replace this symbol with
5646 : that of the procedure. */
5647 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5648 : &gfc_current_locus);
5649 4 : st->n.sym->refs++;
5650 4 : st->n.sym->attr.imported = 1;
5651 4 : st->import_only = 1;
5652 4 : goto next_item;
5653 : }
5654 : }
5655 :
5656 4345 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5657 4345 : if (st && st->n.sym && st->n.sym->attr.imported)
5658 : {
5659 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5660 : "at %C", name);
5661 0 : goto next_item;
5662 : }
5663 :
5664 4345 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5665 4345 : st->n.sym = sym;
5666 4345 : sym->refs++;
5667 4345 : sym->attr.imported = 1;
5668 4345 : st->import_only = 1;
5669 :
5670 4345 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5671 : {
5672 : /* The actual derived type is stored in a symtree with the first
5673 : letter of the name capitalized; the symtree with the all
5674 : lower-case name contains the associated generic function. */
5675 599 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5676 : gfc_dt_upper_string (name));
5677 599 : st->n.sym = sym;
5678 599 : sym->refs++;
5679 599 : sym->attr.imported = 1;
5680 599 : st->import_only = 1;
5681 : }
5682 :
5683 4345 : goto next_item;
5684 :
5685 : case MATCH_NO:
5686 : break;
5687 :
5688 : case MATCH_ERROR:
5689 : return MATCH_ERROR;
5690 : }
5691 :
5692 4349 : next_item:
5693 4349 : if (gfc_match_eos () == MATCH_YES)
5694 : break;
5695 685 : if (gfc_match_char (',') != MATCH_YES)
5696 0 : goto syntax;
5697 : }
5698 :
5699 : return MATCH_YES;
5700 :
5701 0 : syntax:
5702 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5703 0 : return MATCH_ERROR;
5704 :
5705 4 : C897:
5706 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5707 : "program, an external subprogram, a module or block data");
5708 4 : return MATCH_ERROR;
5709 :
5710 0 : C898:
5711 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5712 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5713 : "with an ONLY specifier");
5714 0 : return MATCH_ERROR;
5715 :
5716 0 : C899:
5717 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5718 : " of a submodule as at %C");
5719 0 : return MATCH_ERROR;
5720 :
5721 2 : C8100:
5722 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5723 : "%s has already been declared, which must be unique in the "
5724 : "scoping unit",
5725 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5726 : "IMPORT, NONE");
5727 2 : return MATCH_ERROR;
5728 :
5729 1 : expecting_list:
5730 1 : gfc_error ("Expecting list of named entities at %C");
5731 1 : return MATCH_ERROR;
5732 : }
5733 :
5734 :
5735 : /* A minimal implementation of gfc_match without whitespace, escape
5736 : characters or variable arguments. Returns true if the next
5737 : characters match the TARGET template exactly. */
5738 :
5739 : static bool
5740 142722 : match_string_p (const char *target)
5741 : {
5742 142722 : const char *p;
5743 :
5744 902583 : for (p = target; *p; p++)
5745 759862 : if ((char) gfc_next_ascii_char () != *p)
5746 : return false;
5747 : return true;
5748 : }
5749 :
5750 : /* Matches an attribute specification including array specs. If
5751 : successful, leaves the variables current_attr and current_as
5752 : holding the specification. Also sets the colon_seen variable for
5753 : later use by matchers associated with initializations.
5754 :
5755 : This subroutine is a little tricky in the sense that we don't know
5756 : if we really have an attr-spec until we hit the double colon.
5757 : Until that time, we can only return MATCH_NO. This forces us to
5758 : check for duplicate specification at this level. */
5759 :
5760 : static match
5761 211521 : match_attr_spec (void)
5762 : {
5763 : /* Modifiers that can exist in a type statement. */
5764 211521 : enum
5765 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5766 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5767 : DECL_DIMENSION, DECL_EXTERNAL,
5768 : DECL_INTRINSIC, DECL_OPTIONAL,
5769 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5770 : DECL_STATIC, DECL_AUTOMATIC,
5771 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5772 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5773 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5774 : };
5775 :
5776 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5777 : #define NUM_DECL GFC_DECL_END
5778 :
5779 : /* Make sure that values from sym_intent are safe to be used here. */
5780 211521 : gcc_assert (INTENT_IN > 0);
5781 :
5782 211521 : locus start, seen_at[NUM_DECL];
5783 211521 : int seen[NUM_DECL];
5784 211521 : unsigned int d;
5785 211521 : const char *attr;
5786 211521 : match m;
5787 211521 : bool t;
5788 :
5789 211521 : gfc_clear_attr (¤t_attr);
5790 211521 : start = gfc_current_locus;
5791 :
5792 211521 : current_as = NULL;
5793 211521 : colon_seen = 0;
5794 211521 : attr_seen = 0;
5795 :
5796 : /* See if we get all of the keywords up to the final double colon. */
5797 5711067 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5798 5499546 : seen[d] = 0;
5799 :
5800 327699 : for (;;)
5801 : {
5802 327699 : char ch;
5803 :
5804 327699 : d = DECL_NONE;
5805 327699 : gfc_gobble_whitespace ();
5806 :
5807 327699 : ch = gfc_next_ascii_char ();
5808 327699 : if (ch == ':')
5809 : {
5810 : /* This is the successful exit condition for the loop. */
5811 178879 : if (gfc_next_ascii_char () == ':')
5812 : break;
5813 : }
5814 148820 : else if (ch == ',')
5815 : {
5816 116190 : gfc_gobble_whitespace ();
5817 116190 : switch (gfc_peek_ascii_char ())
5818 : {
5819 18119 : case 'a':
5820 18119 : gfc_next_ascii_char ();
5821 18119 : switch (gfc_next_ascii_char ())
5822 : {
5823 18054 : case 'l':
5824 18054 : if (match_string_p ("locatable"))
5825 : {
5826 : /* Matched "allocatable". */
5827 : d = DECL_ALLOCATABLE;
5828 : }
5829 : break;
5830 :
5831 24 : case 's':
5832 24 : if (match_string_p ("ynchronous"))
5833 : {
5834 : /* Matched "asynchronous". */
5835 : d = DECL_ASYNCHRONOUS;
5836 : }
5837 : break;
5838 :
5839 41 : case 'u':
5840 41 : if (match_string_p ("tomatic"))
5841 : {
5842 : /* Matched "automatic". */
5843 : d = DECL_AUTOMATIC;
5844 : }
5845 : break;
5846 : }
5847 : break;
5848 :
5849 163 : case 'b':
5850 : /* Try and match the bind(c). */
5851 163 : m = gfc_match_bind_c (NULL, true);
5852 163 : if (m == MATCH_YES)
5853 : d = DECL_IS_BIND_C;
5854 0 : else if (m == MATCH_ERROR)
5855 0 : goto cleanup;
5856 : break;
5857 :
5858 2109 : case 'c':
5859 2109 : gfc_next_ascii_char ();
5860 2109 : if ('o' != gfc_next_ascii_char ())
5861 : break;
5862 2108 : switch (gfc_next_ascii_char ())
5863 : {
5864 68 : case 'd':
5865 68 : if (match_string_p ("imension"))
5866 : {
5867 : d = DECL_CODIMENSION;
5868 : break;
5869 : }
5870 : /* FALLTHRU */
5871 2040 : case 'n':
5872 2040 : if (match_string_p ("tiguous"))
5873 : {
5874 : d = DECL_CONTIGUOUS;
5875 : break;
5876 : }
5877 : }
5878 : break;
5879 :
5880 19574 : case 'd':
5881 19574 : if (match_string_p ("dimension"))
5882 : d = DECL_DIMENSION;
5883 : break;
5884 :
5885 177 : case 'e':
5886 177 : if (match_string_p ("external"))
5887 : d = DECL_EXTERNAL;
5888 : break;
5889 :
5890 26696 : case 'i':
5891 26696 : if (match_string_p ("int"))
5892 : {
5893 26696 : ch = gfc_next_ascii_char ();
5894 26696 : if (ch == 'e')
5895 : {
5896 26690 : if (match_string_p ("nt"))
5897 : {
5898 : /* Matched "intent". */
5899 26689 : d = match_intent_spec ();
5900 26689 : if (d == INTENT_UNKNOWN)
5901 : {
5902 2 : m = MATCH_ERROR;
5903 2 : goto cleanup;
5904 : }
5905 : }
5906 : }
5907 6 : else if (ch == 'r')
5908 : {
5909 6 : if (match_string_p ("insic"))
5910 : {
5911 : /* Matched "intrinsic". */
5912 : d = DECL_INTRINSIC;
5913 : }
5914 : }
5915 : }
5916 : break;
5917 :
5918 286 : case 'k':
5919 286 : if (match_string_p ("kind"))
5920 : d = DECL_KIND;
5921 : break;
5922 :
5923 299 : case 'l':
5924 299 : if (match_string_p ("len"))
5925 : d = DECL_LEN;
5926 : break;
5927 :
5928 5042 : case 'o':
5929 5042 : if (match_string_p ("optional"))
5930 : d = DECL_OPTIONAL;
5931 : break;
5932 :
5933 26728 : case 'p':
5934 26728 : gfc_next_ascii_char ();
5935 26728 : switch (gfc_next_ascii_char ())
5936 : {
5937 14096 : case 'a':
5938 14096 : if (match_string_p ("rameter"))
5939 : {
5940 : /* Matched "parameter". */
5941 : d = DECL_PARAMETER;
5942 : }
5943 : break;
5944 :
5945 12113 : case 'o':
5946 12113 : if (match_string_p ("inter"))
5947 : {
5948 : /* Matched "pointer". */
5949 : d = DECL_POINTER;
5950 : }
5951 : break;
5952 :
5953 267 : case 'r':
5954 267 : ch = gfc_next_ascii_char ();
5955 267 : if (ch == 'i')
5956 : {
5957 216 : if (match_string_p ("vate"))
5958 : {
5959 : /* Matched "private". */
5960 : d = DECL_PRIVATE;
5961 : }
5962 : }
5963 51 : else if (ch == 'o')
5964 : {
5965 51 : if (match_string_p ("tected"))
5966 : {
5967 : /* Matched "protected". */
5968 : d = DECL_PROTECTED;
5969 : }
5970 : }
5971 : break;
5972 :
5973 252 : case 'u':
5974 252 : if (match_string_p ("blic"))
5975 : {
5976 : /* Matched "public". */
5977 : d = DECL_PUBLIC;
5978 : }
5979 : break;
5980 : }
5981 : break;
5982 :
5983 1210 : case 's':
5984 1210 : gfc_next_ascii_char ();
5985 1210 : switch (gfc_next_ascii_char ())
5986 : {
5987 1197 : case 'a':
5988 1197 : if (match_string_p ("ve"))
5989 : {
5990 : /* Matched "save". */
5991 : d = DECL_SAVE;
5992 : }
5993 : break;
5994 :
5995 13 : case 't':
5996 13 : if (match_string_p ("atic"))
5997 : {
5998 : /* Matched "static". */
5999 : d = DECL_STATIC;
6000 : }
6001 : break;
6002 : }
6003 : break;
6004 :
6005 5275 : case 't':
6006 5275 : if (match_string_p ("target"))
6007 : d = DECL_TARGET;
6008 : break;
6009 :
6010 10512 : case 'v':
6011 10512 : gfc_next_ascii_char ();
6012 10512 : ch = gfc_next_ascii_char ();
6013 10512 : if (ch == 'a')
6014 : {
6015 10005 : if (match_string_p ("lue"))
6016 : {
6017 : /* Matched "value". */
6018 : d = DECL_VALUE;
6019 : }
6020 : }
6021 507 : else if (ch == 'o')
6022 : {
6023 507 : if (match_string_p ("latile"))
6024 : {
6025 : /* Matched "volatile". */
6026 : d = DECL_VOLATILE;
6027 : }
6028 : }
6029 : break;
6030 : }
6031 : }
6032 :
6033 : /* No double colon and no recognizable decl_type, so assume that
6034 : we've been looking at something else the whole time. */
6035 : if (d == DECL_NONE)
6036 : {
6037 32633 : m = MATCH_NO;
6038 32633 : goto cleanup;
6039 : }
6040 :
6041 : /* Check to make sure any parens are paired up correctly. */
6042 116186 : if (gfc_match_parens () == MATCH_ERROR)
6043 : {
6044 1 : m = MATCH_ERROR;
6045 1 : goto cleanup;
6046 : }
6047 :
6048 116185 : seen[d]++;
6049 116185 : seen_at[d] = gfc_current_locus;
6050 :
6051 116185 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6052 : {
6053 19641 : gfc_array_spec *as = NULL;
6054 :
6055 19641 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6056 : d == DECL_CODIMENSION);
6057 :
6058 19641 : if (current_as == NULL)
6059 19616 : current_as = as;
6060 25 : else if (m == MATCH_YES)
6061 : {
6062 25 : if (!merge_array_spec (as, current_as, false))
6063 2 : m = MATCH_ERROR;
6064 25 : free (as);
6065 : }
6066 :
6067 19641 : if (m == MATCH_NO)
6068 : {
6069 0 : if (d == DECL_CODIMENSION)
6070 0 : gfc_error ("Missing codimension specification at %C");
6071 : else
6072 0 : gfc_error ("Missing dimension specification at %C");
6073 : m = MATCH_ERROR;
6074 : }
6075 :
6076 19641 : if (m == MATCH_ERROR)
6077 7 : goto cleanup;
6078 : }
6079 : }
6080 :
6081 : /* Since we've seen a double colon, we have to be looking at an
6082 : attr-spec. This means that we can now issue errors. */
6083 4829685 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6084 4650809 : if (seen[d] > 1)
6085 : {
6086 2 : switch (d)
6087 : {
6088 : case DECL_ALLOCATABLE:
6089 : attr = "ALLOCATABLE";
6090 : break;
6091 0 : case DECL_ASYNCHRONOUS:
6092 0 : attr = "ASYNCHRONOUS";
6093 0 : break;
6094 0 : case DECL_CODIMENSION:
6095 0 : attr = "CODIMENSION";
6096 0 : break;
6097 0 : case DECL_CONTIGUOUS:
6098 0 : attr = "CONTIGUOUS";
6099 0 : break;
6100 0 : case DECL_DIMENSION:
6101 0 : attr = "DIMENSION";
6102 0 : break;
6103 0 : case DECL_EXTERNAL:
6104 0 : attr = "EXTERNAL";
6105 0 : break;
6106 0 : case DECL_IN:
6107 0 : attr = "INTENT (IN)";
6108 0 : break;
6109 0 : case DECL_OUT:
6110 0 : attr = "INTENT (OUT)";
6111 0 : break;
6112 0 : case DECL_INOUT:
6113 0 : attr = "INTENT (IN OUT)";
6114 0 : break;
6115 0 : case DECL_INTRINSIC:
6116 0 : attr = "INTRINSIC";
6117 0 : break;
6118 0 : case DECL_OPTIONAL:
6119 0 : attr = "OPTIONAL";
6120 0 : break;
6121 0 : case DECL_KIND:
6122 0 : attr = "KIND";
6123 0 : break;
6124 0 : case DECL_LEN:
6125 0 : attr = "LEN";
6126 0 : break;
6127 0 : case DECL_PARAMETER:
6128 0 : attr = "PARAMETER";
6129 0 : break;
6130 0 : case DECL_POINTER:
6131 0 : attr = "POINTER";
6132 0 : break;
6133 0 : case DECL_PROTECTED:
6134 0 : attr = "PROTECTED";
6135 0 : break;
6136 0 : case DECL_PRIVATE:
6137 0 : attr = "PRIVATE";
6138 0 : break;
6139 0 : case DECL_PUBLIC:
6140 0 : attr = "PUBLIC";
6141 0 : break;
6142 0 : case DECL_SAVE:
6143 0 : attr = "SAVE";
6144 0 : break;
6145 0 : case DECL_STATIC:
6146 0 : attr = "STATIC";
6147 0 : break;
6148 1 : case DECL_AUTOMATIC:
6149 1 : attr = "AUTOMATIC";
6150 1 : break;
6151 0 : case DECL_TARGET:
6152 0 : attr = "TARGET";
6153 0 : break;
6154 0 : case DECL_IS_BIND_C:
6155 0 : attr = "IS_BIND_C";
6156 0 : break;
6157 0 : case DECL_VALUE:
6158 0 : attr = "VALUE";
6159 0 : break;
6160 1 : case DECL_VOLATILE:
6161 1 : attr = "VOLATILE";
6162 1 : break;
6163 0 : default:
6164 0 : attr = NULL; /* This shouldn't happen. */
6165 : }
6166 :
6167 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6168 2 : m = MATCH_ERROR;
6169 2 : goto cleanup;
6170 : }
6171 :
6172 : /* Now that we've dealt with duplicate attributes, add the attributes
6173 : to the current attribute. */
6174 4828865 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6175 : {
6176 4650062 : if (seen[d] == 0)
6177 4533893 : continue;
6178 : else
6179 116169 : attr_seen = 1;
6180 :
6181 116169 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6182 52 : && !flag_dec_static)
6183 : {
6184 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6185 : "%<-fdec-static%>",
6186 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6187 2 : m = MATCH_ERROR;
6188 2 : goto cleanup;
6189 : }
6190 : /* Allow SAVE with STATIC, but don't complain. */
6191 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6192 0 : continue;
6193 :
6194 116167 : if (gfc_comp_struct (gfc_current_state ())
6195 6655 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6196 5703 : && d != DECL_POINTER && d != DECL_PRIVATE
6197 4063 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6198 : {
6199 4006 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6200 4006 : if (d == DECL_ALLOCATABLE)
6201 : {
6202 3408 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6203 : ? G_("ALLOCATABLE attribute at %C in a "
6204 : "TYPE definition")
6205 : : G_("ALLOCATABLE attribute at %C in a "
6206 : "STRUCTURE definition")))
6207 : {
6208 2 : m = MATCH_ERROR;
6209 2 : goto cleanup;
6210 : }
6211 : }
6212 598 : else if (d == DECL_KIND)
6213 : {
6214 284 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6215 : ? G_("KIND attribute at %C in a "
6216 : "TYPE definition")
6217 : : G_("KIND attribute at %C in a "
6218 : "STRUCTURE definition")))
6219 : {
6220 1 : m = MATCH_ERROR;
6221 1 : goto cleanup;
6222 : }
6223 283 : if (current_ts.type != BT_INTEGER)
6224 : {
6225 2 : gfc_error ("Component with KIND attribute at %C must be "
6226 : "INTEGER");
6227 2 : m = MATCH_ERROR;
6228 2 : goto cleanup;
6229 : }
6230 : }
6231 314 : else if (d == DECL_LEN)
6232 : {
6233 298 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6234 : ? G_("LEN attribute at %C in a "
6235 : "TYPE definition")
6236 : : G_("LEN attribute at %C in a "
6237 : "STRUCTURE definition")))
6238 : {
6239 0 : m = MATCH_ERROR;
6240 0 : goto cleanup;
6241 : }
6242 298 : if (current_ts.type != BT_INTEGER)
6243 : {
6244 1 : gfc_error ("Component with LEN attribute at %C must be "
6245 : "INTEGER");
6246 1 : m = MATCH_ERROR;
6247 1 : goto cleanup;
6248 : }
6249 : }
6250 : else
6251 : {
6252 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6253 : "TYPE definition")
6254 : : G_("Attribute at %L is not allowed in a "
6255 : "STRUCTURE definition"), &seen_at[d]);
6256 16 : m = MATCH_ERROR;
6257 16 : goto cleanup;
6258 : }
6259 : }
6260 :
6261 116145 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6262 468 : && gfc_current_state () != COMP_MODULE)
6263 : {
6264 147 : if (d == DECL_PRIVATE)
6265 : attr = "PRIVATE";
6266 : else
6267 43 : attr = "PUBLIC";
6268 147 : if (gfc_current_state () == COMP_DERIVED
6269 141 : && gfc_state_stack->previous
6270 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6271 : {
6272 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6273 : "at %L in a TYPE definition", attr,
6274 : &seen_at[d]))
6275 : {
6276 2 : m = MATCH_ERROR;
6277 2 : goto cleanup;
6278 : }
6279 : }
6280 : else
6281 : {
6282 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6283 : "specification part of a module", attr, &seen_at[d]);
6284 9 : m = MATCH_ERROR;
6285 9 : goto cleanup;
6286 : }
6287 : }
6288 :
6289 116134 : if (gfc_current_state () != COMP_DERIVED
6290 109510 : && (d == DECL_KIND || d == DECL_LEN))
6291 : {
6292 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6293 : "definition", &seen_at[d]);
6294 3 : m = MATCH_ERROR;
6295 3 : goto cleanup;
6296 : }
6297 :
6298 116131 : switch (d)
6299 : {
6300 18052 : case DECL_ALLOCATABLE:
6301 18052 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6302 18052 : break;
6303 :
6304 23 : case DECL_ASYNCHRONOUS:
6305 23 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6306 : t = false;
6307 : else
6308 23 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6309 : break;
6310 :
6311 66 : case DECL_CODIMENSION:
6312 66 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6313 66 : break;
6314 :
6315 2040 : case DECL_CONTIGUOUS:
6316 2040 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6317 : t = false;
6318 : else
6319 2039 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6320 : break;
6321 :
6322 19566 : case DECL_DIMENSION:
6323 19566 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6324 19566 : break;
6325 :
6326 176 : case DECL_EXTERNAL:
6327 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6328 176 : break;
6329 :
6330 20141 : case DECL_IN:
6331 20141 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6332 20141 : break;
6333 :
6334 3571 : case DECL_OUT:
6335 3571 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6336 3571 : break;
6337 :
6338 2971 : case DECL_INOUT:
6339 2971 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6340 2971 : break;
6341 :
6342 5 : case DECL_INTRINSIC:
6343 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6344 5 : break;
6345 :
6346 5041 : case DECL_OPTIONAL:
6347 5041 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6348 5041 : break;
6349 :
6350 281 : case DECL_KIND:
6351 281 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6352 281 : break;
6353 :
6354 297 : case DECL_LEN:
6355 297 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6356 297 : break;
6357 :
6358 14095 : case DECL_PARAMETER:
6359 14095 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6360 14095 : break;
6361 :
6362 12112 : case DECL_POINTER:
6363 12112 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6364 12112 : break;
6365 :
6366 50 : case DECL_PROTECTED:
6367 50 : if (gfc_current_state () != COMP_MODULE
6368 48 : || (gfc_current_ns->proc_name
6369 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6370 : {
6371 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6372 : "part of a module");
6373 2 : t = false;
6374 2 : break;
6375 : }
6376 :
6377 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6378 : t = false;
6379 : else
6380 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6381 : break;
6382 :
6383 213 : case DECL_PRIVATE:
6384 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6385 : &seen_at[d]);
6386 213 : break;
6387 :
6388 244 : case DECL_PUBLIC:
6389 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6390 : &seen_at[d]);
6391 244 : break;
6392 :
6393 1207 : case DECL_STATIC:
6394 1207 : case DECL_SAVE:
6395 1207 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6396 1207 : break;
6397 :
6398 37 : case DECL_AUTOMATIC:
6399 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6400 37 : break;
6401 :
6402 5273 : case DECL_TARGET:
6403 5273 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6404 5273 : break;
6405 :
6406 162 : case DECL_IS_BIND_C:
6407 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6408 162 : break;
6409 :
6410 10004 : case DECL_VALUE:
6411 10004 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6412 : t = false;
6413 : else
6414 10004 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6415 : break;
6416 :
6417 504 : case DECL_VOLATILE:
6418 504 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6419 : t = false;
6420 : else
6421 503 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6422 : break;
6423 :
6424 0 : default:
6425 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6426 : }
6427 :
6428 116125 : if (!t)
6429 : {
6430 35 : m = MATCH_ERROR;
6431 35 : goto cleanup;
6432 : }
6433 : }
6434 :
6435 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6436 178803 : if ((gfc_current_state () == COMP_MODULE
6437 178803 : || gfc_current_state () == COMP_SUBMODULE)
6438 5686 : && !current_attr.save
6439 5504 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6440 5412 : current_attr.save = SAVE_IMPLICIT;
6441 :
6442 178803 : colon_seen = 1;
6443 178803 : return MATCH_YES;
6444 :
6445 32718 : cleanup:
6446 32718 : gfc_current_locus = start;
6447 32718 : gfc_free_array_spec (current_as);
6448 32718 : current_as = NULL;
6449 32718 : attr_seen = 0;
6450 32718 : return m;
6451 : }
6452 :
6453 :
6454 : /* Set the binding label, dest_label, either with the binding label
6455 : stored in the given gfc_typespec, ts, or if none was provided, it
6456 : will be the symbol name in all lower case, as required by the draft
6457 : (J3/04-007, section 15.4.1). If a binding label was given and
6458 : there is more than one argument (num_idents), it is an error. */
6459 :
6460 : static bool
6461 310 : set_binding_label (const char **dest_label, const char *sym_name,
6462 : int num_idents)
6463 : {
6464 310 : if (num_idents > 1 && has_name_equals)
6465 : {
6466 4 : gfc_error ("Multiple identifiers provided with "
6467 : "single NAME= specifier at %C");
6468 4 : return false;
6469 : }
6470 :
6471 306 : if (curr_binding_label)
6472 : /* Binding label given; store in temp holder till have sym. */
6473 107 : *dest_label = curr_binding_label;
6474 : else
6475 : {
6476 : /* No binding label given, and the NAME= specifier did not exist,
6477 : which means there was no NAME="". */
6478 199 : if (sym_name != NULL && has_name_equals == 0)
6479 169 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6480 : }
6481 :
6482 : return true;
6483 : }
6484 :
6485 :
6486 : /* Set the status of the given common block as being BIND(C) or not,
6487 : depending on the given parameter, is_bind_c. */
6488 :
6489 : static void
6490 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6491 : {
6492 76 : com_block->is_bind_c = is_bind_c;
6493 76 : return;
6494 : }
6495 :
6496 :
6497 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6498 :
6499 : bool
6500 19897 : gfc_verify_c_interop (gfc_typespec *ts)
6501 : {
6502 19897 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6503 4276 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6504 8509 : ? true : false;
6505 15637 : else if (ts->type == BT_CLASS)
6506 : return false;
6507 15629 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6508 3898 : return false;
6509 :
6510 : return true;
6511 : }
6512 :
6513 :
6514 : /* Verify that the variables of a given common block, which has been
6515 : defined with the attribute specifier bind(c), to be of a C
6516 : interoperable type. Errors will be reported here, if
6517 : encountered. */
6518 :
6519 : bool
6520 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6521 : {
6522 1 : gfc_symbol *curr_sym = NULL;
6523 1 : bool retval = true;
6524 :
6525 1 : curr_sym = com_block->head;
6526 :
6527 : /* Make sure we have at least one symbol. */
6528 1 : if (curr_sym == NULL)
6529 : return retval;
6530 :
6531 : /* Here we know we have a symbol, so we'll execute this loop
6532 : at least once. */
6533 1 : do
6534 : {
6535 : /* The second to last param, 1, says this is in a common block. */
6536 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6537 1 : curr_sym = curr_sym->common_next;
6538 1 : } while (curr_sym != NULL);
6539 :
6540 : return retval;
6541 : }
6542 :
6543 :
6544 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6545 : an appropriate error message is reported. */
6546 :
6547 : bool
6548 6747 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6549 : int is_in_common, gfc_common_head *com_block)
6550 : {
6551 6747 : bool bind_c_function = false;
6552 6747 : bool retval = true;
6553 :
6554 6747 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6555 6747 : bind_c_function = true;
6556 :
6557 6747 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6558 : {
6559 2584 : tmp_sym = tmp_sym->result;
6560 : /* Make sure it wasn't an implicitly typed result. */
6561 2584 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6562 : {
6563 1 : gfc_warning (OPT_Wc_binding_type,
6564 : "Implicitly declared BIND(C) function %qs at "
6565 : "%L may not be C interoperable", tmp_sym->name,
6566 : &tmp_sym->declared_at);
6567 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6568 : /* Mark it as C interoperable to prevent duplicate warnings. */
6569 1 : tmp_sym->ts.is_c_interop = 1;
6570 1 : tmp_sym->attr.is_c_interop = 1;
6571 : }
6572 : }
6573 :
6574 : /* Here, we know we have the bind(c) attribute, so if we have
6575 : enough type info, then verify that it's a C interop kind.
6576 : The info could be in the symbol already, or possibly still in
6577 : the given ts (current_ts), so look in both. */
6578 6747 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6579 : {
6580 2742 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6581 : {
6582 : /* See if we're dealing with a sym in a common block or not. */
6583 163 : if (is_in_common == 1 && warn_c_binding_type)
6584 : {
6585 0 : gfc_warning (OPT_Wc_binding_type,
6586 : "Variable %qs in common block %qs at %L "
6587 : "may not be a C interoperable "
6588 : "kind though common block %qs is BIND(C)",
6589 : tmp_sym->name, com_block->name,
6590 0 : &(tmp_sym->declared_at), com_block->name);
6591 : }
6592 : else
6593 : {
6594 163 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6595 161 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6596 : {
6597 3 : gfc_error ("Type declaration %qs at %L is not C "
6598 : "interoperable but it is BIND(C)",
6599 : tmp_sym->name, &(tmp_sym->declared_at));
6600 3 : retval = false;
6601 : }
6602 160 : else if (warn_c_binding_type)
6603 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6604 : "may not be a C interoperable "
6605 : "kind but it is BIND(C)",
6606 : tmp_sym->name, &(tmp_sym->declared_at));
6607 : }
6608 : }
6609 :
6610 : /* Variables declared w/in a common block can't be bind(c)
6611 : since there's no way for C to see these variables, so there's
6612 : semantically no reason for the attribute. */
6613 2742 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6614 : {
6615 1 : gfc_error ("Variable %qs in common block %qs at "
6616 : "%L cannot be declared with BIND(C) "
6617 : "since it is not a global",
6618 1 : tmp_sym->name, com_block->name,
6619 : &(tmp_sym->declared_at));
6620 1 : retval = false;
6621 : }
6622 :
6623 : /* Scalar variables that are bind(c) cannot have the pointer
6624 : or allocatable attributes. */
6625 2742 : if (tmp_sym->attr.is_bind_c == 1)
6626 : {
6627 2222 : if (tmp_sym->attr.pointer == 1)
6628 : {
6629 1 : gfc_error ("Variable %qs at %L cannot have both the "
6630 : "POINTER and BIND(C) attributes",
6631 : tmp_sym->name, &(tmp_sym->declared_at));
6632 1 : retval = false;
6633 : }
6634 :
6635 2222 : if (tmp_sym->attr.allocatable == 1)
6636 : {
6637 0 : gfc_error ("Variable %qs at %L cannot have both the "
6638 : "ALLOCATABLE and BIND(C) attributes",
6639 : tmp_sym->name, &(tmp_sym->declared_at));
6640 0 : retval = false;
6641 : }
6642 :
6643 : }
6644 :
6645 : /* If it is a BIND(C) function, make sure the return value is a
6646 : scalar value. The previous tests in this function made sure
6647 : the type is interoperable. */
6648 2742 : if (bind_c_function && tmp_sym->as != NULL)
6649 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6650 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6651 :
6652 : /* BIND(C) functions cannot return a character string. */
6653 2584 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6654 68 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6655 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6656 : "type at %L must have length 1", tmp_sym->name,
6657 : &(tmp_sym->declared_at));
6658 : }
6659 :
6660 : /* See if the symbol has been marked as private. If it has, warn if
6661 : there is a binding label with default binding name. */
6662 6747 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6663 11 : && tmp_sym->binding_label
6664 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6665 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6666 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6667 4 : gfc_warning (OPT_Wsurprising,
6668 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6669 : "via its default binding name %qs", tmp_sym->name,
6670 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6671 :
6672 6747 : return retval;
6673 : }
6674 :
6675 :
6676 : /* Set the appropriate fields for a symbol that's been declared as
6677 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6678 : the type is C interoperable. Errors are reported by the functions
6679 : used to set/test these fields. */
6680 :
6681 : static bool
6682 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6683 : {
6684 47 : bool retval = true;
6685 :
6686 : /* TODO: Do we need to make sure the vars aren't marked private? */
6687 :
6688 : /* Set the is_bind_c bit in symbol_attribute. */
6689 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6690 :
6691 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6692 : return false;
6693 :
6694 : return retval;
6695 : }
6696 :
6697 :
6698 : /* Set the fields marking the given common block as BIND(C), including
6699 : a binding label, and report any errors encountered. */
6700 :
6701 : static bool
6702 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6703 : {
6704 76 : bool retval = true;
6705 :
6706 : /* destLabel, common name, typespec (which may have binding label). */
6707 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6708 : num_idents))
6709 : return false;
6710 :
6711 : /* Set the given common block (com_block) to being bind(c) (1). */
6712 76 : set_com_block_bind_c (com_block, 1);
6713 :
6714 76 : return retval;
6715 : }
6716 :
6717 :
6718 : /* Retrieve the list of one or more identifiers that the given bind(c)
6719 : attribute applies to. */
6720 :
6721 : static bool
6722 102 : get_bind_c_idents (void)
6723 : {
6724 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6725 102 : int num_idents = 0;
6726 102 : gfc_symbol *tmp_sym = NULL;
6727 102 : match found_id;
6728 102 : gfc_common_head *com_block = NULL;
6729 :
6730 102 : if (gfc_match_name (name) == MATCH_YES)
6731 : {
6732 38 : found_id = MATCH_YES;
6733 38 : gfc_get_ha_symbol (name, &tmp_sym);
6734 : }
6735 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6736 : {
6737 64 : found_id = MATCH_YES;
6738 64 : com_block = gfc_get_common (name, 0);
6739 : }
6740 : else
6741 : {
6742 0 : gfc_error ("Need either entity or common block name for "
6743 : "attribute specification statement at %C");
6744 0 : return false;
6745 : }
6746 :
6747 : /* Save the current identifier and look for more. */
6748 123 : do
6749 : {
6750 : /* Increment the number of identifiers found for this spec stmt. */
6751 123 : num_idents++;
6752 :
6753 : /* Make sure we have a sym or com block, and verify that it can
6754 : be bind(c). Set the appropriate field(s) and look for more
6755 : identifiers. */
6756 123 : if (tmp_sym != NULL || com_block != NULL)
6757 : {
6758 123 : if (tmp_sym != NULL)
6759 : {
6760 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6761 : return false;
6762 : }
6763 : else
6764 : {
6765 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6766 : return false;
6767 : }
6768 :
6769 : /* Look to see if we have another identifier. */
6770 122 : tmp_sym = NULL;
6771 122 : if (gfc_match_eos () == MATCH_YES)
6772 : found_id = MATCH_NO;
6773 21 : else if (gfc_match_char (',') != MATCH_YES)
6774 : found_id = MATCH_NO;
6775 21 : else if (gfc_match_name (name) == MATCH_YES)
6776 : {
6777 9 : found_id = MATCH_YES;
6778 9 : gfc_get_ha_symbol (name, &tmp_sym);
6779 : }
6780 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6781 : {
6782 12 : found_id = MATCH_YES;
6783 12 : com_block = gfc_get_common (name, 0);
6784 : }
6785 : else
6786 : {
6787 0 : gfc_error ("Missing entity or common block name for "
6788 : "attribute specification statement at %C");
6789 0 : return false;
6790 : }
6791 : }
6792 : else
6793 : {
6794 0 : gfc_internal_error ("Missing symbol");
6795 : }
6796 122 : } while (found_id == MATCH_YES);
6797 :
6798 : /* if we get here we were successful */
6799 : return true;
6800 : }
6801 :
6802 :
6803 : /* Try and match a BIND(C) attribute specification statement. */
6804 :
6805 : match
6806 140 : gfc_match_bind_c_stmt (void)
6807 : {
6808 140 : match found_match = MATCH_NO;
6809 140 : gfc_typespec *ts;
6810 :
6811 140 : ts = ¤t_ts;
6812 :
6813 : /* This may not be necessary. */
6814 140 : gfc_clear_ts (ts);
6815 : /* Clear the temporary binding label holder. */
6816 140 : curr_binding_label = NULL;
6817 :
6818 : /* Look for the bind(c). */
6819 140 : found_match = gfc_match_bind_c (NULL, true);
6820 :
6821 140 : if (found_match == MATCH_YES)
6822 : {
6823 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6824 : return MATCH_ERROR;
6825 :
6826 : /* Look for the :: now, but it is not required. */
6827 102 : gfc_match (" :: ");
6828 :
6829 : /* Get the identifier(s) that needs to be updated. This may need to
6830 : change to hand the flag(s) for the attr specified so all identifiers
6831 : found can have all appropriate parts updated (assuming that the same
6832 : spec stmt can have multiple attrs, such as both bind(c) and
6833 : allocatable...). */
6834 102 : if (!get_bind_c_idents ())
6835 : /* Error message should have printed already. */
6836 : return MATCH_ERROR;
6837 : }
6838 :
6839 : return found_match;
6840 : }
6841 :
6842 :
6843 : /* Match a data declaration statement. */
6844 :
6845 : match
6846 1005277 : gfc_match_data_decl (void)
6847 : {
6848 1005277 : gfc_symbol *sym;
6849 1005277 : match m;
6850 1005277 : int elem;
6851 1005277 : gfc_component *comp_tail = NULL;
6852 :
6853 1005277 : type_param_spec_list = NULL;
6854 1005277 : decl_type_param_list = NULL;
6855 :
6856 1005277 : num_idents_on_line = 0;
6857 :
6858 : /* Record the last component before we start, so that we can roll back
6859 : any components added during this statement on error. PR106946.
6860 : Must be set before any 'goto cleanup' with m == MATCH_ERROR. */
6861 1005277 : if (gfc_comp_struct (gfc_current_state ()))
6862 : {
6863 30966 : gfc_symbol *block = gfc_current_block ();
6864 30966 : if (block)
6865 : {
6866 30966 : comp_tail = block->components;
6867 30966 : if (comp_tail)
6868 32514 : while (comp_tail->next)
6869 : comp_tail = comp_tail->next;
6870 : }
6871 : }
6872 :
6873 1005277 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6874 1005277 : if (m != MATCH_YES)
6875 : return m;
6876 :
6877 210413 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6878 34149 : && !gfc_comp_struct (gfc_current_state ()))
6879 : {
6880 30865 : sym = gfc_use_derived (current_ts.u.derived);
6881 :
6882 30865 : if (sym == NULL)
6883 : {
6884 22 : m = MATCH_ERROR;
6885 22 : goto cleanup;
6886 : }
6887 :
6888 30843 : current_ts.u.derived = sym;
6889 : }
6890 :
6891 210391 : m = match_attr_spec ();
6892 210391 : if (m == MATCH_ERROR)
6893 : {
6894 84 : m = MATCH_NO;
6895 84 : goto cleanup;
6896 : }
6897 :
6898 : /* F2018:C708. */
6899 210307 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6900 : {
6901 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6902 6 : m = MATCH_ERROR;
6903 6 : goto cleanup;
6904 : }
6905 :
6906 210301 : if (current_ts.type == BT_CLASS
6907 10627 : && current_ts.u.derived->attr.unlimited_polymorphic)
6908 1878 : goto ok;
6909 :
6910 208423 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6911 32242 : && current_ts.u.derived->components == NULL
6912 2802 : && !current_ts.u.derived->attr.zero_comp)
6913 : {
6914 :
6915 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6916 136 : goto ok;
6917 :
6918 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6919 47 : goto ok;
6920 :
6921 27 : gfc_find_symbol (current_ts.u.derived->name,
6922 27 : current_ts.u.derived->ns, 1, &sym);
6923 :
6924 : /* Any symbol that we find had better be a type definition
6925 : which has its components defined, or be a structure definition
6926 : actively being parsed. */
6927 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6928 26 : && (current_ts.u.derived->components != NULL
6929 26 : || current_ts.u.derived->attr.zero_comp
6930 26 : || current_ts.u.derived == gfc_new_block))
6931 26 : goto ok;
6932 :
6933 1 : gfc_error ("Derived type at %C has not been previously defined "
6934 : "and so cannot appear in a derived type definition");
6935 1 : m = MATCH_ERROR;
6936 1 : goto cleanup;
6937 : }
6938 :
6939 208213 : ok:
6940 : /* If we have an old-style character declaration, and no new-style
6941 : attribute specifications, then there a comma is optional between
6942 : the type specification and the variable list. */
6943 210300 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6944 1407 : gfc_match_char (',');
6945 :
6946 : /* Give the types/attributes to symbols that follow. Give the element
6947 : a number so that repeat character length expressions can be copied. */
6948 : elem = 1;
6949 274758 : for (;;)
6950 : {
6951 274758 : num_idents_on_line++;
6952 274758 : m = variable_decl (elem++);
6953 274756 : if (m == MATCH_ERROR)
6954 413 : goto cleanup;
6955 274343 : if (m == MATCH_NO)
6956 : break;
6957 :
6958 274332 : if (gfc_match_eos () == MATCH_YES)
6959 209850 : goto cleanup;
6960 64482 : if (gfc_match_char (',') != MATCH_YES)
6961 : break;
6962 : }
6963 :
6964 35 : if (!gfc_error_flag_test ())
6965 : {
6966 : /* An anonymous structure declaration is unambiguous; if we matched one
6967 : according to gfc_match_structure_decl, we need to return MATCH_YES
6968 : here to avoid confusing the remaining matchers, even if there was an
6969 : error during variable_decl. We must flush any such errors. Note this
6970 : causes the parser to gracefully continue parsing the remaining input
6971 : as a structure body, which likely follows. */
6972 11 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
6973 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6974 : {
6975 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
6976 : " at %C");
6977 : /* Skip the bad variable_decl and line up for the start of the
6978 : structure body. */
6979 1 : gfc_error_recovery ();
6980 1 : m = MATCH_YES;
6981 1 : goto cleanup;
6982 : }
6983 :
6984 10 : gfc_error ("Syntax error in data declaration at %C");
6985 : }
6986 :
6987 34 : m = MATCH_ERROR;
6988 :
6989 34 : gfc_free_data_all (gfc_current_ns);
6990 :
6991 210411 : cleanup:
6992 : /* If we failed inside a derived type definition, remove any CLASS
6993 : components that were added during this failed statement. For CLASS
6994 : components, gfc_build_class_symbol creates an extra container symbol in
6995 : the namespace outside the normal undo machinery. When reject_statement
6996 : later calls gfc_undo_symbols, the declaration state is rolled back but
6997 : that helper symbol survives and leaves the component dangling. Ordinary
6998 : components do not create that extra helper symbol, so leave them in
6999 : place for the usual follow-up diagnostics. PR106946.
7000 :
7001 : CLASS containers are shared between components of the same class type
7002 : and attributes (gfc_build_class_symbol reuses existing containers).
7003 : We must not free a container that is still referenced by a previously
7004 : committed component. Unlink and free the components first, then clean
7005 : up only orphaned containers. PR124482. */
7006 210411 : if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
7007 : {
7008 86 : gfc_symbol *block = gfc_current_block ();
7009 86 : if (block)
7010 : {
7011 86 : gfc_component **prev;
7012 86 : if (comp_tail)
7013 43 : prev = &comp_tail->next;
7014 : else
7015 43 : prev = &block->components;
7016 :
7017 : /* Record the CLASS container from the removed components.
7018 : Normally all components in one declaration share a single
7019 : container, but per-variable array specs can produce
7020 : additional ones; any beyond the first are harmlessly
7021 : leaked until namespace destruction. */
7022 86 : gfc_symbol *fclass_container = NULL;
7023 :
7024 120 : while (*prev)
7025 : {
7026 34 : gfc_component *c = *prev;
7027 34 : if (c->ts.type == BT_CLASS && c->ts.u.derived
7028 6 : && c->ts.u.derived->attr.is_class)
7029 : {
7030 3 : *prev = c->next;
7031 3 : if (!fclass_container)
7032 3 : fclass_container = c->ts.u.derived;
7033 3 : c->ts.u.derived = NULL;
7034 3 : gfc_free_component (c);
7035 : }
7036 : else
7037 31 : prev = &c->next;
7038 : }
7039 :
7040 : /* Free the container only if no remaining component still
7041 : references it. CLASS containers are shared between
7042 : components of the same class type and attributes
7043 : (gfc_build_class_symbol reuses existing ones). */
7044 86 : if (fclass_container)
7045 : {
7046 3 : bool shared = false;
7047 3 : for (gfc_component *q = block->components; q; q = q->next)
7048 1 : if (q->ts.type == BT_CLASS
7049 1 : && q->ts.u.derived == fclass_container)
7050 : {
7051 : shared = true;
7052 : break;
7053 : }
7054 3 : if (!shared)
7055 : {
7056 2 : if (gfc_find_symtree (fclass_container->ns->sym_root,
7057 : fclass_container->name))
7058 2 : gfc_delete_symtree (&fclass_container->ns->sym_root,
7059 : fclass_container->name);
7060 2 : gfc_release_symbol (fclass_container);
7061 : }
7062 : }
7063 : }
7064 : }
7065 :
7066 210411 : if (saved_kind_expr)
7067 174 : gfc_free_expr (saved_kind_expr);
7068 210411 : if (type_param_spec_list)
7069 923 : gfc_free_actual_arglist (type_param_spec_list);
7070 210411 : if (decl_type_param_list)
7071 891 : gfc_free_actual_arglist (decl_type_param_list);
7072 210411 : saved_kind_expr = NULL;
7073 210411 : gfc_free_array_spec (current_as);
7074 210411 : current_as = NULL;
7075 210411 : return m;
7076 : }
7077 :
7078 : static bool
7079 23759 : in_module_or_interface(void)
7080 : {
7081 23759 : if (gfc_current_state () == COMP_MODULE
7082 23759 : || gfc_current_state () == COMP_SUBMODULE
7083 23759 : || gfc_current_state () == COMP_INTERFACE)
7084 : return true;
7085 :
7086 19926 : if (gfc_state_stack->state == COMP_CONTAINS
7087 19119 : || gfc_state_stack->state == COMP_FUNCTION
7088 19016 : || gfc_state_stack->state == COMP_SUBROUTINE)
7089 : {
7090 910 : gfc_state_data *p;
7091 953 : for (p = gfc_state_stack->previous; p ; p = p->previous)
7092 : {
7093 949 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
7094 115 : || p->state == COMP_INTERFACE)
7095 : return true;
7096 : }
7097 : }
7098 : return false;
7099 : }
7100 :
7101 : /* Match a prefix associated with a function or subroutine
7102 : declaration. If the typespec pointer is nonnull, then a typespec
7103 : can be matched. Note that if nothing matches, MATCH_YES is
7104 : returned (the null string was matched). */
7105 :
7106 : match
7107 236066 : gfc_match_prefix (gfc_typespec *ts)
7108 : {
7109 236066 : bool seen_type;
7110 236066 : bool seen_impure;
7111 236066 : bool found_prefix;
7112 :
7113 236066 : gfc_clear_attr (¤t_attr);
7114 236066 : seen_type = false;
7115 236066 : seen_impure = false;
7116 :
7117 236066 : gcc_assert (!gfc_matching_prefix);
7118 236066 : gfc_matching_prefix = true;
7119 :
7120 245551 : do
7121 : {
7122 264871 : found_prefix = false;
7123 :
7124 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7125 : corresponding attribute seems natural and distinguishes these
7126 : procedures from procedure types of PROC_MODULE, which these are
7127 : as well. */
7128 264871 : if (gfc_match ("module% ") == MATCH_YES)
7129 : {
7130 24034 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7131 275 : goto error;
7132 :
7133 23759 : if (!in_module_or_interface ())
7134 : {
7135 19020 : gfc_error ("MODULE prefix at %C found outside of a module, "
7136 : "submodule, or interface");
7137 19020 : goto error;
7138 : }
7139 :
7140 4739 : current_attr.module_procedure = 1;
7141 4739 : found_prefix = true;
7142 : }
7143 :
7144 245576 : if (!seen_type && ts != NULL)
7145 : {
7146 132052 : match m;
7147 132052 : m = gfc_match_decl_type_spec (ts, 0);
7148 132052 : if (m == MATCH_ERROR)
7149 15 : goto error;
7150 132037 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7151 : {
7152 : seen_type = true;
7153 : found_prefix = true;
7154 : }
7155 : }
7156 :
7157 245561 : if (gfc_match ("elemental% ") == MATCH_YES)
7158 : {
7159 5175 : if (!gfc_add_elemental (¤t_attr, NULL))
7160 2 : goto error;
7161 :
7162 : found_prefix = true;
7163 : }
7164 :
7165 245559 : if (gfc_match ("pure% ") == MATCH_YES)
7166 : {
7167 2375 : if (!gfc_add_pure (¤t_attr, NULL))
7168 2 : goto error;
7169 :
7170 : found_prefix = true;
7171 : }
7172 :
7173 245557 : if (gfc_match ("recursive% ") == MATCH_YES)
7174 : {
7175 463 : if (!gfc_add_recursive (¤t_attr, NULL))
7176 2 : goto error;
7177 :
7178 : found_prefix = true;
7179 : }
7180 :
7181 : /* IMPURE is a somewhat special case, as it needs not set an actual
7182 : attribute but rather only prevents ELEMENTAL routines from being
7183 : automatically PURE. */
7184 245555 : if (gfc_match ("impure% ") == MATCH_YES)
7185 : {
7186 675 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7187 4 : goto error;
7188 :
7189 : seen_impure = true;
7190 : found_prefix = true;
7191 : }
7192 : }
7193 : while (found_prefix);
7194 :
7195 : /* IMPURE and PURE must not both appear, of course. */
7196 216746 : if (seen_impure && current_attr.pure)
7197 : {
7198 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7199 4 : goto error;
7200 : }
7201 :
7202 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7203 216075 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7204 : {
7205 4522 : if (!gfc_add_pure (¤t_attr, NULL))
7206 0 : goto error;
7207 : }
7208 :
7209 : /* At this point, the next item is not a prefix. */
7210 216742 : gcc_assert (gfc_matching_prefix);
7211 :
7212 216742 : gfc_matching_prefix = false;
7213 216742 : return MATCH_YES;
7214 :
7215 19324 : error:
7216 19324 : gcc_assert (gfc_matching_prefix);
7217 19324 : gfc_matching_prefix = false;
7218 19324 : return MATCH_ERROR;
7219 : }
7220 :
7221 :
7222 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7223 :
7224 : static bool
7225 61401 : copy_prefix (symbol_attribute *dest, locus *where)
7226 : {
7227 61401 : if (dest->module_procedure)
7228 : {
7229 672 : if (current_attr.elemental)
7230 13 : dest->elemental = 1;
7231 :
7232 672 : if (current_attr.pure)
7233 61 : dest->pure = 1;
7234 :
7235 672 : if (current_attr.recursive)
7236 8 : dest->recursive = 1;
7237 :
7238 : /* Module procedures are unusual in that the 'dest' is copied from
7239 : the interface declaration. However, this is an oportunity to
7240 : check that the submodule declaration is compliant with the
7241 : interface. */
7242 672 : if (dest->elemental && !current_attr.elemental)
7243 : {
7244 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7245 : "missing at %L", where);
7246 1 : return false;
7247 : }
7248 :
7249 671 : if (dest->pure && !current_attr.pure)
7250 : {
7251 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7252 : "missing at %L", where);
7253 1 : return false;
7254 : }
7255 :
7256 670 : if (dest->recursive && !current_attr.recursive)
7257 : {
7258 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7259 : "missing at %L", where);
7260 1 : return false;
7261 : }
7262 :
7263 : return true;
7264 : }
7265 :
7266 60729 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7267 : return false;
7268 :
7269 60727 : if (current_attr.pure && !gfc_add_pure (dest, where))
7270 : return false;
7271 :
7272 60727 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7273 : return false;
7274 :
7275 : return true;
7276 : }
7277 :
7278 :
7279 : /* Match a formal argument list or, if typeparam is true, a
7280 : type_param_name_list. */
7281 :
7282 : match
7283 474542 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7284 : int null_flag, bool typeparam)
7285 : {
7286 474542 : gfc_formal_arglist *head, *tail, *p, *q;
7287 474542 : char name[GFC_MAX_SYMBOL_LEN + 1];
7288 474542 : gfc_symbol *sym;
7289 474542 : match m;
7290 474542 : gfc_formal_arglist *formal = NULL;
7291 :
7292 474542 : head = tail = NULL;
7293 :
7294 : /* Keep the interface formal argument list and null it so that the
7295 : matching for the new declaration can be done. The numbers and
7296 : names of the arguments are checked here. The interface formal
7297 : arguments are retained in formal_arglist and the characteristics
7298 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7299 : in get_proc_name about the eventual need to copy the formal_arglist
7300 : and populate the formal namespace of the interface symbol. */
7301 474542 : if (progname->attr.module_procedure
7302 676 : && progname->attr.host_assoc)
7303 : {
7304 180 : formal = progname->formal;
7305 180 : progname->formal = NULL;
7306 : }
7307 :
7308 474542 : if (gfc_match_char ('(') != MATCH_YES)
7309 : {
7310 281245 : if (null_flag)
7311 6417 : goto ok;
7312 : return MATCH_NO;
7313 : }
7314 :
7315 193297 : if (gfc_match_char (')') == MATCH_YES)
7316 : {
7317 10217 : if (typeparam)
7318 : {
7319 1 : gfc_error_now ("A type parameter list is required at %C");
7320 1 : m = MATCH_ERROR;
7321 1 : goto cleanup;
7322 : }
7323 : else
7324 10216 : goto ok;
7325 : }
7326 :
7327 244335 : for (;;)
7328 : {
7329 244335 : gfc_gobble_whitespace ();
7330 244335 : if (gfc_match_char ('*') == MATCH_YES)
7331 : {
7332 10277 : sym = NULL;
7333 10277 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7334 : "Alternate-return argument at %C"))
7335 : {
7336 1 : m = MATCH_ERROR;
7337 1 : goto cleanup;
7338 : }
7339 10276 : else if (typeparam)
7340 2 : gfc_error_now ("A parameter name is required at %C");
7341 : }
7342 : else
7343 : {
7344 234058 : locus loc = gfc_current_locus;
7345 234058 : m = gfc_match_name (name);
7346 234058 : if (m != MATCH_YES)
7347 : {
7348 15815 : if(typeparam)
7349 1 : gfc_error_now ("A parameter name is required at %C");
7350 15831 : goto cleanup;
7351 : }
7352 218243 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7353 :
7354 218243 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7355 16 : goto cleanup;
7356 218227 : else if (typeparam
7357 218227 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7358 0 : goto cleanup;
7359 : }
7360 :
7361 228503 : p = gfc_get_formal_arglist ();
7362 :
7363 228503 : if (head == NULL)
7364 : head = tail = p;
7365 : else
7366 : {
7367 60552 : tail->next = p;
7368 60552 : tail = p;
7369 : }
7370 :
7371 228503 : tail->sym = sym;
7372 :
7373 : /* We don't add the VARIABLE flavor because the name could be a
7374 : dummy procedure. We don't apply these attributes to formal
7375 : arguments of statement functions. */
7376 218227 : if (sym != NULL && !st_flag
7377 327165 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7378 98662 : || !gfc_missing_attr (&sym->attr, NULL)))
7379 : {
7380 0 : m = MATCH_ERROR;
7381 0 : goto cleanup;
7382 : }
7383 :
7384 : /* The name of a program unit can be in a different namespace,
7385 : so check for it explicitly. After the statement is accepted,
7386 : the name is checked for especially in gfc_get_symbol(). */
7387 228503 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7388 97423 : && strcmp (sym->name, gfc_new_block->name) == 0)
7389 : {
7390 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7391 : sym->name);
7392 0 : m = MATCH_ERROR;
7393 0 : goto cleanup;
7394 : }
7395 :
7396 228503 : if (gfc_match_char (')') == MATCH_YES)
7397 120102 : goto ok;
7398 :
7399 108401 : m = gfc_match_char (',');
7400 108401 : if (m != MATCH_YES)
7401 : {
7402 47146 : if (typeparam)
7403 1 : gfc_error_now ("Expected parameter list in type declaration "
7404 : "at %C");
7405 : else
7406 47145 : gfc_error ("Unexpected junk in formal argument list at %C");
7407 47146 : goto cleanup;
7408 : }
7409 : }
7410 :
7411 136735 : ok:
7412 : /* Check for duplicate symbols in the formal argument list. */
7413 136735 : if (head != NULL)
7414 : {
7415 179035 : for (p = head; p->next; p = p->next)
7416 : {
7417 58981 : if (p->sym == NULL)
7418 327 : continue;
7419 :
7420 234111 : for (q = p->next; q; q = q->next)
7421 175505 : if (p->sym == q->sym)
7422 : {
7423 48 : if (typeparam)
7424 1 : gfc_error_now ("Duplicate name %qs in parameter "
7425 : "list at %C", p->sym->name);
7426 : else
7427 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7428 : "list at %C", p->sym->name);
7429 :
7430 48 : m = MATCH_ERROR;
7431 48 : goto cleanup;
7432 : }
7433 : }
7434 : }
7435 :
7436 136687 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7437 : {
7438 0 : m = MATCH_ERROR;
7439 0 : goto cleanup;
7440 : }
7441 :
7442 : /* gfc_error_now used in following and return with MATCH_YES because
7443 : doing otherwise results in a cascade of extraneous errors and in
7444 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7445 136687 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7446 : {
7447 179 : bool arg_count_mismatch = false;
7448 :
7449 179 : if (!formal && head)
7450 : arg_count_mismatch = true;
7451 :
7452 : /* Abbreviated module procedure declaration is not meant to have any
7453 : formal arguments! */
7454 179 : if (!progname->abr_modproc_decl && formal && !head)
7455 1 : arg_count_mismatch = true;
7456 :
7457 349 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7458 : {
7459 170 : if ((p->next != NULL && q->next == NULL)
7460 169 : || (p->next == NULL && q->next != NULL))
7461 : arg_count_mismatch = true;
7462 168 : else if ((p->sym == NULL && q->sym == NULL)
7463 168 : || (p->sym && q->sym
7464 166 : && strcmp (p->sym->name, q->sym->name) == 0))
7465 164 : continue;
7466 : else
7467 : {
7468 4 : if (q->sym == NULL)
7469 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7470 : "conflicts with alternate return at %C",
7471 : p->sym->name);
7472 3 : else if (p->sym == NULL)
7473 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7474 : "alternate return and conflicts with "
7475 : "%qs in the separate declaration at %C",
7476 : q->sym->name);
7477 : else
7478 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7479 : "argument names (%s/%s) at %C",
7480 : p->sym->name, q->sym->name);
7481 : }
7482 : }
7483 :
7484 179 : if (arg_count_mismatch)
7485 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7486 : "formal arguments at %C");
7487 : }
7488 :
7489 : return MATCH_YES;
7490 :
7491 63027 : cleanup:
7492 63027 : gfc_free_formal_arglist (head);
7493 63027 : return m;
7494 : }
7495 :
7496 :
7497 : /* Match a RESULT specification following a function declaration or
7498 : ENTRY statement. Also matches the end-of-statement. */
7499 :
7500 : static match
7501 7925 : match_result (gfc_symbol *function, gfc_symbol **result)
7502 : {
7503 7925 : char name[GFC_MAX_SYMBOL_LEN + 1];
7504 7925 : gfc_symbol *r;
7505 7925 : match m;
7506 :
7507 7925 : if (gfc_match (" result (") != MATCH_YES)
7508 : return MATCH_NO;
7509 :
7510 5881 : m = gfc_match_name (name);
7511 5881 : if (m != MATCH_YES)
7512 : return m;
7513 :
7514 : /* Get the right paren, and that's it because there could be the
7515 : bind(c) attribute after the result clause. */
7516 5881 : if (gfc_match_char (')') != MATCH_YES)
7517 : {
7518 : /* TODO: should report the missing right paren here. */
7519 : return MATCH_ERROR;
7520 : }
7521 :
7522 5881 : if (strcmp (function->name, name) == 0)
7523 : {
7524 1 : gfc_error ("RESULT variable at %C must be different than function name");
7525 1 : return MATCH_ERROR;
7526 : }
7527 :
7528 5880 : if (gfc_get_symbol (name, NULL, &r))
7529 : return MATCH_ERROR;
7530 :
7531 5880 : if (!gfc_add_result (&r->attr, r->name, NULL))
7532 : return MATCH_ERROR;
7533 :
7534 5880 : *result = r;
7535 :
7536 5880 : return MATCH_YES;
7537 : }
7538 :
7539 :
7540 : /* Match a function suffix, which could be a combination of a result
7541 : clause and BIND(C), either one, or neither. The draft does not
7542 : require them to come in a specific order. */
7543 :
7544 : static match
7545 7929 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7546 : {
7547 7929 : match is_bind_c; /* Found bind(c). */
7548 7929 : match is_result; /* Found result clause. */
7549 7929 : match found_match; /* Status of whether we've found a good match. */
7550 7929 : char peek_char; /* Character we're going to peek at. */
7551 7929 : bool allow_binding_name;
7552 :
7553 : /* Initialize to having found nothing. */
7554 7929 : found_match = MATCH_NO;
7555 7929 : is_bind_c = MATCH_NO;
7556 7929 : is_result = MATCH_NO;
7557 :
7558 : /* Get the next char to narrow between result and bind(c). */
7559 7929 : gfc_gobble_whitespace ();
7560 7929 : peek_char = gfc_peek_ascii_char ();
7561 :
7562 : /* C binding names are not allowed for internal procedures. */
7563 7929 : if (gfc_current_state () == COMP_CONTAINS
7564 4652 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7565 : allow_binding_name = false;
7566 : else
7567 6278 : allow_binding_name = true;
7568 :
7569 7929 : switch (peek_char)
7570 : {
7571 5510 : case 'r':
7572 : /* Look for result clause. */
7573 5510 : is_result = match_result (sym, result);
7574 5510 : if (is_result == MATCH_YES)
7575 : {
7576 : /* Now see if there is a bind(c) after it. */
7577 5509 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7578 : /* We've found the result clause and possibly bind(c). */
7579 5509 : found_match = MATCH_YES;
7580 : }
7581 : else
7582 : /* This should only be MATCH_ERROR. */
7583 : found_match = is_result;
7584 : break;
7585 2419 : case 'b':
7586 : /* Look for bind(c) first. */
7587 2419 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7588 2419 : if (is_bind_c == MATCH_YES)
7589 : {
7590 : /* Now see if a result clause followed it. */
7591 2415 : is_result = match_result (sym, result);
7592 2415 : found_match = MATCH_YES;
7593 : }
7594 : else
7595 : {
7596 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7597 : found_match = MATCH_ERROR;
7598 : }
7599 : break;
7600 0 : default:
7601 0 : gfc_error ("Unexpected junk after function declaration at %C");
7602 0 : found_match = MATCH_ERROR;
7603 0 : break;
7604 : }
7605 :
7606 7924 : if (is_bind_c == MATCH_YES)
7607 : {
7608 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7609 2564 : if (gfc_current_state () == COMP_CONTAINS
7610 417 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7611 2576 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7612 : "at %L may not be specified for an internal "
7613 : "procedure", &gfc_current_locus))
7614 : return MATCH_ERROR;
7615 :
7616 2561 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7617 : return MATCH_ERROR;
7618 : }
7619 :
7620 : return found_match;
7621 : }
7622 :
7623 :
7624 : /* Procedure pointer return value without RESULT statement:
7625 : Add "hidden" result variable named "ppr@". */
7626 :
7627 : static bool
7628 72845 : add_hidden_procptr_result (gfc_symbol *sym)
7629 : {
7630 72845 : bool case1,case2;
7631 :
7632 72845 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7633 : return false;
7634 :
7635 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7636 1520 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7637 1520 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7638 73231 : && sym->attr.external;
7639 : /* Second usage case: INTERFACE statements. */
7640 13953 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7641 13953 : && gfc_state_stack->previous->state == COMP_FUNCTION
7642 72892 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7643 :
7644 72661 : if (case1 || case2)
7645 : {
7646 124 : gfc_symtree *stree;
7647 124 : if (case1)
7648 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7649 : else
7650 : {
7651 30 : gfc_symtree *st2;
7652 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7653 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7654 30 : st2->n.sym = stree->n.sym;
7655 30 : stree->n.sym->refs++;
7656 : }
7657 124 : sym->result = stree->n.sym;
7658 :
7659 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7660 124 : sym->result->attr.pointer = sym->attr.pointer;
7661 124 : sym->result->attr.external = sym->attr.external;
7662 124 : sym->result->attr.referenced = sym->attr.referenced;
7663 124 : sym->result->ts = sym->ts;
7664 124 : sym->attr.proc_pointer = 0;
7665 124 : sym->attr.pointer = 0;
7666 124 : sym->attr.external = 0;
7667 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7668 : {
7669 4 : sym->result->attr.pointer = 0;
7670 4 : sym->result->attr.proc_pointer = 1;
7671 : }
7672 :
7673 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7674 : }
7675 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7676 72567 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7677 399 : && sym->result && sym->result != sym && sym->result->attr.external
7678 28 : && sym == gfc_current_ns->proc_name
7679 28 : && sym == sym->result->ns->proc_name
7680 28 : && strcmp ("ppr@", sym->result->name) == 0)
7681 : {
7682 28 : sym->result->attr.proc_pointer = 1;
7683 28 : sym->attr.pointer = 0;
7684 28 : return true;
7685 : }
7686 : else
7687 : return false;
7688 : }
7689 :
7690 :
7691 : /* Match the interface for a PROCEDURE declaration,
7692 : including brackets (R1212). */
7693 :
7694 : static match
7695 1557 : match_procedure_interface (gfc_symbol **proc_if)
7696 : {
7697 1557 : match m;
7698 1557 : gfc_symtree *st;
7699 1557 : locus old_loc, entry_loc;
7700 1557 : gfc_namespace *old_ns = gfc_current_ns;
7701 1557 : char name[GFC_MAX_SYMBOL_LEN + 1];
7702 :
7703 1557 : old_loc = entry_loc = gfc_current_locus;
7704 1557 : gfc_clear_ts (¤t_ts);
7705 :
7706 1557 : if (gfc_match (" (") != MATCH_YES)
7707 : {
7708 1 : gfc_current_locus = entry_loc;
7709 1 : return MATCH_NO;
7710 : }
7711 :
7712 : /* Get the type spec. for the procedure interface. */
7713 1556 : old_loc = gfc_current_locus;
7714 1556 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7715 1556 : gfc_gobble_whitespace ();
7716 1556 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7717 391 : goto got_ts;
7718 :
7719 1165 : if (m == MATCH_ERROR)
7720 : return m;
7721 :
7722 : /* Procedure interface is itself a procedure. */
7723 1165 : gfc_current_locus = old_loc;
7724 1165 : m = gfc_match_name (name);
7725 :
7726 : /* First look to see if it is already accessible in the current
7727 : namespace because it is use associated or contained. */
7728 1165 : st = NULL;
7729 1165 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7730 : return MATCH_ERROR;
7731 :
7732 : /* If it is still not found, then try the parent namespace, if it
7733 : exists and create the symbol there if it is still not found. */
7734 1165 : if (gfc_current_ns->parent)
7735 391 : gfc_current_ns = gfc_current_ns->parent;
7736 1165 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7737 : return MATCH_ERROR;
7738 :
7739 1165 : gfc_current_ns = old_ns;
7740 1165 : *proc_if = st->n.sym;
7741 :
7742 1165 : if (*proc_if)
7743 : {
7744 1165 : (*proc_if)->refs++;
7745 : /* Resolve interface if possible. That way, attr.procedure is only set
7746 : if it is declared by a later procedure-declaration-stmt, which is
7747 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7748 1165 : while ((*proc_if)->ts.interface
7749 1172 : && *proc_if != (*proc_if)->ts.interface)
7750 7 : *proc_if = (*proc_if)->ts.interface;
7751 :
7752 1165 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7753 388 : && (*proc_if)->ts.type == BT_UNKNOWN
7754 1553 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7755 : (*proc_if)->name, NULL))
7756 : return MATCH_ERROR;
7757 : }
7758 :
7759 0 : got_ts:
7760 1556 : if (gfc_match (" )") != MATCH_YES)
7761 : {
7762 0 : gfc_current_locus = entry_loc;
7763 0 : return MATCH_NO;
7764 : }
7765 :
7766 : return MATCH_YES;
7767 : }
7768 :
7769 :
7770 : /* Match a PROCEDURE declaration (R1211). */
7771 :
7772 : static match
7773 1130 : match_procedure_decl (void)
7774 : {
7775 1130 : match m;
7776 1130 : gfc_symbol *sym, *proc_if = NULL;
7777 1130 : int num;
7778 1130 : gfc_expr *initializer = NULL;
7779 :
7780 : /* Parse interface (with brackets). */
7781 1130 : m = match_procedure_interface (&proc_if);
7782 1130 : if (m != MATCH_YES)
7783 : return m;
7784 :
7785 : /* Parse attributes (with colons). */
7786 1130 : m = match_attr_spec();
7787 1130 : if (m == MATCH_ERROR)
7788 : return MATCH_ERROR;
7789 :
7790 1129 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7791 : {
7792 17 : current_attr.is_bind_c = 1;
7793 17 : has_name_equals = 0;
7794 17 : curr_binding_label = NULL;
7795 : }
7796 :
7797 : /* Get procedure symbols. */
7798 79 : for(num=1;;num++)
7799 : {
7800 1208 : m = gfc_match_symbol (&sym, 0);
7801 1208 : if (m == MATCH_NO)
7802 1 : goto syntax;
7803 1207 : else if (m == MATCH_ERROR)
7804 : return m;
7805 :
7806 : /* Add current_attr to the symbol attributes. */
7807 1207 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7808 : return MATCH_ERROR;
7809 :
7810 1205 : if (sym->attr.is_bind_c)
7811 : {
7812 : /* Check for C1218. */
7813 54 : if (!proc_if || !proc_if->attr.is_bind_c)
7814 : {
7815 1 : gfc_error ("BIND(C) attribute at %C requires "
7816 : "an interface with BIND(C)");
7817 1 : return MATCH_ERROR;
7818 : }
7819 : /* Check for C1217. */
7820 53 : if (has_name_equals && sym->attr.pointer)
7821 : {
7822 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7823 : "POINTER attribute at %C");
7824 1 : return MATCH_ERROR;
7825 : }
7826 52 : if (has_name_equals && sym->attr.dummy)
7827 : {
7828 1 : gfc_error ("Dummy procedure at %C may not have "
7829 : "BIND(C) attribute with NAME");
7830 1 : return MATCH_ERROR;
7831 : }
7832 : /* Set binding label for BIND(C). */
7833 51 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7834 : return MATCH_ERROR;
7835 : }
7836 :
7837 1201 : if (!gfc_add_external (&sym->attr, NULL))
7838 : return MATCH_ERROR;
7839 :
7840 1197 : if (add_hidden_procptr_result (sym))
7841 67 : sym = sym->result;
7842 :
7843 1197 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7844 : return MATCH_ERROR;
7845 :
7846 : /* Set interface. */
7847 1196 : if (proc_if != NULL)
7848 : {
7849 857 : if (sym->ts.type != BT_UNKNOWN)
7850 : {
7851 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7852 : sym->name, &gfc_current_locus,
7853 : gfc_basic_typename (sym->ts.type));
7854 1 : return MATCH_ERROR;
7855 : }
7856 856 : sym->ts.interface = proc_if;
7857 856 : sym->attr.untyped = 1;
7858 856 : sym->attr.if_source = IFSRC_IFBODY;
7859 : }
7860 339 : else if (current_ts.type != BT_UNKNOWN)
7861 : {
7862 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7863 : return MATCH_ERROR;
7864 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7865 198 : sym->ts.interface->ts = current_ts;
7866 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7867 198 : sym->ts.interface->attr.function = 1;
7868 198 : sym->attr.function = 1;
7869 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7870 : }
7871 :
7872 1194 : if (gfc_match (" =>") == MATCH_YES)
7873 : {
7874 87 : if (!current_attr.pointer)
7875 : {
7876 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7877 0 : m = MATCH_ERROR;
7878 0 : goto cleanup;
7879 : }
7880 :
7881 87 : m = match_pointer_init (&initializer, 1);
7882 87 : if (m != MATCH_YES)
7883 1 : goto cleanup;
7884 :
7885 86 : if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
7886 0 : goto cleanup;
7887 :
7888 : }
7889 :
7890 1193 : if (gfc_match_eos () == MATCH_YES)
7891 : return MATCH_YES;
7892 79 : if (gfc_match_char (',') != MATCH_YES)
7893 0 : goto syntax;
7894 : }
7895 :
7896 1 : syntax:
7897 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7898 1 : return MATCH_ERROR;
7899 :
7900 1 : cleanup:
7901 : /* Free stuff up and return. */
7902 1 : gfc_free_expr (initializer);
7903 1 : return m;
7904 : }
7905 :
7906 :
7907 : static match
7908 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7909 :
7910 :
7911 : /* Match a procedure pointer component declaration (R445). */
7912 :
7913 : static match
7914 427 : match_ppc_decl (void)
7915 : {
7916 427 : match m;
7917 427 : gfc_symbol *proc_if = NULL;
7918 427 : gfc_typespec ts;
7919 427 : int num;
7920 427 : gfc_component *c;
7921 427 : gfc_expr *initializer = NULL;
7922 427 : gfc_typebound_proc* tb;
7923 427 : char name[GFC_MAX_SYMBOL_LEN + 1];
7924 :
7925 : /* Parse interface (with brackets). */
7926 427 : m = match_procedure_interface (&proc_if);
7927 427 : if (m != MATCH_YES)
7928 1 : goto syntax;
7929 :
7930 : /* Parse attributes. */
7931 426 : tb = XCNEW (gfc_typebound_proc);
7932 426 : tb->where = gfc_current_locus;
7933 426 : m = match_binding_attributes (tb, false, true);
7934 426 : if (m == MATCH_ERROR)
7935 : return m;
7936 :
7937 423 : gfc_clear_attr (¤t_attr);
7938 423 : current_attr.procedure = 1;
7939 423 : current_attr.proc_pointer = 1;
7940 423 : current_attr.access = tb->access;
7941 423 : current_attr.flavor = FL_PROCEDURE;
7942 :
7943 : /* Match the colons (required). */
7944 423 : if (gfc_match (" ::") != MATCH_YES)
7945 : {
7946 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7947 1 : return MATCH_ERROR;
7948 : }
7949 :
7950 : /* Check for C450. */
7951 422 : if (!tb->nopass && proc_if == NULL)
7952 : {
7953 2 : gfc_error("NOPASS or explicit interface required at %C");
7954 2 : return MATCH_ERROR;
7955 : }
7956 :
7957 420 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7958 : return MATCH_ERROR;
7959 :
7960 : /* Match PPC names. */
7961 419 : ts = current_ts;
7962 419 : for(num=1;;num++)
7963 : {
7964 420 : m = gfc_match_name (name);
7965 420 : if (m == MATCH_NO)
7966 0 : goto syntax;
7967 420 : else if (m == MATCH_ERROR)
7968 : return m;
7969 :
7970 420 : if (!gfc_add_component (gfc_current_block(), name, &c))
7971 : return MATCH_ERROR;
7972 :
7973 : /* Add current_attr to the symbol attributes. */
7974 420 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
7975 : return MATCH_ERROR;
7976 :
7977 420 : if (!gfc_add_external (&c->attr, NULL))
7978 : return MATCH_ERROR;
7979 :
7980 420 : if (!gfc_add_proc (&c->attr, name, NULL))
7981 : return MATCH_ERROR;
7982 :
7983 420 : if (num == 1)
7984 419 : c->tb = tb;
7985 : else
7986 : {
7987 1 : c->tb = XCNEW (gfc_typebound_proc);
7988 1 : c->tb->where = gfc_current_locus;
7989 1 : *c->tb = *tb;
7990 : }
7991 :
7992 420 : if (saved_kind_expr)
7993 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
7994 :
7995 : /* Set interface. */
7996 420 : if (proc_if != NULL)
7997 : {
7998 353 : c->ts.interface = proc_if;
7999 353 : c->attr.untyped = 1;
8000 353 : c->attr.if_source = IFSRC_IFBODY;
8001 : }
8002 67 : else if (ts.type != BT_UNKNOWN)
8003 : {
8004 29 : c->ts = ts;
8005 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
8006 29 : c->ts.interface->result = c->ts.interface;
8007 29 : c->ts.interface->ts = ts;
8008 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
8009 29 : c->ts.interface->attr.function = 1;
8010 29 : c->attr.function = 1;
8011 29 : c->attr.if_source = IFSRC_UNKNOWN;
8012 : }
8013 :
8014 420 : if (gfc_match (" =>") == MATCH_YES)
8015 : {
8016 67 : m = match_pointer_init (&initializer, 1);
8017 67 : if (m != MATCH_YES)
8018 : {
8019 0 : gfc_free_expr (initializer);
8020 0 : return m;
8021 : }
8022 67 : c->initializer = initializer;
8023 : }
8024 :
8025 420 : if (gfc_match_eos () == MATCH_YES)
8026 : return MATCH_YES;
8027 1 : if (gfc_match_char (',') != MATCH_YES)
8028 0 : goto syntax;
8029 : }
8030 :
8031 1 : syntax:
8032 1 : gfc_error ("Syntax error in procedure pointer component at %C");
8033 1 : return MATCH_ERROR;
8034 : }
8035 :
8036 :
8037 : /* Match a PROCEDURE declaration inside an interface (R1206). */
8038 :
8039 : static match
8040 1561 : match_procedure_in_interface (void)
8041 : {
8042 1561 : match m;
8043 1561 : gfc_symbol *sym;
8044 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
8045 1561 : locus old_locus;
8046 :
8047 1561 : if (current_interface.type == INTERFACE_NAMELESS
8048 1561 : || current_interface.type == INTERFACE_ABSTRACT)
8049 : {
8050 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
8051 1 : return MATCH_ERROR;
8052 : }
8053 :
8054 : /* Check if the F2008 optional double colon appears. */
8055 1560 : gfc_gobble_whitespace ();
8056 1560 : old_locus = gfc_current_locus;
8057 1560 : if (gfc_match ("::") == MATCH_YES)
8058 : {
8059 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8060 : "MODULE PROCEDURE statement at %L", &old_locus))
8061 : return MATCH_ERROR;
8062 : }
8063 : else
8064 685 : gfc_current_locus = old_locus;
8065 :
8066 2214 : for(;;)
8067 : {
8068 2214 : m = gfc_match_name (name);
8069 2214 : if (m == MATCH_NO)
8070 0 : goto syntax;
8071 2214 : else if (m == MATCH_ERROR)
8072 : return m;
8073 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
8074 : return MATCH_ERROR;
8075 :
8076 2214 : if (!gfc_add_interface (sym))
8077 : return MATCH_ERROR;
8078 :
8079 2213 : if (gfc_match_eos () == MATCH_YES)
8080 : break;
8081 655 : if (gfc_match_char (',') != MATCH_YES)
8082 0 : goto syntax;
8083 : }
8084 :
8085 : return MATCH_YES;
8086 :
8087 0 : syntax:
8088 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8089 0 : return MATCH_ERROR;
8090 : }
8091 :
8092 :
8093 : /* General matcher for PROCEDURE declarations. */
8094 :
8095 : static match match_procedure_in_type (void);
8096 :
8097 : match
8098 6265 : gfc_match_procedure (void)
8099 : {
8100 6265 : match m;
8101 :
8102 6265 : switch (gfc_current_state ())
8103 : {
8104 1130 : case COMP_NONE:
8105 1130 : case COMP_PROGRAM:
8106 1130 : case COMP_MODULE:
8107 1130 : case COMP_SUBMODULE:
8108 1130 : case COMP_SUBROUTINE:
8109 1130 : case COMP_FUNCTION:
8110 1130 : case COMP_BLOCK:
8111 1130 : m = match_procedure_decl ();
8112 1130 : break;
8113 1561 : case COMP_INTERFACE:
8114 1561 : m = match_procedure_in_interface ();
8115 1561 : break;
8116 427 : case COMP_DERIVED:
8117 427 : m = match_ppc_decl ();
8118 427 : break;
8119 3147 : case COMP_DERIVED_CONTAINS:
8120 3147 : m = match_procedure_in_type ();
8121 3147 : break;
8122 : default:
8123 : return MATCH_NO;
8124 : }
8125 :
8126 6265 : if (m != MATCH_YES)
8127 : return m;
8128 :
8129 6209 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8130 4 : return MATCH_ERROR;
8131 :
8132 : return m;
8133 : }
8134 :
8135 :
8136 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8137 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8138 : parser-state-stack to find out whether we're in a module. */
8139 :
8140 : static void
8141 61398 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8142 : {
8143 61398 : bool in_module;
8144 :
8145 122796 : in_module = (gfc_state_stack->previous
8146 61398 : && (gfc_state_stack->previous->state == COMP_MODULE
8147 49970 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8148 :
8149 61398 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8150 61398 : }
8151 :
8152 :
8153 : /* Match a function declaration. */
8154 :
8155 : match
8156 125612 : gfc_match_function_decl (void)
8157 : {
8158 125612 : char name[GFC_MAX_SYMBOL_LEN + 1];
8159 125612 : gfc_symbol *sym, *result;
8160 125612 : locus old_loc;
8161 125612 : match m;
8162 125612 : match suffix_match;
8163 125612 : match found_match; /* Status returned by match func. */
8164 :
8165 125612 : if (gfc_current_state () != COMP_NONE
8166 78791 : && gfc_current_state () != COMP_INTERFACE
8167 51159 : && gfc_current_state () != COMP_CONTAINS)
8168 : return MATCH_NO;
8169 :
8170 125612 : gfc_clear_ts (¤t_ts);
8171 :
8172 125612 : old_loc = gfc_current_locus;
8173 :
8174 125612 : m = gfc_match_prefix (¤t_ts);
8175 125612 : if (m != MATCH_YES)
8176 : {
8177 9664 : gfc_current_locus = old_loc;
8178 9664 : return m;
8179 : }
8180 :
8181 115948 : if (gfc_match ("function% %n", name) != MATCH_YES)
8182 : {
8183 96960 : gfc_current_locus = old_loc;
8184 96960 : return MATCH_NO;
8185 : }
8186 :
8187 18988 : if (get_proc_name (name, &sym, false))
8188 : return MATCH_ERROR;
8189 :
8190 18983 : if (add_hidden_procptr_result (sym))
8191 20 : sym = sym->result;
8192 :
8193 18983 : if (current_attr.module_procedure)
8194 297 : sym->attr.module_procedure = 1;
8195 :
8196 18983 : gfc_new_block = sym;
8197 :
8198 18983 : m = gfc_match_formal_arglist (sym, 0, 0);
8199 18983 : if (m == MATCH_NO)
8200 : {
8201 6 : gfc_error ("Expected formal argument list in function "
8202 : "definition at %C");
8203 6 : m = MATCH_ERROR;
8204 6 : goto cleanup;
8205 : }
8206 18977 : else if (m == MATCH_ERROR)
8207 0 : goto cleanup;
8208 :
8209 18977 : result = NULL;
8210 :
8211 : /* According to the draft, the bind(c) and result clause can
8212 : come in either order after the formal_arg_list (i.e., either
8213 : can be first, both can exist together or by themselves or neither
8214 : one). Therefore, the match_result can't match the end of the
8215 : string, and check for the bind(c) or result clause in either order. */
8216 18977 : found_match = gfc_match_eos ();
8217 :
8218 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8219 : must have been marked BIND(C) with a BIND(C) attribute and that is
8220 : not allowed for procedures. */
8221 18977 : if (sym->attr.is_bind_c == 1)
8222 : {
8223 3 : sym->attr.is_bind_c = 0;
8224 :
8225 3 : if (gfc_state_stack->previous
8226 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8227 : {
8228 1 : locus loc;
8229 1 : loc = sym->old_symbol != NULL
8230 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8231 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8232 : "variables or common blocks", &loc);
8233 : }
8234 : }
8235 :
8236 18977 : if (found_match != MATCH_YES)
8237 : {
8238 : /* If we haven't found the end-of-statement, look for a suffix. */
8239 7698 : suffix_match = gfc_match_suffix (sym, &result);
8240 7698 : if (suffix_match == MATCH_YES)
8241 : /* Need to get the eos now. */
8242 7690 : found_match = gfc_match_eos ();
8243 : else
8244 : found_match = suffix_match;
8245 : }
8246 :
8247 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8248 : subprogram and a binding label is specified, it shall be the
8249 : same as the binding label specified in the corresponding module
8250 : procedure interface body. */
8251 18977 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8252 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8253 3 : && sym->binding_label && sym->old_symbol->binding_label
8254 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8255 : {
8256 1 : const char *null = "NULL", *s1, *s2;
8257 1 : s1 = sym->binding_label;
8258 1 : if (!s1) s1 = null;
8259 1 : s2 = sym->old_symbol->binding_label;
8260 1 : if (!s2) s2 = null;
8261 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8262 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8263 1 : return MATCH_ERROR;
8264 : }
8265 :
8266 18976 : if(found_match != MATCH_YES)
8267 : m = MATCH_ERROR;
8268 : else
8269 : {
8270 : /* Make changes to the symbol. */
8271 18968 : m = MATCH_ERROR;
8272 :
8273 18968 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8274 0 : goto cleanup;
8275 :
8276 18968 : if (!gfc_missing_attr (&sym->attr, NULL))
8277 0 : goto cleanup;
8278 :
8279 18968 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8280 : {
8281 1 : if(!sym->attr.module_procedure)
8282 1 : goto cleanup;
8283 : else
8284 0 : gfc_error_check ();
8285 : }
8286 :
8287 : /* Delay matching the function characteristics until after the
8288 : specification block by signalling kind=-1. */
8289 18967 : sym->declared_at = old_loc;
8290 18967 : if (current_ts.type != BT_UNKNOWN)
8291 6746 : current_ts.kind = -1;
8292 : else
8293 12221 : current_ts.kind = 0;
8294 :
8295 18967 : if (result == NULL)
8296 : {
8297 13299 : if (current_ts.type != BT_UNKNOWN
8298 13299 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8299 1 : goto cleanup;
8300 13298 : sym->result = sym;
8301 : }
8302 : else
8303 : {
8304 5668 : if (current_ts.type != BT_UNKNOWN
8305 5668 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8306 0 : goto cleanup;
8307 5668 : sym->result = result;
8308 : }
8309 :
8310 : /* Warn if this procedure has the same name as an intrinsic. */
8311 18966 : do_warn_intrinsic_shadow (sym, true);
8312 :
8313 18966 : return MATCH_YES;
8314 : }
8315 :
8316 16 : cleanup:
8317 16 : gfc_current_locus = old_loc;
8318 16 : return m;
8319 : }
8320 :
8321 :
8322 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8323 : pass the name of the entry, rather than the gfc_current_block name, and
8324 : to return false upon finding an existing global entry. */
8325 :
8326 : static bool
8327 505 : add_global_entry (const char *name, const char *binding_label, bool sub,
8328 : locus *where)
8329 : {
8330 505 : gfc_gsymbol *s;
8331 505 : enum gfc_symbol_type type;
8332 :
8333 505 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8334 :
8335 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8336 : name is a global identifier. */
8337 505 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8338 : {
8339 500 : s = gfc_get_gsymbol (name, false);
8340 :
8341 500 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8342 : {
8343 2 : gfc_global_used (s, where);
8344 2 : return false;
8345 : }
8346 : else
8347 : {
8348 498 : s->type = type;
8349 498 : s->sym_name = name;
8350 498 : s->where = *where;
8351 498 : s->defined = 1;
8352 498 : s->ns = gfc_current_ns;
8353 : }
8354 : }
8355 :
8356 : /* Don't add the symbol multiple times. */
8357 503 : if (binding_label
8358 503 : && (!gfc_notification_std (GFC_STD_F2008)
8359 0 : || strcmp (name, binding_label) != 0))
8360 : {
8361 5 : s = gfc_get_gsymbol (binding_label, true);
8362 :
8363 5 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8364 : {
8365 1 : gfc_global_used (s, where);
8366 1 : return false;
8367 : }
8368 : else
8369 : {
8370 4 : s->type = type;
8371 4 : s->sym_name = name;
8372 4 : s->binding_label = binding_label;
8373 4 : s->where = *where;
8374 4 : s->defined = 1;
8375 4 : s->ns = gfc_current_ns;
8376 : }
8377 : }
8378 :
8379 : return true;
8380 : }
8381 :
8382 :
8383 : /* Match an ENTRY statement. */
8384 :
8385 : match
8386 771 : gfc_match_entry (void)
8387 : {
8388 771 : gfc_symbol *proc;
8389 771 : gfc_symbol *result;
8390 771 : gfc_symbol *entry;
8391 771 : char name[GFC_MAX_SYMBOL_LEN + 1];
8392 771 : gfc_compile_state state;
8393 771 : match m;
8394 771 : gfc_entry_list *el;
8395 771 : locus old_loc;
8396 771 : bool module_procedure;
8397 771 : char peek_char;
8398 771 : match is_bind_c;
8399 :
8400 771 : m = gfc_match_name (name);
8401 771 : if (m != MATCH_YES)
8402 : return m;
8403 :
8404 771 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8405 : return MATCH_ERROR;
8406 :
8407 771 : state = gfc_current_state ();
8408 771 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8409 : {
8410 3 : switch (state)
8411 : {
8412 0 : case COMP_PROGRAM:
8413 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8414 0 : break;
8415 0 : case COMP_MODULE:
8416 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8417 0 : break;
8418 0 : case COMP_SUBMODULE:
8419 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8420 0 : break;
8421 0 : case COMP_BLOCK_DATA:
8422 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8423 : "a BLOCK DATA");
8424 0 : break;
8425 0 : case COMP_INTERFACE:
8426 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8427 : "an INTERFACE");
8428 0 : break;
8429 1 : case COMP_STRUCTURE:
8430 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8431 : "a STRUCTURE block");
8432 1 : break;
8433 0 : case COMP_DERIVED:
8434 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8435 : "a DERIVED TYPE block");
8436 0 : break;
8437 0 : case COMP_IF:
8438 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8439 : "an IF-THEN block");
8440 0 : break;
8441 0 : case COMP_DO:
8442 0 : case COMP_DO_CONCURRENT:
8443 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8444 : "a DO block");
8445 0 : break;
8446 0 : case COMP_SELECT:
8447 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8448 : "a SELECT block");
8449 0 : break;
8450 0 : case COMP_FORALL:
8451 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8452 : "a FORALL block");
8453 0 : break;
8454 0 : case COMP_WHERE:
8455 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8456 : "a WHERE block");
8457 0 : break;
8458 0 : case COMP_CONTAINS:
8459 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8460 : "a contained subprogram");
8461 0 : break;
8462 2 : default:
8463 2 : gfc_error ("Unexpected ENTRY statement at %C");
8464 : }
8465 3 : return MATCH_ERROR;
8466 : }
8467 :
8468 768 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8469 768 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8470 : {
8471 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8472 1 : return MATCH_ERROR;
8473 : }
8474 :
8475 1534 : module_procedure = gfc_current_ns->parent != NULL
8476 260 : && gfc_current_ns->parent->proc_name
8477 767 : && gfc_current_ns->parent->proc_name->attr.flavor
8478 260 : == FL_MODULE;
8479 :
8480 767 : if (gfc_current_ns->parent != NULL
8481 260 : && gfc_current_ns->parent->proc_name
8482 260 : && !module_procedure)
8483 : {
8484 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8485 : "contained procedure");
8486 0 : return MATCH_ERROR;
8487 : }
8488 :
8489 : /* Module function entries need special care in get_proc_name
8490 : because previous references within the function will have
8491 : created symbols attached to the current namespace. */
8492 767 : if (get_proc_name (name, &entry,
8493 : gfc_current_ns->parent != NULL
8494 767 : && module_procedure))
8495 : return MATCH_ERROR;
8496 :
8497 765 : proc = gfc_current_block ();
8498 :
8499 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8500 : must have been marked BIND(C) with a BIND(C) attribute and that is
8501 : not allowed for procedures. */
8502 765 : if (entry->attr.is_bind_c == 1)
8503 : {
8504 0 : locus loc;
8505 :
8506 0 : entry->attr.is_bind_c = 0;
8507 :
8508 0 : loc = entry->old_symbol != NULL
8509 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8510 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8511 : "variables or common blocks", &loc);
8512 : }
8513 :
8514 : /* Check what next non-whitespace character is so we can tell if there
8515 : is the required parens if we have a BIND(C). */
8516 765 : old_loc = gfc_current_locus;
8517 765 : gfc_gobble_whitespace ();
8518 765 : peek_char = gfc_peek_ascii_char ();
8519 :
8520 765 : if (state == COMP_SUBROUTINE)
8521 : {
8522 134 : m = gfc_match_formal_arglist (entry, 0, 1);
8523 134 : if (m != MATCH_YES)
8524 : return MATCH_ERROR;
8525 :
8526 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8527 : never be an internal procedure. */
8528 134 : is_bind_c = gfc_match_bind_c (entry, true);
8529 134 : if (is_bind_c == MATCH_ERROR)
8530 : return MATCH_ERROR;
8531 134 : if (is_bind_c == MATCH_YES)
8532 : {
8533 22 : if (peek_char != '(')
8534 : {
8535 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8536 0 : return MATCH_ERROR;
8537 : }
8538 :
8539 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8540 22 : &(entry->declared_at), 1))
8541 : return MATCH_ERROR;
8542 :
8543 : }
8544 :
8545 134 : if (!gfc_current_ns->parent
8546 134 : && !add_global_entry (name, entry->binding_label, true,
8547 : &old_loc))
8548 : return MATCH_ERROR;
8549 :
8550 : /* An entry in a subroutine. */
8551 131 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8552 131 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8553 3 : return MATCH_ERROR;
8554 : }
8555 : else
8556 : {
8557 : /* An entry in a function.
8558 : We need to take special care because writing
8559 : ENTRY f()
8560 : as
8561 : ENTRY f
8562 : is allowed, whereas
8563 : ENTRY f() RESULT (r)
8564 : can't be written as
8565 : ENTRY f RESULT (r). */
8566 631 : if (gfc_match_eos () == MATCH_YES)
8567 : {
8568 24 : gfc_current_locus = old_loc;
8569 : /* Match the empty argument list, and add the interface to
8570 : the symbol. */
8571 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8572 : }
8573 : else
8574 607 : m = gfc_match_formal_arglist (entry, 0, 0);
8575 :
8576 631 : if (m != MATCH_YES)
8577 : return MATCH_ERROR;
8578 :
8579 630 : result = NULL;
8580 :
8581 630 : if (gfc_match_eos () == MATCH_YES)
8582 : {
8583 399 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8584 399 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8585 2 : return MATCH_ERROR;
8586 :
8587 397 : entry->result = entry;
8588 : }
8589 : else
8590 : {
8591 231 : m = gfc_match_suffix (entry, &result);
8592 231 : if (m == MATCH_NO)
8593 0 : gfc_syntax_error (ST_ENTRY);
8594 231 : if (m != MATCH_YES)
8595 : return MATCH_ERROR;
8596 :
8597 231 : if (result)
8598 : {
8599 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8600 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8601 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8602 0 : return MATCH_ERROR;
8603 212 : entry->result = result;
8604 : }
8605 : else
8606 : {
8607 19 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8608 19 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8609 0 : return MATCH_ERROR;
8610 19 : entry->result = entry;
8611 : }
8612 : }
8613 :
8614 628 : if (!gfc_current_ns->parent
8615 628 : && !add_global_entry (name, entry->binding_label, false,
8616 : &old_loc))
8617 : return MATCH_ERROR;
8618 : }
8619 :
8620 756 : if (gfc_match_eos () != MATCH_YES)
8621 : {
8622 0 : gfc_syntax_error (ST_ENTRY);
8623 0 : return MATCH_ERROR;
8624 : }
8625 :
8626 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8627 756 : if (proc->attr.elemental && entry->attr.is_bind_c)
8628 : {
8629 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8630 : "elemental procedure", &entry->declared_at);
8631 2 : return MATCH_ERROR;
8632 : }
8633 :
8634 754 : entry->attr.recursive = proc->attr.recursive;
8635 754 : entry->attr.elemental = proc->attr.elemental;
8636 754 : entry->attr.pure = proc->attr.pure;
8637 :
8638 754 : el = gfc_get_entry_list ();
8639 754 : el->sym = entry;
8640 754 : el->next = gfc_current_ns->entries;
8641 754 : gfc_current_ns->entries = el;
8642 754 : if (el->next)
8643 84 : el->id = el->next->id + 1;
8644 : else
8645 670 : el->id = 1;
8646 :
8647 754 : new_st.op = EXEC_ENTRY;
8648 754 : new_st.ext.entry = el;
8649 :
8650 754 : return MATCH_YES;
8651 : }
8652 :
8653 :
8654 : /* Match a subroutine statement, including optional prefixes. */
8655 :
8656 : match
8657 793903 : gfc_match_subroutine (void)
8658 : {
8659 793903 : char name[GFC_MAX_SYMBOL_LEN + 1];
8660 793903 : gfc_symbol *sym;
8661 793903 : match m;
8662 793903 : match is_bind_c;
8663 793903 : char peek_char;
8664 793903 : bool allow_binding_name;
8665 793903 : locus loc;
8666 :
8667 793903 : if (gfc_current_state () != COMP_NONE
8668 752840 : && gfc_current_state () != COMP_INTERFACE
8669 731008 : && gfc_current_state () != COMP_CONTAINS)
8670 : return MATCH_NO;
8671 :
8672 103710 : m = gfc_match_prefix (NULL);
8673 103710 : if (m != MATCH_YES)
8674 : return m;
8675 :
8676 94056 : loc = gfc_current_locus;
8677 94056 : m = gfc_match ("subroutine% %n", name);
8678 94056 : if (m != MATCH_YES)
8679 : return m;
8680 :
8681 42469 : if (get_proc_name (name, &sym, false))
8682 : return MATCH_ERROR;
8683 :
8684 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8685 : the symbol existed before. */
8686 42457 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8687 : &gfc_current_locus);
8688 :
8689 42457 : if (current_attr.module_procedure)
8690 367 : sym->attr.module_procedure = 1;
8691 :
8692 42457 : if (add_hidden_procptr_result (sym))
8693 9 : sym = sym->result;
8694 :
8695 42457 : gfc_new_block = sym;
8696 :
8697 : /* Check what next non-whitespace character is so we can tell if there
8698 : is the required parens if we have a BIND(C). */
8699 42457 : gfc_gobble_whitespace ();
8700 42457 : peek_char = gfc_peek_ascii_char ();
8701 :
8702 42457 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8703 : return MATCH_ERROR;
8704 :
8705 42454 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8706 : return MATCH_ERROR;
8707 :
8708 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8709 : must have been marked BIND(C) with a BIND(C) attribute and that is
8710 : not allowed for procedures. */
8711 42454 : if (sym->attr.is_bind_c == 1)
8712 : {
8713 4 : sym->attr.is_bind_c = 0;
8714 :
8715 4 : if (gfc_state_stack->previous
8716 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8717 : {
8718 2 : locus loc;
8719 2 : loc = sym->old_symbol != NULL
8720 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8721 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8722 : "variables or common blocks", &loc);
8723 : }
8724 : }
8725 :
8726 : /* C binding names are not allowed for internal procedures. */
8727 42454 : if (gfc_current_state () == COMP_CONTAINS
8728 25700 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8729 : allow_binding_name = false;
8730 : else
8731 27721 : allow_binding_name = true;
8732 :
8733 : /* Here, we are just checking if it has the bind(c) attribute, and if
8734 : so, then we need to make sure it's all correct. If it doesn't,
8735 : we still need to continue matching the rest of the subroutine line. */
8736 42454 : gfc_gobble_whitespace ();
8737 42454 : loc = gfc_current_locus;
8738 42454 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8739 42454 : if (is_bind_c == MATCH_ERROR)
8740 : {
8741 : /* There was an attempt at the bind(c), but it was wrong. An
8742 : error message should have been printed w/in the gfc_match_bind_c
8743 : so here we'll just return the MATCH_ERROR. */
8744 : return MATCH_ERROR;
8745 : }
8746 :
8747 42441 : if (is_bind_c == MATCH_YES)
8748 : {
8749 3968 : gfc_formal_arglist *arg;
8750 :
8751 : /* The following is allowed in the Fortran 2008 draft. */
8752 3968 : if (gfc_current_state () == COMP_CONTAINS
8753 1297 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8754 4379 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8755 : "at %L may not be specified for an internal "
8756 : "procedure", &gfc_current_locus))
8757 : return MATCH_ERROR;
8758 :
8759 3965 : if (peek_char != '(')
8760 : {
8761 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8762 1 : return MATCH_ERROR;
8763 : }
8764 :
8765 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8766 : subprogram and a binding label is specified, it shall be the
8767 : same as the binding label specified in the corresponding module
8768 : procedure interface body. */
8769 3964 : if (sym->attr.module_procedure && sym->old_symbol
8770 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8771 3 : && sym->binding_label && sym->old_symbol->binding_label
8772 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8773 : {
8774 1 : const char *null = "NULL", *s1, *s2;
8775 1 : s1 = sym->binding_label;
8776 1 : if (!s1) s1 = null;
8777 1 : s2 = sym->old_symbol->binding_label;
8778 1 : if (!s2) s2 = null;
8779 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8780 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8781 1 : return MATCH_ERROR;
8782 : }
8783 :
8784 : /* Scan the dummy arguments for an alternate return. */
8785 12240 : for (arg = sym->formal; arg; arg = arg->next)
8786 8278 : if (!arg->sym)
8787 : {
8788 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8789 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8790 1 : return MATCH_ERROR;
8791 : }
8792 :
8793 3962 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8794 : return MATCH_ERROR;
8795 : }
8796 :
8797 42434 : if (gfc_match_eos () != MATCH_YES)
8798 : {
8799 1 : gfc_syntax_error (ST_SUBROUTINE);
8800 1 : return MATCH_ERROR;
8801 : }
8802 :
8803 42433 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8804 : {
8805 4 : if(!sym->attr.module_procedure)
8806 : return MATCH_ERROR;
8807 : else
8808 3 : gfc_error_check ();
8809 : }
8810 :
8811 : /* Warn if it has the same name as an intrinsic. */
8812 42432 : do_warn_intrinsic_shadow (sym, false);
8813 :
8814 42432 : return MATCH_YES;
8815 : }
8816 :
8817 :
8818 : /* Check that the NAME identifier in a BIND attribute or statement
8819 : is conform to C identifier rules. */
8820 :
8821 : match
8822 1162 : check_bind_name_identifier (char **name)
8823 : {
8824 1162 : char *n = *name, *p;
8825 :
8826 : /* Remove leading spaces. */
8827 1188 : while (*n == ' ')
8828 26 : n++;
8829 :
8830 : /* On an empty string, free memory and set name to NULL. */
8831 1162 : if (*n == '\0')
8832 : {
8833 42 : free (*name);
8834 42 : *name = NULL;
8835 42 : return MATCH_YES;
8836 : }
8837 :
8838 : /* Remove trailing spaces. */
8839 1120 : p = n + strlen(n) - 1;
8840 1136 : while (*p == ' ')
8841 16 : *(p--) = '\0';
8842 :
8843 : /* Insert the identifier into the symbol table. */
8844 1120 : p = xstrdup (n);
8845 1120 : free (*name);
8846 1120 : *name = p;
8847 :
8848 : /* Now check that identifier is valid under C rules. */
8849 1120 : if (ISDIGIT (*p))
8850 : {
8851 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8852 2 : return MATCH_ERROR;
8853 : }
8854 :
8855 12355 : for (; *p; p++)
8856 11240 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8857 : {
8858 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8859 3 : return MATCH_ERROR;
8860 : }
8861 :
8862 : return MATCH_YES;
8863 : }
8864 :
8865 :
8866 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8867 : given, and set the binding label in either the given symbol (if not
8868 : NULL), or in the current_ts. The symbol may be NULL because we may
8869 : encounter the BIND(C) before the declaration itself. Return
8870 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8871 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8872 : or MATCH_YES if the specifier was correct and the binding label and
8873 : bind(c) fields were set correctly for the given symbol or the
8874 : current_ts. If allow_binding_name is false, no binding name may be
8875 : given. */
8876 :
8877 : match
8878 50819 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8879 : {
8880 50819 : char *binding_label = NULL;
8881 50819 : gfc_expr *e = NULL;
8882 :
8883 : /* Initialize the flag that specifies whether we encountered a NAME=
8884 : specifier or not. */
8885 50819 : has_name_equals = 0;
8886 :
8887 : /* This much we have to be able to match, in this order, if
8888 : there is a bind(c) label. */
8889 50819 : if (gfc_match (" bind ( c ") != MATCH_YES)
8890 : return MATCH_NO;
8891 :
8892 : /* Now see if there is a binding label, or if we've reached the
8893 : end of the bind(c) attribute without one. */
8894 6842 : if (gfc_match_char (',') == MATCH_YES)
8895 : {
8896 1169 : if (gfc_match (" name = ") != MATCH_YES)
8897 : {
8898 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8899 : "at %C");
8900 : /* should give an error message here */
8901 1 : return MATCH_ERROR;
8902 : }
8903 :
8904 1168 : has_name_equals = 1;
8905 :
8906 1168 : if (gfc_match_init_expr (&e) != MATCH_YES)
8907 : {
8908 2 : gfc_free_expr (e);
8909 2 : return MATCH_ERROR;
8910 : }
8911 :
8912 1166 : if (!gfc_simplify_expr(e, 0))
8913 : {
8914 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8915 0 : gfc_free_expr (e);
8916 0 : return MATCH_ERROR;
8917 : }
8918 :
8919 1166 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8920 1163 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
8921 : {
8922 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
8923 : "default character kind");
8924 4 : gfc_free_expr(e);
8925 4 : return MATCH_ERROR;
8926 : }
8927 :
8928 : // Get a C string from the Fortran string constant
8929 2324 : binding_label = gfc_widechar_to_char (e->value.character.string,
8930 1162 : e->value.character.length);
8931 1162 : gfc_free_expr(e);
8932 :
8933 : // Check that it is valid (old gfc_match_name_C)
8934 1162 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
8935 : return MATCH_ERROR;
8936 : }
8937 :
8938 : /* Get the required right paren. */
8939 6830 : if (gfc_match_char (')') != MATCH_YES)
8940 : {
8941 1 : gfc_error ("Missing closing paren for binding label at %C");
8942 1 : return MATCH_ERROR;
8943 : }
8944 :
8945 6829 : if (has_name_equals && !allow_binding_name)
8946 : {
8947 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
8948 6 : return MATCH_ERROR;
8949 : }
8950 :
8951 6823 : if (has_name_equals && sym != NULL && sym->attr.dummy)
8952 : {
8953 2 : gfc_error ("For dummy procedure %s, no binding name is "
8954 : "allowed in BIND(C) at %C", sym->name);
8955 2 : return MATCH_ERROR;
8956 : }
8957 :
8958 :
8959 : /* Save the binding label to the symbol. If sym is null, we're
8960 : probably matching the typespec attributes of a declaration and
8961 : haven't gotten the name yet, and therefore, no symbol yet. */
8962 6821 : if (binding_label)
8963 : {
8964 1108 : if (sym != NULL)
8965 999 : sym->binding_label = binding_label;
8966 : else
8967 109 : curr_binding_label = binding_label;
8968 : }
8969 5713 : else if (allow_binding_name)
8970 : {
8971 : /* No binding label, but if symbol isn't null, we
8972 : can set the label for it here.
8973 : If name="" or allow_binding_name is false, no C binding name is
8974 : created. */
8975 5290 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
8976 5123 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
8977 : }
8978 :
8979 6821 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
8980 718 : && current_interface.type == INTERFACE_ABSTRACT)
8981 : {
8982 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8983 1 : return MATCH_ERROR;
8984 : }
8985 :
8986 : return MATCH_YES;
8987 : }
8988 :
8989 :
8990 : /* Return nonzero if we're currently compiling a contained procedure. */
8991 :
8992 : static int
8993 61710 : contained_procedure (void)
8994 : {
8995 61710 : gfc_state_data *s = gfc_state_stack;
8996 :
8997 61710 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
8998 60828 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
8999 35959 : return 1;
9000 :
9001 : return 0;
9002 : }
9003 :
9004 : /* Set the kind of each enumerator. The kind is selected such that it is
9005 : interoperable with the corresponding C enumeration type, making
9006 : sure that -fshort-enums is honored. */
9007 :
9008 : static void
9009 158 : set_enum_kind(void)
9010 : {
9011 158 : enumerator_history *current_history = NULL;
9012 158 : int kind;
9013 158 : int i;
9014 :
9015 158 : if (max_enum == NULL || enum_history == NULL)
9016 : return;
9017 :
9018 150 : if (!flag_short_enums)
9019 : return;
9020 :
9021 : i = 0;
9022 48 : do
9023 : {
9024 48 : kind = gfc_integer_kinds[i++].kind;
9025 : }
9026 48 : while (kind < gfc_c_int_kind
9027 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
9028 : kind) != ARITH_OK);
9029 :
9030 24 : current_history = enum_history;
9031 96 : while (current_history != NULL)
9032 : {
9033 72 : current_history->sym->ts.kind = kind;
9034 72 : current_history = current_history->next;
9035 : }
9036 : }
9037 :
9038 :
9039 : /* Match any of the various end-block statements. Returns the type of
9040 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
9041 : and END BLOCK statements cannot be replaced by a single END statement. */
9042 :
9043 : match
9044 181929 : gfc_match_end (gfc_statement *st)
9045 : {
9046 181929 : char name[GFC_MAX_SYMBOL_LEN + 1];
9047 181929 : gfc_compile_state state;
9048 181929 : locus old_loc;
9049 181929 : const char *block_name;
9050 181929 : const char *target;
9051 181929 : int eos_ok;
9052 181929 : match m;
9053 181929 : gfc_namespace *parent_ns, *ns, *prev_ns;
9054 181929 : gfc_namespace **nsp;
9055 181929 : bool abbreviated_modproc_decl = false;
9056 181929 : bool got_matching_end = false;
9057 :
9058 181929 : old_loc = gfc_current_locus;
9059 181929 : if (gfc_match ("end") != MATCH_YES)
9060 : return MATCH_NO;
9061 :
9062 176915 : state = gfc_current_state ();
9063 96458 : block_name = gfc_current_block () == NULL
9064 176915 : ? NULL : gfc_current_block ()->name;
9065 :
9066 176915 : switch (state)
9067 : {
9068 2874 : case COMP_ASSOCIATE:
9069 2874 : case COMP_BLOCK:
9070 2874 : case COMP_CHANGE_TEAM:
9071 2874 : if (startswith (block_name, "block@"))
9072 : block_name = NULL;
9073 : break;
9074 :
9075 17066 : case COMP_CONTAINS:
9076 17066 : case COMP_DERIVED_CONTAINS:
9077 17066 : case COMP_OMP_BEGIN_METADIRECTIVE:
9078 17066 : state = gfc_state_stack->previous->state;
9079 15526 : block_name = gfc_state_stack->previous->sym == NULL
9080 17066 : ? NULL : gfc_state_stack->previous->sym->name;
9081 17066 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
9082 17066 : && gfc_state_stack->previous->sym->abr_modproc_decl;
9083 : break;
9084 :
9085 : case COMP_OMP_METADIRECTIVE:
9086 : {
9087 : /* Metadirectives can be nested, so we need to drill down to the
9088 : first state that is not COMP_OMP_METADIRECTIVE. */
9089 : gfc_state_data *state_data = gfc_state_stack;
9090 :
9091 85 : do
9092 : {
9093 85 : state_data = state_data->previous;
9094 85 : state = state_data->state;
9095 77 : block_name = (state_data->sym == NULL
9096 85 : ? NULL : state_data->sym->name);
9097 170 : abbreviated_modproc_decl = (state_data->sym
9098 85 : && state_data->sym->abr_modproc_decl);
9099 : }
9100 85 : while (state == COMP_OMP_METADIRECTIVE);
9101 :
9102 83 : if (block_name && startswith (block_name, "block@"))
9103 : block_name = NULL;
9104 : }
9105 : break;
9106 :
9107 : default:
9108 : break;
9109 : }
9110 :
9111 83 : if (!abbreviated_modproc_decl)
9112 176914 : abbreviated_modproc_decl = gfc_current_block ()
9113 176914 : && gfc_current_block ()->abr_modproc_decl;
9114 :
9115 176915 : switch (state)
9116 : {
9117 27609 : case COMP_NONE:
9118 27609 : case COMP_PROGRAM:
9119 27609 : *st = ST_END_PROGRAM;
9120 27609 : target = " program";
9121 27609 : eos_ok = 1;
9122 27609 : break;
9123 :
9124 42610 : case COMP_SUBROUTINE:
9125 42610 : *st = ST_END_SUBROUTINE;
9126 42610 : if (!abbreviated_modproc_decl)
9127 : target = " subroutine";
9128 : else
9129 135 : target = " procedure";
9130 42610 : eos_ok = !contained_procedure ();
9131 42610 : break;
9132 :
9133 19100 : case COMP_FUNCTION:
9134 19100 : *st = ST_END_FUNCTION;
9135 19100 : if (!abbreviated_modproc_decl)
9136 : target = " function";
9137 : else
9138 117 : target = " procedure";
9139 19100 : eos_ok = !contained_procedure ();
9140 19100 : break;
9141 :
9142 87 : case COMP_BLOCK_DATA:
9143 87 : *st = ST_END_BLOCK_DATA;
9144 87 : target = " block data";
9145 87 : eos_ok = 1;
9146 87 : break;
9147 :
9148 9646 : case COMP_MODULE:
9149 9646 : *st = ST_END_MODULE;
9150 9646 : target = " module";
9151 9646 : eos_ok = 1;
9152 9646 : break;
9153 :
9154 239 : case COMP_SUBMODULE:
9155 239 : *st = ST_END_SUBMODULE;
9156 239 : target = " submodule";
9157 239 : eos_ok = 1;
9158 239 : break;
9159 :
9160 10531 : case COMP_INTERFACE:
9161 10531 : *st = ST_END_INTERFACE;
9162 10531 : target = " interface";
9163 10531 : eos_ok = 0;
9164 10531 : break;
9165 :
9166 257 : case COMP_MAP:
9167 257 : *st = ST_END_MAP;
9168 257 : target = " map";
9169 257 : eos_ok = 0;
9170 257 : break;
9171 :
9172 132 : case COMP_UNION:
9173 132 : *st = ST_END_UNION;
9174 132 : target = " union";
9175 132 : eos_ok = 0;
9176 132 : break;
9177 :
9178 313 : case COMP_STRUCTURE:
9179 313 : *st = ST_END_STRUCTURE;
9180 313 : target = " structure";
9181 313 : eos_ok = 0;
9182 313 : break;
9183 :
9184 12674 : case COMP_DERIVED:
9185 12674 : case COMP_DERIVED_CONTAINS:
9186 12674 : *st = ST_END_TYPE;
9187 12674 : target = " type";
9188 12674 : eos_ok = 0;
9189 12674 : break;
9190 :
9191 1465 : case COMP_ASSOCIATE:
9192 1465 : *st = ST_END_ASSOCIATE;
9193 1465 : target = " associate";
9194 1465 : eos_ok = 0;
9195 1465 : break;
9196 :
9197 1365 : case COMP_BLOCK:
9198 1365 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9199 1365 : *st = ST_END_BLOCK;
9200 1365 : target = " block";
9201 1365 : eos_ok = 0;
9202 1365 : break;
9203 :
9204 14740 : case COMP_IF:
9205 14740 : *st = ST_ENDIF;
9206 14740 : target = " if";
9207 14740 : eos_ok = 0;
9208 14740 : break;
9209 :
9210 30394 : case COMP_DO:
9211 30394 : case COMP_DO_CONCURRENT:
9212 30394 : *st = ST_ENDDO;
9213 30394 : target = " do";
9214 30394 : eos_ok = 0;
9215 30394 : break;
9216 :
9217 54 : case COMP_CRITICAL:
9218 54 : *st = ST_END_CRITICAL;
9219 54 : target = " critical";
9220 54 : eos_ok = 0;
9221 54 : break;
9222 :
9223 4577 : case COMP_SELECT:
9224 4577 : case COMP_SELECT_TYPE:
9225 4577 : case COMP_SELECT_RANK:
9226 4577 : *st = ST_END_SELECT;
9227 4577 : target = " select";
9228 4577 : eos_ok = 0;
9229 4577 : break;
9230 :
9231 508 : case COMP_FORALL:
9232 508 : *st = ST_END_FORALL;
9233 508 : target = " forall";
9234 508 : eos_ok = 0;
9235 508 : break;
9236 :
9237 373 : case COMP_WHERE:
9238 373 : *st = ST_END_WHERE;
9239 373 : target = " where";
9240 373 : eos_ok = 0;
9241 373 : break;
9242 :
9243 158 : case COMP_ENUM:
9244 158 : *st = ST_END_ENUM;
9245 158 : target = " enum";
9246 158 : eos_ok = 0;
9247 158 : last_initializer = NULL;
9248 158 : set_enum_kind ();
9249 158 : gfc_free_enum_history ();
9250 158 : break;
9251 :
9252 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9253 0 : *st = ST_OMP_END_METADIRECTIVE;
9254 0 : target = " metadirective";
9255 0 : eos_ok = 0;
9256 0 : break;
9257 :
9258 74 : case COMP_CHANGE_TEAM:
9259 74 : *st = ST_END_TEAM;
9260 74 : target = " team";
9261 74 : eos_ok = 0;
9262 74 : break;
9263 :
9264 9 : default:
9265 9 : gfc_error ("Unexpected END statement at %C");
9266 9 : goto cleanup;
9267 : }
9268 :
9269 176906 : old_loc = gfc_current_locus;
9270 176906 : if (gfc_match_eos () == MATCH_YES)
9271 : {
9272 20450 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9273 : {
9274 7989 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9275 : "instead of %s statement at %L",
9276 : abbreviated_modproc_decl ? "END PROCEDURE"
9277 3982 : : gfc_ascii_statement(*st), &old_loc))
9278 4 : goto cleanup;
9279 : }
9280 9 : else if (!eos_ok)
9281 : {
9282 : /* We would have required END [something]. */
9283 9 : gfc_error ("%s statement expected at %L",
9284 : gfc_ascii_statement (*st), &old_loc);
9285 9 : goto cleanup;
9286 : }
9287 :
9288 20437 : return MATCH_YES;
9289 : }
9290 :
9291 : /* Verify that we've got the sort of end-block that we're expecting. */
9292 156456 : if (gfc_match (target) != MATCH_YES)
9293 : {
9294 331 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9295 165 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9296 166 : goto cleanup;
9297 : }
9298 : else
9299 156290 : got_matching_end = true;
9300 :
9301 156290 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9302 : /* Emit errors of stat and errmsg parsing now to finish the block and
9303 : continue analysis of compilation unit. */
9304 2 : gfc_error_check ();
9305 :
9306 156290 : old_loc = gfc_current_locus;
9307 : /* If we're at the end, make sure a block name wasn't required. */
9308 156290 : if (gfc_match_eos () == MATCH_YES)
9309 : {
9310 103429 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9311 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9312 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9313 : && *st != ST_END_TEAM)
9314 : return MATCH_YES;
9315 :
9316 53054 : if (!block_name)
9317 : return MATCH_YES;
9318 :
9319 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9320 : block_name, gfc_ascii_statement (*st), &old_loc);
9321 :
9322 8 : return MATCH_ERROR;
9323 : }
9324 :
9325 : /* END INTERFACE has a special handler for its several possible endings. */
9326 52861 : if (*st == ST_END_INTERFACE)
9327 624 : return gfc_match_end_interface ();
9328 :
9329 : /* We haven't hit the end of statement, so what is left must be an
9330 : end-name. */
9331 52237 : m = gfc_match_space ();
9332 52237 : if (m == MATCH_YES)
9333 52237 : m = gfc_match_name (name);
9334 :
9335 52237 : if (m == MATCH_NO)
9336 0 : gfc_error ("Expected terminating name at %C");
9337 52237 : if (m != MATCH_YES)
9338 0 : goto cleanup;
9339 :
9340 52237 : if (block_name == NULL)
9341 15 : goto syntax;
9342 :
9343 : /* We have to pick out the declared submodule name from the composite
9344 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9345 52222 : if (state == COMP_SUBMODULE)
9346 118 : block_name = strchr (block_name, '.') + 1;
9347 :
9348 52222 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9349 : {
9350 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9351 : gfc_ascii_statement (*st));
9352 8 : goto cleanup;
9353 : }
9354 : /* Procedure pointer as function result. */
9355 52214 : else if (strcmp (block_name, "ppr@") == 0
9356 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9357 : {
9358 0 : gfc_error ("Expected label %qs for %s statement at %C",
9359 0 : gfc_current_block ()->ns->proc_name->name,
9360 : gfc_ascii_statement (*st));
9361 0 : goto cleanup;
9362 : }
9363 :
9364 52214 : if (gfc_match_eos () == MATCH_YES)
9365 : return MATCH_YES;
9366 :
9367 0 : syntax:
9368 15 : gfc_syntax_error (*st);
9369 :
9370 211 : cleanup:
9371 211 : gfc_current_locus = old_loc;
9372 :
9373 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9374 : Remove it from the parent namespace's sibling list. */
9375 :
9376 211 : if (state == COMP_BLOCK && !got_matching_end)
9377 : {
9378 7 : parent_ns = gfc_current_ns->parent;
9379 :
9380 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9381 :
9382 7 : prev_ns = NULL;
9383 7 : ns = *nsp;
9384 14 : while (ns)
9385 : {
9386 7 : if (ns == gfc_current_ns)
9387 : {
9388 7 : if (prev_ns == NULL)
9389 7 : *nsp = NULL;
9390 : else
9391 0 : prev_ns->sibling = ns->sibling;
9392 : }
9393 7 : prev_ns = ns;
9394 7 : ns = ns->sibling;
9395 : }
9396 :
9397 : /* The namespace can still be referenced by parser state and code nodes;
9398 : let normal block unwinding/freeing own its lifetime. */
9399 7 : gfc_current_ns = parent_ns;
9400 7 : gfc_state_stack = gfc_state_stack->previous;
9401 7 : state = gfc_current_state ();
9402 : }
9403 :
9404 : return MATCH_ERROR;
9405 : }
9406 :
9407 :
9408 :
9409 : /***************** Attribute declaration statements ****************/
9410 :
9411 : /* Set the attribute of a single variable. */
9412 :
9413 : static match
9414 10258 : attr_decl1 (void)
9415 : {
9416 10258 : char name[GFC_MAX_SYMBOL_LEN + 1];
9417 10258 : gfc_array_spec *as;
9418 :
9419 : /* Workaround -Wmaybe-uninitialized false positive during
9420 : profiledbootstrap by initializing them. */
9421 10258 : gfc_symbol *sym = NULL;
9422 10258 : locus var_locus;
9423 10258 : match m;
9424 :
9425 10258 : as = NULL;
9426 :
9427 10258 : m = gfc_match_name (name);
9428 10258 : if (m != MATCH_YES)
9429 0 : goto cleanup;
9430 :
9431 10258 : if (find_special (name, &sym, false))
9432 : return MATCH_ERROR;
9433 :
9434 10258 : if (!check_function_name (name))
9435 : {
9436 7 : m = MATCH_ERROR;
9437 7 : goto cleanup;
9438 : }
9439 :
9440 10251 : var_locus = gfc_current_locus;
9441 :
9442 : /* Deal with possible array specification for certain attributes. */
9443 10251 : if (current_attr.dimension
9444 8674 : || current_attr.codimension
9445 8652 : || current_attr.allocatable
9446 8228 : || current_attr.pointer
9447 7517 : || current_attr.target)
9448 : {
9449 2960 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9450 : !current_attr.dimension
9451 1383 : && !current_attr.pointer
9452 3632 : && !current_attr.target);
9453 2960 : if (m == MATCH_ERROR)
9454 2 : goto cleanup;
9455 :
9456 2958 : if (current_attr.dimension && m == MATCH_NO)
9457 : {
9458 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9459 : "statement", &var_locus);
9460 0 : m = MATCH_ERROR;
9461 0 : goto cleanup;
9462 : }
9463 :
9464 2958 : if (current_attr.dimension && sym->value)
9465 : {
9466 1 : gfc_error ("Dimensions specified for %s at %L after its "
9467 : "initialization", sym->name, &var_locus);
9468 1 : m = MATCH_ERROR;
9469 1 : goto cleanup;
9470 : }
9471 :
9472 2957 : if (current_attr.codimension && m == MATCH_NO)
9473 : {
9474 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9475 : "statement", &var_locus);
9476 0 : m = MATCH_ERROR;
9477 0 : goto cleanup;
9478 : }
9479 :
9480 2957 : if ((current_attr.allocatable || current_attr.pointer)
9481 1135 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9482 : {
9483 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9484 0 : m = MATCH_ERROR;
9485 0 : goto cleanup;
9486 : }
9487 : }
9488 :
9489 10248 : if (sym->ts.type == BT_CLASS
9490 200 : && sym->ts.u.derived
9491 200 : && sym->ts.u.derived->attr.is_class)
9492 : {
9493 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9494 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9495 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9496 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9497 177 : if (CLASS_DATA (sym)->as)
9498 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9499 : }
9500 8673 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9501 18900 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9502 : {
9503 22 : m = MATCH_ERROR;
9504 22 : goto cleanup;
9505 : }
9506 10226 : if (!gfc_set_array_spec (sym, as, &var_locus))
9507 : {
9508 18 : m = MATCH_ERROR;
9509 18 : goto cleanup;
9510 : }
9511 :
9512 10208 : if (sym->attr.cray_pointee && sym->as != NULL)
9513 : {
9514 : /* Fix the array spec. */
9515 2 : m = gfc_mod_pointee_as (sym->as);
9516 2 : if (m == MATCH_ERROR)
9517 0 : goto cleanup;
9518 : }
9519 :
9520 10208 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9521 : {
9522 0 : m = MATCH_ERROR;
9523 0 : goto cleanup;
9524 : }
9525 :
9526 5711 : if ((current_attr.external || current_attr.intrinsic)
9527 6134 : && sym->attr.flavor != FL_PROCEDURE
9528 16310 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9529 : {
9530 0 : m = MATCH_ERROR;
9531 0 : goto cleanup;
9532 : }
9533 :
9534 10208 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9535 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9536 136 : && !current_attr.external)
9537 : {
9538 136 : sym->attr.pointer = 0;
9539 136 : sym->attr.allocatable = 0;
9540 136 : sym->attr.dimension = 0;
9541 136 : sym->attr.codimension = 0;
9542 136 : gfc_free_array_spec (sym->as);
9543 136 : sym->as = NULL;
9544 : }
9545 10072 : else if (sym->ts.type == BT_CLASS
9546 10072 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9547 : {
9548 0 : m = MATCH_ERROR;
9549 0 : goto cleanup;
9550 : }
9551 :
9552 10208 : add_hidden_procptr_result (sym);
9553 :
9554 10208 : return MATCH_YES;
9555 :
9556 50 : cleanup:
9557 50 : gfc_free_array_spec (as);
9558 50 : return m;
9559 : }
9560 :
9561 :
9562 : /* Generic attribute declaration subroutine. Used for attributes that
9563 : just have a list of names. */
9564 :
9565 : static match
9566 6596 : attr_decl (void)
9567 : {
9568 6596 : match m;
9569 :
9570 : /* Gobble the optional double colon, by simply ignoring the result
9571 : of gfc_match(). */
9572 6596 : gfc_match (" ::");
9573 :
9574 10258 : for (;;)
9575 : {
9576 10258 : m = attr_decl1 ();
9577 10258 : if (m != MATCH_YES)
9578 : break;
9579 :
9580 10208 : if (gfc_match_eos () == MATCH_YES)
9581 : {
9582 : m = MATCH_YES;
9583 : break;
9584 : }
9585 :
9586 3662 : if (gfc_match_char (',') != MATCH_YES)
9587 : {
9588 0 : gfc_error ("Unexpected character in variable list at %C");
9589 0 : m = MATCH_ERROR;
9590 0 : break;
9591 : }
9592 : }
9593 :
9594 6596 : return m;
9595 : }
9596 :
9597 :
9598 : /* This routine matches Cray Pointer declarations of the form:
9599 : pointer ( <pointer>, <pointee> )
9600 : or
9601 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9602 : The pointer, if already declared, should be an integer. Otherwise, we
9603 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9604 : be either a scalar, or an array declaration. No space is allocated for
9605 : the pointee. For the statement
9606 : pointer (ipt, ar(10))
9607 : any subsequent uses of ar will be translated (in C-notation) as
9608 : ar(i) => ((<type> *) ipt)(i)
9609 : After gimplification, pointee variable will disappear in the code. */
9610 :
9611 : static match
9612 334 : cray_pointer_decl (void)
9613 : {
9614 334 : match m;
9615 334 : gfc_array_spec *as = NULL;
9616 334 : gfc_symbol *cptr; /* Pointer symbol. */
9617 334 : gfc_symbol *cpte; /* Pointee symbol. */
9618 334 : locus var_locus;
9619 334 : bool done = false;
9620 :
9621 334 : while (!done)
9622 : {
9623 347 : if (gfc_match_char ('(') != MATCH_YES)
9624 : {
9625 1 : gfc_error ("Expected %<(%> at %C");
9626 1 : return MATCH_ERROR;
9627 : }
9628 :
9629 : /* Match pointer. */
9630 346 : var_locus = gfc_current_locus;
9631 346 : gfc_clear_attr (¤t_attr);
9632 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9633 346 : current_ts.type = BT_INTEGER;
9634 346 : current_ts.kind = gfc_index_integer_kind;
9635 :
9636 346 : m = gfc_match_symbol (&cptr, 0);
9637 346 : if (m != MATCH_YES)
9638 : {
9639 2 : gfc_error ("Expected variable name at %C");
9640 2 : return m;
9641 : }
9642 :
9643 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9644 : return MATCH_ERROR;
9645 :
9646 341 : gfc_set_sym_referenced (cptr);
9647 :
9648 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9649 : {
9650 327 : cptr->ts.type = BT_INTEGER;
9651 327 : cptr->ts.kind = gfc_index_integer_kind;
9652 : }
9653 14 : else if (cptr->ts.type != BT_INTEGER)
9654 : {
9655 1 : gfc_error ("Cray pointer at %C must be an integer");
9656 1 : return MATCH_ERROR;
9657 : }
9658 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9659 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9660 : " memory addresses require %d bytes",
9661 : cptr->ts.kind, gfc_index_integer_kind);
9662 :
9663 340 : if (gfc_match_char (',') != MATCH_YES)
9664 : {
9665 2 : gfc_error ("Expected \",\" at %C");
9666 2 : return MATCH_ERROR;
9667 : }
9668 :
9669 : /* Match Pointee. */
9670 338 : var_locus = gfc_current_locus;
9671 338 : gfc_clear_attr (¤t_attr);
9672 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9673 338 : current_ts.type = BT_UNKNOWN;
9674 338 : current_ts.kind = 0;
9675 :
9676 338 : m = gfc_match_symbol (&cpte, 0);
9677 338 : if (m != MATCH_YES)
9678 : {
9679 2 : gfc_error ("Expected variable name at %C");
9680 2 : return m;
9681 : }
9682 :
9683 : /* Check for an optional array spec. */
9684 336 : m = gfc_match_array_spec (&as, true, false);
9685 336 : if (m == MATCH_ERROR)
9686 : {
9687 0 : gfc_free_array_spec (as);
9688 0 : return m;
9689 : }
9690 336 : else if (m == MATCH_NO)
9691 : {
9692 226 : gfc_free_array_spec (as);
9693 226 : as = NULL;
9694 : }
9695 :
9696 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9697 : return MATCH_ERROR;
9698 :
9699 329 : gfc_set_sym_referenced (cpte);
9700 :
9701 329 : if (cpte->as == NULL)
9702 : {
9703 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9704 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9705 : }
9706 82 : else if (as != NULL)
9707 : {
9708 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9709 1 : gfc_free_array_spec (as);
9710 1 : return MATCH_ERROR;
9711 : }
9712 :
9713 328 : as = NULL;
9714 :
9715 328 : if (cpte->as != NULL)
9716 : {
9717 : /* Fix array spec. */
9718 190 : m = gfc_mod_pointee_as (cpte->as);
9719 190 : if (m == MATCH_ERROR)
9720 : return m;
9721 : }
9722 :
9723 : /* Point the Pointee at the Pointer. */
9724 328 : cpte->cp_pointer = cptr;
9725 :
9726 328 : if (gfc_match_char (')') != MATCH_YES)
9727 : {
9728 2 : gfc_error ("Expected \")\" at %C");
9729 2 : return MATCH_ERROR;
9730 : }
9731 326 : m = gfc_match_char (',');
9732 326 : if (m != MATCH_YES)
9733 313 : done = true; /* Stop searching for more declarations. */
9734 :
9735 : }
9736 :
9737 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9738 313 : || gfc_match_eos () != MATCH_YES)
9739 : {
9740 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9741 0 : return MATCH_ERROR;
9742 : }
9743 : return MATCH_YES;
9744 : }
9745 :
9746 :
9747 : match
9748 3117 : gfc_match_external (void)
9749 : {
9750 :
9751 3117 : gfc_clear_attr (¤t_attr);
9752 3117 : current_attr.external = 1;
9753 :
9754 3117 : return attr_decl ();
9755 : }
9756 :
9757 :
9758 : match
9759 208 : gfc_match_intent (void)
9760 : {
9761 208 : sym_intent intent;
9762 :
9763 : /* This is not allowed within a BLOCK construct! */
9764 208 : if (gfc_current_state () == COMP_BLOCK)
9765 : {
9766 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9767 2 : return MATCH_ERROR;
9768 : }
9769 :
9770 206 : intent = match_intent_spec ();
9771 206 : if (intent == INTENT_UNKNOWN)
9772 : return MATCH_ERROR;
9773 :
9774 206 : gfc_clear_attr (¤t_attr);
9775 206 : current_attr.intent = intent;
9776 :
9777 206 : return attr_decl ();
9778 : }
9779 :
9780 :
9781 : match
9782 1477 : gfc_match_intrinsic (void)
9783 : {
9784 :
9785 1477 : gfc_clear_attr (¤t_attr);
9786 1477 : current_attr.intrinsic = 1;
9787 :
9788 1477 : return attr_decl ();
9789 : }
9790 :
9791 :
9792 : match
9793 220 : gfc_match_optional (void)
9794 : {
9795 : /* This is not allowed within a BLOCK construct! */
9796 220 : if (gfc_current_state () == COMP_BLOCK)
9797 : {
9798 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9799 2 : return MATCH_ERROR;
9800 : }
9801 :
9802 218 : gfc_clear_attr (¤t_attr);
9803 218 : current_attr.optional = 1;
9804 :
9805 218 : return attr_decl ();
9806 : }
9807 :
9808 :
9809 : match
9810 903 : gfc_match_pointer (void)
9811 : {
9812 903 : gfc_gobble_whitespace ();
9813 903 : if (gfc_peek_ascii_char () == '(')
9814 : {
9815 335 : if (!flag_cray_pointer)
9816 : {
9817 1 : gfc_error ("Cray pointer declaration at %C requires "
9818 : "%<-fcray-pointer%> flag");
9819 1 : return MATCH_ERROR;
9820 : }
9821 334 : return cray_pointer_decl ();
9822 : }
9823 : else
9824 : {
9825 568 : gfc_clear_attr (¤t_attr);
9826 568 : current_attr.pointer = 1;
9827 :
9828 568 : return attr_decl ();
9829 : }
9830 : }
9831 :
9832 :
9833 : match
9834 162 : gfc_match_allocatable (void)
9835 : {
9836 162 : gfc_clear_attr (¤t_attr);
9837 162 : current_attr.allocatable = 1;
9838 :
9839 162 : return attr_decl ();
9840 : }
9841 :
9842 :
9843 : match
9844 23 : gfc_match_codimension (void)
9845 : {
9846 23 : gfc_clear_attr (¤t_attr);
9847 23 : current_attr.codimension = 1;
9848 :
9849 23 : return attr_decl ();
9850 : }
9851 :
9852 :
9853 : match
9854 80 : gfc_match_contiguous (void)
9855 : {
9856 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9857 : return MATCH_ERROR;
9858 :
9859 79 : gfc_clear_attr (¤t_attr);
9860 79 : current_attr.contiguous = 1;
9861 :
9862 79 : return attr_decl ();
9863 : }
9864 :
9865 :
9866 : match
9867 647 : gfc_match_dimension (void)
9868 : {
9869 647 : gfc_clear_attr (¤t_attr);
9870 647 : current_attr.dimension = 1;
9871 :
9872 647 : return attr_decl ();
9873 : }
9874 :
9875 :
9876 : match
9877 99 : gfc_match_target (void)
9878 : {
9879 99 : gfc_clear_attr (¤t_attr);
9880 99 : current_attr.target = 1;
9881 :
9882 99 : return attr_decl ();
9883 : }
9884 :
9885 :
9886 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9887 : statement. */
9888 :
9889 : static match
9890 1708 : access_attr_decl (gfc_statement st)
9891 : {
9892 1708 : char name[GFC_MAX_SYMBOL_LEN + 1];
9893 1708 : interface_type type;
9894 1708 : gfc_user_op *uop;
9895 1708 : gfc_symbol *sym, *dt_sym;
9896 1708 : gfc_intrinsic_op op;
9897 1708 : match m;
9898 1708 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9899 :
9900 1708 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9901 0 : goto done;
9902 :
9903 2834 : for (;;)
9904 : {
9905 2834 : m = gfc_match_generic_spec (&type, name, &op);
9906 2834 : if (m == MATCH_NO)
9907 0 : goto syntax;
9908 2834 : if (m == MATCH_ERROR)
9909 0 : goto done;
9910 :
9911 2834 : switch (type)
9912 : {
9913 0 : case INTERFACE_NAMELESS:
9914 0 : case INTERFACE_ABSTRACT:
9915 0 : goto syntax;
9916 :
9917 2758 : case INTERFACE_GENERIC:
9918 2758 : case INTERFACE_DTIO:
9919 :
9920 2758 : if (gfc_get_symbol (name, NULL, &sym))
9921 0 : goto done;
9922 :
9923 2758 : if (type == INTERFACE_DTIO
9924 26 : && gfc_current_ns->proc_name
9925 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9926 26 : && sym->attr.flavor == FL_UNKNOWN)
9927 2 : sym->attr.flavor = FL_PROCEDURE;
9928 :
9929 2758 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9930 4 : goto done;
9931 :
9932 323 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9933 2804 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9934 0 : goto done;
9935 :
9936 : break;
9937 :
9938 72 : case INTERFACE_INTRINSIC_OP:
9939 72 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9940 : {
9941 72 : gfc_intrinsic_op other_op;
9942 :
9943 72 : gfc_current_ns->operator_access[op] = access;
9944 :
9945 : /* Handle the case if there is another op with the same
9946 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9947 72 : other_op = gfc_equivalent_op (op);
9948 :
9949 72 : if (other_op != INTRINSIC_NONE)
9950 21 : gfc_current_ns->operator_access[other_op] = access;
9951 : }
9952 : else
9953 : {
9954 0 : gfc_error ("Access specification of the %s operator at %C has "
9955 : "already been specified", gfc_op2string (op));
9956 0 : goto done;
9957 : }
9958 :
9959 : break;
9960 :
9961 4 : case INTERFACE_USER_OP:
9962 4 : uop = gfc_get_uop (name);
9963 :
9964 4 : if (uop->access == ACCESS_UNKNOWN)
9965 : {
9966 3 : uop->access = access;
9967 : }
9968 : else
9969 : {
9970 1 : gfc_error ("Access specification of the .%s. operator at %C "
9971 : "has already been specified", uop->name);
9972 1 : goto done;
9973 : }
9974 :
9975 3 : break;
9976 : }
9977 :
9978 2829 : if (gfc_match_char (',') == MATCH_NO)
9979 : break;
9980 : }
9981 :
9982 1703 : if (gfc_match_eos () != MATCH_YES)
9983 0 : goto syntax;
9984 : return MATCH_YES;
9985 :
9986 0 : syntax:
9987 0 : gfc_syntax_error (st);
9988 :
9989 : done:
9990 : return MATCH_ERROR;
9991 : }
9992 :
9993 :
9994 : match
9995 23 : gfc_match_protected (void)
9996 : {
9997 23 : gfc_symbol *sym;
9998 23 : match m;
9999 23 : char c;
10000 :
10001 : /* PROTECTED has already been seen, but must be followed by whitespace
10002 : or ::. */
10003 23 : c = gfc_peek_ascii_char ();
10004 23 : if (!gfc_is_whitespace (c) && c != ':')
10005 : return MATCH_NO;
10006 :
10007 22 : if (!gfc_current_ns->proc_name
10008 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
10009 : {
10010 3 : gfc_error ("PROTECTED at %C only allowed in specification "
10011 : "part of a module");
10012 3 : return MATCH_ERROR;
10013 :
10014 : }
10015 :
10016 19 : gfc_match (" ::");
10017 :
10018 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
10019 : return MATCH_ERROR;
10020 :
10021 : /* PROTECTED has an entity-list. */
10022 18 : if (gfc_match_eos () == MATCH_YES)
10023 0 : goto syntax;
10024 :
10025 26 : for(;;)
10026 : {
10027 26 : m = gfc_match_symbol (&sym, 0);
10028 26 : switch (m)
10029 : {
10030 26 : case MATCH_YES:
10031 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
10032 : return MATCH_ERROR;
10033 25 : goto next_item;
10034 :
10035 : case MATCH_NO:
10036 : break;
10037 :
10038 : case MATCH_ERROR:
10039 : return MATCH_ERROR;
10040 : }
10041 :
10042 25 : next_item:
10043 25 : if (gfc_match_eos () == MATCH_YES)
10044 : break;
10045 8 : if (gfc_match_char (',') != MATCH_YES)
10046 0 : goto syntax;
10047 : }
10048 :
10049 : return MATCH_YES;
10050 :
10051 0 : syntax:
10052 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
10053 0 : return MATCH_ERROR;
10054 : }
10055 :
10056 :
10057 : /* The PRIVATE statement is a bit weird in that it can be an attribute
10058 : declaration, but also works as a standalone statement inside of a
10059 : type declaration or a module. */
10060 :
10061 : match
10062 28543 : gfc_match_private (gfc_statement *st)
10063 : {
10064 28543 : gfc_state_data *prev;
10065 :
10066 28543 : if (gfc_match ("private") != MATCH_YES)
10067 : return MATCH_NO;
10068 :
10069 : /* Try matching PRIVATE without an access-list. */
10070 1577 : if (gfc_match_eos () == MATCH_YES)
10071 : {
10072 1290 : prev = gfc_state_stack->previous;
10073 1290 : if (gfc_current_state () != COMP_MODULE
10074 366 : && !(gfc_current_state () == COMP_DERIVED
10075 333 : && prev && prev->state == COMP_MODULE)
10076 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10077 32 : && prev->previous && prev->previous->state == COMP_MODULE))
10078 : {
10079 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10080 : "specification part of a module");
10081 2 : return MATCH_ERROR;
10082 : }
10083 :
10084 1288 : *st = ST_PRIVATE;
10085 1288 : return MATCH_YES;
10086 : }
10087 :
10088 : /* At this point in free-form source code, PRIVATE must be followed
10089 : by whitespace or ::. */
10090 287 : if (gfc_current_form == FORM_FREE)
10091 : {
10092 285 : char c = gfc_peek_ascii_char ();
10093 285 : if (!gfc_is_whitespace (c) && c != ':')
10094 : return MATCH_NO;
10095 : }
10096 :
10097 286 : prev = gfc_state_stack->previous;
10098 286 : if (gfc_current_state () != COMP_MODULE
10099 1 : && !(gfc_current_state () == COMP_DERIVED
10100 0 : && prev && prev->state == COMP_MODULE)
10101 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10102 0 : && prev->previous && prev->previous->state == COMP_MODULE))
10103 : {
10104 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10105 : "specification part of a module");
10106 1 : return MATCH_ERROR;
10107 : }
10108 :
10109 285 : *st = ST_ATTR_DECL;
10110 285 : return access_attr_decl (ST_PRIVATE);
10111 : }
10112 :
10113 :
10114 : match
10115 1821 : gfc_match_public (gfc_statement *st)
10116 : {
10117 1821 : if (gfc_match ("public") != MATCH_YES)
10118 : return MATCH_NO;
10119 :
10120 : /* Try matching PUBLIC without an access-list. */
10121 1470 : if (gfc_match_eos () == MATCH_YES)
10122 : {
10123 45 : if (gfc_current_state () != COMP_MODULE)
10124 : {
10125 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10126 : "specification part of a module");
10127 2 : return MATCH_ERROR;
10128 : }
10129 :
10130 43 : *st = ST_PUBLIC;
10131 43 : return MATCH_YES;
10132 : }
10133 :
10134 : /* At this point in free-form source code, PUBLIC must be followed
10135 : by whitespace or ::. */
10136 1425 : if (gfc_current_form == FORM_FREE)
10137 : {
10138 1423 : char c = gfc_peek_ascii_char ();
10139 1423 : if (!gfc_is_whitespace (c) && c != ':')
10140 : return MATCH_NO;
10141 : }
10142 :
10143 1424 : if (gfc_current_state () != COMP_MODULE)
10144 : {
10145 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10146 : "specification part of a module");
10147 1 : return MATCH_ERROR;
10148 : }
10149 :
10150 1423 : *st = ST_ATTR_DECL;
10151 1423 : return access_attr_decl (ST_PUBLIC);
10152 : }
10153 :
10154 :
10155 : /* Workhorse for gfc_match_parameter. */
10156 :
10157 : static match
10158 7643 : do_parm (void)
10159 : {
10160 7643 : gfc_symbol *sym;
10161 7643 : gfc_expr *init;
10162 7643 : match m;
10163 7643 : bool t;
10164 :
10165 7643 : m = gfc_match_symbol (&sym, 0);
10166 7643 : if (m == MATCH_NO)
10167 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10168 :
10169 7643 : if (m != MATCH_YES)
10170 : return m;
10171 :
10172 7643 : if (gfc_match_char ('=') == MATCH_NO)
10173 : {
10174 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10175 0 : return MATCH_ERROR;
10176 : }
10177 :
10178 7643 : m = gfc_match_init_expr (&init);
10179 7643 : if (m == MATCH_NO)
10180 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10181 7643 : if (m != MATCH_YES)
10182 : return m;
10183 :
10184 7642 : if (sym->ts.type == BT_UNKNOWN
10185 7642 : && !gfc_set_default_type (sym, 1, NULL))
10186 : {
10187 1 : m = MATCH_ERROR;
10188 1 : goto cleanup;
10189 : }
10190 :
10191 7641 : if (!gfc_check_assign_symbol (sym, NULL, init)
10192 7641 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10193 : {
10194 1 : m = MATCH_ERROR;
10195 1 : goto cleanup;
10196 : }
10197 :
10198 7640 : if (sym->value)
10199 : {
10200 1 : gfc_error ("Initializing already initialized variable at %C");
10201 1 : m = MATCH_ERROR;
10202 1 : goto cleanup;
10203 : }
10204 :
10205 7639 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
10206 7639 : return (t) ? MATCH_YES : MATCH_ERROR;
10207 :
10208 3 : cleanup:
10209 3 : gfc_free_expr (init);
10210 3 : return m;
10211 : }
10212 :
10213 :
10214 : /* Match a parameter statement, with the weird syntax that these have. */
10215 :
10216 : match
10217 6930 : gfc_match_parameter (void)
10218 : {
10219 6930 : const char *term = " )%t";
10220 6930 : match m;
10221 :
10222 6930 : if (gfc_match_char ('(') == MATCH_NO)
10223 : {
10224 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10225 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10226 : return MATCH_NO;
10227 6929 : term = " %t";
10228 : }
10229 :
10230 7643 : for (;;)
10231 : {
10232 7643 : m = do_parm ();
10233 7643 : if (m != MATCH_YES)
10234 : break;
10235 :
10236 7639 : if (gfc_match (term) == MATCH_YES)
10237 : break;
10238 :
10239 714 : if (gfc_match_char (',') != MATCH_YES)
10240 : {
10241 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10242 0 : m = MATCH_ERROR;
10243 0 : break;
10244 : }
10245 : }
10246 :
10247 : return m;
10248 : }
10249 :
10250 :
10251 : match
10252 8 : gfc_match_automatic (void)
10253 : {
10254 8 : gfc_symbol *sym;
10255 8 : match m;
10256 8 : bool seen_symbol = false;
10257 :
10258 8 : if (!flag_dec_static)
10259 : {
10260 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10261 : "%<-fdec-static%>",
10262 : "AUTOMATIC"
10263 : );
10264 2 : return MATCH_ERROR;
10265 : }
10266 :
10267 6 : gfc_match (" ::");
10268 :
10269 6 : for (;;)
10270 : {
10271 6 : m = gfc_match_symbol (&sym, 0);
10272 6 : switch (m)
10273 : {
10274 : case MATCH_NO:
10275 : break;
10276 :
10277 : case MATCH_ERROR:
10278 : return MATCH_ERROR;
10279 :
10280 4 : case MATCH_YES:
10281 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10282 : return MATCH_ERROR;
10283 : seen_symbol = true;
10284 : break;
10285 : }
10286 :
10287 4 : if (gfc_match_eos () == MATCH_YES)
10288 : break;
10289 0 : if (gfc_match_char (',') != MATCH_YES)
10290 0 : goto syntax;
10291 : }
10292 :
10293 4 : if (!seen_symbol)
10294 : {
10295 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10296 2 : return MATCH_ERROR;
10297 : }
10298 :
10299 : return MATCH_YES;
10300 :
10301 0 : syntax:
10302 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10303 0 : return MATCH_ERROR;
10304 : }
10305 :
10306 :
10307 : match
10308 7 : gfc_match_static (void)
10309 : {
10310 7 : gfc_symbol *sym;
10311 7 : match m;
10312 7 : bool seen_symbol = false;
10313 :
10314 7 : if (!flag_dec_static)
10315 : {
10316 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10317 : "%<-fdec-static%>",
10318 : "STATIC");
10319 2 : return MATCH_ERROR;
10320 : }
10321 :
10322 5 : gfc_match (" ::");
10323 :
10324 5 : for (;;)
10325 : {
10326 5 : m = gfc_match_symbol (&sym, 0);
10327 5 : switch (m)
10328 : {
10329 : case MATCH_NO:
10330 : break;
10331 :
10332 : case MATCH_ERROR:
10333 : return MATCH_ERROR;
10334 :
10335 3 : case MATCH_YES:
10336 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10337 : &gfc_current_locus))
10338 : return MATCH_ERROR;
10339 : seen_symbol = true;
10340 : break;
10341 : }
10342 :
10343 3 : if (gfc_match_eos () == MATCH_YES)
10344 : break;
10345 0 : if (gfc_match_char (',') != MATCH_YES)
10346 0 : goto syntax;
10347 : }
10348 :
10349 3 : if (!seen_symbol)
10350 : {
10351 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10352 2 : return MATCH_ERROR;
10353 : }
10354 :
10355 : return MATCH_YES;
10356 :
10357 0 : syntax:
10358 0 : gfc_error ("Syntax error in STATIC statement at %C");
10359 0 : return MATCH_ERROR;
10360 : }
10361 :
10362 :
10363 : /* Save statements have a special syntax. */
10364 :
10365 : match
10366 272 : gfc_match_save (void)
10367 : {
10368 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10369 272 : gfc_common_head *c;
10370 272 : gfc_symbol *sym;
10371 272 : match m;
10372 :
10373 272 : if (gfc_match_eos () == MATCH_YES)
10374 : {
10375 150 : if (gfc_current_ns->seen_save)
10376 : {
10377 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10378 : "follows previous SAVE statement"))
10379 : return MATCH_ERROR;
10380 : }
10381 :
10382 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10383 149 : return MATCH_YES;
10384 : }
10385 :
10386 122 : if (gfc_current_ns->save_all)
10387 : {
10388 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10389 : "blanket SAVE statement"))
10390 : return MATCH_ERROR;
10391 : }
10392 :
10393 121 : gfc_match (" ::");
10394 :
10395 183 : for (;;)
10396 : {
10397 183 : m = gfc_match_symbol (&sym, 0);
10398 183 : switch (m)
10399 : {
10400 181 : case MATCH_YES:
10401 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10402 : &gfc_current_locus))
10403 : return MATCH_ERROR;
10404 179 : goto next_item;
10405 :
10406 : case MATCH_NO:
10407 : break;
10408 :
10409 : case MATCH_ERROR:
10410 : return MATCH_ERROR;
10411 : }
10412 :
10413 2 : m = gfc_match (" / %n /", &n);
10414 2 : if (m == MATCH_ERROR)
10415 : return MATCH_ERROR;
10416 2 : if (m == MATCH_NO)
10417 0 : goto syntax;
10418 :
10419 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10420 : saved-entity-list that does not specify a common-block-name. */
10421 2 : if (gfc_current_state () == COMP_BLOCK)
10422 : {
10423 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10424 : "in a BLOCK construct", n);
10425 1 : return MATCH_ERROR;
10426 : }
10427 :
10428 1 : c = gfc_get_common (n, 0);
10429 1 : c->saved = 1;
10430 :
10431 1 : gfc_current_ns->seen_save = 1;
10432 :
10433 180 : next_item:
10434 180 : if (gfc_match_eos () == MATCH_YES)
10435 : break;
10436 62 : if (gfc_match_char (',') != MATCH_YES)
10437 0 : goto syntax;
10438 : }
10439 :
10440 : return MATCH_YES;
10441 :
10442 0 : syntax:
10443 0 : if (gfc_current_ns->seen_save)
10444 : {
10445 0 : gfc_error ("Syntax error in SAVE statement at %C");
10446 0 : return MATCH_ERROR;
10447 : }
10448 : else
10449 : return MATCH_NO;
10450 : }
10451 :
10452 :
10453 : match
10454 93 : gfc_match_value (void)
10455 : {
10456 93 : gfc_symbol *sym;
10457 93 : match m;
10458 :
10459 : /* This is not allowed within a BLOCK construct! */
10460 93 : if (gfc_current_state () == COMP_BLOCK)
10461 : {
10462 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10463 2 : return MATCH_ERROR;
10464 : }
10465 :
10466 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10467 : return MATCH_ERROR;
10468 :
10469 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10470 : {
10471 : return MATCH_ERROR;
10472 : }
10473 :
10474 90 : if (gfc_match_eos () == MATCH_YES)
10475 0 : goto syntax;
10476 :
10477 116 : for(;;)
10478 : {
10479 116 : m = gfc_match_symbol (&sym, 0);
10480 116 : switch (m)
10481 : {
10482 116 : case MATCH_YES:
10483 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10484 : return MATCH_ERROR;
10485 109 : goto next_item;
10486 :
10487 : case MATCH_NO:
10488 : break;
10489 :
10490 : case MATCH_ERROR:
10491 : return MATCH_ERROR;
10492 : }
10493 :
10494 109 : next_item:
10495 109 : if (gfc_match_eos () == MATCH_YES)
10496 : break;
10497 26 : if (gfc_match_char (',') != MATCH_YES)
10498 0 : goto syntax;
10499 : }
10500 :
10501 : return MATCH_YES;
10502 :
10503 0 : syntax:
10504 0 : gfc_error ("Syntax error in VALUE statement at %C");
10505 0 : return MATCH_ERROR;
10506 : }
10507 :
10508 :
10509 : match
10510 45 : gfc_match_volatile (void)
10511 : {
10512 45 : gfc_symbol *sym;
10513 45 : char *name;
10514 45 : match m;
10515 :
10516 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10517 : return MATCH_ERROR;
10518 :
10519 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10520 : {
10521 : return MATCH_ERROR;
10522 : }
10523 :
10524 44 : if (gfc_match_eos () == MATCH_YES)
10525 1 : goto syntax;
10526 :
10527 48 : for(;;)
10528 : {
10529 : /* VOLATILE is special because it can be added to host-associated
10530 : symbols locally. Except for coarrays. */
10531 48 : m = gfc_match_symbol (&sym, 1);
10532 48 : switch (m)
10533 : {
10534 48 : case MATCH_YES:
10535 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10536 48 : strcpy (name, sym->name);
10537 48 : if (!check_function_name (name))
10538 : return MATCH_ERROR;
10539 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10540 : for variable in a BLOCK which is defined outside of the BLOCK. */
10541 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10542 : {
10543 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10544 : "%C, which is use-/host-associated", sym->name);
10545 2 : return MATCH_ERROR;
10546 : }
10547 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10548 : return MATCH_ERROR;
10549 42 : goto next_item;
10550 :
10551 : case MATCH_NO:
10552 : break;
10553 :
10554 : case MATCH_ERROR:
10555 : return MATCH_ERROR;
10556 : }
10557 :
10558 42 : next_item:
10559 42 : if (gfc_match_eos () == MATCH_YES)
10560 : break;
10561 5 : if (gfc_match_char (',') != MATCH_YES)
10562 0 : goto syntax;
10563 : }
10564 :
10565 : return MATCH_YES;
10566 :
10567 1 : syntax:
10568 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10569 1 : return MATCH_ERROR;
10570 : }
10571 :
10572 :
10573 : match
10574 11 : gfc_match_asynchronous (void)
10575 : {
10576 11 : gfc_symbol *sym;
10577 11 : char *name;
10578 11 : match m;
10579 :
10580 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10581 : return MATCH_ERROR;
10582 :
10583 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10584 : {
10585 : return MATCH_ERROR;
10586 : }
10587 :
10588 10 : if (gfc_match_eos () == MATCH_YES)
10589 0 : goto syntax;
10590 :
10591 10 : for(;;)
10592 : {
10593 : /* ASYNCHRONOUS is special because it can be added to host-associated
10594 : symbols locally. */
10595 10 : m = gfc_match_symbol (&sym, 1);
10596 10 : switch (m)
10597 : {
10598 10 : case MATCH_YES:
10599 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10600 10 : strcpy (name, sym->name);
10601 10 : if (!check_function_name (name))
10602 : return MATCH_ERROR;
10603 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10604 : return MATCH_ERROR;
10605 7 : goto next_item;
10606 :
10607 : case MATCH_NO:
10608 : break;
10609 :
10610 : case MATCH_ERROR:
10611 : return MATCH_ERROR;
10612 : }
10613 :
10614 7 : next_item:
10615 7 : if (gfc_match_eos () == MATCH_YES)
10616 : break;
10617 0 : if (gfc_match_char (',') != MATCH_YES)
10618 0 : goto syntax;
10619 : }
10620 :
10621 : return MATCH_YES;
10622 :
10623 0 : syntax:
10624 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10625 0 : return MATCH_ERROR;
10626 : }
10627 :
10628 :
10629 : /* Match a module procedure statement in a submodule. */
10630 :
10631 : match
10632 751471 : gfc_match_submod_proc (void)
10633 : {
10634 751471 : char name[GFC_MAX_SYMBOL_LEN + 1];
10635 751471 : gfc_symbol *sym, *fsym;
10636 751471 : match m;
10637 751471 : gfc_formal_arglist *formal, *head, *tail;
10638 :
10639 751471 : if (gfc_current_state () != COMP_CONTAINS
10640 15130 : || !(gfc_state_stack->previous
10641 15130 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10642 15130 : || gfc_state_stack->previous->state == COMP_MODULE)))
10643 : return MATCH_NO;
10644 :
10645 7553 : m = gfc_match (" module% procedure% %n", name);
10646 7553 : if (m != MATCH_YES)
10647 : return m;
10648 :
10649 254 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10650 : "at %C"))
10651 : return MATCH_ERROR;
10652 :
10653 254 : if (get_proc_name (name, &sym, false))
10654 : return MATCH_ERROR;
10655 :
10656 : /* Make sure that the result field is appropriately filled. */
10657 254 : if (sym->tlink && sym->tlink->attr.function)
10658 : {
10659 117 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10660 : {
10661 67 : sym->result = sym->tlink->result;
10662 67 : if (!sym->result->attr.use_assoc)
10663 : {
10664 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10665 : sym->result->name);
10666 20 : st->n.sym = sym->result;
10667 20 : sym->result->refs++;
10668 : }
10669 : }
10670 : else
10671 50 : sym->result = sym;
10672 : }
10673 :
10674 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10675 : the symbol existed before. */
10676 254 : sym->declared_at = gfc_current_locus;
10677 :
10678 254 : if (!sym->attr.module_procedure)
10679 : return MATCH_ERROR;
10680 :
10681 : /* Signal match_end to expect "end procedure". */
10682 252 : sym->abr_modproc_decl = 1;
10683 :
10684 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10685 252 : sym->attr.if_source = IFSRC_DECL;
10686 :
10687 252 : gfc_new_block = sym;
10688 :
10689 : /* Make a new formal arglist with the symbols in the procedure
10690 : namespace. */
10691 252 : head = tail = NULL;
10692 575 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10693 : {
10694 323 : if (formal == sym->formal)
10695 226 : head = tail = gfc_get_formal_arglist ();
10696 : else
10697 : {
10698 97 : tail->next = gfc_get_formal_arglist ();
10699 97 : tail = tail->next;
10700 : }
10701 :
10702 323 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10703 0 : goto cleanup;
10704 :
10705 323 : tail->sym = fsym;
10706 323 : gfc_set_sym_referenced (fsym);
10707 : }
10708 :
10709 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10710 : interface declaration is cleared. This allows us to add the
10711 : explicit interface as is done for other type of procedure. */
10712 252 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10713 : &gfc_current_locus))
10714 : return MATCH_ERROR;
10715 :
10716 252 : if (gfc_match_eos () != MATCH_YES)
10717 : {
10718 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10719 : undone, such that the st->n.sym->formal points to the original symbol;
10720 : if now this namespace is finalized, the formal namespace is freed,
10721 : but it might be still needed in the parent namespace. */
10722 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10723 1 : st->n.sym = NULL;
10724 1 : gfc_free_symbol (sym->tlink);
10725 1 : sym->tlink = NULL;
10726 1 : sym->refs--;
10727 1 : gfc_syntax_error (ST_MODULE_PROC);
10728 1 : return MATCH_ERROR;
10729 : }
10730 :
10731 : return MATCH_YES;
10732 :
10733 0 : cleanup:
10734 0 : gfc_free_formal_arglist (head);
10735 0 : return MATCH_ERROR;
10736 : }
10737 :
10738 :
10739 : /* Match a module procedure statement. Note that we have to modify
10740 : symbols in the parent's namespace because the current one was there
10741 : to receive symbols that are in an interface's formal argument list. */
10742 :
10743 : match
10744 1574 : gfc_match_modproc (void)
10745 : {
10746 1574 : char name[GFC_MAX_SYMBOL_LEN + 1];
10747 1574 : gfc_symbol *sym;
10748 1574 : match m;
10749 1574 : locus old_locus;
10750 1574 : gfc_namespace *module_ns;
10751 1574 : gfc_interface *old_interface_head, *interface;
10752 :
10753 1574 : if (gfc_state_stack->previous == NULL
10754 1572 : || (gfc_state_stack->state != COMP_INTERFACE
10755 5 : && (gfc_state_stack->state != COMP_CONTAINS
10756 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10757 1567 : || current_interface.type == INTERFACE_NAMELESS
10758 1567 : || current_interface.type == INTERFACE_ABSTRACT)
10759 : {
10760 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10761 : "interface");
10762 8 : return MATCH_ERROR;
10763 : }
10764 :
10765 1566 : module_ns = gfc_current_ns->parent;
10766 1572 : for (; module_ns; module_ns = module_ns->parent)
10767 1572 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10768 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10769 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10770 12 : && !module_ns->proc_name->attr.contained))
10771 : break;
10772 :
10773 1566 : if (module_ns == NULL)
10774 : return MATCH_ERROR;
10775 :
10776 : /* Store the current state of the interface. We will need it if we
10777 : end up with a syntax error and need to recover. */
10778 1566 : old_interface_head = gfc_current_interface_head ();
10779 :
10780 : /* Check if the F2008 optional double colon appears. */
10781 1566 : gfc_gobble_whitespace ();
10782 1566 : old_locus = gfc_current_locus;
10783 1566 : if (gfc_match ("::") == MATCH_YES)
10784 : {
10785 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10786 : "MODULE PROCEDURE statement at %L", &old_locus))
10787 : return MATCH_ERROR;
10788 : }
10789 : else
10790 1541 : gfc_current_locus = old_locus;
10791 :
10792 1921 : for (;;)
10793 : {
10794 1921 : bool last = false;
10795 1921 : old_locus = gfc_current_locus;
10796 :
10797 1921 : m = gfc_match_name (name);
10798 1921 : if (m == MATCH_NO)
10799 1 : goto syntax;
10800 1920 : if (m != MATCH_YES)
10801 : return MATCH_ERROR;
10802 :
10803 : /* Check for syntax error before starting to add symbols to the
10804 : current namespace. */
10805 1920 : if (gfc_match_eos () == MATCH_YES)
10806 : last = true;
10807 :
10808 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10809 2 : goto syntax;
10810 :
10811 : /* Now we're sure the syntax is valid, we process this item
10812 : further. */
10813 1918 : if (gfc_get_symbol (name, module_ns, &sym))
10814 : return MATCH_ERROR;
10815 :
10816 1918 : if (sym->attr.intrinsic)
10817 : {
10818 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10819 : "PROCEDURE", &old_locus);
10820 1 : return MATCH_ERROR;
10821 : }
10822 :
10823 1917 : if (sym->attr.proc != PROC_MODULE
10824 1917 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10825 : return MATCH_ERROR;
10826 :
10827 1914 : if (!gfc_add_interface (sym))
10828 : return MATCH_ERROR;
10829 :
10830 1911 : sym->attr.mod_proc = 1;
10831 1911 : sym->declared_at = old_locus;
10832 :
10833 1911 : if (last)
10834 : break;
10835 : }
10836 :
10837 : return MATCH_YES;
10838 :
10839 3 : syntax:
10840 : /* Restore the previous state of the interface. */
10841 3 : interface = gfc_current_interface_head ();
10842 3 : gfc_set_current_interface_head (old_interface_head);
10843 :
10844 : /* Free the new interfaces. */
10845 10 : while (interface != old_interface_head)
10846 : {
10847 4 : gfc_interface *i = interface->next;
10848 4 : free (interface);
10849 4 : interface = i;
10850 : }
10851 :
10852 : /* And issue a syntax error. */
10853 3 : gfc_syntax_error (ST_MODULE_PROC);
10854 3 : return MATCH_ERROR;
10855 : }
10856 :
10857 :
10858 : /* Check a derived type that is being extended. */
10859 :
10860 : static gfc_symbol*
10861 1477 : check_extended_derived_type (char *name)
10862 : {
10863 1477 : gfc_symbol *extended;
10864 :
10865 1477 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10866 : {
10867 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10868 0 : return NULL;
10869 : }
10870 :
10871 1477 : extended = gfc_find_dt_in_generic (extended);
10872 :
10873 : /* F08:C428. */
10874 1477 : if (!extended)
10875 : {
10876 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10877 2 : return NULL;
10878 : }
10879 :
10880 1475 : if (extended->attr.flavor != FL_DERIVED)
10881 : {
10882 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10883 : "derived type", name);
10884 0 : return NULL;
10885 : }
10886 :
10887 1475 : if (extended->attr.is_bind_c)
10888 : {
10889 1 : gfc_error ("%qs cannot be extended at %C because it "
10890 : "is BIND(C)", extended->name);
10891 1 : return NULL;
10892 : }
10893 :
10894 1474 : if (extended->attr.sequence)
10895 : {
10896 1 : gfc_error ("%qs cannot be extended at %C because it "
10897 : "is a SEQUENCE type", extended->name);
10898 1 : return NULL;
10899 : }
10900 :
10901 : return extended;
10902 : }
10903 :
10904 :
10905 : /* Match the optional attribute specifiers for a type declaration.
10906 : Return MATCH_ERROR if an error is encountered in one of the handled
10907 : attributes (public, private, bind(c)), MATCH_NO if what's found is
10908 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10909 : checking on attribute conflicts needs to be done. */
10910 :
10911 : static match
10912 19020 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10913 : {
10914 : /* See if the derived type is marked as private. */
10915 19020 : if (gfc_match (" , private") == MATCH_YES)
10916 : {
10917 15 : if (gfc_current_state () != COMP_MODULE)
10918 : {
10919 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
10920 : "specification part of a module");
10921 1 : return MATCH_ERROR;
10922 : }
10923 :
10924 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10925 : return MATCH_ERROR;
10926 : }
10927 19005 : else if (gfc_match (" , public") == MATCH_YES)
10928 : {
10929 546 : if (gfc_current_state () != COMP_MODULE)
10930 : {
10931 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
10932 : "specification part of a module");
10933 0 : return MATCH_ERROR;
10934 : }
10935 :
10936 546 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10937 : return MATCH_ERROR;
10938 : }
10939 18459 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
10940 : {
10941 : /* If the type is defined to be bind(c) it then needs to make
10942 : sure that all fields are interoperable. This will
10943 : need to be a semantic check on the finished derived type.
10944 : See 15.2.3 (lines 9-12) of F2003 draft. */
10945 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10946 : return MATCH_ERROR;
10947 :
10948 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10949 : }
10950 18052 : else if (gfc_match (" , abstract") == MATCH_YES)
10951 : {
10952 331 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
10953 : return MATCH_ERROR;
10954 :
10955 330 : if (!gfc_add_abstract (attr, &gfc_current_locus))
10956 : return MATCH_ERROR;
10957 : }
10958 17721 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
10959 : {
10960 1478 : if (!gfc_add_extension (attr, &gfc_current_locus))
10961 : return MATCH_ERROR;
10962 : }
10963 : else
10964 16243 : return MATCH_NO;
10965 :
10966 : /* If we get here, something matched. */
10967 : return MATCH_YES;
10968 : }
10969 :
10970 :
10971 : /* Common function for type declaration blocks similar to derived types, such
10972 : as STRUCTURES and MAPs. Unlike derived types, a structure type
10973 : does NOT have a generic symbol matching the name given by the user.
10974 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
10975 : for the creation of an independent symbol.
10976 : Other parameters are a message to prefix errors with, the name of the new
10977 : type to be created, and the flavor to add to the resulting symbol. */
10978 :
10979 : static bool
10980 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
10981 : gfc_symbol **result)
10982 : {
10983 717 : gfc_symbol *sym;
10984 717 : locus where;
10985 :
10986 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
10987 :
10988 717 : if (decl)
10989 717 : where = *decl;
10990 : else
10991 0 : where = gfc_current_locus;
10992 :
10993 717 : if (gfc_get_symbol (name, NULL, &sym))
10994 : return false;
10995 :
10996 717 : if (!sym)
10997 : {
10998 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
10999 : return false;
11000 : }
11001 :
11002 717 : if (sym->components != NULL || sym->attr.zero_comp)
11003 : {
11004 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
11005 : sym->name, &sym->declared_at);
11006 3 : return false;
11007 : }
11008 :
11009 714 : sym->declared_at = where;
11010 :
11011 714 : if (sym->attr.flavor != fl
11012 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
11013 : return false;
11014 :
11015 714 : if (!sym->hash_value)
11016 : /* Set the hash for the compound name for this type. */
11017 713 : sym->hash_value = gfc_hash_value (sym);
11018 :
11019 : /* Normally the type is expected to have been completely parsed by the time
11020 : a field declaration with this type is seen. For unions, maps, and nested
11021 : structure declarations, we need to indicate that it is okay that we
11022 : haven't seen any components yet. This will be updated after the structure
11023 : is fully parsed. */
11024 714 : sym->attr.zero_comp = 0;
11025 :
11026 : /* Structures always act like derived-types with the SEQUENCE attribute */
11027 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
11028 :
11029 714 : if (result) *result = sym;
11030 :
11031 : return true;
11032 : }
11033 :
11034 :
11035 : /* Match the opening of a MAP block. Like a struct within a union in C;
11036 : behaves identical to STRUCTURE blocks. */
11037 :
11038 : match
11039 259 : gfc_match_map (void)
11040 : {
11041 : /* Counter used to give unique internal names to map structures. */
11042 259 : static unsigned int gfc_map_id = 0;
11043 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
11044 259 : gfc_symbol *sym;
11045 259 : locus old_loc;
11046 :
11047 259 : old_loc = gfc_current_locus;
11048 :
11049 259 : if (gfc_match_eos () != MATCH_YES)
11050 : {
11051 1 : gfc_error ("Junk after MAP statement at %C");
11052 1 : gfc_current_locus = old_loc;
11053 1 : return MATCH_ERROR;
11054 : }
11055 :
11056 : /* Map blocks are anonymous so we make up unique names for the symbol table
11057 : which are invalid Fortran identifiers. */
11058 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
11059 :
11060 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
11061 : return MATCH_ERROR;
11062 :
11063 258 : gfc_new_block = sym;
11064 :
11065 258 : return MATCH_YES;
11066 : }
11067 :
11068 :
11069 : /* Match the opening of a UNION block. */
11070 :
11071 : match
11072 133 : gfc_match_union (void)
11073 : {
11074 : /* Counter used to give unique internal names to union types. */
11075 133 : static unsigned int gfc_union_id = 0;
11076 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
11077 133 : gfc_symbol *sym;
11078 133 : locus old_loc;
11079 :
11080 133 : old_loc = gfc_current_locus;
11081 :
11082 133 : if (gfc_match_eos () != MATCH_YES)
11083 : {
11084 1 : gfc_error ("Junk after UNION statement at %C");
11085 1 : gfc_current_locus = old_loc;
11086 1 : return MATCH_ERROR;
11087 : }
11088 :
11089 : /* Unions are anonymous so we make up unique names for the symbol table
11090 : which are invalid Fortran identifiers. */
11091 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
11092 :
11093 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
11094 : return MATCH_ERROR;
11095 :
11096 132 : gfc_new_block = sym;
11097 :
11098 132 : return MATCH_YES;
11099 : }
11100 :
11101 :
11102 : /* Match the beginning of a STRUCTURE declaration. This is similar to
11103 : matching the beginning of a derived type declaration with a few
11104 : twists. The resulting type symbol has no access control or other
11105 : interesting attributes. */
11106 :
11107 : match
11108 336 : gfc_match_structure_decl (void)
11109 : {
11110 : /* Counter used to give unique internal names to anonymous structures. */
11111 336 : static unsigned int gfc_structure_id = 0;
11112 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
11113 336 : gfc_symbol *sym;
11114 336 : match m;
11115 336 : locus where;
11116 :
11117 336 : if (!flag_dec_structure)
11118 : {
11119 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11120 : "%<-fdec-structure%>",
11121 : "STRUCTURE");
11122 3 : return MATCH_ERROR;
11123 : }
11124 :
11125 333 : name[0] = '\0';
11126 :
11127 333 : m = gfc_match (" /%n/", name);
11128 333 : if (m != MATCH_YES)
11129 : {
11130 : /* Non-nested structure declarations require a structure name. */
11131 24 : if (!gfc_comp_struct (gfc_current_state ()))
11132 : {
11133 4 : gfc_error ("Structure name expected in non-nested structure "
11134 : "declaration at %C");
11135 4 : return MATCH_ERROR;
11136 : }
11137 : /* This is an anonymous structure; make up a unique name for it
11138 : (upper-case letters never make it to symbol names from the source).
11139 : The important thing is initializing the type variable
11140 : and setting gfc_new_symbol, which is immediately used by
11141 : parse_structure () and variable_decl () to add components of
11142 : this type. */
11143 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11144 : }
11145 :
11146 329 : where = gfc_current_locus;
11147 : /* No field list allowed after non-nested structure declaration. */
11148 329 : if (!gfc_comp_struct (gfc_current_state ())
11149 296 : && gfc_match_eos () != MATCH_YES)
11150 : {
11151 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11152 1 : return MATCH_ERROR;
11153 : }
11154 :
11155 : /* Make sure the name is not the name of an intrinsic type. */
11156 328 : if (gfc_is_intrinsic_typename (name))
11157 : {
11158 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11159 : " intrinsic type", name);
11160 1 : return MATCH_ERROR;
11161 : }
11162 :
11163 : /* Store the actual type symbol for the structure with an upper-case first
11164 : letter (an invalid Fortran identifier). */
11165 :
11166 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11167 : return MATCH_ERROR;
11168 :
11169 324 : gfc_new_block = sym;
11170 324 : return MATCH_YES;
11171 : }
11172 :
11173 :
11174 : /* This function does some work to determine which matcher should be used to
11175 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11176 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11177 : * and [parameterized] derived type declarations. */
11178 :
11179 : match
11180 519466 : gfc_match_type (gfc_statement *st)
11181 : {
11182 519466 : char name[GFC_MAX_SYMBOL_LEN + 1];
11183 519466 : match m;
11184 519466 : locus old_loc;
11185 :
11186 : /* Requires -fdec. */
11187 519466 : if (!flag_dec)
11188 : return MATCH_NO;
11189 :
11190 2483 : m = gfc_match ("type");
11191 2483 : if (m != MATCH_YES)
11192 : return m;
11193 : /* If we already have an error in the buffer, it is probably from failing to
11194 : * match a derived type data declaration. Let it happen. */
11195 20 : else if (gfc_error_flag_test ())
11196 : return MATCH_NO;
11197 :
11198 20 : old_loc = gfc_current_locus;
11199 20 : *st = ST_NONE;
11200 :
11201 : /* If we see an attribute list before anything else it's definitely a derived
11202 : * type declaration. */
11203 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11204 8 : goto derived;
11205 :
11206 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11207 : * be something like "TYPE *" or "TYPE <fmt>". */
11208 12 : m = gfc_match_name (name);
11209 12 : if (m != MATCH_YES)
11210 : {
11211 : /* Let print match if it can, otherwise throw an error from
11212 : * gfc_match_derived_decl. */
11213 7 : gfc_current_locus = old_loc;
11214 7 : if (gfc_match_print () == MATCH_YES)
11215 : {
11216 7 : *st = ST_WRITE;
11217 7 : return MATCH_YES;
11218 : }
11219 0 : goto derived;
11220 : }
11221 :
11222 : /* Check for EOS. */
11223 5 : if (gfc_match_eos () == MATCH_YES)
11224 : {
11225 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11226 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11227 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11228 : * symbol which can be printed. */
11229 3 : gfc_current_locus = old_loc;
11230 3 : m = gfc_match_derived_decl ();
11231 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11232 : {
11233 2 : *st = ST_DERIVED_DECL;
11234 2 : return m;
11235 : }
11236 : }
11237 : else
11238 : {
11239 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11240 : like <type name(parameter)>. */
11241 2 : gfc_gobble_whitespace ();
11242 2 : bool paren = gfc_peek_ascii_char () == '(';
11243 2 : if (paren)
11244 : {
11245 1 : if (strcmp ("is", name) == 0)
11246 1 : goto typeis;
11247 : else
11248 0 : goto derived;
11249 : }
11250 : }
11251 :
11252 : /* Treat TYPE... like PRINT... */
11253 2 : gfc_current_locus = old_loc;
11254 2 : *st = ST_WRITE;
11255 2 : return gfc_match_print ();
11256 :
11257 8 : derived:
11258 8 : gfc_current_locus = old_loc;
11259 8 : *st = ST_DERIVED_DECL;
11260 8 : return gfc_match_derived_decl ();
11261 :
11262 1 : typeis:
11263 1 : gfc_current_locus = old_loc;
11264 1 : *st = ST_TYPE_IS;
11265 1 : return gfc_match_type_is ();
11266 : }
11267 :
11268 :
11269 : /* Match the beginning of a derived type declaration. If a type name
11270 : was the result of a function, then it is possible to have a symbol
11271 : already to be known as a derived type yet have no components. */
11272 :
11273 : match
11274 16250 : gfc_match_derived_decl (void)
11275 : {
11276 16250 : char name[GFC_MAX_SYMBOL_LEN + 1];
11277 16250 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11278 16250 : symbol_attribute attr;
11279 16250 : gfc_symbol *sym, *gensym;
11280 16250 : gfc_symbol *extended;
11281 16250 : match m;
11282 16250 : match is_type_attr_spec = MATCH_NO;
11283 16250 : bool seen_attr = false;
11284 16250 : gfc_interface *intr = NULL, *head;
11285 16250 : bool parameterized_type = false;
11286 16250 : bool seen_colons = false;
11287 :
11288 16250 : if (gfc_comp_struct (gfc_current_state ()))
11289 : return MATCH_NO;
11290 :
11291 16246 : name[0] = '\0';
11292 16246 : parent[0] = '\0';
11293 16246 : gfc_clear_attr (&attr);
11294 16246 : extended = NULL;
11295 :
11296 19020 : do
11297 : {
11298 19020 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11299 19020 : if (is_type_attr_spec == MATCH_ERROR)
11300 : return MATCH_ERROR;
11301 19017 : if (is_type_attr_spec == MATCH_YES)
11302 2774 : seen_attr = true;
11303 19017 : } while (is_type_attr_spec == MATCH_YES);
11304 :
11305 : /* Deal with derived type extensions. The extension attribute has
11306 : been added to 'attr' but now the parent type must be found and
11307 : checked. */
11308 16243 : if (parent[0])
11309 1477 : extended = check_extended_derived_type (parent);
11310 :
11311 16243 : if (parent[0] && !extended)
11312 : return MATCH_ERROR;
11313 :
11314 16239 : m = gfc_match (" ::");
11315 16239 : if (m == MATCH_YES)
11316 : {
11317 : seen_colons = true;
11318 : }
11319 10271 : else if (seen_attr)
11320 : {
11321 5 : gfc_error ("Expected :: in TYPE definition at %C");
11322 5 : return MATCH_ERROR;
11323 : }
11324 :
11325 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11326 : But, we need to simply return for TYPE(. */
11327 10266 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11328 : {
11329 10218 : char c = gfc_peek_ascii_char ();
11330 10218 : if (c == '(')
11331 : return m;
11332 10137 : if (!gfc_is_whitespace (c))
11333 : {
11334 4 : gfc_error ("Mangled derived type definition at %C");
11335 4 : return MATCH_NO;
11336 : }
11337 : }
11338 :
11339 16149 : m = gfc_match (" %n ", name);
11340 16149 : if (m != MATCH_YES)
11341 : return m;
11342 :
11343 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11344 : derived type named 'is'.
11345 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11346 : and checking if this is a(n intrinsic) typename. This picks up
11347 : misplaced TYPE IS statements such as in select_type_1.f03. */
11348 16137 : if (gfc_peek_ascii_char () == '(')
11349 : {
11350 3864 : if (gfc_current_state () == COMP_SELECT_TYPE
11351 438 : || (!seen_colons && !strcmp (name, "is")))
11352 : return MATCH_NO;
11353 : parameterized_type = true;
11354 : }
11355 :
11356 12709 : m = gfc_match_eos ();
11357 12709 : if (m != MATCH_YES && !parameterized_type)
11358 : return m;
11359 :
11360 : /* Make sure the name is not the name of an intrinsic type. */
11361 12706 : if (gfc_is_intrinsic_typename (name))
11362 : {
11363 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11364 : "type", name);
11365 18 : return MATCH_ERROR;
11366 : }
11367 :
11368 12688 : if (gfc_get_symbol (name, NULL, &gensym))
11369 : return MATCH_ERROR;
11370 :
11371 12688 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11372 : {
11373 5 : if (gensym->ts.u.derived)
11374 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11375 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11376 : else
11377 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11378 : gensym->name);
11379 5 : return MATCH_ERROR;
11380 : }
11381 :
11382 12683 : if (!gensym->attr.generic
11383 12683 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11384 : return MATCH_ERROR;
11385 :
11386 12679 : if (!gensym->attr.function
11387 12679 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11388 : return MATCH_ERROR;
11389 :
11390 12678 : if (gensym->attr.dummy)
11391 : {
11392 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11393 : name, &gensym->declared_at);
11394 1 : return MATCH_ERROR;
11395 : }
11396 :
11397 12677 : sym = gfc_find_dt_in_generic (gensym);
11398 :
11399 12677 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11400 : {
11401 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11402 : "defined", sym->name);
11403 1 : return MATCH_ERROR;
11404 : }
11405 :
11406 12676 : if (!sym)
11407 : {
11408 : /* Use upper case to save the actual derived-type symbol. */
11409 12586 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11410 12586 : sym->name = gfc_get_string ("%s", gensym->name);
11411 12586 : head = gensym->generic;
11412 12586 : intr = gfc_get_interface ();
11413 12586 : intr->sym = sym;
11414 12586 : intr->where = gfc_current_locus;
11415 12586 : intr->sym->declared_at = gfc_current_locus;
11416 12586 : intr->next = head;
11417 12586 : gensym->generic = intr;
11418 12586 : gensym->attr.if_source = IFSRC_DECL;
11419 : }
11420 :
11421 : /* The symbol may already have the derived attribute without the
11422 : components. The ways this can happen is via a function
11423 : definition, an INTRINSIC statement or a subtype in another
11424 : derived type that is a pointer. The first part of the AND clause
11425 : is true if the symbol is not the return value of a function. */
11426 12676 : if (sym->attr.flavor != FL_DERIVED
11427 12676 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11428 : return MATCH_ERROR;
11429 :
11430 12676 : if (attr.access != ACCESS_UNKNOWN
11431 12676 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11432 : return MATCH_ERROR;
11433 12676 : else if (sym->attr.access == ACCESS_UNKNOWN
11434 12120 : && gensym->attr.access != ACCESS_UNKNOWN
11435 13004 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11436 : sym->name, NULL))
11437 : return MATCH_ERROR;
11438 :
11439 12676 : if (sym->attr.access != ACCESS_UNKNOWN
11440 884 : && gensym->attr.access == ACCESS_UNKNOWN)
11441 556 : gensym->attr.access = sym->attr.access;
11442 :
11443 : /* See if the derived type was labeled as bind(c). */
11444 12676 : if (attr.is_bind_c != 0)
11445 404 : sym->attr.is_bind_c = attr.is_bind_c;
11446 :
11447 : /* Construct the f2k_derived namespace if it is not yet there. */
11448 12676 : if (!sym->f2k_derived)
11449 12676 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11450 :
11451 12676 : if (parameterized_type)
11452 : {
11453 : /* Ignore error or mismatches by going to the end of the statement
11454 : in order to avoid the component declarations causing problems. */
11455 436 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11456 436 : if (m != MATCH_YES)
11457 4 : gfc_error_recovery ();
11458 : else
11459 432 : sym->attr.pdt_template = 1;
11460 436 : m = gfc_match_eos ();
11461 436 : if (m != MATCH_YES)
11462 : {
11463 1 : gfc_error_recovery ();
11464 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11465 : }
11466 : }
11467 :
11468 12676 : if (extended && !sym->components)
11469 : {
11470 1473 : gfc_component *p;
11471 1473 : gfc_formal_arglist *f, *g, *h;
11472 :
11473 : /* Add the extended derived type as the first component. */
11474 1473 : gfc_add_component (sym, parent, &p);
11475 1473 : extended->refs++;
11476 1473 : gfc_set_sym_referenced (extended);
11477 :
11478 1473 : p->ts.type = BT_DERIVED;
11479 1473 : p->ts.u.derived = extended;
11480 1473 : p->initializer = gfc_default_initializer (&p->ts);
11481 :
11482 : /* Set extension level. */
11483 1473 : if (extended->attr.extension == 255)
11484 : {
11485 : /* Since the extension field is 8 bit wide, we can only have
11486 : up to 255 extension levels. */
11487 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11488 : extended->name, &extended->declared_at);
11489 0 : return MATCH_ERROR;
11490 : }
11491 1473 : sym->attr.extension = extended->attr.extension + 1;
11492 :
11493 : /* Provide the links between the extended type and its extension. */
11494 1473 : if (!extended->f2k_derived)
11495 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11496 :
11497 : /* Copy the extended type-param-name-list from the extended type,
11498 : append those of the extension and add the whole lot to the
11499 : extension. */
11500 1473 : if (extended->attr.pdt_template)
11501 : {
11502 34 : g = h = NULL;
11503 34 : sym->attr.pdt_template = 1;
11504 99 : for (f = extended->formal; f; f = f->next)
11505 : {
11506 65 : if (f == extended->formal)
11507 : {
11508 34 : g = gfc_get_formal_arglist ();
11509 34 : h = g;
11510 : }
11511 : else
11512 : {
11513 31 : g->next = gfc_get_formal_arglist ();
11514 31 : g = g->next;
11515 : }
11516 65 : g->sym = f->sym;
11517 : }
11518 34 : g->next = sym->formal;
11519 34 : sym->formal = h;
11520 : }
11521 : }
11522 :
11523 12676 : if (!sym->hash_value)
11524 : /* Set the hash for the compound name for this type. */
11525 12676 : sym->hash_value = gfc_hash_value (sym);
11526 :
11527 : /* Take over the ABSTRACT attribute. */
11528 12676 : sym->attr.abstract = attr.abstract;
11529 :
11530 12676 : gfc_new_block = sym;
11531 :
11532 12676 : return MATCH_YES;
11533 : }
11534 :
11535 :
11536 : /* Cray Pointees can be declared as:
11537 : pointer (ipt, a (n,m,...,*)) */
11538 :
11539 : match
11540 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11541 : {
11542 240 : as->cray_pointee = true; /* This will be useful to know later. */
11543 240 : if (as->type == AS_ASSUMED_SIZE)
11544 72 : as->cp_was_assumed = true;
11545 168 : else if (as->type == AS_ASSUMED_SHAPE)
11546 : {
11547 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11548 0 : return MATCH_ERROR;
11549 : }
11550 : return MATCH_YES;
11551 : }
11552 :
11553 :
11554 : /* Match the enum definition statement, here we are trying to match
11555 : the first line of enum definition statement.
11556 : Returns MATCH_YES if match is found. */
11557 :
11558 : match
11559 158 : gfc_match_enum (void)
11560 : {
11561 158 : match m;
11562 :
11563 158 : m = gfc_match_eos ();
11564 158 : if (m != MATCH_YES)
11565 : return m;
11566 :
11567 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11568 0 : return MATCH_ERROR;
11569 :
11570 : return MATCH_YES;
11571 : }
11572 :
11573 :
11574 : /* Returns an initializer whose value is one higher than the value of the
11575 : LAST_INITIALIZER argument. If the argument is NULL, the
11576 : initializers value will be set to zero. The initializer's kind
11577 : will be set to gfc_c_int_kind.
11578 :
11579 : If -fshort-enums is given, the appropriate kind will be selected
11580 : later after all enumerators have been parsed. A warning is issued
11581 : here if an initializer exceeds gfc_c_int_kind. */
11582 :
11583 : static gfc_expr *
11584 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11585 : {
11586 377 : gfc_expr *result;
11587 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11588 :
11589 377 : mpz_init (result->value.integer);
11590 :
11591 377 : if (last_initializer != NULL)
11592 : {
11593 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11594 266 : result->where = last_initializer->where;
11595 :
11596 266 : if (gfc_check_integer_range (result->value.integer,
11597 : gfc_c_int_kind) != ARITH_OK)
11598 : {
11599 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11600 0 : return NULL;
11601 : }
11602 : }
11603 : else
11604 : {
11605 : /* Control comes here, if it's the very first enumerator and no
11606 : initializer has been given. It will be initialized to zero. */
11607 111 : mpz_set_si (result->value.integer, 0);
11608 : }
11609 :
11610 : return result;
11611 : }
11612 :
11613 :
11614 : /* Match a variable name with an optional initializer. When this
11615 : subroutine is called, a variable is expected to be parsed next.
11616 : Depending on what is happening at the moment, updates either the
11617 : symbol table or the current interface. */
11618 :
11619 : static match
11620 549 : enumerator_decl (void)
11621 : {
11622 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11623 549 : gfc_expr *initializer;
11624 549 : gfc_array_spec *as = NULL;
11625 549 : gfc_symbol *sym;
11626 549 : locus var_locus;
11627 549 : match m;
11628 549 : bool t;
11629 549 : locus old_locus;
11630 :
11631 549 : initializer = NULL;
11632 549 : old_locus = gfc_current_locus;
11633 :
11634 : /* When we get here, we've just matched a list of attributes and
11635 : maybe a type and a double colon. The next thing we expect to see
11636 : is the name of the symbol. */
11637 549 : m = gfc_match_name (name);
11638 549 : if (m != MATCH_YES)
11639 1 : goto cleanup;
11640 :
11641 548 : var_locus = gfc_current_locus;
11642 :
11643 : /* OK, we've successfully matched the declaration. Now put the
11644 : symbol in the current namespace. If we fail to create the symbol,
11645 : bail out. */
11646 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11647 : {
11648 1 : m = MATCH_ERROR;
11649 1 : goto cleanup;
11650 : }
11651 :
11652 : /* The double colon must be present in order to have initializers.
11653 : Otherwise the statement is ambiguous with an assignment statement. */
11654 547 : if (colon_seen)
11655 : {
11656 471 : if (gfc_match_char ('=') == MATCH_YES)
11657 : {
11658 170 : m = gfc_match_init_expr (&initializer);
11659 170 : if (m == MATCH_NO)
11660 : {
11661 0 : gfc_error ("Expected an initialization expression at %C");
11662 0 : m = MATCH_ERROR;
11663 : }
11664 :
11665 170 : if (m != MATCH_YES)
11666 2 : goto cleanup;
11667 : }
11668 : }
11669 :
11670 : /* If we do not have an initializer, the initialization value of the
11671 : previous enumerator (stored in last_initializer) is incremented
11672 : by 1 and is used to initialize the current enumerator. */
11673 545 : if (initializer == NULL)
11674 377 : initializer = enum_initializer (last_initializer, old_locus);
11675 :
11676 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11677 : {
11678 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11679 : &var_locus);
11680 2 : m = MATCH_ERROR;
11681 2 : goto cleanup;
11682 : }
11683 :
11684 : /* Store this current initializer, for the next enumerator variable
11685 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11686 : use last_initializer below. */
11687 543 : last_initializer = initializer;
11688 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
11689 :
11690 : /* Maintain enumerator history. */
11691 543 : gfc_find_symbol (name, NULL, 0, &sym);
11692 543 : create_enum_history (sym, last_initializer);
11693 :
11694 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11695 :
11696 6 : cleanup:
11697 : /* Free stuff up and return. */
11698 6 : gfc_free_expr (initializer);
11699 :
11700 6 : return m;
11701 : }
11702 :
11703 :
11704 : /* Match the enumerator definition statement. */
11705 :
11706 : match
11707 795424 : gfc_match_enumerator_def (void)
11708 : {
11709 795424 : match m;
11710 795424 : bool t;
11711 :
11712 795424 : gfc_clear_ts (¤t_ts);
11713 :
11714 795424 : m = gfc_match (" enumerator");
11715 795424 : if (m != MATCH_YES)
11716 : return m;
11717 :
11718 269 : m = gfc_match (" :: ");
11719 269 : if (m == MATCH_ERROR)
11720 : return m;
11721 :
11722 269 : colon_seen = (m == MATCH_YES);
11723 :
11724 269 : if (gfc_current_state () != COMP_ENUM)
11725 : {
11726 4 : gfc_error ("ENUM definition statement expected before %C");
11727 4 : gfc_free_enum_history ();
11728 4 : return MATCH_ERROR;
11729 : }
11730 :
11731 265 : (¤t_ts)->type = BT_INTEGER;
11732 265 : (¤t_ts)->kind = gfc_c_int_kind;
11733 :
11734 265 : gfc_clear_attr (¤t_attr);
11735 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11736 265 : if (!t)
11737 : {
11738 0 : m = MATCH_ERROR;
11739 0 : goto cleanup;
11740 : }
11741 :
11742 549 : for (;;)
11743 : {
11744 549 : m = enumerator_decl ();
11745 549 : if (m == MATCH_ERROR)
11746 : {
11747 6 : gfc_free_enum_history ();
11748 6 : goto cleanup;
11749 : }
11750 543 : if (m == MATCH_NO)
11751 : break;
11752 :
11753 542 : if (gfc_match_eos () == MATCH_YES)
11754 256 : goto cleanup;
11755 286 : if (gfc_match_char (',') != MATCH_YES)
11756 : break;
11757 : }
11758 :
11759 3 : if (gfc_current_state () == COMP_ENUM)
11760 : {
11761 3 : gfc_free_enum_history ();
11762 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11763 3 : m = MATCH_ERROR;
11764 : }
11765 :
11766 0 : cleanup:
11767 265 : gfc_free_array_spec (current_as);
11768 265 : current_as = NULL;
11769 265 : return m;
11770 :
11771 : }
11772 :
11773 :
11774 : /* Match binding attributes. */
11775 :
11776 : static match
11777 4581 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11778 : {
11779 4581 : bool found_passing = false;
11780 4581 : bool seen_ptr = false;
11781 4581 : match m = MATCH_YES;
11782 :
11783 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11784 : this case the defaults are in there. */
11785 4581 : ba->access = ACCESS_UNKNOWN;
11786 4581 : ba->pass_arg = NULL;
11787 4581 : ba->pass_arg_num = 0;
11788 4581 : ba->nopass = 0;
11789 4581 : ba->non_overridable = 0;
11790 4581 : ba->deferred = 0;
11791 4581 : ba->ppc = ppc;
11792 :
11793 : /* If we find a comma, we believe there are binding attributes. */
11794 4581 : m = gfc_match_char (',');
11795 4581 : if (m == MATCH_NO)
11796 2367 : goto done;
11797 :
11798 2757 : do
11799 : {
11800 : /* Access specifier. */
11801 :
11802 2757 : m = gfc_match (" public");
11803 2757 : if (m == MATCH_ERROR)
11804 0 : goto error;
11805 2757 : if (m == MATCH_YES)
11806 : {
11807 250 : if (ba->access != ACCESS_UNKNOWN)
11808 : {
11809 0 : gfc_error ("Duplicate access-specifier at %C");
11810 0 : goto error;
11811 : }
11812 :
11813 250 : ba->access = ACCESS_PUBLIC;
11814 250 : continue;
11815 : }
11816 :
11817 2507 : m = gfc_match (" private");
11818 2507 : if (m == MATCH_ERROR)
11819 0 : goto error;
11820 2507 : if (m == MATCH_YES)
11821 : {
11822 163 : if (ba->access != ACCESS_UNKNOWN)
11823 : {
11824 1 : gfc_error ("Duplicate access-specifier at %C");
11825 1 : goto error;
11826 : }
11827 :
11828 162 : ba->access = ACCESS_PRIVATE;
11829 162 : continue;
11830 : }
11831 :
11832 : /* If inside GENERIC, the following is not allowed. */
11833 2344 : if (!generic)
11834 : {
11835 :
11836 : /* NOPASS flag. */
11837 2343 : m = gfc_match (" nopass");
11838 2343 : if (m == MATCH_ERROR)
11839 0 : goto error;
11840 2343 : if (m == MATCH_YES)
11841 : {
11842 701 : if (found_passing)
11843 : {
11844 1 : gfc_error ("Binding attributes already specify passing,"
11845 : " illegal NOPASS at %C");
11846 1 : goto error;
11847 : }
11848 :
11849 700 : found_passing = true;
11850 700 : ba->nopass = 1;
11851 700 : continue;
11852 : }
11853 :
11854 : /* PASS possibly including argument. */
11855 1642 : m = gfc_match (" pass");
11856 1642 : if (m == MATCH_ERROR)
11857 0 : goto error;
11858 1642 : if (m == MATCH_YES)
11859 : {
11860 895 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11861 :
11862 895 : if (found_passing)
11863 : {
11864 2 : gfc_error ("Binding attributes already specify passing,"
11865 : " illegal PASS at %C");
11866 2 : goto error;
11867 : }
11868 :
11869 893 : m = gfc_match (" ( %n )", arg);
11870 893 : if (m == MATCH_ERROR)
11871 0 : goto error;
11872 893 : if (m == MATCH_YES)
11873 484 : ba->pass_arg = gfc_get_string ("%s", arg);
11874 893 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11875 :
11876 893 : found_passing = true;
11877 893 : ba->nopass = 0;
11878 893 : continue;
11879 893 : }
11880 :
11881 747 : if (ppc)
11882 : {
11883 : /* POINTER flag. */
11884 425 : m = gfc_match (" pointer");
11885 425 : if (m == MATCH_ERROR)
11886 0 : goto error;
11887 425 : if (m == MATCH_YES)
11888 : {
11889 425 : if (seen_ptr)
11890 : {
11891 1 : gfc_error ("Duplicate POINTER attribute at %C");
11892 1 : goto error;
11893 : }
11894 :
11895 424 : seen_ptr = true;
11896 424 : continue;
11897 : }
11898 : }
11899 : else
11900 : {
11901 : /* NON_OVERRIDABLE flag. */
11902 322 : m = gfc_match (" non_overridable");
11903 322 : if (m == MATCH_ERROR)
11904 0 : goto error;
11905 322 : if (m == MATCH_YES)
11906 : {
11907 62 : if (ba->non_overridable)
11908 : {
11909 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11910 1 : goto error;
11911 : }
11912 :
11913 61 : ba->non_overridable = 1;
11914 61 : continue;
11915 : }
11916 :
11917 : /* DEFERRED flag. */
11918 260 : m = gfc_match (" deferred");
11919 260 : if (m == MATCH_ERROR)
11920 0 : goto error;
11921 260 : if (m == MATCH_YES)
11922 : {
11923 260 : if (ba->deferred)
11924 : {
11925 1 : gfc_error ("Duplicate DEFERRED at %C");
11926 1 : goto error;
11927 : }
11928 :
11929 259 : ba->deferred = 1;
11930 259 : continue;
11931 : }
11932 : }
11933 :
11934 : }
11935 :
11936 : /* Nothing matching found. */
11937 1 : if (generic)
11938 1 : gfc_error ("Expected access-specifier at %C");
11939 : else
11940 0 : gfc_error ("Expected binding attribute at %C");
11941 1 : goto error;
11942 : }
11943 2749 : while (gfc_match_char (',') == MATCH_YES);
11944 :
11945 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11946 2206 : if (ba->non_overridable && ba->deferred)
11947 : {
11948 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11949 1 : goto error;
11950 : }
11951 :
11952 : m = MATCH_YES;
11953 :
11954 4572 : done:
11955 4572 : if (ba->access == ACCESS_UNKNOWN)
11956 4161 : ba->access = ppc ? gfc_current_block()->component_access
11957 : : gfc_typebound_default_access;
11958 :
11959 4572 : if (ppc && !seen_ptr)
11960 : {
11961 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
11962 : " at %C");
11963 2 : goto error;
11964 : }
11965 :
11966 : return m;
11967 :
11968 : error:
11969 : return MATCH_ERROR;
11970 : }
11971 :
11972 :
11973 : /* Match a PROCEDURE specific binding inside a derived type. */
11974 :
11975 : static match
11976 3147 : match_procedure_in_type (void)
11977 : {
11978 3147 : char name[GFC_MAX_SYMBOL_LEN + 1];
11979 3147 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
11980 3147 : char* target = NULL, *ifc = NULL;
11981 3147 : gfc_typebound_proc tb;
11982 3147 : bool seen_colons;
11983 3147 : bool seen_attrs;
11984 3147 : match m;
11985 3147 : gfc_symtree* stree;
11986 3147 : gfc_namespace* ns;
11987 3147 : gfc_symbol* block;
11988 3147 : int num;
11989 :
11990 : /* Check current state. */
11991 3147 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
11992 3147 : block = gfc_state_stack->previous->sym;
11993 3147 : gcc_assert (block);
11994 :
11995 : /* Try to match PROCEDURE(interface). */
11996 3147 : if (gfc_match (" (") == MATCH_YES)
11997 : {
11998 261 : m = gfc_match_name (target_buf);
11999 261 : if (m == MATCH_ERROR)
12000 : return m;
12001 261 : if (m != MATCH_YES)
12002 : {
12003 1 : gfc_error ("Interface-name expected after %<(%> at %C");
12004 1 : return MATCH_ERROR;
12005 : }
12006 :
12007 260 : if (gfc_match (" )") != MATCH_YES)
12008 : {
12009 1 : gfc_error ("%<)%> expected at %C");
12010 1 : return MATCH_ERROR;
12011 : }
12012 :
12013 : ifc = target_buf;
12014 : }
12015 :
12016 : /* Construct the data structure. */
12017 3145 : memset (&tb, 0, sizeof (tb));
12018 3145 : tb.where = gfc_current_locus;
12019 :
12020 : /* Match binding attributes. */
12021 3145 : m = match_binding_attributes (&tb, false, false);
12022 3145 : if (m == MATCH_ERROR)
12023 : return m;
12024 3138 : seen_attrs = (m == MATCH_YES);
12025 :
12026 : /* Check that attribute DEFERRED is given if an interface is specified. */
12027 3138 : if (tb.deferred && !ifc)
12028 : {
12029 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
12030 1 : return MATCH_ERROR;
12031 : }
12032 3137 : if (ifc && !tb.deferred)
12033 : {
12034 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
12035 1 : return MATCH_ERROR;
12036 : }
12037 :
12038 : /* Match the colons. */
12039 3136 : m = gfc_match (" ::");
12040 3136 : if (m == MATCH_ERROR)
12041 : return m;
12042 3136 : seen_colons = (m == MATCH_YES);
12043 3136 : if (seen_attrs && !seen_colons)
12044 : {
12045 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
12046 4 : return MATCH_ERROR;
12047 : }
12048 :
12049 : /* Match the binding names. */
12050 19 : for(num=1;;num++)
12051 : {
12052 3151 : m = gfc_match_name (name);
12053 3151 : if (m == MATCH_ERROR)
12054 : return m;
12055 3151 : if (m == MATCH_NO)
12056 : {
12057 5 : gfc_error ("Expected binding name at %C");
12058 5 : return MATCH_ERROR;
12059 : }
12060 :
12061 3146 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
12062 : return MATCH_ERROR;
12063 :
12064 : /* Try to match the '=> target', if it's there. */
12065 3145 : target = ifc;
12066 3145 : m = gfc_match (" =>");
12067 3145 : if (m == MATCH_ERROR)
12068 : return m;
12069 3145 : if (m == MATCH_YES)
12070 : {
12071 1248 : if (tb.deferred)
12072 : {
12073 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
12074 1 : return MATCH_ERROR;
12075 : }
12076 :
12077 1247 : if (!seen_colons)
12078 : {
12079 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
12080 : " at %C");
12081 1 : return MATCH_ERROR;
12082 : }
12083 :
12084 1246 : m = gfc_match_name (target_buf);
12085 1246 : if (m == MATCH_ERROR)
12086 : return m;
12087 1246 : if (m == MATCH_NO)
12088 : {
12089 2 : gfc_error ("Expected binding target after %<=>%> at %C");
12090 2 : return MATCH_ERROR;
12091 : }
12092 : target = target_buf;
12093 : }
12094 :
12095 : /* If no target was found, it has the same name as the binding. */
12096 1897 : if (!target)
12097 1642 : target = name;
12098 :
12099 : /* Get the namespace to insert the symbols into. */
12100 3141 : ns = block->f2k_derived;
12101 3141 : gcc_assert (ns);
12102 :
12103 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
12104 3141 : if (tb.deferred && !block->attr.abstract)
12105 : {
12106 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
12107 : "is not ABSTRACT", block->name);
12108 1 : return MATCH_ERROR;
12109 : }
12110 :
12111 : /* See if we already have a binding with this name in the symtree which
12112 : would be an error. If a GENERIC already targeted this binding, it may
12113 : be already there but then typebound is still NULL. */
12114 3140 : stree = gfc_find_symtree (ns->tb_sym_root, name);
12115 3140 : if (stree && stree->n.tb)
12116 : {
12117 2 : gfc_error ("There is already a procedure with binding name %qs for "
12118 : "the derived type %qs at %C", name, block->name);
12119 2 : return MATCH_ERROR;
12120 : }
12121 :
12122 : /* Insert it and set attributes. */
12123 :
12124 3043 : if (!stree)
12125 : {
12126 3043 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12127 3043 : gcc_assert (stree);
12128 : }
12129 3138 : stree->n.tb = gfc_get_typebound_proc (&tb);
12130 :
12131 3138 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12132 : false))
12133 : return MATCH_ERROR;
12134 3138 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12135 3138 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12136 3138 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12137 :
12138 3138 : if (gfc_match_eos () == MATCH_YES)
12139 : return MATCH_YES;
12140 20 : if (gfc_match_char (',') != MATCH_YES)
12141 1 : goto syntax;
12142 : }
12143 :
12144 1 : syntax:
12145 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12146 1 : return MATCH_ERROR;
12147 : }
12148 :
12149 :
12150 : /* Match a GENERIC statement.
12151 : F2018 15.4.3.3 GENERIC statement
12152 :
12153 : A GENERIC statement specifies a generic identifier for one or more specific
12154 : procedures, in the same way as a generic interface block that does not contain
12155 : interface bodies.
12156 :
12157 : R1510 generic-stmt is:
12158 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12159 :
12160 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12161 : procedure that was specified previously in any accessible interface with the
12162 : same generic identifier.
12163 :
12164 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12165 :
12166 : For GENERIC statements outside of a derived type, use is made of the existing,
12167 : typebound matching functions to obtain access-spec and generic-spec. After
12168 : this the standard INTERFACE machinery is used. */
12169 :
12170 : static match
12171 100 : match_generic_stmt (void)
12172 : {
12173 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12174 : /* Allow space for OPERATOR(...). */
12175 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12176 : /* Generics other than uops */
12177 100 : gfc_symbol* generic_spec = NULL;
12178 : /* Generic uops */
12179 100 : gfc_user_op *generic_uop = NULL;
12180 : /* For the matching calls */
12181 100 : gfc_typebound_proc tbattr;
12182 100 : gfc_namespace* ns = gfc_current_ns;
12183 100 : interface_type op_type;
12184 100 : gfc_intrinsic_op op;
12185 100 : match m;
12186 100 : gfc_symtree* st;
12187 : /* The specific-procedure-list */
12188 100 : gfc_interface *generic = NULL;
12189 : /* The head of the specific-procedure-list */
12190 100 : gfc_interface **generic_tail = NULL;
12191 :
12192 100 : memset (&tbattr, 0, sizeof (tbattr));
12193 100 : tbattr.where = gfc_current_locus;
12194 :
12195 : /* See if we get an access-specifier. */
12196 100 : m = match_binding_attributes (&tbattr, true, false);
12197 100 : tbattr.where = gfc_current_locus;
12198 100 : if (m == MATCH_ERROR)
12199 0 : goto error;
12200 :
12201 : /* Now the colons, those are required. */
12202 100 : if (gfc_match (" ::") != MATCH_YES)
12203 : {
12204 0 : gfc_error ("Expected %<::%> at %C");
12205 0 : goto error;
12206 : }
12207 :
12208 : /* Match the generic-spec name; depending on type (operator / generic) format
12209 : it for future error messages in 'generic_spec_name'. */
12210 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12211 100 : if (m == MATCH_ERROR)
12212 : return MATCH_ERROR;
12213 100 : if (m == MATCH_NO)
12214 : {
12215 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12216 0 : goto error;
12217 : }
12218 :
12219 100 : switch (op_type)
12220 : {
12221 63 : case INTERFACE_GENERIC:
12222 63 : case INTERFACE_DTIO:
12223 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12224 63 : break;
12225 :
12226 22 : case INTERFACE_USER_OP:
12227 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12228 22 : break;
12229 :
12230 13 : case INTERFACE_INTRINSIC_OP:
12231 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12232 : gfc_op2string (op));
12233 13 : break;
12234 :
12235 2 : case INTERFACE_NAMELESS:
12236 2 : gfc_error ("Malformed GENERIC statement at %C");
12237 2 : goto error;
12238 0 : break;
12239 :
12240 0 : default:
12241 0 : gcc_unreachable ();
12242 : }
12243 :
12244 : /* Match the required =>. */
12245 98 : if (gfc_match (" =>") != MATCH_YES)
12246 : {
12247 1 : gfc_error ("Expected %<=>%> at %C");
12248 1 : goto error;
12249 : }
12250 :
12251 :
12252 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12253 : {
12254 1 : gfc_error ("The access specification at %L not in a module",
12255 : &tbattr.where);
12256 1 : goto error;
12257 : }
12258 :
12259 : /* Try to find existing generic-spec with this name for this operator;
12260 : if there is something, check that it is another generic-spec and then
12261 : extend it rather than building a new symbol. Otherwise, create a new
12262 : one with the right attributes. */
12263 :
12264 96 : switch (op_type)
12265 : {
12266 61 : case INTERFACE_DTIO:
12267 61 : case INTERFACE_GENERIC:
12268 61 : st = gfc_find_symtree (ns->sym_root, name);
12269 61 : generic_spec = st ? st->n.sym : NULL;
12270 61 : if (generic_spec)
12271 : {
12272 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12273 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12274 : {
12275 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12276 : "name of an entity declared at %L that is not a "
12277 : "procedure", name, &generic_spec->declared_at);
12278 1 : goto error;
12279 : }
12280 :
12281 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12282 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12283 : {
12284 0 : gfc_error ("There's already a non-generic procedure with "
12285 : "name %qs at %C", generic_spec->name);
12286 0 : goto error;
12287 : }
12288 :
12289 24 : if (tbattr.access != ACCESS_UNKNOWN)
12290 : {
12291 2 : if (generic_spec->attr.access != tbattr.access)
12292 : {
12293 1 : gfc_error ("The access specification at %L conflicts with "
12294 : "that already given to %qs", &tbattr.where,
12295 : generic_spec->name);
12296 1 : goto error;
12297 : }
12298 : else
12299 : {
12300 1 : gfc_error ("The access specification at %L repeats that "
12301 : "already given to %qs", &tbattr.where,
12302 : generic_spec->name);
12303 1 : goto error;
12304 : }
12305 : }
12306 :
12307 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12308 : {
12309 1 : gfc_error ("The generic-spec in the generic statement at %C "
12310 : "has a type from the declaration at %L",
12311 : &generic_spec->declared_at);
12312 1 : goto error;
12313 : }
12314 : }
12315 :
12316 : /* Now create the generic_spec if it doesn't already exist and provide
12317 : is with the appropriate attributes. */
12318 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12319 : {
12320 45 : if (!generic_spec)
12321 : {
12322 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12323 36 : gfc_set_sym_referenced (generic_spec);
12324 36 : generic_spec->attr.access = tbattr.access;
12325 : }
12326 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12327 0 : generic_spec->attr.access = tbattr.access;
12328 45 : generic_spec->refs++;
12329 45 : generic_spec->attr.generic = 1;
12330 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12331 :
12332 45 : generic_spec->declared_at = gfc_current_locus;
12333 : }
12334 :
12335 : /* Prepare to add the specific procedures. */
12336 57 : generic = generic_spec->generic;
12337 57 : generic_tail = &generic_spec->generic;
12338 57 : break;
12339 :
12340 22 : case INTERFACE_USER_OP:
12341 22 : st = gfc_find_symtree (ns->uop_root, name);
12342 22 : generic_uop = st ? st->n.uop : NULL;
12343 2 : if (generic_uop)
12344 : {
12345 2 : if (generic_uop->access != ACCESS_UNKNOWN
12346 2 : && tbattr.access != ACCESS_UNKNOWN)
12347 : {
12348 2 : if (generic_uop->access != tbattr.access)
12349 : {
12350 1 : gfc_error ("The user operator at %L must have the same "
12351 : "access specification as already defined user "
12352 : "operator %qs", &tbattr.where, generic_spec_name);
12353 1 : goto error;
12354 : }
12355 : else
12356 : {
12357 1 : gfc_error ("The user operator at %L repeats the access "
12358 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12359 1 : goto error;
12360 : }
12361 : }
12362 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12363 0 : generic_uop->access = tbattr.access;
12364 : }
12365 : else
12366 : {
12367 20 : generic_uop = gfc_get_uop (name);
12368 20 : generic_uop->access = tbattr.access;
12369 : }
12370 :
12371 : /* Prepare to add the specific procedures. */
12372 20 : generic = generic_uop->op;
12373 20 : generic_tail = &generic_uop->op;
12374 20 : break;
12375 :
12376 13 : case INTERFACE_INTRINSIC_OP:
12377 13 : generic = ns->op[op];
12378 13 : generic_tail = &ns->op[op];
12379 13 : break;
12380 :
12381 0 : default:
12382 0 : gcc_unreachable ();
12383 : }
12384 :
12385 : /* Now, match all following names in the specific-procedure-list. */
12386 154 : do
12387 : {
12388 154 : m = gfc_match_name (name);
12389 154 : if (m == MATCH_ERROR)
12390 0 : goto error;
12391 154 : if (m == MATCH_NO)
12392 : {
12393 0 : gfc_error ("Expected specific procedure name at %C");
12394 0 : goto error;
12395 : }
12396 :
12397 154 : if (op_type == INTERFACE_GENERIC
12398 95 : && !strcmp (generic_spec->name, name))
12399 : {
12400 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12401 : "with that of the generic-spec", name);
12402 2 : goto error;
12403 : }
12404 :
12405 152 : generic = *generic_tail;
12406 242 : for (; generic; generic = generic->next)
12407 : {
12408 90 : if (!strcmp (generic->sym->name, name))
12409 : {
12410 0 : gfc_error ("%qs already defined as a specific procedure for the"
12411 : " generic %qs at %C", name, generic_spec->name);
12412 0 : goto error;
12413 : }
12414 : }
12415 :
12416 152 : gfc_find_sym_tree (name, ns, 1, &st);
12417 152 : if (!st)
12418 : {
12419 : /* This might be a procedure that has not yet been parsed. If
12420 : so gfc_fixup_sibling_symbols will replace this symbol with
12421 : that of the procedure. */
12422 75 : gfc_get_sym_tree (name, ns, &st, false);
12423 75 : st->n.sym->refs++;
12424 : }
12425 :
12426 152 : generic = gfc_get_interface();
12427 152 : generic->next = *generic_tail;
12428 152 : *generic_tail = generic;
12429 152 : generic->where = gfc_current_locus;
12430 152 : generic->sym = st->n.sym;
12431 : }
12432 152 : while (gfc_match (" ,") == MATCH_YES);
12433 :
12434 88 : if (gfc_match_eos () != MATCH_YES)
12435 : {
12436 0 : gfc_error ("Junk after GENERIC statement at %C");
12437 0 : goto error;
12438 : }
12439 :
12440 88 : gfc_commit_symbols ();
12441 88 : return MATCH_YES;
12442 :
12443 : error:
12444 : return MATCH_ERROR;
12445 : }
12446 :
12447 :
12448 : /* Match a GENERIC procedure binding inside a derived type. */
12449 :
12450 : static match
12451 910 : match_typebound_generic (void)
12452 : {
12453 910 : char name[GFC_MAX_SYMBOL_LEN + 1];
12454 910 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12455 910 : gfc_symbol* block;
12456 910 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12457 910 : gfc_typebound_proc* tb;
12458 910 : gfc_namespace* ns;
12459 910 : interface_type op_type;
12460 910 : gfc_intrinsic_op op;
12461 910 : match m;
12462 :
12463 : /* Check current state. */
12464 910 : if (gfc_current_state () == COMP_DERIVED)
12465 : {
12466 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12467 0 : return MATCH_ERROR;
12468 : }
12469 910 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12470 : return MATCH_NO;
12471 910 : block = gfc_state_stack->previous->sym;
12472 910 : ns = block->f2k_derived;
12473 910 : gcc_assert (block && ns);
12474 :
12475 910 : memset (&tbattr, 0, sizeof (tbattr));
12476 910 : tbattr.where = gfc_current_locus;
12477 :
12478 : /* See if we get an access-specifier. */
12479 910 : m = match_binding_attributes (&tbattr, true, false);
12480 910 : if (m == MATCH_ERROR)
12481 1 : goto error;
12482 :
12483 : /* Now the colons, those are required. */
12484 909 : if (gfc_match (" ::") != MATCH_YES)
12485 : {
12486 0 : gfc_error ("Expected %<::%> at %C");
12487 0 : goto error;
12488 : }
12489 :
12490 : /* Match the binding name; depending on type (operator / generic) format
12491 : it for future error messages into bind_name. */
12492 :
12493 909 : m = gfc_match_generic_spec (&op_type, name, &op);
12494 909 : if (m == MATCH_ERROR)
12495 : return MATCH_ERROR;
12496 909 : if (m == MATCH_NO)
12497 : {
12498 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12499 0 : goto error;
12500 : }
12501 :
12502 909 : switch (op_type)
12503 : {
12504 456 : case INTERFACE_GENERIC:
12505 456 : case INTERFACE_DTIO:
12506 456 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12507 456 : break;
12508 :
12509 29 : case INTERFACE_USER_OP:
12510 29 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12511 29 : break;
12512 :
12513 423 : case INTERFACE_INTRINSIC_OP:
12514 423 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12515 : gfc_op2string (op));
12516 423 : break;
12517 :
12518 1 : case INTERFACE_NAMELESS:
12519 1 : gfc_error ("Malformed GENERIC statement at %C");
12520 1 : goto error;
12521 0 : break;
12522 :
12523 0 : default:
12524 0 : gcc_unreachable ();
12525 : }
12526 :
12527 : /* Match the required =>. */
12528 908 : if (gfc_match (" =>") != MATCH_YES)
12529 : {
12530 0 : gfc_error ("Expected %<=>%> at %C");
12531 0 : goto error;
12532 : }
12533 :
12534 : /* Try to find existing GENERIC binding with this name / for this operator;
12535 : if there is something, check that it is another GENERIC and then extend
12536 : it rather than building a new node. Otherwise, create it and put it
12537 : at the right position. */
12538 :
12539 908 : switch (op_type)
12540 : {
12541 485 : case INTERFACE_DTIO:
12542 485 : case INTERFACE_USER_OP:
12543 485 : case INTERFACE_GENERIC:
12544 485 : {
12545 485 : const bool is_op = (op_type == INTERFACE_USER_OP);
12546 485 : gfc_symtree* st;
12547 :
12548 485 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12549 485 : tb = st ? st->n.tb : NULL;
12550 : break;
12551 : }
12552 :
12553 423 : case INTERFACE_INTRINSIC_OP:
12554 423 : tb = ns->tb_op[op];
12555 423 : break;
12556 :
12557 0 : default:
12558 0 : gcc_unreachable ();
12559 : }
12560 :
12561 434 : if (tb)
12562 : {
12563 9 : if (!tb->is_generic)
12564 : {
12565 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12566 1 : gfc_error ("There's already a non-generic procedure with binding name"
12567 : " %qs for the derived type %qs at %C",
12568 : bind_name, block->name);
12569 1 : goto error;
12570 : }
12571 :
12572 8 : if (tb->access != tbattr.access)
12573 : {
12574 2 : gfc_error ("Binding at %C must have the same access as already"
12575 : " defined binding %qs", bind_name);
12576 2 : goto error;
12577 : }
12578 : }
12579 : else
12580 : {
12581 899 : tb = gfc_get_typebound_proc (NULL);
12582 899 : tb->where = gfc_current_locus;
12583 899 : tb->access = tbattr.access;
12584 899 : tb->is_generic = 1;
12585 899 : tb->u.generic = NULL;
12586 :
12587 899 : switch (op_type)
12588 : {
12589 476 : case INTERFACE_DTIO:
12590 476 : case INTERFACE_GENERIC:
12591 476 : case INTERFACE_USER_OP:
12592 476 : {
12593 476 : const bool is_op = (op_type == INTERFACE_USER_OP);
12594 476 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12595 : &ns->tb_sym_root, name);
12596 476 : gcc_assert (st);
12597 476 : st->n.tb = tb;
12598 :
12599 476 : break;
12600 : }
12601 :
12602 423 : case INTERFACE_INTRINSIC_OP:
12603 423 : ns->tb_op[op] = tb;
12604 423 : break;
12605 :
12606 0 : default:
12607 0 : gcc_unreachable ();
12608 : }
12609 : }
12610 :
12611 : /* Now, match all following names as specific targets. */
12612 1056 : do
12613 : {
12614 1056 : gfc_symtree* target_st;
12615 1056 : gfc_tbp_generic* target;
12616 :
12617 1056 : m = gfc_match_name (name);
12618 1056 : if (m == MATCH_ERROR)
12619 0 : goto error;
12620 1056 : if (m == MATCH_NO)
12621 : {
12622 1 : gfc_error ("Expected specific binding name at %C");
12623 1 : goto error;
12624 : }
12625 :
12626 1055 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12627 :
12628 : /* See if this is a duplicate specification. */
12629 1284 : for (target = tb->u.generic; target; target = target->next)
12630 230 : if (target_st == target->specific_st)
12631 : {
12632 1 : gfc_error ("%qs already defined as specific binding for the"
12633 : " generic %qs at %C", name, bind_name);
12634 1 : goto error;
12635 : }
12636 :
12637 1054 : target = gfc_get_tbp_generic ();
12638 1054 : target->specific_st = target_st;
12639 1054 : target->specific = NULL;
12640 1054 : target->next = tb->u.generic;
12641 1054 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12642 1054 : || (op_type == INTERFACE_INTRINSIC_OP));
12643 1054 : tb->u.generic = target;
12644 : }
12645 1054 : while (gfc_match (" ,") == MATCH_YES);
12646 :
12647 : /* Here should be the end. */
12648 903 : if (gfc_match_eos () != MATCH_YES)
12649 : {
12650 1 : gfc_error ("Junk after GENERIC binding at %C");
12651 1 : goto error;
12652 : }
12653 :
12654 : return MATCH_YES;
12655 :
12656 : error:
12657 : return MATCH_ERROR;
12658 : }
12659 :
12660 :
12661 : match
12662 1010 : gfc_match_generic ()
12663 : {
12664 1010 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12665 1008 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12666 100 : return match_generic_stmt ();
12667 : else
12668 910 : return match_typebound_generic ();
12669 : }
12670 :
12671 :
12672 : /* Match a FINAL declaration inside a derived type. */
12673 :
12674 : match
12675 454 : gfc_match_final_decl (void)
12676 : {
12677 454 : char name[GFC_MAX_SYMBOL_LEN + 1];
12678 454 : gfc_symbol* sym;
12679 454 : match m;
12680 454 : gfc_namespace* module_ns;
12681 454 : bool first, last;
12682 454 : gfc_symbol* block;
12683 :
12684 454 : if (gfc_current_form == FORM_FREE)
12685 : {
12686 454 : char c = gfc_peek_ascii_char ();
12687 454 : if (!gfc_is_whitespace (c) && c != ':')
12688 : return MATCH_NO;
12689 : }
12690 :
12691 453 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12692 : {
12693 1 : if (gfc_current_form == FORM_FIXED)
12694 : return MATCH_NO;
12695 :
12696 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12697 : "CONTAINS section");
12698 1 : return MATCH_ERROR;
12699 : }
12700 :
12701 452 : block = gfc_state_stack->previous->sym;
12702 452 : gcc_assert (block);
12703 :
12704 452 : if (gfc_state_stack->previous->previous
12705 452 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12706 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12707 : {
12708 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12709 : " specification part of a MODULE");
12710 0 : return MATCH_ERROR;
12711 : }
12712 :
12713 452 : module_ns = gfc_current_ns;
12714 452 : gcc_assert (module_ns);
12715 452 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12716 :
12717 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12718 452 : if (gfc_match (" ::") == MATCH_ERROR)
12719 : return MATCH_ERROR;
12720 :
12721 : /* Match the sequence of procedure names. */
12722 : first = true;
12723 : last = false;
12724 538 : do
12725 : {
12726 538 : gfc_finalizer* f;
12727 :
12728 538 : if (first && gfc_match_eos () == MATCH_YES)
12729 : {
12730 2 : gfc_error ("Empty FINAL at %C");
12731 2 : return MATCH_ERROR;
12732 : }
12733 :
12734 536 : m = gfc_match_name (name);
12735 536 : if (m == MATCH_NO)
12736 : {
12737 1 : gfc_error ("Expected module procedure name at %C");
12738 1 : return MATCH_ERROR;
12739 : }
12740 535 : else if (m != MATCH_YES)
12741 : return MATCH_ERROR;
12742 :
12743 535 : if (gfc_match_eos () == MATCH_YES)
12744 : last = true;
12745 87 : if (!last && gfc_match_char (',') != MATCH_YES)
12746 : {
12747 1 : gfc_error ("Expected %<,%> at %C");
12748 1 : return MATCH_ERROR;
12749 : }
12750 :
12751 534 : if (gfc_get_symbol (name, module_ns, &sym))
12752 : {
12753 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12754 0 : return MATCH_ERROR;
12755 : }
12756 :
12757 : /* Mark the symbol as module procedure. */
12758 534 : if (sym->attr.proc != PROC_MODULE
12759 534 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12760 : return MATCH_ERROR;
12761 :
12762 : /* Check if we already have this symbol in the list, this is an error. */
12763 715 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12764 182 : if (f->proc_sym == sym)
12765 : {
12766 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12767 : name);
12768 1 : return MATCH_ERROR;
12769 : }
12770 :
12771 : /* Add this symbol to the list of finalizers. */
12772 533 : gcc_assert (block->f2k_derived);
12773 533 : sym->refs++;
12774 533 : f = XCNEW (gfc_finalizer);
12775 533 : f->proc_sym = sym;
12776 533 : f->proc_tree = NULL;
12777 533 : f->where = gfc_current_locus;
12778 533 : f->next = block->f2k_derived->finalizers;
12779 533 : block->f2k_derived->finalizers = f;
12780 :
12781 533 : first = false;
12782 : }
12783 533 : while (!last);
12784 :
12785 : return MATCH_YES;
12786 : }
12787 :
12788 :
12789 : const ext_attr_t ext_attr_list[] = {
12790 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12791 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12792 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12793 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12794 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12795 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12796 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12797 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12798 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12799 : { "weak", EXT_ATTR_WEAK, NULL },
12800 : { NULL, EXT_ATTR_LAST, NULL }
12801 : };
12802 :
12803 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12804 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12805 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12806 :
12807 : TODO: We should support all GCC attributes using the same syntax for
12808 : the attribute list, i.e. the list in C
12809 : __attributes(( attribute-list ))
12810 : matches then
12811 : !GCC$ ATTRIBUTES attribute-list ::
12812 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12813 : saved into a TREE.
12814 :
12815 : As there is absolutely no risk of confusion, we should never return
12816 : MATCH_NO. */
12817 : match
12818 2976 : gfc_match_gcc_attributes (void)
12819 : {
12820 2976 : symbol_attribute attr;
12821 2976 : char name[GFC_MAX_SYMBOL_LEN + 1];
12822 2976 : unsigned id;
12823 2976 : gfc_symbol *sym;
12824 2976 : match m;
12825 :
12826 2976 : gfc_clear_attr (&attr);
12827 2976 : for(;;)
12828 : {
12829 2976 : char ch;
12830 :
12831 2976 : if (gfc_match_name (name) != MATCH_YES)
12832 : return MATCH_ERROR;
12833 :
12834 17941 : for (id = 0; id < EXT_ATTR_LAST; id++)
12835 17941 : if (strcmp (name, ext_attr_list[id].name) == 0)
12836 : break;
12837 :
12838 2976 : if (id == EXT_ATTR_LAST)
12839 : {
12840 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12841 0 : return MATCH_ERROR;
12842 : }
12843 :
12844 2976 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12845 : return MATCH_ERROR;
12846 :
12847 2976 : gfc_gobble_whitespace ();
12848 2976 : ch = gfc_next_ascii_char ();
12849 2976 : if (ch == ':')
12850 : {
12851 : /* This is the successful exit condition for the loop. */
12852 2976 : if (gfc_next_ascii_char () == ':')
12853 : break;
12854 : }
12855 :
12856 0 : if (ch == ',')
12857 0 : continue;
12858 :
12859 0 : goto syntax;
12860 0 : }
12861 :
12862 2976 : if (gfc_match_eos () == MATCH_YES)
12863 0 : goto syntax;
12864 :
12865 2991 : for(;;)
12866 : {
12867 2991 : m = gfc_match_name (name);
12868 2991 : if (m != MATCH_YES)
12869 : return m;
12870 :
12871 2991 : if (find_special (name, &sym, true))
12872 : return MATCH_ERROR;
12873 :
12874 2991 : sym->attr.ext_attr |= attr.ext_attr;
12875 :
12876 2991 : if (gfc_match_eos () == MATCH_YES)
12877 : break;
12878 :
12879 15 : if (gfc_match_char (',') != MATCH_YES)
12880 0 : goto syntax;
12881 : }
12882 :
12883 : return MATCH_YES;
12884 :
12885 0 : syntax:
12886 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
12887 0 : return MATCH_ERROR;
12888 : }
12889 :
12890 :
12891 : /* Match a !GCC$ UNROLL statement of the form:
12892 : !GCC$ UNROLL n
12893 :
12894 : The parameter n is the number of times we are supposed to unroll.
12895 :
12896 : When we come here, we have already matched the !GCC$ UNROLL string. */
12897 : match
12898 19 : gfc_match_gcc_unroll (void)
12899 : {
12900 19 : int value;
12901 :
12902 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
12903 19 : if (gfc_match_small_int (&value) == MATCH_YES)
12904 : {
12905 19 : if (value < 0 || value > USHRT_MAX)
12906 : {
12907 2 : gfc_error ("%<GCC unroll%> directive requires a"
12908 : " non-negative integral constant"
12909 : " less than or equal to %u at %C",
12910 : USHRT_MAX
12911 : );
12912 2 : return MATCH_ERROR;
12913 : }
12914 17 : if (gfc_match_eos () == MATCH_YES)
12915 : {
12916 17 : directive_unroll = value == 0 ? 1 : value;
12917 17 : return MATCH_YES;
12918 : }
12919 : }
12920 :
12921 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
12922 0 : return MATCH_ERROR;
12923 : }
12924 :
12925 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
12926 :
12927 : The parameter b is name of a middle-end built-in.
12928 : FLAGS is optional and must be one of:
12929 : - (inbranch)
12930 : - (notinbranch)
12931 :
12932 : IF('target') is optional and TARGET is a name of a multilib ABI.
12933 :
12934 : When we come here, we have already matched the !GCC$ builtin string. */
12935 :
12936 : match
12937 3386265 : gfc_match_gcc_builtin (void)
12938 : {
12939 3386265 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
12940 3386265 : char target[GFC_MAX_SYMBOL_LEN + 1];
12941 :
12942 3386265 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
12943 : return MATCH_ERROR;
12944 :
12945 3386265 : gfc_simd_clause clause = SIMD_NONE;
12946 3386265 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
12947 : clause = SIMD_NOTINBRANCH;
12948 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
12949 15 : clause = SIMD_INBRANCH;
12950 :
12951 3386265 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
12952 : {
12953 3386235 : if (strcmp (target, "fastmath") == 0)
12954 : {
12955 0 : if (!fast_math_flags_set_p (&global_options))
12956 : return MATCH_YES;
12957 : }
12958 : else
12959 : {
12960 3386235 : const char *abi = targetm.get_multilib_abi_name ();
12961 3386235 : if (abi == NULL || strcmp (abi, target) != 0)
12962 : return MATCH_YES;
12963 : }
12964 : }
12965 :
12966 1671170 : if (gfc_vectorized_builtins == NULL)
12967 30953 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
12968 :
12969 1671170 : char *r = XNEWVEC (char, strlen (builtin) + 32);
12970 1671170 : sprintf (r, "__builtin_%s", builtin);
12971 :
12972 1671170 : bool existed;
12973 1671170 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
12974 1671170 : value |= clause;
12975 1671170 : if (existed)
12976 23 : free (r);
12977 :
12978 : return MATCH_YES;
12979 : }
12980 :
12981 : /* Match an !GCC$ IVDEP statement.
12982 : When we come here, we have already matched the !GCC$ IVDEP string. */
12983 :
12984 : match
12985 3 : gfc_match_gcc_ivdep (void)
12986 : {
12987 3 : if (gfc_match_eos () == MATCH_YES)
12988 : {
12989 3 : directive_ivdep = true;
12990 3 : return MATCH_YES;
12991 : }
12992 :
12993 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
12994 0 : return MATCH_ERROR;
12995 : }
12996 :
12997 : /* Match an !GCC$ VECTOR statement.
12998 : When we come here, we have already matched the !GCC$ VECTOR string. */
12999 :
13000 : match
13001 3 : gfc_match_gcc_vector (void)
13002 : {
13003 3 : if (gfc_match_eos () == MATCH_YES)
13004 : {
13005 3 : directive_vector = true;
13006 3 : directive_novector = false;
13007 3 : return MATCH_YES;
13008 : }
13009 :
13010 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
13011 0 : return MATCH_ERROR;
13012 : }
13013 :
13014 : /* Match an !GCC$ NOVECTOR statement.
13015 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
13016 :
13017 : match
13018 3 : gfc_match_gcc_novector (void)
13019 : {
13020 3 : if (gfc_match_eos () == MATCH_YES)
13021 : {
13022 3 : directive_novector = true;
13023 3 : directive_vector = false;
13024 3 : return MATCH_YES;
13025 : }
13026 :
13027 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
13028 0 : return MATCH_ERROR;
13029 : }
|
