Line data Source code
1 : /* Declaration statement matcher
2 : Copyright (C) 2002-2026 Free Software Foundation, Inc.
3 : Contributed by Andy Vaught
4 :
5 : This file is part of GCC.
6 :
7 : GCC is free software; you can redistribute it and/or modify it under
8 : the terms of the GNU General Public License as published by the Free
9 : Software Foundation; either version 3, or (at your option) any later
10 : version.
11 :
12 : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13 : WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 : FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 : for more details.
16 :
17 : You should have received a copy of the GNU General Public License
18 : along with GCC; see the file COPYING3. If not see
19 : <http://www.gnu.org/licenses/>. */
20 :
21 : #include "config.h"
22 : #include "system.h"
23 : #include "coretypes.h"
24 : #include "options.h"
25 : #include "tree.h"
26 : #include "gfortran.h"
27 : #include "stringpool.h"
28 : #include "match.h"
29 : #include "parse.h"
30 : #include "constructor.h"
31 : #include "target.h"
32 : #include "flags.h"
33 :
34 : /* Macros to access allocate memory for gfc_data_variable,
35 : gfc_data_value and gfc_data. */
36 : #define gfc_get_data_variable() XCNEW (gfc_data_variable)
37 : #define gfc_get_data_value() XCNEW (gfc_data_value)
38 : #define gfc_get_data() XCNEW (gfc_data)
39 :
40 :
41 : static bool set_binding_label (const char **, const char *, int);
42 :
43 :
44 : /* This flag is set if an old-style length selector is matched
45 : during a type-declaration statement. */
46 :
47 : static int old_char_selector;
48 :
49 : /* When variables acquire types and attributes from a declaration
50 : statement, they get them from the following static variables. The
51 : first part of a declaration sets these variables and the second
52 : part copies these into symbol structures. */
53 :
54 : static gfc_typespec current_ts;
55 :
56 : static symbol_attribute current_attr;
57 : static gfc_array_spec *current_as;
58 : static int colon_seen;
59 : static int attr_seen;
60 :
61 : /* The current binding label (if any). */
62 : static const char* curr_binding_label;
63 : /* Need to know how many identifiers are on the current data declaration
64 : line in case we're given the BIND(C) attribute with a NAME= specifier. */
65 : static int num_idents_on_line;
66 : /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
67 : can supply a name if the curr_binding_label is nil and NAME= was not. */
68 : static int has_name_equals = 0;
69 :
70 : /* Initializer of the previous enumerator. */
71 :
72 : static gfc_expr *last_initializer;
73 :
74 : /* History of all the enumerators is maintained, so that
75 : kind values of all the enumerators could be updated depending
76 : upon the maximum initialized value. */
77 :
78 : typedef struct enumerator_history
79 : {
80 : gfc_symbol *sym;
81 : gfc_expr *initializer;
82 : struct enumerator_history *next;
83 : }
84 : enumerator_history;
85 :
86 : /* Header of enum history chain. */
87 :
88 : static enumerator_history *enum_history = NULL;
89 :
90 : /* Pointer of enum history node containing largest initializer. */
91 :
92 : static enumerator_history *max_enum = NULL;
93 :
94 : /* gfc_new_block points to the symbol of a newly matched block. */
95 :
96 : gfc_symbol *gfc_new_block;
97 :
98 : bool gfc_matching_function;
99 :
100 : /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
101 : int directive_unroll = -1;
102 :
103 : /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
104 : bool directive_ivdep = false;
105 : bool directive_vector = false;
106 : bool directive_novector = false;
107 :
108 : /* Map of middle-end built-ins that should be vectorized. */
109 : hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
110 :
111 : /* If a kind expression of a component of a parameterized derived type is
112 : parameterized, temporarily store the expression here. */
113 : static gfc_expr *saved_kind_expr = NULL;
114 :
115 : /* Used to store the parameter list arising in a PDT declaration and
116 : in the typespec of a PDT variable or component. */
117 : static gfc_actual_arglist *decl_type_param_list;
118 : static gfc_actual_arglist *type_param_spec_list;
119 :
120 : /* Drop an unattached gfc_charlen node from the current namespace. This is
121 : used when declaration processing created a length node for a symbol that is
122 : rejected before the node is attached to any surviving symbol. */
123 : static void
124 1 : discard_pending_charlen (gfc_charlen *cl)
125 : {
126 1 : if (!cl || !gfc_current_ns || gfc_current_ns->cl_list != cl)
127 : return;
128 :
129 1 : gfc_current_ns->cl_list = cl->next;
130 1 : gfc_free_expr (cl->length);
131 1 : free (cl);
132 : }
133 :
134 : /* Drop the charlen nodes created while matching a declaration that is about
135 : to be rejected. Callers must clear any surviving owners before using this
136 : helper, so only the statement-local nodes remain on the namespace list. */
137 :
138 : static void
139 3 : discard_pending_charlens (gfc_charlen *saved_cl)
140 : {
141 3 : if (!gfc_current_ns)
142 : return;
143 :
144 14 : while (gfc_current_ns->cl_list != saved_cl)
145 : {
146 11 : gfc_charlen *cl = gfc_current_ns->cl_list;
147 :
148 11 : gcc_assert (cl);
149 11 : gfc_current_ns->cl_list = cl->next;
150 11 : gfc_free_expr (cl->length);
151 11 : free (cl);
152 : }
153 : }
154 :
155 : /********************* DATA statement subroutines *********************/
156 :
157 : static bool in_match_data = false;
158 :
159 : bool
160 9189 : gfc_in_match_data (void)
161 : {
162 9189 : return in_match_data;
163 : }
164 :
165 : static void
166 4840 : set_in_match_data (bool set_value)
167 : {
168 4840 : in_match_data = set_value;
169 2420 : }
170 :
171 : /* Free a gfc_data_variable structure and everything beneath it. */
172 :
173 : static void
174 5663 : free_variable (gfc_data_variable *p)
175 : {
176 5663 : gfc_data_variable *q;
177 :
178 8752 : for (; p; p = q)
179 : {
180 3089 : q = p->next;
181 3089 : gfc_free_expr (p->expr);
182 3089 : gfc_free_iterator (&p->iter, 0);
183 3089 : free_variable (p->list);
184 3089 : free (p);
185 : }
186 5663 : }
187 :
188 :
189 : /* Free a gfc_data_value structure and everything beneath it. */
190 :
191 : static void
192 2574 : free_value (gfc_data_value *p)
193 : {
194 2574 : gfc_data_value *q;
195 :
196 10886 : for (; p; p = q)
197 : {
198 8312 : q = p->next;
199 8312 : mpz_clear (p->repeat);
200 8312 : gfc_free_expr (p->expr);
201 8312 : free (p);
202 : }
203 2574 : }
204 :
205 :
206 : /* Free a list of gfc_data structures. */
207 :
208 : void
209 528895 : gfc_free_data (gfc_data *p)
210 : {
211 528895 : gfc_data *q;
212 :
213 531469 : for (; p; p = q)
214 : {
215 2574 : q = p->next;
216 2574 : free_variable (p->var);
217 2574 : free_value (p->value);
218 2574 : free (p);
219 : }
220 528895 : }
221 :
222 :
223 : /* Free all data in a namespace. */
224 :
225 : static void
226 41 : gfc_free_data_all (gfc_namespace *ns)
227 : {
228 41 : gfc_data *d;
229 :
230 47 : for (;ns->data;)
231 : {
232 6 : d = ns->data->next;
233 6 : free (ns->data);
234 6 : ns->data = d;
235 : }
236 41 : }
237 :
238 : /* Reject data parsed since the last restore point was marked. */
239 :
240 : void
241 9062168 : gfc_reject_data (gfc_namespace *ns)
242 : {
243 9062168 : gfc_data *d;
244 :
245 9062170 : while (ns->data && ns->data != ns->old_data)
246 : {
247 2 : d = ns->data->next;
248 2 : free (ns->data);
249 2 : ns->data = d;
250 : }
251 9062168 : }
252 :
253 : static match var_element (gfc_data_variable *);
254 :
255 : /* Match a list of variables terminated by an iterator and a right
256 : parenthesis. */
257 :
258 : static match
259 154 : var_list (gfc_data_variable *parent)
260 : {
261 154 : gfc_data_variable *tail, var;
262 154 : match m;
263 :
264 154 : m = var_element (&var);
265 154 : if (m == MATCH_ERROR)
266 : return MATCH_ERROR;
267 154 : if (m == MATCH_NO)
268 0 : goto syntax;
269 :
270 154 : tail = gfc_get_data_variable ();
271 154 : *tail = var;
272 :
273 154 : parent->list = tail;
274 :
275 156 : for (;;)
276 : {
277 155 : if (gfc_match_char (',') != MATCH_YES)
278 0 : goto syntax;
279 :
280 155 : m = gfc_match_iterator (&parent->iter, 1);
281 155 : if (m == MATCH_YES)
282 : break;
283 1 : if (m == MATCH_ERROR)
284 : return MATCH_ERROR;
285 :
286 1 : m = var_element (&var);
287 1 : if (m == MATCH_ERROR)
288 : return MATCH_ERROR;
289 1 : if (m == MATCH_NO)
290 0 : goto syntax;
291 :
292 1 : tail->next = gfc_get_data_variable ();
293 1 : tail = tail->next;
294 :
295 1 : *tail = var;
296 : }
297 :
298 154 : if (gfc_match_char (')') != MATCH_YES)
299 0 : goto syntax;
300 : return MATCH_YES;
301 :
302 0 : syntax:
303 0 : gfc_syntax_error (ST_DATA);
304 0 : return MATCH_ERROR;
305 : }
306 :
307 :
308 : /* Match a single element in a data variable list, which can be a
309 : variable-iterator list. */
310 :
311 : static match
312 3047 : var_element (gfc_data_variable *new_var)
313 : {
314 3047 : match m;
315 3047 : gfc_symbol *sym;
316 :
317 3047 : memset (new_var, 0, sizeof (gfc_data_variable));
318 :
319 3047 : if (gfc_match_char ('(') == MATCH_YES)
320 154 : return var_list (new_var);
321 :
322 2893 : m = gfc_match_variable (&new_var->expr, 0);
323 2893 : if (m != MATCH_YES)
324 : return m;
325 :
326 2889 : if (new_var->expr->expr_type == EXPR_CONSTANT
327 2 : && new_var->expr->symtree == NULL)
328 : {
329 2 : gfc_error ("Inquiry parameter cannot appear in a "
330 : "data-stmt-object-list at %C");
331 2 : return MATCH_ERROR;
332 : }
333 :
334 2887 : sym = new_var->expr->symtree->n.sym;
335 :
336 : /* Symbol should already have an associated type. */
337 2887 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
338 : return MATCH_ERROR;
339 :
340 2886 : if (!sym->attr.function && gfc_current_ns->parent
341 148 : && gfc_current_ns->parent == sym->ns)
342 : {
343 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
344 : "statement at %C", sym->name);
345 1 : return MATCH_ERROR;
346 : }
347 :
348 2885 : if (gfc_current_state () != COMP_BLOCK_DATA
349 2732 : && sym->attr.in_common
350 2914 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
351 : "common block variable %qs in DATA statement at %C",
352 : sym->name))
353 : return MATCH_ERROR;
354 :
355 2883 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
356 : return MATCH_ERROR;
357 :
358 : return MATCH_YES;
359 : }
360 :
361 :
362 : /* Match the top-level list of data variables. */
363 :
364 : static match
365 2517 : top_var_list (gfc_data *d)
366 : {
367 2517 : gfc_data_variable var, *tail, *new_var;
368 2517 : match m;
369 :
370 2517 : tail = NULL;
371 :
372 2892 : for (;;)
373 : {
374 2892 : m = var_element (&var);
375 2892 : if (m == MATCH_NO)
376 0 : goto syntax;
377 2892 : if (m == MATCH_ERROR)
378 : return MATCH_ERROR;
379 :
380 2877 : new_var = gfc_get_data_variable ();
381 2877 : *new_var = var;
382 2877 : if (new_var->expr)
383 2751 : new_var->expr->where = gfc_current_locus;
384 :
385 2877 : if (tail == NULL)
386 2502 : d->var = new_var;
387 : else
388 375 : tail->next = new_var;
389 :
390 2877 : tail = new_var;
391 :
392 2877 : if (gfc_match_char ('/') == MATCH_YES)
393 : break;
394 378 : if (gfc_match_char (',') != MATCH_YES)
395 3 : goto syntax;
396 : }
397 :
398 : return MATCH_YES;
399 :
400 3 : syntax:
401 3 : gfc_syntax_error (ST_DATA);
402 3 : gfc_free_data_all (gfc_current_ns);
403 3 : return MATCH_ERROR;
404 : }
405 :
406 :
407 : static match
408 8713 : match_data_constant (gfc_expr **result)
409 : {
410 8713 : char name[GFC_MAX_SYMBOL_LEN + 1];
411 8713 : gfc_symbol *sym, *dt_sym = NULL;
412 8713 : gfc_expr *expr;
413 8713 : match m;
414 8713 : locus old_loc;
415 8713 : gfc_symtree *symtree;
416 :
417 8713 : m = gfc_match_literal_constant (&expr, 1);
418 8713 : if (m == MATCH_YES)
419 : {
420 8368 : *result = expr;
421 8368 : return MATCH_YES;
422 : }
423 :
424 345 : if (m == MATCH_ERROR)
425 : return MATCH_ERROR;
426 :
427 337 : m = gfc_match_null (result);
428 337 : if (m != MATCH_NO)
429 : return m;
430 :
431 329 : old_loc = gfc_current_locus;
432 :
433 : /* Should this be a structure component, try to match it
434 : before matching a name. */
435 329 : m = gfc_match_rvalue (result);
436 329 : if (m == MATCH_ERROR)
437 : return m;
438 :
439 329 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
440 : {
441 4 : if (!gfc_simplify_expr (*result, 0))
442 0 : m = MATCH_ERROR;
443 4 : return m;
444 : }
445 319 : else if (m == MATCH_YES)
446 : {
447 : /* If a parameter inquiry ends up here, symtree is NULL but **result
448 : contains the right constant expression. Check here. */
449 319 : if ((*result)->symtree == NULL
450 37 : && (*result)->expr_type == EXPR_CONSTANT
451 37 : && ((*result)->ts.type == BT_INTEGER
452 1 : || (*result)->ts.type == BT_REAL))
453 : return m;
454 :
455 : /* F2018:R845 data-stmt-constant is initial-data-target.
456 : A data-stmt-constant shall be ... initial-data-target if and
457 : only if the corresponding data-stmt-object has the POINTER
458 : attribute. ... If data-stmt-constant is initial-data-target
459 : the corresponding data statement object shall be
460 : data-pointer-initialization compatible (7.5.4.6) with the initial
461 : data target; the data statement object is initially associated
462 : with the target. */
463 283 : if ((*result)->symtree
464 282 : && (*result)->symtree->n.sym->attr.save
465 218 : && (*result)->symtree->n.sym->attr.target)
466 : return m;
467 250 : gfc_free_expr (*result);
468 : }
469 :
470 256 : gfc_current_locus = old_loc;
471 :
472 256 : m = gfc_match_name (name);
473 256 : if (m != MATCH_YES)
474 : return m;
475 :
476 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
477 : return MATCH_ERROR;
478 :
479 250 : sym = symtree->n.sym;
480 :
481 250 : if (sym && sym->attr.generic)
482 60 : dt_sym = gfc_find_dt_in_generic (sym);
483 :
484 60 : if (sym == NULL
485 250 : || (sym->attr.flavor != FL_PARAMETER
486 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
487 : {
488 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
489 : name);
490 5 : *result = NULL;
491 5 : return MATCH_ERROR;
492 : }
493 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
494 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
495 :
496 : /* Check to see if the value is an initialization array expression. */
497 185 : if (sym->value->expr_type == EXPR_ARRAY)
498 : {
499 67 : gfc_current_locus = old_loc;
500 :
501 67 : m = gfc_match_init_expr (result);
502 67 : if (m == MATCH_ERROR)
503 : return m;
504 :
505 66 : if (m == MATCH_YES)
506 : {
507 66 : if (!gfc_simplify_expr (*result, 0))
508 0 : m = MATCH_ERROR;
509 :
510 66 : if ((*result)->expr_type == EXPR_CONSTANT)
511 : return m;
512 : else
513 : {
514 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
515 2 : return MATCH_ERROR;
516 : }
517 : }
518 : }
519 :
520 118 : *result = gfc_copy_expr (sym->value);
521 118 : return MATCH_YES;
522 : }
523 :
524 :
525 : /* Match a list of values in a DATA statement. The leading '/' has
526 : already been seen at this point. */
527 :
528 : static match
529 2560 : top_val_list (gfc_data *data)
530 : {
531 2560 : gfc_data_value *new_val, *tail;
532 2560 : gfc_expr *expr;
533 2560 : match m;
534 :
535 2560 : tail = NULL;
536 :
537 8349 : for (;;)
538 : {
539 8349 : m = match_data_constant (&expr);
540 8349 : if (m == MATCH_NO)
541 3 : goto syntax;
542 8346 : if (m == MATCH_ERROR)
543 : return MATCH_ERROR;
544 :
545 8324 : new_val = gfc_get_data_value ();
546 8324 : mpz_init (new_val->repeat);
547 :
548 8324 : if (tail == NULL)
549 2535 : data->value = new_val;
550 : else
551 5789 : tail->next = new_val;
552 :
553 8324 : tail = new_val;
554 :
555 8324 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
556 : {
557 8119 : tail->expr = expr;
558 8119 : mpz_set_ui (tail->repeat, 1);
559 : }
560 : else
561 : {
562 205 : mpz_set (tail->repeat, expr->value.integer);
563 205 : gfc_free_expr (expr);
564 :
565 205 : m = match_data_constant (&tail->expr);
566 205 : if (m == MATCH_NO)
567 0 : goto syntax;
568 205 : if (m == MATCH_ERROR)
569 : return MATCH_ERROR;
570 : }
571 :
572 8320 : if (gfc_match_char ('/') == MATCH_YES)
573 : break;
574 5790 : if (gfc_match_char (',') == MATCH_NO)
575 1 : goto syntax;
576 : }
577 :
578 : return MATCH_YES;
579 :
580 4 : syntax:
581 4 : gfc_syntax_error (ST_DATA);
582 4 : gfc_free_data_all (gfc_current_ns);
583 4 : return MATCH_ERROR;
584 : }
585 :
586 :
587 : /* Matches an old style initialization. */
588 :
589 : static match
590 70 : match_old_style_init (const char *name)
591 : {
592 70 : match m;
593 70 : gfc_symtree *st;
594 70 : gfc_symbol *sym;
595 70 : gfc_data *newdata, *nd;
596 :
597 : /* Set up data structure to hold initializers. */
598 70 : gfc_find_sym_tree (name, NULL, 0, &st);
599 70 : sym = st->n.sym;
600 :
601 70 : newdata = gfc_get_data ();
602 70 : newdata->var = gfc_get_data_variable ();
603 70 : newdata->var->expr = gfc_get_variable_expr (st);
604 70 : newdata->var->expr->where = sym->declared_at;
605 70 : newdata->where = gfc_current_locus;
606 :
607 : /* Match initial value list. This also eats the terminal '/'. */
608 70 : m = top_val_list (newdata);
609 70 : if (m != MATCH_YES)
610 : {
611 1 : free (newdata);
612 1 : return m;
613 : }
614 :
615 : /* Check that a BOZ did not creep into an old-style initialization. */
616 137 : for (nd = newdata; nd; nd = nd->next)
617 : {
618 69 : if (nd->value->expr->ts.type == BT_BOZ
619 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
620 : "initialization"), &nd->value->expr->where))
621 : return MATCH_ERROR;
622 :
623 68 : if (nd->var->expr->ts.type != BT_INTEGER
624 27 : && nd->var->expr->ts.type != BT_REAL
625 21 : && nd->value->expr->ts.type == BT_BOZ)
626 : {
627 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
628 : "a %qs variable in an old-style initialization"),
629 0 : &nd->value->expr->where,
630 : gfc_typename (&nd->value->expr->ts));
631 0 : return MATCH_ERROR;
632 : }
633 : }
634 :
635 68 : if (gfc_pure (NULL))
636 : {
637 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
638 1 : free (newdata);
639 1 : return MATCH_ERROR;
640 : }
641 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
642 :
643 : /* Mark the variable as having appeared in a data statement. */
644 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
645 : {
646 2 : free (newdata);
647 2 : return MATCH_ERROR;
648 : }
649 :
650 : /* Chain in namespace list of DATA initializers. */
651 65 : newdata->next = gfc_current_ns->data;
652 65 : gfc_current_ns->data = newdata;
653 :
654 65 : return m;
655 : }
656 :
657 :
658 : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
659 : we are matching a DATA statement and are therefore issuing an error
660 : if we encounter something unexpected, if not, we're trying to match
661 : an old-style initialization expression of the form INTEGER I /2/. */
662 :
663 : match
664 2422 : gfc_match_data (void)
665 : {
666 2422 : gfc_data *new_data;
667 2422 : gfc_expr *e;
668 2422 : gfc_ref *ref;
669 2422 : match m;
670 2422 : char c;
671 :
672 : /* DATA has been matched. In free form source code, the next character
673 : needs to be whitespace or '(' from an implied do-loop. Check that
674 : here. */
675 2422 : c = gfc_peek_ascii_char ();
676 2422 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
677 : return MATCH_NO;
678 :
679 : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
680 2421 : if ((gfc_current_state () == COMP_FUNCTION
681 2421 : || gfc_current_state () == COMP_SUBROUTINE)
682 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
683 : {
684 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
685 1 : return MATCH_ERROR;
686 : }
687 :
688 2420 : set_in_match_data (true);
689 :
690 2614 : for (;;)
691 : {
692 2517 : new_data = gfc_get_data ();
693 2517 : new_data->where = gfc_current_locus;
694 :
695 2517 : m = top_var_list (new_data);
696 2517 : if (m != MATCH_YES)
697 18 : goto cleanup;
698 :
699 2499 : if (new_data->var->iter.var
700 117 : && new_data->var->iter.var->ts.type == BT_INTEGER
701 74 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
702 68 : && new_data->var->list
703 68 : && new_data->var->list->expr
704 55 : && new_data->var->list->expr->ts.type == BT_CHARACTER
705 3 : && new_data->var->list->expr->ref
706 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
707 : {
708 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
709 : "statement", &new_data->var->list->expr->where);
710 1 : goto cleanup;
711 : }
712 :
713 : /* Check for an entity with an allocatable component, which is not
714 : allowed. */
715 2498 : e = new_data->var->expr;
716 2498 : if (e)
717 : {
718 2382 : bool invalid;
719 :
720 2382 : invalid = false;
721 3606 : for (ref = e->ref; ref; ref = ref->next)
722 1224 : if ((ref->type == REF_COMPONENT
723 140 : && ref->u.c.component->attr.allocatable)
724 1222 : || (ref->type == REF_ARRAY
725 1034 : && e->symtree->n.sym->attr.pointer != 1
726 1031 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
727 1224 : invalid = true;
728 :
729 2382 : if (invalid)
730 : {
731 2 : gfc_error ("Allocatable component or deferred-shaped array "
732 : "near %C in DATA statement");
733 2 : goto cleanup;
734 : }
735 :
736 : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
737 : as a data-stmt-object shall not be an object designator in which
738 : a pointer appears other than as the entire rightmost part-ref. */
739 2380 : if (!e->ref && e->ts.type == BT_DERIVED
740 43 : && e->symtree->n.sym->attr.pointer)
741 4 : goto partref;
742 :
743 2376 : ref = e->ref;
744 2376 : if (e->symtree->n.sym->ts.type == BT_DERIVED
745 125 : && e->symtree->n.sym->attr.pointer
746 1 : && ref->type == REF_COMPONENT)
747 1 : goto partref;
748 :
749 3591 : for (; ref; ref = ref->next)
750 1217 : if (ref->type == REF_COMPONENT
751 135 : && ref->u.c.component->attr.pointer
752 27 : && ref->next)
753 1 : goto partref;
754 : }
755 :
756 2490 : m = top_val_list (new_data);
757 2490 : if (m != MATCH_YES)
758 29 : goto cleanup;
759 :
760 2461 : new_data->next = gfc_current_ns->data;
761 2461 : gfc_current_ns->data = new_data;
762 :
763 : /* A BOZ literal constant cannot appear in a structure constructor.
764 : Check for that here for a data statement value. */
765 2461 : if (new_data->value->expr->ts.type == BT_DERIVED
766 37 : && new_data->value->expr->value.constructor)
767 : {
768 35 : gfc_constructor *c;
769 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
770 106 : for (; c; c = gfc_constructor_next (c))
771 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
772 : {
773 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
774 : "structure constructor", &c->expr->where);
775 0 : return MATCH_ERROR;
776 : }
777 : }
778 :
779 2461 : if (gfc_match_eos () == MATCH_YES)
780 : break;
781 :
782 97 : gfc_match_char (','); /* Optional comma */
783 97 : }
784 :
785 2364 : set_in_match_data (false);
786 :
787 2364 : if (gfc_pure (NULL))
788 : {
789 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
790 0 : return MATCH_ERROR;
791 : }
792 2364 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
793 :
794 2364 : return MATCH_YES;
795 :
796 6 : partref:
797 :
798 6 : gfc_error ("part-ref with pointer attribute near %L is not "
799 : "rightmost part-ref of data-stmt-object",
800 : &e->where);
801 :
802 56 : cleanup:
803 56 : set_in_match_data (false);
804 56 : gfc_free_data (new_data);
805 56 : return MATCH_ERROR;
806 : }
807 :
808 :
809 : /************************ Declaration statements *********************/
810 :
811 :
812 : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
813 : list). The difference here is the expression is a list of constants
814 : and is surrounded by '/'.
815 : The typespec ts must match the typespec of the variable which the
816 : clist is initializing.
817 : The arrayspec tells whether this should match a list of constants
818 : corresponding to array elements or a scalar (as == NULL). */
819 :
820 : static match
821 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
822 : {
823 74 : gfc_constructor_base array_head = NULL;
824 74 : gfc_expr *expr = NULL;
825 74 : match m = MATCH_ERROR;
826 74 : locus where;
827 74 : mpz_t repeat, cons_size, as_size;
828 74 : bool scalar;
829 74 : int cmp;
830 :
831 74 : gcc_assert (ts);
832 :
833 : /* We have already matched '/' - now look for a constant list, as with
834 : top_val_list from decl.cc, but append the result to an array. */
835 74 : if (gfc_match ("/") == MATCH_YES)
836 : {
837 1 : gfc_error ("Empty old style initializer list at %C");
838 1 : return MATCH_ERROR;
839 : }
840 :
841 73 : where = gfc_current_locus;
842 73 : scalar = !as || !as->rank;
843 :
844 42 : if (!scalar && !spec_size (as, &as_size))
845 : {
846 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
847 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
848 : /* Nothing to cleanup yet. */
849 1 : return MATCH_ERROR;
850 : }
851 :
852 72 : mpz_init_set_ui (repeat, 0);
853 :
854 143 : for (;;)
855 : {
856 143 : m = match_data_constant (&expr);
857 143 : if (m != MATCH_YES)
858 3 : expr = NULL; /* match_data_constant may set expr to garbage */
859 3 : if (m == MATCH_NO)
860 2 : goto syntax;
861 141 : if (m == MATCH_ERROR)
862 1 : goto cleanup;
863 :
864 : /* Found r in repeat spec r*c; look for the constant to repeat. */
865 140 : if ( gfc_match_char ('*') == MATCH_YES)
866 : {
867 18 : if (scalar)
868 : {
869 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
870 1 : goto cleanup;
871 : }
872 17 : if (expr->ts.type != BT_INTEGER)
873 : {
874 1 : gfc_error ("Repeat spec must be an integer at %C");
875 1 : goto cleanup;
876 : }
877 16 : mpz_set (repeat, expr->value.integer);
878 16 : gfc_free_expr (expr);
879 16 : expr = NULL;
880 :
881 16 : m = match_data_constant (&expr);
882 16 : if (m == MATCH_NO)
883 : {
884 1 : m = MATCH_ERROR;
885 1 : gfc_error ("Expected data constant after repeat spec at %C");
886 : }
887 16 : if (m != MATCH_YES)
888 1 : goto cleanup;
889 : }
890 : /* No repeat spec, we matched the data constant itself. */
891 : else
892 122 : mpz_set_ui (repeat, 1);
893 :
894 137 : if (!scalar)
895 : {
896 : /* Add the constant initializer as many times as repeated. */
897 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
898 : {
899 : /* Make sure types of elements match */
900 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
901 12 : && !gfc_convert_type (expr, ts, 1))
902 0 : goto cleanup;
903 :
904 144 : gfc_constructor_append_expr (&array_head,
905 : gfc_copy_expr (expr), &gfc_current_locus);
906 : }
907 :
908 107 : gfc_free_expr (expr);
909 107 : expr = NULL;
910 : }
911 :
912 : /* For scalar initializers quit after one element. */
913 : else
914 : {
915 30 : if(gfc_match_char ('/') != MATCH_YES)
916 : {
917 1 : gfc_error ("End of scalar initializer expected at %C");
918 1 : goto cleanup;
919 : }
920 : break;
921 : }
922 :
923 107 : if (gfc_match_char ('/') == MATCH_YES)
924 : break;
925 72 : if (gfc_match_char (',') == MATCH_NO)
926 1 : goto syntax;
927 : }
928 :
929 : /* If we break early from here out, we encountered an error. */
930 64 : m = MATCH_ERROR;
931 :
932 : /* Set up expr as an array constructor. */
933 64 : if (!scalar)
934 : {
935 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
936 35 : expr->ts = *ts;
937 35 : expr->value.constructor = array_head;
938 :
939 : /* Validate sizes. We built expr ourselves, so cons_size will be
940 : constant (we fail above for non-constant expressions).
941 : We still need to verify that the sizes match. */
942 35 : gcc_assert (gfc_array_size (expr, &cons_size));
943 35 : cmp = mpz_cmp (cons_size, as_size);
944 35 : if (cmp < 0)
945 2 : gfc_error ("Not enough elements in array initializer at %C");
946 33 : else if (cmp > 0)
947 3 : gfc_error ("Too many elements in array initializer at %C");
948 35 : mpz_clear (cons_size);
949 35 : if (cmp)
950 5 : goto cleanup;
951 :
952 : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
953 30 : expr->rank = as->rank;
954 30 : expr->corank = as->corank;
955 30 : expr->shape = gfc_get_shape (as->rank);
956 66 : for (int i = 0; i < as->rank; ++i)
957 36 : spec_dimen_size (as, i, &expr->shape[i]);
958 : }
959 :
960 : /* Make sure scalar types match. */
961 29 : else if (!gfc_compare_types (&expr->ts, ts)
962 29 : && !gfc_convert_type (expr, ts, 1))
963 2 : goto cleanup;
964 :
965 57 : if (expr->ts.u.cl)
966 1 : expr->ts.u.cl->length_from_typespec = 1;
967 :
968 57 : *result = expr;
969 57 : m = MATCH_YES;
970 57 : goto done;
971 :
972 3 : syntax:
973 3 : m = MATCH_ERROR;
974 3 : gfc_error ("Syntax error in old style initializer list at %C");
975 :
976 15 : cleanup:
977 15 : if (expr)
978 10 : expr->value.constructor = NULL;
979 15 : gfc_free_expr (expr);
980 15 : gfc_constructor_free (array_head);
981 :
982 72 : done:
983 72 : mpz_clear (repeat);
984 72 : if (!scalar)
985 41 : mpz_clear (as_size);
986 : return m;
987 : }
988 :
989 :
990 : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
991 :
992 : static bool
993 114 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
994 : {
995 114 : if ((from->type == AS_ASSUMED_RANK && to->corank)
996 112 : || (to->type == AS_ASSUMED_RANK && from->corank))
997 : {
998 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
999 5 : return false;
1000 : }
1001 :
1002 109 : if (to->rank == 0 && from->rank > 0)
1003 : {
1004 48 : to->rank = from->rank;
1005 48 : to->type = from->type;
1006 48 : to->cray_pointee = from->cray_pointee;
1007 48 : to->cp_was_assumed = from->cp_was_assumed;
1008 :
1009 152 : for (int i = to->corank - 1; i >= 0; i--)
1010 : {
1011 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1012 : cleans up elsewhere. */
1013 104 : int j = from->rank + i;
1014 104 : if (j >= GFC_MAX_DIMENSIONS)
1015 : break;
1016 :
1017 104 : to->lower[j] = to->lower[i];
1018 104 : to->upper[j] = to->upper[i];
1019 : }
1020 115 : for (int i = 0; i < from->rank; i++)
1021 : {
1022 67 : if (copy)
1023 : {
1024 43 : to->lower[i] = gfc_copy_expr (from->lower[i]);
1025 43 : to->upper[i] = gfc_copy_expr (from->upper[i]);
1026 : }
1027 : else
1028 : {
1029 24 : to->lower[i] = from->lower[i];
1030 24 : to->upper[i] = from->upper[i];
1031 : }
1032 : }
1033 : }
1034 61 : else if (to->corank == 0 && from->corank > 0)
1035 : {
1036 34 : to->corank = from->corank;
1037 34 : to->cotype = from->cotype;
1038 :
1039 104 : for (int i = 0; i < from->corank; i++)
1040 : {
1041 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1042 : cleans up elsewhere. */
1043 71 : int k = from->rank + i;
1044 71 : int j = to->rank + i;
1045 71 : if (j >= GFC_MAX_DIMENSIONS)
1046 : break;
1047 :
1048 70 : if (copy)
1049 : {
1050 37 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1051 37 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1052 : }
1053 : else
1054 : {
1055 33 : to->lower[j] = from->lower[k];
1056 33 : to->upper[j] = from->upper[k];
1057 : }
1058 : }
1059 : }
1060 :
1061 109 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1062 : {
1063 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1064 : "allowed dimensions of %d",
1065 : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1066 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1067 1 : return false;
1068 : }
1069 : return true;
1070 : }
1071 :
1072 :
1073 : /* Match an intent specification. Since this can only happen after an
1074 : INTENT word, a legal intent-spec must follow. */
1075 :
1076 : static sym_intent
1077 27583 : match_intent_spec (void)
1078 : {
1079 :
1080 27583 : if (gfc_match (" ( in out )") == MATCH_YES)
1081 : return INTENT_INOUT;
1082 24421 : if (gfc_match (" ( in )") == MATCH_YES)
1083 : return INTENT_IN;
1084 3661 : if (gfc_match (" ( out )") == MATCH_YES)
1085 : return INTENT_OUT;
1086 :
1087 2 : gfc_error ("Bad INTENT specification at %C");
1088 2 : return INTENT_UNKNOWN;
1089 : }
1090 :
1091 :
1092 : /* Matches a character length specification, which is either a
1093 : specification expression, '*', or ':'. */
1094 :
1095 : static match
1096 27722 : char_len_param_value (gfc_expr **expr, bool *deferred)
1097 : {
1098 27722 : match m;
1099 27722 : gfc_expr *p;
1100 :
1101 27722 : *expr = NULL;
1102 27722 : *deferred = false;
1103 :
1104 27722 : if (gfc_match_char ('*') == MATCH_YES)
1105 : return MATCH_YES;
1106 :
1107 21225 : if (gfc_match_char (':') == MATCH_YES)
1108 : {
1109 3351 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1110 : return MATCH_ERROR;
1111 :
1112 3349 : *deferred = true;
1113 :
1114 3349 : return MATCH_YES;
1115 : }
1116 :
1117 17874 : m = gfc_match_expr (expr);
1118 :
1119 17874 : if (m == MATCH_NO || m == MATCH_ERROR)
1120 : return m;
1121 :
1122 17869 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1123 : return MATCH_ERROR;
1124 :
1125 : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1126 17863 : p = gfc_copy_expr (*expr);
1127 17863 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1128 14831 : gfc_replace_expr (*expr, p);
1129 : else
1130 3032 : gfc_free_expr (p);
1131 :
1132 17863 : if ((*expr)->expr_type == EXPR_FUNCTION)
1133 : {
1134 1015 : if ((*expr)->ts.type == BT_INTEGER
1135 1014 : || ((*expr)->ts.type == BT_UNKNOWN
1136 1014 : && strcmp((*expr)->symtree->name, "null") != 0))
1137 : return MATCH_YES;
1138 :
1139 2 : goto syntax;
1140 : }
1141 16848 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1142 : {
1143 : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1144 : processor dependent and its value is greater than or equal to zero.
1145 : F2008, 4.4.3.2: If the character length parameter value evaluates
1146 : to a negative value, the length of character entities declared
1147 : is zero. */
1148 :
1149 14759 : if ((*expr)->ts.type == BT_INTEGER)
1150 : {
1151 14741 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1152 4 : mpz_set_si ((*expr)->value.integer, 0);
1153 : }
1154 : else
1155 18 : goto syntax;
1156 : }
1157 2089 : else if ((*expr)->expr_type == EXPR_ARRAY)
1158 8 : goto syntax;
1159 2081 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1160 : {
1161 1512 : bool t;
1162 1512 : gfc_expr *e;
1163 :
1164 1512 : e = gfc_copy_expr (*expr);
1165 :
1166 : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1167 : which causes an ICE if gfc_reduce_init_expr() is called. */
1168 1512 : if (e->ref && e->ref->type == REF_ARRAY
1169 8 : && e->ref->u.ar.type == AR_UNKNOWN
1170 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1171 2 : goto syntax;
1172 :
1173 1510 : t = gfc_reduce_init_expr (e);
1174 :
1175 1510 : if (!t && e->ts.type == BT_UNKNOWN
1176 7 : && e->symtree->n.sym->attr.untyped == 1
1177 7 : && (flag_implicit_none
1178 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1179 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1180 : {
1181 7 : gfc_free_expr (e);
1182 7 : goto syntax;
1183 : }
1184 :
1185 1503 : if ((e->ref && e->ref->type == REF_ARRAY
1186 4 : && e->ref->u.ar.type != AR_ELEMENT)
1187 1502 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1188 : {
1189 2 : gfc_free_expr (e);
1190 2 : goto syntax;
1191 : }
1192 :
1193 1501 : gfc_free_expr (e);
1194 : }
1195 :
1196 16811 : if (gfc_seen_div0)
1197 52 : m = MATCH_ERROR;
1198 :
1199 : return m;
1200 :
1201 39 : syntax:
1202 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1203 39 : return MATCH_ERROR;
1204 : }
1205 :
1206 :
1207 : /* A character length is a '*' followed by a literal integer or a
1208 : char_len_param_value in parenthesis. */
1209 :
1210 : static match
1211 62824 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1212 : {
1213 62824 : int length;
1214 62824 : match m;
1215 :
1216 62824 : *deferred = false;
1217 62824 : m = gfc_match_char ('*');
1218 62824 : if (m != MATCH_YES)
1219 : return m;
1220 :
1221 2641 : m = gfc_match_small_literal_int (&length, NULL);
1222 2641 : if (m == MATCH_ERROR)
1223 : return m;
1224 :
1225 2641 : if (m == MATCH_YES)
1226 : {
1227 2137 : if (obsolescent_check
1228 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1229 : return MATCH_ERROR;
1230 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1231 2137 : return m;
1232 : }
1233 :
1234 504 : if (gfc_match_char ('(') == MATCH_NO)
1235 0 : goto syntax;
1236 :
1237 504 : m = char_len_param_value (expr, deferred);
1238 504 : if (m != MATCH_YES && gfc_matching_function)
1239 : {
1240 0 : gfc_undo_symbols ();
1241 0 : m = MATCH_YES;
1242 : }
1243 :
1244 1 : if (m == MATCH_ERROR)
1245 : return m;
1246 503 : if (m == MATCH_NO)
1247 0 : goto syntax;
1248 :
1249 503 : if (gfc_match_char (')') == MATCH_NO)
1250 : {
1251 0 : gfc_free_expr (*expr);
1252 0 : *expr = NULL;
1253 0 : goto syntax;
1254 : }
1255 :
1256 503 : if (obsolescent_check
1257 503 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1258 : return MATCH_ERROR;
1259 :
1260 : return MATCH_YES;
1261 :
1262 0 : syntax:
1263 0 : gfc_error ("Syntax error in character length specification at %C");
1264 0 : return MATCH_ERROR;
1265 : }
1266 :
1267 :
1268 : /* Special subroutine for finding a symbol. Check if the name is found
1269 : in the current name space. If not, and we're compiling a function or
1270 : subroutine and the parent compilation unit is an interface, then check
1271 : to see if the name we've been given is the name of the interface
1272 : (located in another namespace). */
1273 :
1274 : static int
1275 282720 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1276 : {
1277 282720 : gfc_state_data *s;
1278 282720 : gfc_symtree *st;
1279 282720 : int i;
1280 :
1281 282720 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1282 282720 : if (i == 0)
1283 : {
1284 282720 : *result = st ? st->n.sym : NULL;
1285 282720 : goto end;
1286 : }
1287 :
1288 0 : if (gfc_current_state () != COMP_SUBROUTINE
1289 0 : && gfc_current_state () != COMP_FUNCTION)
1290 0 : goto end;
1291 :
1292 0 : s = gfc_state_stack->previous;
1293 0 : if (s == NULL)
1294 0 : goto end;
1295 :
1296 0 : if (s->state != COMP_INTERFACE)
1297 0 : goto end;
1298 0 : if (s->sym == NULL)
1299 0 : goto end; /* Nameless interface. */
1300 :
1301 0 : if (strcmp (name, s->sym->name) == 0)
1302 : {
1303 0 : *result = s->sym;
1304 0 : return 0;
1305 : }
1306 :
1307 0 : end:
1308 : return i;
1309 : }
1310 :
1311 :
1312 : /* Special subroutine for getting a symbol node associated with a
1313 : procedure name, used in SUBROUTINE and FUNCTION statements. The
1314 : symbol is created in the parent using with symtree node in the
1315 : child unit pointing to the symbol. If the current namespace has no
1316 : parent, then the symbol is just created in the current unit. */
1317 :
1318 : static int
1319 63562 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1320 : {
1321 63562 : gfc_symtree *st;
1322 63562 : gfc_symbol *sym;
1323 63562 : int rc = 0;
1324 :
1325 : /* Module functions have to be left in their own namespace because
1326 : they have potentially (almost certainly!) already been referenced.
1327 : In this sense, they are rather like external functions. This is
1328 : fixed up in resolve.cc(resolve_entries), where the symbol name-
1329 : space is set to point to the master function, so that the fake
1330 : result mechanism can work. */
1331 63562 : if (module_fcn_entry)
1332 : {
1333 : /* Present if entry is declared to be a module procedure. */
1334 260 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1335 :
1336 260 : if (*result == NULL)
1337 217 : rc = gfc_get_symbol (name, NULL, result);
1338 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1339 43 : && (*result)->ts.type == BT_UNKNOWN
1340 86 : && sym->attr.flavor == FL_UNKNOWN)
1341 : /* Pick up the typespec for the entry, if declared in the function
1342 : body. Note that this symbol is FL_UNKNOWN because it will
1343 : only have appeared in a type declaration. The local symtree
1344 : is set to point to the module symbol and a unique symtree
1345 : to the local version. This latter ensures a correct clearing
1346 : of the symbols. */
1347 : {
1348 : /* If the ENTRY proceeds its specification, we need to ensure
1349 : that this does not raise a "has no IMPLICIT type" error. */
1350 43 : if (sym->ts.type == BT_UNKNOWN)
1351 23 : sym->attr.untyped = 1;
1352 :
1353 43 : (*result)->ts = sym->ts;
1354 :
1355 : /* Put the symbol in the procedure namespace so that, should
1356 : the ENTRY precede its specification, the specification
1357 : can be applied. */
1358 43 : (*result)->ns = gfc_current_ns;
1359 :
1360 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1361 43 : st->n.sym = *result;
1362 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1363 43 : sym->refs++;
1364 43 : st->n.sym = sym;
1365 : }
1366 : }
1367 : else
1368 63302 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1369 :
1370 63562 : if (rc)
1371 : return rc;
1372 :
1373 63561 : sym = *result;
1374 63561 : if (sym->attr.proc == PROC_ST_FUNCTION)
1375 : return rc;
1376 :
1377 63560 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1378 : {
1379 : /* Create a partially populated interface symbol to carry the
1380 : characteristics of the procedure and the result. */
1381 471 : sym->tlink = gfc_new_symbol (name, sym->ns);
1382 471 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1383 471 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1384 471 : if (sym->attr.dimension)
1385 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1386 :
1387 : /* Ideally, at this point, a copy would be made of the formal
1388 : arguments and their namespace. However, this does not appear
1389 : to be necessary, albeit at the expense of not being able to
1390 : use gfc_compare_interfaces directly. */
1391 :
1392 471 : if (sym->result && sym->result != sym)
1393 : {
1394 105 : sym->tlink->result = sym->result;
1395 105 : sym->result = NULL;
1396 : }
1397 366 : else if (sym->result)
1398 : {
1399 93 : sym->tlink->result = sym->tlink;
1400 : }
1401 : }
1402 63089 : else if (sym && !sym->gfc_new
1403 24381 : && gfc_current_state () != COMP_INTERFACE)
1404 : {
1405 : /* Trap another encompassed procedure with the same name. All
1406 : these conditions are necessary to avoid picking up an entry
1407 : whose name clashes with that of the encompassing procedure;
1408 : this is handled using gsymbols to register unique, globally
1409 : accessible names. */
1410 23277 : if (sym->attr.flavor != 0
1411 21200 : && sym->attr.proc != 0
1412 2367 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1413 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1414 : {
1415 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1416 : name, &sym->declared_at);
1417 7 : return true;
1418 : }
1419 23270 : if (sym->attr.flavor != 0
1420 21193 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1421 : {
1422 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1423 : name, &sym->declared_at);
1424 1 : return true;
1425 : }
1426 :
1427 23269 : if (sym->attr.external && sym->attr.procedure
1428 2 : && gfc_current_state () == COMP_CONTAINS)
1429 : {
1430 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1431 : "procedure defined at %L",
1432 : name, &sym->declared_at);
1433 1 : return true;
1434 : }
1435 :
1436 : /* Trap a procedure with a name the same as interface in the
1437 : encompassing scope. */
1438 23268 : if (sym->attr.generic != 0
1439 60 : && (sym->attr.subroutine || sym->attr.function)
1440 1 : && !sym->attr.mod_proc)
1441 : {
1442 1 : gfc_error_now ("Name %qs at %C is already defined"
1443 : " as a generic interface at %L",
1444 : name, &sym->declared_at);
1445 1 : return true;
1446 : }
1447 :
1448 : /* Trap declarations of attributes in encompassing scope. The
1449 : signature for this is that ts.kind is nonzero for no-CLASS
1450 : entity. For a CLASS entity, ts.kind is zero. */
1451 23267 : if ((sym->ts.kind != 0
1452 22894 : || sym->ts.type == BT_CLASS
1453 22893 : || sym->ts.type == BT_DERIVED)
1454 397 : && !sym->attr.implicit_type
1455 396 : && sym->attr.proc == 0
1456 378 : && gfc_current_ns->parent != NULL
1457 138 : && sym->attr.access == 0
1458 136 : && !module_fcn_entry)
1459 : {
1460 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1461 : "from a previous declaration", name);
1462 5 : return true;
1463 : }
1464 : }
1465 :
1466 : /* F2023: C1247 (R1526) MODULE shall appear only in the function-stmt or
1467 : subroutine-stmt of a module subprogram or of a nonabstract interface
1468 : body that is declared in the scoping unit of a module or submodule. */
1469 63545 : if (sym->attr.external
1470 92 : && (sym->attr.subroutine || sym->attr.function)
1471 91 : && sym->attr.if_source == IFSRC_IFBODY
1472 91 : && !current_attr.module_procedure
1473 3 : && sym->attr.proc == PROC_MODULE
1474 3 : && gfc_state_stack->state == COMP_CONTAINS)
1475 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1476 : "clashes with internal procedure defined at %C",
1477 : name, &sym->declared_at);
1478 :
1479 : /* This is the converse requirement: The separate-module-subprogram for a
1480 : module procedure shall have the MODULE prefix or be declared a MODULE
1481 : PROCEDURE, otherwise it would be ambiguous. */
1482 63545 : if (sym->attr.module_procedure
1483 471 : && (sym->attr.subroutine || sym->attr.function)
1484 471 : && sym->attr.if_source == IFSRC_IFBODY
1485 471 : && !current_attr.module_procedure
1486 4 : && sym->attr.proc == PROC_MODULE
1487 4 : && gfc_state_stack->state == COMP_CONTAINS
1488 2 : && gfc_state_stack->previous
1489 2 : && gfc_state_stack->previous->state == COMP_SUBMODULE)
1490 1 : gfc_error_now ("Procedure %qs at %C requires the MODULE prefix because "
1491 : "it is a module procedure declared in module %qs",
1492 1 : name, sym->module ? sym->module : "");
1493 :
1494 63545 : if (sym && !sym->gfc_new
1495 24837 : && sym->attr.flavor != FL_UNKNOWN
1496 22360 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1497 243 : && gfc_state_stack->state == COMP_CONTAINS
1498 238 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1499 : {
1500 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1501 : name, &sym->declared_at);
1502 1 : return true;
1503 : }
1504 :
1505 63544 : if (gfc_current_ns->parent == NULL || *result == NULL)
1506 : return rc;
1507 :
1508 : /* Module function entries will already have a symtree in
1509 : the current namespace but will need one at module level. */
1510 51461 : if (module_fcn_entry)
1511 : {
1512 : /* Present if entry is declared to be a module procedure. */
1513 258 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1514 258 : if (st == NULL)
1515 217 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1516 : }
1517 : else
1518 51203 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1519 :
1520 51461 : st->n.sym = sym;
1521 51461 : sym->refs++;
1522 :
1523 : /* See if the procedure should be a module procedure. */
1524 :
1525 51461 : if (((sym->ns->proc_name != NULL
1526 51461 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1527 21023 : && sym->attr.proc != PROC_MODULE)
1528 51461 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1529 69675 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1530 : rc = 2;
1531 :
1532 : return rc;
1533 : }
1534 :
1535 :
1536 : /* Verify that the given symbol representing a parameter is C
1537 : interoperable, by checking to see if it was marked as such after
1538 : its declaration. If the given symbol is not interoperable, a
1539 : warning is reported, thus removing the need to return the status to
1540 : the calling function. The standard does not require the user use
1541 : one of the iso_c_binding named constants to declare an
1542 : interoperable parameter, but we can't be sure if the param is C
1543 : interop or not if the user doesn't. For example, integer(4) may be
1544 : legal Fortran, but doesn't have meaning in C. It may interop with
1545 : a number of the C types, which causes a problem because the
1546 : compiler can't know which one. This code is almost certainly not
1547 : portable, and the user will get what they deserve if the C type
1548 : across platforms isn't always interoperable with integer(4). If
1549 : the user had used something like integer(c_int) or integer(c_long),
1550 : the compiler could have automatically handled the varying sizes
1551 : across platforms. */
1552 :
1553 : bool
1554 16695 : gfc_verify_c_interop_param (gfc_symbol *sym)
1555 : {
1556 16695 : int is_c_interop = 0;
1557 16695 : bool retval = true;
1558 :
1559 : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1560 : Don't repeat the checks here. */
1561 16695 : if (sym->attr.implicit_type)
1562 : return true;
1563 :
1564 : /* For subroutines or functions that are passed to a BIND(C) procedure,
1565 : they're interoperable if they're BIND(C) and their params are all
1566 : interoperable. */
1567 16695 : if (sym->attr.flavor == FL_PROCEDURE)
1568 : {
1569 4 : if (sym->attr.is_bind_c == 0)
1570 : {
1571 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1572 : "attribute to be C interoperable", sym->name,
1573 : &(sym->declared_at));
1574 0 : return false;
1575 : }
1576 : else
1577 : {
1578 4 : if (sym->attr.is_c_interop == 1)
1579 : /* We've already checked this procedure; don't check it again. */
1580 : return true;
1581 : else
1582 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1583 4 : sym->common_block);
1584 : }
1585 : }
1586 :
1587 : /* See if we've stored a reference to a procedure that owns sym. */
1588 16691 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1589 : {
1590 16691 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1591 : {
1592 16652 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1593 16652 : bool f2018_added = false;
1594 :
1595 16652 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1596 :
1597 : /* F2018:18.3.6 has the following text:
1598 : "(5) any dummy argument without the VALUE attribute corresponds to
1599 : a formal parameter of the prototype that is of a pointer type, and
1600 : either
1601 : • the dummy argument is interoperable with an entity of the
1602 : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1603 : the formal parameter (this is equivalent to the F2008 text),
1604 : • the dummy argument is a nonallocatable nonpointer variable of
1605 : type CHARACTER with assumed character length and the formal
1606 : parameter is a pointer to CFI_cdesc_t,
1607 : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1608 : or a pointer without the CONTIGUOUS attribute, and the formal
1609 : parameter is a pointer to CFI_cdesc_t, or
1610 : • the dummy argument is assumed-type and not allocatable,
1611 : assumed-shape, assumed-rank, or a pointer, and the formal
1612 : parameter is a pointer to void," */
1613 3727 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1614 : {
1615 2360 : bool as_ar = (sym->as
1616 2360 : && (sym->as->type == AS_ASSUMED_SHAPE
1617 2114 : || sym->as->type == AS_ASSUMED_RANK));
1618 4720 : bool cond1 = (sym->ts.type == BT_CHARACTER
1619 1564 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1620 904 : && !sym->attr.allocatable
1621 3246 : && !sym->attr.pointer);
1622 4720 : bool cond2 = (sym->attr.allocatable
1623 2263 : || as_ar
1624 3381 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1625 4720 : bool cond3 = (sym->ts.type == BT_ASSUMED
1626 0 : && !sym->attr.allocatable
1627 0 : && !sym->attr.pointer
1628 2360 : && !as_ar);
1629 2360 : f2018_added = cond1 || cond2 || cond3;
1630 : }
1631 :
1632 16652 : if (is_c_interop != 1 && !f2018_added)
1633 : {
1634 : /* Make personalized messages to give better feedback. */
1635 1834 : if (sym->ts.type == BT_DERIVED)
1636 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1637 : "BIND(C) procedure %qs but is not C interoperable "
1638 : "because derived type %qs is not C interoperable",
1639 : sym->name, &(sym->declared_at),
1640 1 : sym->ns->proc_name->name,
1641 1 : sym->ts.u.derived->name);
1642 1833 : else if (sym->ts.type == BT_CLASS)
1643 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1644 : "BIND(C) procedure %qs but is not C interoperable "
1645 : "because it is polymorphic",
1646 : sym->name, &(sym->declared_at),
1647 6 : sym->ns->proc_name->name);
1648 1827 : else if (warn_c_binding_type)
1649 39 : gfc_warning (OPT_Wc_binding_type,
1650 : "Variable %qs at %L is a dummy argument of the "
1651 : "BIND(C) procedure %qs but may not be C "
1652 : "interoperable",
1653 : sym->name, &(sym->declared_at),
1654 39 : sym->ns->proc_name->name);
1655 : }
1656 :
1657 : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1658 16652 : if (sym->attr.pointer && sym->attr.contiguous)
1659 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1660 : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1661 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1662 :
1663 : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1664 : procedure that are default-initialized are not permitted. */
1665 16014 : if ((sym->attr.pointer || sym->attr.allocatable)
1666 1037 : && sym->ts.type == BT_DERIVED
1667 17030 : && gfc_has_default_initializer (sym->ts.u.derived))
1668 : {
1669 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1670 : "attribute at %L is not permitted in BIND(C) "
1671 : "procedure %qs", sym->name,
1672 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1673 4 : &sym->declared_at, sym->ns->proc_name->name);
1674 4 : retval = false;
1675 : }
1676 :
1677 : /* Character strings are only C interoperable if they have a
1678 : length of 1. However, as an argument they are also interoperable
1679 : when passed as descriptor (which requires len=: or len=*). */
1680 16652 : if (sym->ts.type == BT_CHARACTER)
1681 : {
1682 2338 : gfc_charlen *cl = sym->ts.u.cl;
1683 :
1684 2338 : if (sym->attr.allocatable || sym->attr.pointer)
1685 : {
1686 : /* F2018, 18.3.6 (6). */
1687 193 : if (!sym->ts.deferred)
1688 : {
1689 64 : if (sym->attr.allocatable)
1690 32 : gfc_error ("Allocatable character dummy argument %qs "
1691 : "at %L must have deferred length as "
1692 : "procedure %qs is BIND(C)", sym->name,
1693 32 : &sym->declared_at, sym->ns->proc_name->name);
1694 : else
1695 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1696 : "must have deferred length as procedure %qs "
1697 : "is BIND(C)", sym->name, &sym->declared_at,
1698 32 : sym->ns->proc_name->name);
1699 : retval = false;
1700 : }
1701 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1702 : "Deferred-length character dummy "
1703 : "argument %qs at %L of procedure "
1704 : "%qs with BIND(C) attribute",
1705 : sym->name, &sym->declared_at,
1706 129 : sym->ns->proc_name->name))
1707 102 : retval = false;
1708 : }
1709 2145 : else if (sym->attr.value
1710 354 : && (!cl || !cl->length
1711 354 : || cl->length->expr_type != EXPR_CONSTANT
1712 354 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1713 : {
1714 1 : gfc_error ("Character dummy argument %qs at %L must be "
1715 : "of length 1 as it has the VALUE attribute",
1716 : sym->name, &sym->declared_at);
1717 1 : retval = false;
1718 : }
1719 2144 : else if (!cl || !cl->length)
1720 : {
1721 : /* Assumed length; F2018, 18.3.6 (5)(2).
1722 : Uses the CFI array descriptor - also for scalars and
1723 : explicit-size/assumed-size arrays. */
1724 957 : if (!gfc_notify_std (GFC_STD_F2018,
1725 : "Assumed-length character dummy argument "
1726 : "%qs at %L of procedure %qs with BIND(C) "
1727 : "attribute", sym->name, &sym->declared_at,
1728 957 : sym->ns->proc_name->name))
1729 102 : retval = false;
1730 : }
1731 1187 : else if (cl->length->expr_type != EXPR_CONSTANT
1732 873 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1733 : {
1734 : /* F2018, 18.3.6, (5), item 4. */
1735 653 : if (!sym->attr.dimension
1736 645 : || sym->as->type == AS_ASSUMED_SIZE
1737 639 : || sym->as->type == AS_EXPLICIT)
1738 : {
1739 20 : gfc_error ("Character dummy argument %qs at %L must be "
1740 : "of constant length of one or assumed length, "
1741 : "unless it has assumed shape or assumed rank, "
1742 : "as procedure %qs has the BIND(C) attribute",
1743 : sym->name, &sym->declared_at,
1744 20 : sym->ns->proc_name->name);
1745 20 : retval = false;
1746 : }
1747 : /* else: valid only since F2018 - and an assumed-shape/rank
1748 : array; however, gfc_notify_std is already called when
1749 : those array types are used. Thus, silently accept F200x. */
1750 : }
1751 : }
1752 :
1753 : /* We have to make sure that any param to a bind(c) routine does
1754 : not have the allocatable, pointer, or optional attributes,
1755 : according to J3/04-007, section 5.1. */
1756 16652 : if (sym->attr.allocatable == 1
1757 17051 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1758 : "ALLOCATABLE attribute in procedure %qs "
1759 : "with BIND(C)", sym->name,
1760 : &(sym->declared_at),
1761 399 : sym->ns->proc_name->name))
1762 : retval = false;
1763 :
1764 16652 : if (sym->attr.pointer == 1
1765 17290 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1766 : "POINTER attribute in procedure %qs "
1767 : "with BIND(C)", sym->name,
1768 : &(sym->declared_at),
1769 638 : sym->ns->proc_name->name))
1770 : retval = false;
1771 :
1772 16652 : if (sym->attr.optional == 1 && sym->attr.value)
1773 : {
1774 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1775 : "and the VALUE attribute because procedure %qs "
1776 : "is BIND(C)", sym->name, &(sym->declared_at),
1777 9 : sym->ns->proc_name->name);
1778 9 : retval = false;
1779 : }
1780 16643 : else if (sym->attr.optional == 1
1781 17592 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1782 : "at %L with OPTIONAL attribute in "
1783 : "procedure %qs which is BIND(C)",
1784 : sym->name, &(sym->declared_at),
1785 949 : sym->ns->proc_name->name))
1786 : retval = false;
1787 :
1788 : /* Make sure that if it has the dimension attribute, that it is
1789 : either assumed size or explicit shape. Deferred shape is already
1790 : covered by the pointer/allocatable attribute. */
1791 5530 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1792 17983 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1793 : "at %L as dummy argument to the BIND(C) "
1794 : "procedure %qs at %L", sym->name,
1795 : &(sym->declared_at),
1796 : sym->ns->proc_name->name,
1797 1331 : &(sym->ns->proc_name->declared_at)))
1798 : retval = false;
1799 : }
1800 : }
1801 :
1802 : return retval;
1803 : }
1804 :
1805 :
1806 :
1807 : /* Function called by variable_decl() that adds a name to the symbol table. */
1808 :
1809 : static bool
1810 261162 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1811 : gfc_array_spec **as, locus *var_locus)
1812 : {
1813 261162 : symbol_attribute attr;
1814 261162 : gfc_symbol *sym;
1815 261162 : int upper;
1816 261162 : gfc_symtree *st, *host_st = NULL;
1817 :
1818 : /* Symbols in a submodule are host associated from the parent module or
1819 : submodules. Therefore, they can be overridden by declarations in the
1820 : submodule scope. Deal with this by attaching the existing symbol to
1821 : a new symtree and recycling the old symtree with a new symbol... */
1822 261162 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1823 261162 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1824 3 : && gfc_current_ns->parent)
1825 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1826 :
1827 261162 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1828 12 : && st->n.sym != NULL
1829 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1830 : {
1831 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1832 12 : s->n.sym = st->n.sym;
1833 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1834 :
1835 12 : st->n.sym = sym;
1836 12 : sym->refs++;
1837 12 : gfc_set_sym_referenced (sym);
1838 12 : }
1839 : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1840 : current scope are not violated by local redeclarations. Note that there is
1841 : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1842 : only set for these standards. */
1843 261150 : else if (host_st && host_st->n.sym
1844 2 : && host_st->n.sym != gfc_current_ns->proc_name
1845 2 : && !(st && st->n.sym
1846 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1847 : {
1848 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1849 : "statement and must not be re-declared", name, var_locus,
1850 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1851 2 : return false;
1852 : }
1853 : /* ...Otherwise generate a new symtree and new symbol. */
1854 261148 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1855 : return false;
1856 :
1857 : /* Check if the name has already been defined as a type. The
1858 : first letter of the symtree will be in upper case then. Of
1859 : course, this is only necessary if the upper case letter is
1860 : actually different. */
1861 :
1862 261160 : upper = TOUPPER(name[0]);
1863 261160 : if (upper != name[0])
1864 : {
1865 260522 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1866 260522 : gfc_symtree *st;
1867 :
1868 260522 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1869 260522 : strcpy (u_name, name);
1870 260522 : u_name[0] = upper;
1871 :
1872 260522 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1873 :
1874 : /* STRUCTURE types can alias symbol names */
1875 260522 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1876 : {
1877 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1878 : &st->n.sym->declared_at);
1879 1 : return false;
1880 : }
1881 : }
1882 :
1883 : /* Start updating the symbol table. Add basic type attribute if present. */
1884 261159 : if (current_ts.type != BT_UNKNOWN
1885 261159 : && (sym->attr.implicit_type == 0
1886 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1887 522136 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1888 : {
1889 : /* Duplicate-type rejection can leave a fresh CHARACTER length node on
1890 : the namespace list before it is attached to any surviving symbol.
1891 : Drop only that unattached node; shared constant charlen nodes are
1892 : already reachable from earlier declarations. PR82721. */
1893 27 : if (current_ts.type == BT_CHARACTER && cl && elem == 1)
1894 : {
1895 1 : discard_pending_charlen (cl);
1896 1 : gfc_clear_ts (¤t_ts);
1897 : }
1898 26 : else if (current_ts.type == BT_CHARACTER && cl && cl != current_ts.u.cl)
1899 0 : discard_pending_charlen (cl);
1900 27 : return false;
1901 : }
1902 :
1903 261132 : if (sym->ts.type == BT_CHARACTER)
1904 : {
1905 28973 : if (elem > 1)
1906 4145 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1907 : else
1908 24828 : sym->ts.u.cl = cl;
1909 28973 : sym->ts.deferred = cl_deferred;
1910 : }
1911 :
1912 : /* Add dimension attribute if present. */
1913 261132 : if (!gfc_set_array_spec (sym, *as, var_locus))
1914 : return false;
1915 261130 : *as = NULL;
1916 :
1917 : /* Add attribute to symbol. The copy is so that we can reset the
1918 : dimension attribute. */
1919 261130 : attr = current_attr;
1920 261130 : attr.dimension = 0;
1921 261130 : attr.codimension = 0;
1922 :
1923 261130 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1924 : return false;
1925 :
1926 : /* Finish any work that may need to be done for the binding label,
1927 : if it's a bind(c). The bind(c) attr is found before the symbol
1928 : is made, and before the symbol name (for data decls), so the
1929 : current_ts is holding the binding label, or nothing if the
1930 : name= attr wasn't given. Therefore, test here if we're dealing
1931 : with a bind(c) and make sure the binding label is set correctly. */
1932 261116 : if (sym->attr.is_bind_c == 1)
1933 : {
1934 1370 : if (!sym->binding_label)
1935 : {
1936 : /* Set the binding label and verify that if a NAME= was specified
1937 : then only one identifier was in the entity-decl-list. */
1938 136 : if (!set_binding_label (&sym->binding_label, sym->name,
1939 : num_idents_on_line))
1940 : return false;
1941 : }
1942 : }
1943 :
1944 : /* See if we know we're in a common block, and if it's a bind(c)
1945 : common then we need to make sure we're an interoperable type. */
1946 261114 : if (sym->attr.in_common == 1)
1947 : {
1948 : /* Test the common block object. */
1949 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1950 6 : && sym->ts.is_c_interop != 1)
1951 : {
1952 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1953 : "must be declared with a C interoperable "
1954 : "kind since common block %qs is BIND(C)",
1955 : sym->name, sym->common_block->name,
1956 0 : sym->common_block->name);
1957 0 : gfc_clear_error ();
1958 : }
1959 : }
1960 :
1961 261114 : sym->attr.implied_index = 0;
1962 :
1963 : /* Use the parameter expressions for a parameterized derived type. */
1964 261114 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1965 36902 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1966 1062 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1967 :
1968 261114 : if (sym->ts.type == BT_CLASS)
1969 11089 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1970 :
1971 : return true;
1972 : }
1973 :
1974 :
1975 : /* Set character constant to the given length. The constant will be padded or
1976 : truncated. If we're inside an array constructor without a typespec, we
1977 : additionally check that all elements have the same length; check_len -1
1978 : means no checking. */
1979 :
1980 : void
1981 14377 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1982 : gfc_charlen_t check_len)
1983 : {
1984 14377 : gfc_char_t *s;
1985 14377 : gfc_charlen_t slen;
1986 :
1987 14377 : if (expr->ts.type != BT_CHARACTER)
1988 : return;
1989 :
1990 14375 : if (expr->expr_type != EXPR_CONSTANT)
1991 : {
1992 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1993 1 : return;
1994 : }
1995 :
1996 14374 : slen = expr->value.character.length;
1997 14374 : if (len != slen)
1998 : {
1999 2141 : s = gfc_get_wide_string (len + 1);
2000 2141 : memcpy (s, expr->value.character.string,
2001 2141 : MIN (len, slen) * sizeof (gfc_char_t));
2002 2141 : if (len > slen)
2003 1850 : gfc_wide_memset (&s[slen], ' ', len - slen);
2004 :
2005 2141 : if (warn_character_truncation && slen > len)
2006 1 : gfc_warning_now (OPT_Wcharacter_truncation,
2007 : "CHARACTER expression at %L is being truncated "
2008 : "(%ld/%ld)", &expr->where,
2009 : (long) slen, (long) len);
2010 :
2011 : /* Apply the standard by 'hand' otherwise it gets cleared for
2012 : initializers. */
2013 2141 : if (check_len != -1 && slen != check_len)
2014 : {
2015 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
2016 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
2017 : "at %L must have the same length (%ld/%ld)",
2018 : &expr->where, (long) slen,
2019 : (long) check_len);
2020 : else
2021 3 : gfc_notify_std (GFC_STD_LEGACY,
2022 : "The CHARACTER elements of the array constructor "
2023 : "at %L must have the same length (%ld/%ld)",
2024 : &expr->where, (long) slen,
2025 : (long) check_len);
2026 : }
2027 :
2028 2141 : s[len] = '\0';
2029 2141 : free (expr->value.character.string);
2030 2141 : expr->value.character.string = s;
2031 2141 : expr->value.character.length = len;
2032 : /* If explicit representation was given, clear it
2033 : as it is no longer needed after padding. */
2034 2141 : if (expr->representation.length)
2035 : {
2036 45 : expr->representation.length = 0;
2037 45 : free (expr->representation.string);
2038 45 : expr->representation.string = NULL;
2039 : }
2040 : }
2041 : }
2042 :
2043 :
2044 : /* Function to create and update the enumerator history
2045 : using the information passed as arguments.
2046 : Pointer "max_enum" is also updated, to point to
2047 : enum history node containing largest initializer.
2048 :
2049 : SYM points to the symbol node of enumerator.
2050 : INIT points to its enumerator value. */
2051 :
2052 : static void
2053 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
2054 : {
2055 543 : enumerator_history *new_enum_history;
2056 543 : gcc_assert (sym != NULL && init != NULL);
2057 :
2058 543 : new_enum_history = XCNEW (enumerator_history);
2059 :
2060 543 : new_enum_history->sym = sym;
2061 543 : new_enum_history->initializer = init;
2062 543 : new_enum_history->next = NULL;
2063 :
2064 543 : if (enum_history == NULL)
2065 : {
2066 160 : enum_history = new_enum_history;
2067 160 : max_enum = enum_history;
2068 : }
2069 : else
2070 : {
2071 383 : new_enum_history->next = enum_history;
2072 383 : enum_history = new_enum_history;
2073 :
2074 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2075 383 : new_enum_history->initializer->value.integer) < 0)
2076 381 : max_enum = new_enum_history;
2077 : }
2078 543 : }
2079 :
2080 :
2081 : /* Function to free enum kind history. */
2082 :
2083 : void
2084 175 : gfc_free_enum_history (void)
2085 : {
2086 175 : enumerator_history *current = enum_history;
2087 175 : enumerator_history *next;
2088 :
2089 718 : while (current != NULL)
2090 : {
2091 543 : next = current->next;
2092 543 : free (current);
2093 543 : current = next;
2094 : }
2095 175 : max_enum = NULL;
2096 175 : enum_history = NULL;
2097 175 : }
2098 :
2099 :
2100 : /* Function to fix initializer character length if the length of the
2101 : symbol or component is constant. */
2102 :
2103 : static bool
2104 2735 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2105 : {
2106 2735 : if (!gfc_specification_expr (ts->u.cl->length))
2107 : return false;
2108 :
2109 2735 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2110 :
2111 : /* resolve_charlen will complain later on if the length
2112 : is too large. Just skip the initialization in that case. */
2113 2735 : if (mpz_cmp (ts->u.cl->length->value.integer,
2114 2735 : gfc_integer_kinds[k].huge) <= 0)
2115 : {
2116 2734 : HOST_WIDE_INT len
2117 2734 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2118 :
2119 2734 : if (init->expr_type == EXPR_CONSTANT)
2120 2000 : gfc_set_constant_character_len (len, init, -1);
2121 734 : else if (init->expr_type == EXPR_ARRAY)
2122 : {
2123 733 : gfc_constructor *cons;
2124 :
2125 : /* Build a new charlen to prevent simplification from
2126 : deleting the length before it is resolved. */
2127 733 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2128 733 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2129 733 : cons = gfc_constructor_first (init->value.constructor);
2130 4971 : for (; cons; cons = gfc_constructor_next (cons))
2131 3505 : gfc_set_constant_character_len (len, cons->expr, -1);
2132 : }
2133 : }
2134 :
2135 : return true;
2136 : }
2137 :
2138 :
2139 : /* Function called by variable_decl() that adds an initialization
2140 : expression to a symbol. */
2141 :
2142 : static bool
2143 269384 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus,
2144 : gfc_charlen *saved_cl_list)
2145 : {
2146 269384 : symbol_attribute attr;
2147 269384 : gfc_symbol *sym;
2148 269384 : gfc_expr *init;
2149 :
2150 269384 : init = *initp;
2151 269384 : if (find_special (name, &sym, false))
2152 : return false;
2153 :
2154 269384 : attr = sym->attr;
2155 :
2156 : /* If this symbol is confirming an implicit parameter type,
2157 : then an initialization expression is not allowed. */
2158 269384 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2159 : {
2160 1 : if (*initp != NULL)
2161 : {
2162 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2163 : sym->name);
2164 0 : return false;
2165 : }
2166 : else
2167 : return true;
2168 : }
2169 :
2170 269383 : if (init == NULL)
2171 : {
2172 : /* An initializer is required for PARAMETER declarations. */
2173 236235 : if (attr.flavor == FL_PARAMETER)
2174 : {
2175 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2176 1 : return false;
2177 : }
2178 : }
2179 : else
2180 : {
2181 : /* If a variable appears in a DATA block, it cannot have an
2182 : initializer. */
2183 33148 : if (sym->attr.data)
2184 : {
2185 0 : gfc_error ("Variable %qs at %C with an initializer already "
2186 : "appears in a DATA statement", sym->name);
2187 0 : return false;
2188 : }
2189 :
2190 : /* Check if the assignment can happen. This has to be put off
2191 : until later for derived type variables and procedure pointers. */
2192 31987 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2193 31964 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2194 31914 : && !sym->attr.proc_pointer
2195 64953 : && !gfc_check_assign_symbol (sym, NULL, init))
2196 : return false;
2197 :
2198 33117 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2199 3434 : && init->ts.type == BT_CHARACTER)
2200 : {
2201 : /* Update symbol character length according initializer. */
2202 3270 : if (!gfc_check_assign_symbol (sym, NULL, init))
2203 : return false;
2204 :
2205 3270 : if (sym->ts.u.cl->length == NULL)
2206 : {
2207 851 : gfc_charlen_t clen;
2208 : /* If there are multiple CHARACTER variables declared on the
2209 : same line, we don't want them to share the same length. */
2210 851 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2211 :
2212 851 : if (sym->attr.flavor == FL_PARAMETER)
2213 : {
2214 842 : if (init->expr_type == EXPR_CONSTANT)
2215 : {
2216 557 : clen = init->value.character.length;
2217 557 : sym->ts.u.cl->length
2218 557 : = gfc_get_int_expr (gfc_charlen_int_kind,
2219 : NULL, clen);
2220 : }
2221 285 : else if (init->expr_type == EXPR_ARRAY)
2222 : {
2223 285 : if (init->ts.u.cl && init->ts.u.cl->length)
2224 : {
2225 273 : const gfc_expr *length = init->ts.u.cl->length;
2226 273 : if (length->expr_type != EXPR_CONSTANT)
2227 : {
2228 3 : gfc_error ("Cannot initialize parameter array "
2229 : "at %L "
2230 : "with variable length elements",
2231 : &sym->declared_at);
2232 :
2233 : /* This rejection path can leave several
2234 : declaration-local charlens on cl_list,
2235 : including the replacement symbol charlen and
2236 : the array-constructor typespec charlen.
2237 : Clear the surviving owners first, then drop
2238 : only the nodes created by this declaration. */
2239 3 : sym->ts.u.cl = NULL;
2240 3 : init->ts.u.cl = NULL;
2241 3 : discard_pending_charlens (saved_cl_list);
2242 3 : return false;
2243 : }
2244 270 : clen = mpz_get_si (length->value.integer);
2245 270 : }
2246 12 : else if (init->value.constructor)
2247 : {
2248 12 : gfc_constructor *c;
2249 12 : c = gfc_constructor_first (init->value.constructor);
2250 12 : clen = c->expr->value.character.length;
2251 : }
2252 : else
2253 0 : gcc_unreachable ();
2254 282 : sym->ts.u.cl->length
2255 282 : = gfc_get_int_expr (gfc_charlen_int_kind,
2256 : NULL, clen);
2257 : }
2258 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2259 0 : sym->ts.u.cl->length =
2260 0 : gfc_copy_expr (init->ts.u.cl->length);
2261 : }
2262 : }
2263 : /* Update initializer character length according to symbol. */
2264 2419 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2265 2419 : && !fix_initializer_charlen (&sym->ts, init))
2266 : return false;
2267 : }
2268 :
2269 33114 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2270 3767 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2271 : {
2272 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2273 : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2274 3 : return false;
2275 : }
2276 :
2277 : /* If sym is implied-shape, set its upper bounds from init. */
2278 33111 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2279 3764 : && sym->as && sym->as->type == AS_IMPLIED_SHAPE)
2280 : {
2281 1038 : int dim;
2282 :
2283 1038 : if (init->rank == 0)
2284 : {
2285 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2286 : " with scalar", &sym->declared_at);
2287 1 : return false;
2288 : }
2289 :
2290 : /* The shape may be NULL for EXPR_ARRAY, set it. */
2291 1037 : if (init->shape == NULL)
2292 : {
2293 5 : if (init->expr_type != EXPR_ARRAY)
2294 : {
2295 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2296 2 : return false;
2297 : }
2298 :
2299 3 : init->shape = gfc_get_shape (1);
2300 3 : if (!gfc_array_size (init, &init->shape[0]))
2301 : {
2302 1 : gfc_error ("Cannot determine shape of initializer at %L",
2303 : &init->where);
2304 1 : free (init->shape);
2305 1 : init->shape = NULL;
2306 1 : return false;
2307 : }
2308 : }
2309 :
2310 2169 : for (dim = 0; dim < sym->as->rank; ++dim)
2311 : {
2312 1136 : int k;
2313 1136 : gfc_expr *e, *lower;
2314 :
2315 1136 : lower = sym->as->lower[dim];
2316 :
2317 : /* If the lower bound is an array element from another
2318 : parameterized array, then it is marked with EXPR_VARIABLE and
2319 : is an initialization expression. Try to reduce it. */
2320 1136 : if (lower->expr_type == EXPR_VARIABLE)
2321 7 : gfc_reduce_init_expr (lower);
2322 :
2323 1136 : if (lower->expr_type == EXPR_CONSTANT)
2324 : {
2325 : /* All dimensions must be without upper bound. */
2326 1135 : gcc_assert (!sym->as->upper[dim]);
2327 :
2328 1135 : k = lower->ts.kind;
2329 1135 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2330 1135 : mpz_add (e->value.integer, lower->value.integer,
2331 1135 : init->shape[dim]);
2332 1135 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2333 1135 : sym->as->upper[dim] = e;
2334 : }
2335 : else
2336 : {
2337 1 : gfc_error ("Non-constant lower bound in implied-shape"
2338 : " declaration at %L", &lower->where);
2339 1 : return false;
2340 : }
2341 : }
2342 :
2343 1033 : sym->as->type = AS_EXPLICIT;
2344 : }
2345 :
2346 : /* Ensure that explicit bounds are simplified. */
2347 33106 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2348 3759 : && sym->as && sym->as->type == AS_EXPLICIT)
2349 : {
2350 8350 : for (int dim = 0; dim < sym->as->rank; ++dim)
2351 : {
2352 4603 : gfc_expr *e;
2353 :
2354 4603 : e = sym->as->lower[dim];
2355 4603 : if (e->expr_type != EXPR_CONSTANT)
2356 12 : gfc_reduce_init_expr (e);
2357 :
2358 4603 : e = sym->as->upper[dim];
2359 4603 : if (e->expr_type != EXPR_CONSTANT)
2360 106 : gfc_reduce_init_expr (e);
2361 : }
2362 : }
2363 :
2364 : /* Need to check if the expression we initialized this
2365 : to was one of the iso_c_binding named constants. If so,
2366 : and we're a parameter (constant), let it be iso_c.
2367 : For example:
2368 : integer(c_int), parameter :: my_int = c_int
2369 : integer(my_int) :: my_int_2
2370 : If we mark my_int as iso_c (since we can see it's value
2371 : is equal to one of the named constants), then my_int_2
2372 : will be considered C interoperable. */
2373 33106 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2374 : {
2375 28517 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2376 28517 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2377 : /* attr bits needed for module files. */
2378 28517 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2379 28517 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2380 28517 : if (init->ts.is_iso_c)
2381 117 : sym->ts.f90_type = init->ts.f90_type;
2382 : }
2383 :
2384 : /* Catch the case: type(t), parameter :: x = z'1'. */
2385 33106 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2386 : {
2387 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2388 : "literal constant", name, &sym->declared_at);
2389 1 : return false;
2390 : }
2391 :
2392 : /* Add initializer. Make sure we keep the ranks sane. */
2393 33105 : if (sym->attr.dimension && init->rank == 0)
2394 : {
2395 1242 : mpz_t size;
2396 1242 : gfc_expr *array;
2397 1242 : int n;
2398 1242 : if (sym->attr.flavor == FL_PARAMETER
2399 439 : && gfc_is_constant_expr (init)
2400 439 : && (init->expr_type == EXPR_CONSTANT
2401 32 : || init->expr_type == EXPR_STRUCTURE)
2402 1681 : && spec_size (sym->as, &size))
2403 : {
2404 435 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2405 : &init->where);
2406 435 : if (init->ts.type == BT_DERIVED)
2407 32 : array->ts.u.derived = init->ts.u.derived;
2408 67551 : for (n = 0; n < (int)mpz_get_si (size); n++)
2409 133938 : gfc_constructor_append_expr (&array->value.constructor,
2410 : n == 0
2411 : ? init
2412 66822 : : gfc_copy_expr (init),
2413 : &init->where);
2414 :
2415 435 : array->shape = gfc_get_shape (sym->as->rank);
2416 996 : for (n = 0; n < sym->as->rank; n++)
2417 561 : spec_dimen_size (sym->as, n, &array->shape[n]);
2418 :
2419 435 : init = array;
2420 435 : mpz_clear (size);
2421 : }
2422 1242 : init->rank = sym->as->rank;
2423 1242 : init->corank = sym->as->corank;
2424 : }
2425 :
2426 33105 : sym->value = init;
2427 33105 : if (sym->attr.save == SAVE_NONE)
2428 28567 : sym->attr.save = SAVE_IMPLICIT;
2429 33105 : *initp = NULL;
2430 : }
2431 :
2432 : return true;
2433 : }
2434 :
2435 :
2436 : /* Function called by variable_decl() that adds a name to a structure
2437 : being built. */
2438 :
2439 : static bool
2440 18115 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2441 : gfc_array_spec **as)
2442 : {
2443 18115 : gfc_state_data *s;
2444 18115 : gfc_component *c;
2445 :
2446 : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2447 : constructing, it must have the pointer attribute. */
2448 18115 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2449 3419 : && current_ts.u.derived == gfc_current_block ()
2450 267 : && current_attr.pointer == 0)
2451 : {
2452 106 : if (current_attr.allocatable
2453 106 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2454 : "must have the POINTER attribute"))
2455 : {
2456 : return false;
2457 : }
2458 105 : else if (current_attr.allocatable == 0)
2459 : {
2460 0 : gfc_error ("Component at %C must have the POINTER attribute");
2461 0 : return false;
2462 : }
2463 : }
2464 :
2465 : /* F03:C437. */
2466 18114 : if (current_ts.type == BT_CLASS
2467 833 : && !(current_attr.pointer || current_attr.allocatable))
2468 : {
2469 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2470 : "or pointer", name);
2471 5 : return false;
2472 : }
2473 :
2474 18109 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2475 : {
2476 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2477 : {
2478 0 : gfc_error ("Array component of structure at %C must have explicit "
2479 : "or deferred shape");
2480 0 : return false;
2481 : }
2482 : }
2483 :
2484 : /* If we are in a nested union/map definition, gfc_add_component will not
2485 : properly find repeated components because:
2486 : (i) gfc_add_component does a flat search, where components of unions
2487 : and maps are implicity chained so nested components may conflict.
2488 : (ii) Unions and maps are not linked as components of their parent
2489 : structures until after they are parsed.
2490 : For (i) we use gfc_find_component which searches recursively, and for (ii)
2491 : we search each block directly from the parse stack until we find the top
2492 : level structure. */
2493 :
2494 18109 : s = gfc_state_stack;
2495 18109 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2496 : {
2497 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2498 : {
2499 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2500 1434 : if (c != NULL)
2501 : {
2502 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2503 : name, &c->loc);
2504 0 : return false;
2505 : }
2506 : /* Break after we've searched the entire chain. */
2507 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2508 : break;
2509 1000 : s = s->previous;
2510 : }
2511 : }
2512 :
2513 18109 : if (!gfc_add_component (gfc_current_block(), name, &c))
2514 : return false;
2515 :
2516 18103 : c->ts = current_ts;
2517 18103 : if (c->ts.type == BT_CHARACTER)
2518 1940 : c->ts.u.cl = cl;
2519 :
2520 18103 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2521 14690 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2522 2126 : && saved_kind_expr != NULL)
2523 200 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2524 :
2525 18103 : c->attr = current_attr;
2526 :
2527 18103 : c->initializer = *init;
2528 18103 : *init = NULL;
2529 :
2530 : /* Update initializer character length according to component. */
2531 1940 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2532 1539 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2533 1474 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2534 18422 : && !fix_initializer_charlen (&c->ts, c->initializer))
2535 : return false;
2536 :
2537 18103 : c->as = *as;
2538 18103 : if (c->as != NULL)
2539 : {
2540 4848 : if (c->as->corank)
2541 107 : c->attr.codimension = 1;
2542 4848 : if (c->as->rank)
2543 4773 : c->attr.dimension = 1;
2544 : }
2545 18103 : *as = NULL;
2546 :
2547 18103 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2548 :
2549 : /* Check array components. */
2550 18103 : if (!c->attr.dimension)
2551 13330 : goto scalar;
2552 :
2553 4773 : if (c->attr.pointer)
2554 : {
2555 731 : if (c->as->type != AS_DEFERRED)
2556 : {
2557 5 : gfc_error ("Pointer array component of structure at %C must have a "
2558 : "deferred shape");
2559 5 : return false;
2560 : }
2561 : }
2562 4042 : else if (c->attr.allocatable)
2563 : {
2564 2403 : const char *err = G_("Allocatable component of structure at %C must have "
2565 : "a deferred shape");
2566 2403 : if (c->as->type != AS_DEFERRED)
2567 : {
2568 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2569 : {
2570 : /* Issue an immediate error and allow this component to pass for
2571 : the sake of clean error recovery. Set the error flag for the
2572 : containing derived type so that finalizers are not built. */
2573 4 : gfc_error_now (err);
2574 4 : s->sym->error = 1;
2575 4 : c->as->type = AS_DEFERRED;
2576 : }
2577 : else
2578 : {
2579 10 : gfc_error (err);
2580 10 : return false;
2581 : }
2582 : }
2583 : }
2584 : else
2585 : {
2586 1639 : if (c->as->type != AS_EXPLICIT)
2587 : {
2588 7 : gfc_error ("Array component of structure at %C must have an "
2589 : "explicit shape");
2590 7 : return false;
2591 : }
2592 : }
2593 :
2594 1632 : scalar:
2595 18081 : if (c->ts.type == BT_CLASS)
2596 825 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2597 :
2598 17256 : if (c->attr.pdt_kind || c->attr.pdt_len)
2599 : {
2600 592 : gfc_symbol *sym;
2601 592 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2602 : 0, &sym);
2603 592 : if (sym == NULL)
2604 : {
2605 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2606 : "in the type parameter name list at %L",
2607 0 : c->name, &gfc_current_block ()->declared_at);
2608 0 : return false;
2609 : }
2610 592 : sym->ts = c->ts;
2611 592 : sym->attr.pdt_kind = c->attr.pdt_kind;
2612 592 : sym->attr.pdt_len = c->attr.pdt_len;
2613 592 : if (c->initializer)
2614 240 : sym->value = gfc_copy_expr (c->initializer);
2615 592 : sym->attr.flavor = FL_VARIABLE;
2616 : }
2617 :
2618 17256 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2619 2585 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2620 130 : && decl_type_param_list)
2621 130 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2622 :
2623 : return true;
2624 : }
2625 :
2626 :
2627 : /* Match a 'NULL()', and possibly take care of some side effects. */
2628 :
2629 : match
2630 1712 : gfc_match_null (gfc_expr **result)
2631 : {
2632 1712 : gfc_symbol *sym;
2633 1712 : match m, m2 = MATCH_NO;
2634 :
2635 1712 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2636 : return MATCH_ERROR;
2637 :
2638 1712 : if (m == MATCH_NO)
2639 : {
2640 511 : locus old_loc;
2641 511 : char name[GFC_MAX_SYMBOL_LEN + 1];
2642 :
2643 511 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2644 505 : return m2;
2645 :
2646 6 : old_loc = gfc_current_locus;
2647 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2648 : return MATCH_ERROR;
2649 6 : if (m2 != MATCH_YES
2650 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2651 : return MATCH_ERROR;
2652 6 : if (m2 == MATCH_NO)
2653 : {
2654 0 : gfc_current_locus = old_loc;
2655 0 : return MATCH_NO;
2656 : }
2657 : }
2658 :
2659 : /* The NULL symbol now has to be/become an intrinsic function. */
2660 1207 : if (gfc_get_symbol ("null", NULL, &sym))
2661 : {
2662 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2663 0 : return MATCH_ERROR;
2664 : }
2665 :
2666 1207 : gfc_intrinsic_symbol (sym);
2667 :
2668 1207 : if (sym->attr.proc != PROC_INTRINSIC
2669 849 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2670 2055 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2671 848 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2672 0 : return MATCH_ERROR;
2673 :
2674 1207 : *result = gfc_get_null_expr (&gfc_current_locus);
2675 :
2676 : /* Invalid per F2008, C512. */
2677 1207 : if (m2 == MATCH_YES)
2678 : {
2679 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2680 6 : return MATCH_ERROR;
2681 : }
2682 :
2683 : return MATCH_YES;
2684 : }
2685 :
2686 :
2687 : /* Match the initialization expr for a data pointer or procedure pointer. */
2688 :
2689 : static match
2690 1376 : match_pointer_init (gfc_expr **init, int procptr)
2691 : {
2692 1376 : match m;
2693 :
2694 1376 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2695 : {
2696 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2697 : "a PURE procedure");
2698 1 : return MATCH_ERROR;
2699 : }
2700 1375 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2701 :
2702 : /* Match NULL() initialization. */
2703 1375 : m = gfc_match_null (init);
2704 1375 : if (m != MATCH_NO)
2705 : return m;
2706 :
2707 : /* Match non-NULL initialization. */
2708 176 : gfc_matching_ptr_assignment = !procptr;
2709 176 : gfc_matching_procptr_assignment = procptr;
2710 176 : m = gfc_match_rvalue (init);
2711 176 : gfc_matching_ptr_assignment = 0;
2712 176 : gfc_matching_procptr_assignment = 0;
2713 176 : if (m == MATCH_ERROR)
2714 : return MATCH_ERROR;
2715 175 : else if (m == MATCH_NO)
2716 : {
2717 2 : gfc_error ("Error in pointer initialization at %C");
2718 2 : return MATCH_ERROR;
2719 : }
2720 :
2721 173 : if (!procptr && !gfc_resolve_expr (*init))
2722 : return MATCH_ERROR;
2723 :
2724 172 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2725 : "initialization at %C"))
2726 : return MATCH_ERROR;
2727 :
2728 : return MATCH_YES;
2729 : }
2730 :
2731 :
2732 : static bool
2733 289105 : check_function_name (char *name)
2734 : {
2735 : /* In functions that have a RESULT variable defined, the function name always
2736 : refers to function calls. Therefore, the name is not allowed to appear in
2737 : specification statements. When checking this, be careful about
2738 : 'hidden' procedure pointer results ('ppr@'). */
2739 :
2740 289105 : if (gfc_current_state () == COMP_FUNCTION)
2741 : {
2742 46280 : gfc_symbol *block = gfc_current_block ();
2743 46280 : if (block && block->result && block->result != block
2744 15365 : && strcmp (block->result->name, "ppr@") != 0
2745 15306 : && strcmp (block->name, name) == 0)
2746 : {
2747 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2748 : "from appearing in a specification statement",
2749 : block->result->name, &block->result->declared_at, name);
2750 9 : return false;
2751 : }
2752 : }
2753 :
2754 : return true;
2755 : }
2756 :
2757 :
2758 : /* Match a variable name with an optional initializer. When this
2759 : subroutine is called, a variable is expected to be parsed next.
2760 : Depending on what is happening at the moment, updates either the
2761 : symbol table or the current interface. */
2762 :
2763 : static match
2764 278964 : variable_decl (int elem)
2765 : {
2766 278964 : char name[GFC_MAX_SYMBOL_LEN + 1];
2767 278964 : static unsigned int fill_id = 0;
2768 278964 : gfc_expr *initializer, *char_len;
2769 278964 : gfc_array_spec *as;
2770 278964 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2771 278964 : gfc_charlen *cl;
2772 278964 : gfc_charlen *saved_cl_list;
2773 278964 : bool cl_deferred;
2774 278964 : locus var_locus;
2775 278964 : match m;
2776 278964 : bool t;
2777 278964 : gfc_symbol *sym;
2778 278964 : char c;
2779 :
2780 278964 : initializer = NULL;
2781 278964 : as = NULL;
2782 278964 : cp_as = NULL;
2783 278964 : saved_cl_list = gfc_current_ns->cl_list;
2784 :
2785 : /* When we get here, we've just matched a list of attributes and
2786 : maybe a type and a double colon. The next thing we expect to see
2787 : is the name of the symbol. */
2788 :
2789 : /* If we are parsing a structure with legacy support, we allow the symbol
2790 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2791 278964 : m = MATCH_NO;
2792 278964 : gfc_gobble_whitespace ();
2793 278964 : var_locus = gfc_current_locus;
2794 278964 : c = gfc_peek_ascii_char ();
2795 278964 : if (c == '%')
2796 : {
2797 12 : gfc_next_ascii_char (); /* Burn % character. */
2798 12 : m = gfc_match ("fill");
2799 12 : if (m == MATCH_YES)
2800 : {
2801 11 : if (gfc_current_state () != COMP_STRUCTURE)
2802 : {
2803 2 : if (flag_dec_structure)
2804 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2805 : else
2806 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2807 : "%<-fdec-structure%>", "%FILL");
2808 2 : m = MATCH_ERROR;
2809 2 : goto cleanup;
2810 : }
2811 :
2812 9 : if (attr_seen)
2813 : {
2814 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2815 1 : m = MATCH_ERROR;
2816 1 : goto cleanup;
2817 : }
2818 :
2819 : /* %FILL components are given invalid fortran names. */
2820 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2821 : }
2822 : else
2823 : {
2824 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2825 1 : return MATCH_ERROR;
2826 : }
2827 : }
2828 : else
2829 : {
2830 278952 : m = gfc_match_name (name);
2831 278951 : if (m != MATCH_YES)
2832 10 : goto cleanup;
2833 : }
2834 :
2835 : /* Now we could see the optional array spec. or character length. */
2836 278949 : m = gfc_match_array_spec (&as, true, true);
2837 278948 : if (m == MATCH_ERROR)
2838 57 : goto cleanup;
2839 :
2840 278891 : if (m == MATCH_NO)
2841 217771 : as = gfc_copy_array_spec (current_as);
2842 61120 : else if (current_as
2843 61120 : && !merge_array_spec (current_as, as, true))
2844 : {
2845 4 : m = MATCH_ERROR;
2846 4 : goto cleanup;
2847 : }
2848 :
2849 278887 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2850 : &gfc_current_locus);
2851 278887 : if (flag_cray_pointer)
2852 3063 : cp_as = gfc_copy_array_spec (as);
2853 :
2854 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2855 : determine (and check) whether it can be implied-shape. If it
2856 : was parsed as assumed-size, change it because PARAMETERs cannot
2857 : be assumed-size.
2858 :
2859 : An explicit-shape-array cannot appear under several conditions.
2860 : That check is done here as well. */
2861 278887 : if (as)
2862 : {
2863 83699 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2864 : {
2865 2 : m = MATCH_ERROR;
2866 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2867 : name, &var_locus);
2868 2 : goto cleanup;
2869 : }
2870 :
2871 83697 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2872 6490 : && current_attr.flavor == FL_PARAMETER)
2873 990 : as->type = AS_IMPLIED_SHAPE;
2874 :
2875 83697 : if (as->type == AS_IMPLIED_SHAPE
2876 83697 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2877 : &var_locus))
2878 : {
2879 1 : m = MATCH_ERROR;
2880 1 : goto cleanup;
2881 : }
2882 :
2883 83696 : gfc_seen_div0 = false;
2884 :
2885 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2886 : constant expressions shall appear only in a subprogram, derived
2887 : type definition, BLOCK construct, or interface body. */
2888 83696 : if (as->type == AS_EXPLICIT
2889 41866 : && gfc_current_state () != COMP_BLOCK
2890 : && gfc_current_state () != COMP_DERIVED
2891 : && gfc_current_state () != COMP_FUNCTION
2892 : && gfc_current_state () != COMP_INTERFACE
2893 : && gfc_current_state () != COMP_SUBROUTINE)
2894 : {
2895 : gfc_expr *e;
2896 49729 : bool not_constant = false;
2897 :
2898 49729 : for (int i = 0; i < as->rank; i++)
2899 : {
2900 28320 : e = gfc_copy_expr (as->lower[i]);
2901 28320 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2902 : {
2903 0 : m = MATCH_ERROR;
2904 0 : goto cleanup;
2905 : }
2906 :
2907 28320 : gfc_simplify_expr (e, 0);
2908 28320 : if (e && (e->expr_type != EXPR_CONSTANT))
2909 : {
2910 : not_constant = true;
2911 : break;
2912 : }
2913 28320 : gfc_free_expr (e);
2914 :
2915 28320 : e = gfc_copy_expr (as->upper[i]);
2916 28320 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2917 : {
2918 4 : m = MATCH_ERROR;
2919 4 : goto cleanup;
2920 : }
2921 :
2922 28316 : gfc_simplify_expr (e, 0);
2923 28316 : if (e && (e->expr_type != EXPR_CONSTANT))
2924 : {
2925 : not_constant = true;
2926 : break;
2927 : }
2928 28303 : gfc_free_expr (e);
2929 : }
2930 :
2931 21422 : if (not_constant && e->ts.type != BT_INTEGER)
2932 : {
2933 4 : gfc_error ("Explicit array shape at %C must be constant of "
2934 : "INTEGER type and not %s type",
2935 : gfc_basic_typename (e->ts.type));
2936 4 : m = MATCH_ERROR;
2937 4 : goto cleanup;
2938 : }
2939 9 : if (not_constant)
2940 : {
2941 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2942 9 : m = MATCH_ERROR;
2943 9 : goto cleanup;
2944 : }
2945 : }
2946 83679 : if (as->type == AS_EXPLICIT)
2947 : {
2948 100157 : for (int i = 0; i < as->rank; i++)
2949 : {
2950 58308 : gfc_expr *e, *n;
2951 58308 : e = as->lower[i];
2952 58308 : if (e->expr_type != EXPR_CONSTANT)
2953 : {
2954 452 : n = gfc_copy_expr (e);
2955 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2956 : {
2957 0 : m = MATCH_ERROR;
2958 0 : goto cleanup;
2959 : }
2960 :
2961 452 : if (n->expr_type == EXPR_CONSTANT)
2962 22 : gfc_replace_expr (e, n);
2963 : else
2964 430 : gfc_free_expr (n);
2965 : }
2966 58308 : e = as->upper[i];
2967 58308 : if (e->expr_type != EXPR_CONSTANT)
2968 : {
2969 6742 : n = gfc_copy_expr (e);
2970 6742 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2971 : {
2972 0 : m = MATCH_ERROR;
2973 0 : goto cleanup;
2974 : }
2975 :
2976 6742 : if (n->expr_type == EXPR_CONSTANT)
2977 45 : gfc_replace_expr (e, n);
2978 : else
2979 6697 : gfc_free_expr (n);
2980 : }
2981 : /* For an explicit-shape spec with constant bounds, ensure
2982 : that the effective upper bound is not lower than the
2983 : respective lower bound minus one. Otherwise adjust it so
2984 : that the extent is trivially derived to be zero. */
2985 58308 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2986 57878 : && as->upper[i]->expr_type == EXPR_CONSTANT
2987 51605 : && as->lower[i]->ts.type == BT_INTEGER
2988 51605 : && as->upper[i]->ts.type == BT_INTEGER
2989 51600 : && mpz_cmp (as->upper[i]->value.integer,
2990 51600 : as->lower[i]->value.integer) < 0)
2991 1212 : mpz_sub_ui (as->upper[i]->value.integer,
2992 : as->lower[i]->value.integer, 1);
2993 : }
2994 : }
2995 : }
2996 :
2997 278867 : char_len = NULL;
2998 278867 : cl = NULL;
2999 278867 : cl_deferred = false;
3000 :
3001 278867 : if (current_ts.type == BT_CHARACTER)
3002 : {
3003 30954 : switch (match_char_length (&char_len, &cl_deferred, false))
3004 : {
3005 435 : case MATCH_YES:
3006 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3007 :
3008 435 : cl->length = char_len;
3009 435 : break;
3010 :
3011 : /* Non-constant lengths need to be copied after the first
3012 : element. Also copy assumed lengths. */
3013 30518 : case MATCH_NO:
3014 30518 : if (elem > 1
3015 3914 : && (current_ts.u.cl->length == NULL
3016 2701 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
3017 : {
3018 1268 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3019 1268 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
3020 : }
3021 : else
3022 29250 : cl = current_ts.u.cl;
3023 :
3024 30518 : cl_deferred = current_ts.deferred;
3025 :
3026 30518 : break;
3027 :
3028 1 : case MATCH_ERROR:
3029 1 : goto cleanup;
3030 : }
3031 : }
3032 :
3033 : /* The dummy arguments and result of the abbreviated form of MODULE
3034 : PROCEDUREs, used in SUBMODULES should not be redefined. */
3035 278866 : if (gfc_current_ns->proc_name
3036 274376 : && gfc_current_ns->proc_name->abr_modproc_decl)
3037 : {
3038 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
3039 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
3040 : {
3041 2 : m = MATCH_ERROR;
3042 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
3043 : "in the corresponding interface for MODULE "
3044 : "PROCEDURE %qs", sym->name, &var_locus,
3045 2 : gfc_current_ns->proc_name->name);
3046 2 : goto cleanup;
3047 : }
3048 : }
3049 :
3050 : /* %FILL components may not have initializers. */
3051 278864 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
3052 : {
3053 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
3054 : &var_locus);
3055 1 : m = MATCH_ERROR;
3056 1 : goto cleanup;
3057 : }
3058 :
3059 : /* If this symbol has already shown up in a Cray Pointer declaration,
3060 : and this is not a component declaration,
3061 : then we want to set the type & bail out. */
3062 278863 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
3063 : {
3064 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3065 2959 : if (sym != NULL && sym->attr.cray_pointee)
3066 : {
3067 101 : m = MATCH_YES;
3068 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
3069 : {
3070 1 : m = MATCH_ERROR;
3071 1 : goto cleanup;
3072 : }
3073 :
3074 : /* Check to see if we have an array specification. */
3075 100 : if (cp_as != NULL)
3076 : {
3077 49 : if (sym->as != NULL)
3078 : {
3079 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3080 1 : gfc_free_array_spec (cp_as);
3081 1 : m = MATCH_ERROR;
3082 1 : goto cleanup;
3083 : }
3084 : else
3085 : {
3086 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3087 0 : gfc_internal_error ("Cannot set pointee array spec.");
3088 :
3089 : /* Fix the array spec. */
3090 48 : m = gfc_mod_pointee_as (sym->as);
3091 48 : if (m == MATCH_ERROR)
3092 0 : goto cleanup;
3093 : }
3094 : }
3095 99 : goto cleanup;
3096 : }
3097 : else
3098 : {
3099 2858 : gfc_free_array_spec (cp_as);
3100 : }
3101 : }
3102 : else
3103 : {
3104 : /* Check to see if this is the declaration of the type and/or attributes
3105 : of an implicit function result, emanating from a module function
3106 : interface declared within the parent module or submodule of a
3107 : containing submodule. */
3108 275904 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3109 275904 : if (gfc_current_state () == COMP_FUNCTION
3110 44804 : && sym == gfc_current_block ()
3111 7608 : && sym->attr.if_source == IFSRC_DECL
3112 4822 : && sym->attr.used_in_submodule
3113 4 : && sym == sym->result
3114 4 : && sym->ts.type != BT_UNKNOWN)
3115 : {
3116 4 : m = MATCH_YES;
3117 4 : goto cleanup;
3118 : }
3119 275900 : sym = NULL;
3120 : }
3121 :
3122 : /* Procedure pointer as function result. */
3123 278758 : if (gfc_current_state () == COMP_FUNCTION
3124 44914 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3125 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3126 7 : strcpy (name, "ppr@");
3127 :
3128 278758 : if (gfc_current_state () == COMP_FUNCTION
3129 44914 : && strcmp (name, gfc_current_block ()->name) == 0
3130 7624 : && gfc_current_block ()->result
3131 7624 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3132 16 : strcpy (name, "ppr@");
3133 :
3134 : /* OK, we've successfully matched the declaration. Now put the
3135 : symbol in the current namespace, because it might be used in the
3136 : optional initialization expression for this symbol, e.g. this is
3137 : perfectly legal:
3138 :
3139 : integer, parameter :: i = huge(i)
3140 :
3141 : This is only true for parameters or variables of a basic type.
3142 : For components of derived types, it is not true, so we don't
3143 : create a symbol for those yet. If we fail to create the symbol,
3144 : bail out. */
3145 278758 : if (!gfc_comp_struct (gfc_current_state ())
3146 260614 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3147 : {
3148 48 : m = MATCH_ERROR;
3149 48 : goto cleanup;
3150 : }
3151 :
3152 278710 : if (!check_function_name (name))
3153 : {
3154 0 : m = MATCH_ERROR;
3155 0 : goto cleanup;
3156 : }
3157 :
3158 : /* We allow old-style initializations of the form
3159 : integer i /2/, j(4) /3*3, 1/
3160 : (if no colon has been seen). These are different from data
3161 : statements in that initializers are only allowed to apply to the
3162 : variable immediately preceding, i.e.
3163 : integer i, j /1, 2/
3164 : is not allowed. Therefore we have to do some work manually, that
3165 : could otherwise be left to the matchers for DATA statements. */
3166 :
3167 278710 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3168 : {
3169 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3170 : "initialization at %C"))
3171 : return MATCH_ERROR;
3172 :
3173 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3174 : but not components of derived types. */
3175 146 : else if (gfc_current_state () == COMP_DERIVED)
3176 : {
3177 2 : gfc_error ("Invalid old style initialization for derived type "
3178 : "component at %C");
3179 2 : m = MATCH_ERROR;
3180 2 : goto cleanup;
3181 : }
3182 :
3183 : /* For structure components, read the initializer as a special
3184 : expression and let the rest of this function apply the initializer
3185 : as usual. */
3186 144 : else if (gfc_comp_struct (gfc_current_state ()))
3187 : {
3188 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3189 74 : if (m == MATCH_NO)
3190 : gfc_error ("Syntax error in old style initialization of %s at %C",
3191 : name);
3192 74 : if (m != MATCH_YES)
3193 14 : goto cleanup;
3194 : }
3195 :
3196 : /* Otherwise we treat the old style initialization just like a
3197 : DATA declaration for the current variable. */
3198 : else
3199 70 : return match_old_style_init (name);
3200 : }
3201 :
3202 : /* The double colon must be present in order to have initializers.
3203 : Otherwise the statement is ambiguous with an assignment statement. */
3204 278624 : if (colon_seen)
3205 : {
3206 232591 : if (gfc_match (" =>") == MATCH_YES)
3207 : {
3208 1197 : if (!current_attr.pointer)
3209 : {
3210 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3211 0 : m = MATCH_ERROR;
3212 0 : goto cleanup;
3213 : }
3214 :
3215 1197 : m = match_pointer_init (&initializer, 0);
3216 1197 : if (m != MATCH_YES)
3217 10 : goto cleanup;
3218 :
3219 : /* The target of a pointer initialization must have the SAVE
3220 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3221 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3222 1187 : if (initializer->expr_type == EXPR_VARIABLE
3223 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3224 25 : && (gfc_current_state () == COMP_PROGRAM
3225 : || gfc_current_state () == COMP_MODULE
3226 25 : || gfc_current_state () == COMP_SUBMODULE))
3227 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3228 : }
3229 231394 : else if (gfc_match_char ('=') == MATCH_YES)
3230 : {
3231 26146 : if (current_attr.pointer)
3232 : {
3233 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3234 : "not %<=%>");
3235 0 : m = MATCH_ERROR;
3236 0 : goto cleanup;
3237 : }
3238 :
3239 26146 : if (gfc_comp_struct (gfc_current_state ())
3240 2478 : && gfc_current_block ()->attr.pdt_template)
3241 : {
3242 263 : m = gfc_match_expr (&initializer);
3243 263 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3244 115 : initializer->ts = current_ts;
3245 : }
3246 : else
3247 25883 : m = gfc_match_init_expr (&initializer);
3248 :
3249 26146 : if (m == MATCH_NO)
3250 : {
3251 1 : gfc_error ("Expected an initialization expression at %C");
3252 1 : m = MATCH_ERROR;
3253 : }
3254 :
3255 10142 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3256 26148 : && !gfc_comp_struct (gfc_state_stack->state))
3257 : {
3258 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3259 : "a PURE procedure");
3260 1 : m = MATCH_ERROR;
3261 : }
3262 :
3263 26146 : if (current_attr.flavor != FL_PARAMETER
3264 10142 : && !gfc_comp_struct (gfc_state_stack->state))
3265 7664 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3266 :
3267 26146 : if (m != MATCH_YES)
3268 160 : goto cleanup;
3269 : }
3270 : }
3271 :
3272 278454 : if (initializer != NULL && current_attr.allocatable
3273 3 : && gfc_comp_struct (gfc_current_state ()))
3274 : {
3275 2 : gfc_error ("Initialization of allocatable component at %C is not "
3276 : "allowed");
3277 2 : m = MATCH_ERROR;
3278 2 : goto cleanup;
3279 : }
3280 :
3281 278452 : if (gfc_current_state () == COMP_DERIVED
3282 17102 : && initializer && initializer->ts.type == BT_HOLLERITH)
3283 : {
3284 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3285 : "constant at %L is not allowed", &initializer->where);
3286 1 : m = MATCH_ERROR;
3287 1 : goto cleanup;
3288 : }
3289 :
3290 278451 : if (gfc_current_state () == COMP_DERIVED
3291 17101 : && gfc_current_block ()->attr.pdt_template)
3292 : {
3293 1122 : gfc_symbol *param;
3294 1122 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3295 : 0, ¶m);
3296 1122 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3297 : {
3298 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3299 : "not appear in the type parameter list at %L",
3300 1 : &gfc_current_block ()->declared_at);
3301 1 : m = MATCH_ERROR;
3302 4 : goto cleanup;
3303 : }
3304 1121 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3305 : {
3306 1 : gfc_error ("The component at %C that appears in the type parameter "
3307 : "list at %L has neither the KIND nor LEN attribute",
3308 1 : &gfc_current_block ()->declared_at);
3309 1 : m = MATCH_ERROR;
3310 1 : goto cleanup;
3311 : }
3312 1120 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3313 : {
3314 1 : gfc_error ("The component at %C which is a type parameter must be "
3315 : "a scalar");
3316 1 : m = MATCH_ERROR;
3317 1 : goto cleanup;
3318 : }
3319 1119 : else if (param && initializer)
3320 : {
3321 241 : if (initializer->ts.type == BT_BOZ)
3322 : {
3323 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3324 : "initializer", &initializer->where);
3325 1 : m = MATCH_ERROR;
3326 1 : goto cleanup;
3327 : }
3328 240 : param->value = gfc_copy_expr (initializer);
3329 : }
3330 : }
3331 :
3332 : /* Before adding a possible initializer, do a simple check for compatibility
3333 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3334 : good thing. */
3335 28375 : if (current_ts.type == BT_DERIVED && initializer
3336 279872 : && (gfc_numeric_ts (&initializer->ts)
3337 1423 : || initializer->ts.type == BT_LOGICAL
3338 1423 : || initializer->ts.type == BT_CHARACTER))
3339 : {
3340 2 : gfc_error ("Incompatible initialization between a derived type "
3341 : "entity and an entity with %qs type at %C",
3342 : gfc_typename (initializer));
3343 2 : m = MATCH_ERROR;
3344 2 : goto cleanup;
3345 : }
3346 :
3347 :
3348 : /* Add the initializer. Note that it is fine if initializer is
3349 : NULL here, because we sometimes also need to check if a
3350 : declaration *must* have an initialization expression. */
3351 278445 : if (!gfc_comp_struct (gfc_current_state ()))
3352 260330 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
3353 : saved_cl_list);
3354 : else
3355 : {
3356 18115 : if (current_ts.type == BT_DERIVED
3357 2585 : && !current_attr.pointer && !initializer)
3358 2032 : initializer = gfc_default_initializer (¤t_ts);
3359 18115 : t = build_struct (name, cl, &initializer, &as);
3360 :
3361 : /* If we match a nested structure definition we expect to see the
3362 : * body even if the variable declarations blow up, so we need to keep
3363 : * the structure declaration around. */
3364 18115 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3365 34 : gfc_commit_symbol (gfc_new_block);
3366 : }
3367 :
3368 278593 : m = (t) ? MATCH_YES : MATCH_ERROR;
3369 :
3370 278891 : cleanup:
3371 : /* Free stuff up and return. */
3372 278891 : gfc_seen_div0 = false;
3373 278891 : gfc_free_expr (initializer);
3374 278891 : gfc_free_array_spec (as);
3375 :
3376 278891 : return m;
3377 : }
3378 :
3379 :
3380 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3381 : This assumes that the byte size is equal to the kind number for
3382 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3383 :
3384 : static match
3385 107289 : gfc_match_old_kind_spec (gfc_typespec *ts)
3386 : {
3387 107289 : match m;
3388 107289 : int original_kind;
3389 :
3390 107289 : if (gfc_match_char ('*') != MATCH_YES)
3391 : return MATCH_NO;
3392 :
3393 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3394 1150 : if (m != MATCH_YES)
3395 : return MATCH_ERROR;
3396 :
3397 1150 : original_kind = ts->kind;
3398 :
3399 : /* Massage the kind numbers for complex types. */
3400 1150 : if (ts->type == BT_COMPLEX)
3401 : {
3402 79 : if (ts->kind % 2)
3403 : {
3404 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3405 : gfc_basic_typename (ts->type), original_kind);
3406 0 : return MATCH_ERROR;
3407 : }
3408 79 : ts->kind /= 2;
3409 :
3410 : }
3411 :
3412 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3413 0 : ts->kind = 8;
3414 :
3415 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3416 : {
3417 858 : if (ts->kind == 4)
3418 : {
3419 224 : if (flag_real4_kind == 8)
3420 24 : ts->kind = 8;
3421 224 : if (flag_real4_kind == 10)
3422 24 : ts->kind = 10;
3423 224 : if (flag_real4_kind == 16)
3424 24 : ts->kind = 16;
3425 : }
3426 634 : else if (ts->kind == 8)
3427 : {
3428 629 : if (flag_real8_kind == 4)
3429 24 : ts->kind = 4;
3430 629 : if (flag_real8_kind == 10)
3431 24 : ts->kind = 10;
3432 629 : if (flag_real8_kind == 16)
3433 24 : ts->kind = 16;
3434 : }
3435 : }
3436 :
3437 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3438 : {
3439 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3440 : gfc_basic_typename (ts->type), original_kind);
3441 8 : return MATCH_ERROR;
3442 : }
3443 :
3444 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3445 : "Nonstandard type declaration %s*%d at %C",
3446 : gfc_basic_typename(ts->type), original_kind))
3447 : return MATCH_ERROR;
3448 :
3449 : return MATCH_YES;
3450 : }
3451 :
3452 :
3453 : /* Match a kind specification. Since kinds are generally optional, we
3454 : usually return MATCH_NO if something goes wrong. If a "kind="
3455 : string is found, then we know we have an error. */
3456 :
3457 : match
3458 158653 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3459 : {
3460 158653 : locus where, loc;
3461 158653 : gfc_expr *e;
3462 158653 : match m, n;
3463 158653 : char c;
3464 :
3465 158653 : m = MATCH_NO;
3466 158653 : n = MATCH_YES;
3467 158653 : e = NULL;
3468 158653 : saved_kind_expr = NULL;
3469 :
3470 158653 : where = loc = gfc_current_locus;
3471 :
3472 158653 : if (kind_expr_only)
3473 0 : goto kind_expr;
3474 :
3475 158653 : if (gfc_match_char ('(') == MATCH_NO)
3476 : return MATCH_NO;
3477 :
3478 : /* Also gobbles optional text. */
3479 49893 : if (gfc_match (" kind = ") == MATCH_YES)
3480 49893 : m = MATCH_ERROR;
3481 :
3482 49893 : loc = gfc_current_locus;
3483 :
3484 49893 : kind_expr:
3485 :
3486 49893 : n = gfc_match_init_expr (&e);
3487 :
3488 49893 : if (gfc_derived_parameter_expr (e))
3489 : {
3490 166 : ts->kind = 0;
3491 166 : saved_kind_expr = gfc_copy_expr (e);
3492 166 : goto close_brackets;
3493 : }
3494 :
3495 49727 : if (n != MATCH_YES)
3496 : {
3497 460 : if (gfc_matching_function)
3498 : {
3499 : /* The function kind expression might include use associated or
3500 : imported parameters and try again after the specification
3501 : expressions..... */
3502 432 : if (gfc_match_char (')') != MATCH_YES)
3503 : {
3504 1 : gfc_error ("Missing right parenthesis at %C");
3505 1 : m = MATCH_ERROR;
3506 1 : goto no_match;
3507 : }
3508 :
3509 431 : gfc_free_expr (e);
3510 431 : gfc_undo_symbols ();
3511 431 : return MATCH_YES;
3512 : }
3513 : else
3514 : {
3515 : /* ....or else, the match is real. */
3516 28 : if (n == MATCH_NO)
3517 0 : gfc_error ("Expected initialization expression at %C");
3518 28 : if (n != MATCH_YES)
3519 28 : return MATCH_ERROR;
3520 : }
3521 : }
3522 :
3523 49267 : if (e->rank != 0)
3524 : {
3525 0 : gfc_error ("Expected scalar initialization expression at %C");
3526 0 : m = MATCH_ERROR;
3527 0 : goto no_match;
3528 : }
3529 :
3530 49267 : if (gfc_extract_int (e, &ts->kind, 1))
3531 : {
3532 0 : m = MATCH_ERROR;
3533 0 : goto no_match;
3534 : }
3535 :
3536 : /* Before throwing away the expression, let's see if we had a
3537 : C interoperable kind (and store the fact). */
3538 49267 : if (e->ts.is_c_interop == 1)
3539 : {
3540 : /* Mark this as C interoperable if being declared with one
3541 : of the named constants from iso_c_binding. */
3542 17973 : ts->is_c_interop = e->ts.is_iso_c;
3543 17973 : ts->f90_type = e->ts.f90_type;
3544 17973 : if (e->symtree)
3545 17972 : ts->interop_kind = e->symtree->n.sym;
3546 : }
3547 :
3548 49267 : gfc_free_expr (e);
3549 49267 : e = NULL;
3550 :
3551 : /* Ignore errors to this point, if we've gotten here. This means
3552 : we ignore the m=MATCH_ERROR from above. */
3553 49267 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3554 : {
3555 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3556 : gfc_basic_typename (ts->type));
3557 7 : gfc_current_locus = where;
3558 7 : return MATCH_ERROR;
3559 : }
3560 :
3561 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3562 : if, e.g., c_double is used for COMPLEX as the standard
3563 : explicitly says that the kind type parameter for complex and real
3564 : variable is the same, i.e. c_float == c_float_complex. */
3565 49260 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3566 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3567 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3568 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3569 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3570 : gfc_basic_typename (ts->type));
3571 :
3572 49247 : close_brackets:
3573 :
3574 49426 : gfc_gobble_whitespace ();
3575 49426 : if ((c = gfc_next_ascii_char ()) != ')'
3576 49426 : && (ts->type != BT_CHARACTER || c != ','))
3577 : {
3578 0 : if (ts->type == BT_CHARACTER)
3579 0 : gfc_error ("Missing right parenthesis or comma at %C");
3580 : else
3581 0 : gfc_error ("Missing right parenthesis at %C");
3582 0 : m = MATCH_ERROR;
3583 0 : goto no_match;
3584 : }
3585 : else
3586 : /* All tests passed. */
3587 49426 : m = MATCH_YES;
3588 :
3589 49426 : if(m == MATCH_ERROR)
3590 : gfc_current_locus = where;
3591 :
3592 49426 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3593 0 : ts->kind = 8;
3594 :
3595 49426 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3596 : {
3597 14094 : if (ts->kind == 4)
3598 : {
3599 4522 : if (flag_real4_kind == 8)
3600 54 : ts->kind = 8;
3601 4522 : if (flag_real4_kind == 10)
3602 54 : ts->kind = 10;
3603 4522 : if (flag_real4_kind == 16)
3604 54 : ts->kind = 16;
3605 : }
3606 9572 : else if (ts->kind == 8)
3607 : {
3608 6540 : if (flag_real8_kind == 4)
3609 48 : ts->kind = 4;
3610 6540 : if (flag_real8_kind == 10)
3611 48 : ts->kind = 10;
3612 6540 : if (flag_real8_kind == 16)
3613 48 : ts->kind = 16;
3614 : }
3615 : }
3616 :
3617 : /* Return what we know from the test(s). */
3618 : return m;
3619 :
3620 1 : no_match:
3621 1 : gfc_free_expr (e);
3622 1 : gfc_current_locus = where;
3623 1 : return m;
3624 : }
3625 :
3626 :
3627 : static match
3628 4865 : match_char_kind (int * kind, int * is_iso_c)
3629 : {
3630 4865 : locus where;
3631 4865 : gfc_expr *e;
3632 4865 : match m, n;
3633 4865 : bool fail;
3634 :
3635 4865 : m = MATCH_NO;
3636 4865 : e = NULL;
3637 4865 : where = gfc_current_locus;
3638 :
3639 4865 : n = gfc_match_init_expr (&e);
3640 :
3641 4865 : if (n != MATCH_YES && gfc_matching_function)
3642 : {
3643 : /* The expression might include use-associated or imported
3644 : parameters and try again after the specification
3645 : expressions. */
3646 7 : gfc_free_expr (e);
3647 7 : gfc_undo_symbols ();
3648 7 : return MATCH_YES;
3649 : }
3650 :
3651 7 : if (n == MATCH_NO)
3652 2 : gfc_error ("Expected initialization expression at %C");
3653 4858 : if (n != MATCH_YES)
3654 : return MATCH_ERROR;
3655 :
3656 4851 : if (e->rank != 0)
3657 : {
3658 0 : gfc_error ("Expected scalar initialization expression at %C");
3659 0 : m = MATCH_ERROR;
3660 0 : goto no_match;
3661 : }
3662 :
3663 4851 : if (gfc_derived_parameter_expr (e))
3664 : {
3665 14 : saved_kind_expr = e;
3666 14 : *kind = 0;
3667 14 : return MATCH_YES;
3668 : }
3669 :
3670 4837 : fail = gfc_extract_int (e, kind, 1);
3671 4837 : *is_iso_c = e->ts.is_iso_c;
3672 4837 : if (fail)
3673 : {
3674 0 : m = MATCH_ERROR;
3675 0 : goto no_match;
3676 : }
3677 :
3678 4837 : gfc_free_expr (e);
3679 :
3680 : /* Ignore errors to this point, if we've gotten here. This means
3681 : we ignore the m=MATCH_ERROR from above. */
3682 4837 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3683 : {
3684 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3685 14 : m = MATCH_ERROR;
3686 : }
3687 : else
3688 : /* All tests passed. */
3689 : m = MATCH_YES;
3690 :
3691 14 : if (m == MATCH_ERROR)
3692 14 : gfc_current_locus = where;
3693 :
3694 : /* Return what we know from the test(s). */
3695 : return m;
3696 :
3697 0 : no_match:
3698 0 : gfc_free_expr (e);
3699 0 : gfc_current_locus = where;
3700 0 : return m;
3701 : }
3702 :
3703 :
3704 : /* Match the various kind/length specifications in a CHARACTER
3705 : declaration. We don't return MATCH_NO. */
3706 :
3707 : match
3708 31870 : gfc_match_char_spec (gfc_typespec *ts)
3709 : {
3710 31870 : int kind, seen_length, is_iso_c;
3711 31870 : gfc_charlen *cl;
3712 31870 : gfc_expr *len;
3713 31870 : match m;
3714 31870 : bool deferred;
3715 :
3716 31870 : len = NULL;
3717 31870 : seen_length = 0;
3718 31870 : kind = 0;
3719 31870 : is_iso_c = 0;
3720 31870 : deferred = false;
3721 :
3722 : /* Try the old-style specification first. */
3723 31870 : old_char_selector = 0;
3724 :
3725 31870 : m = match_char_length (&len, &deferred, true);
3726 31870 : if (m != MATCH_NO)
3727 : {
3728 2205 : if (m == MATCH_YES)
3729 2205 : old_char_selector = 1;
3730 2205 : seen_length = 1;
3731 2205 : goto done;
3732 : }
3733 :
3734 29665 : m = gfc_match_char ('(');
3735 29665 : if (m != MATCH_YES)
3736 : {
3737 1915 : m = MATCH_YES; /* Character without length is a single char. */
3738 1915 : goto done;
3739 : }
3740 :
3741 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3742 27750 : if (gfc_match (" kind =") == MATCH_YES)
3743 : {
3744 3386 : m = match_char_kind (&kind, &is_iso_c);
3745 :
3746 3386 : if (m == MATCH_ERROR)
3747 16 : goto done;
3748 3370 : if (m == MATCH_NO)
3749 : goto syntax;
3750 :
3751 3370 : if (gfc_match (" , len =") == MATCH_NO)
3752 516 : goto rparen;
3753 :
3754 2854 : m = char_len_param_value (&len, &deferred);
3755 2854 : if (m == MATCH_NO)
3756 0 : goto syntax;
3757 2854 : if (m == MATCH_ERROR)
3758 2 : goto done;
3759 2852 : seen_length = 1;
3760 :
3761 2852 : goto rparen;
3762 : }
3763 :
3764 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3765 24364 : if (gfc_match (" len =") == MATCH_YES)
3766 : {
3767 13910 : m = char_len_param_value (&len, &deferred);
3768 13910 : if (m == MATCH_NO)
3769 2 : goto syntax;
3770 13908 : if (m == MATCH_ERROR)
3771 8 : goto done;
3772 13900 : seen_length = 1;
3773 :
3774 13900 : if (gfc_match_char (')') == MATCH_YES)
3775 12595 : goto done;
3776 :
3777 1305 : if (gfc_match (" , kind =") != MATCH_YES)
3778 0 : goto syntax;
3779 :
3780 1305 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3781 2 : goto done;
3782 :
3783 1303 : goto rparen;
3784 : }
3785 :
3786 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3787 10454 : m = char_len_param_value (&len, &deferred);
3788 10454 : if (m == MATCH_NO)
3789 0 : goto syntax;
3790 10454 : if (m == MATCH_ERROR)
3791 44 : goto done;
3792 10410 : seen_length = 1;
3793 :
3794 10410 : m = gfc_match_char (')');
3795 10410 : if (m == MATCH_YES)
3796 10234 : goto done;
3797 :
3798 176 : if (gfc_match_char (',') != MATCH_YES)
3799 2 : goto syntax;
3800 :
3801 174 : gfc_match (" kind ="); /* Gobble optional text. */
3802 :
3803 174 : m = match_char_kind (&kind, &is_iso_c);
3804 174 : if (m == MATCH_ERROR)
3805 3 : goto done;
3806 : if (m == MATCH_NO)
3807 : goto syntax;
3808 :
3809 4842 : rparen:
3810 : /* Require a right-paren at this point. */
3811 4842 : m = gfc_match_char (')');
3812 4842 : if (m == MATCH_YES)
3813 4842 : goto done;
3814 :
3815 0 : syntax:
3816 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3817 4 : m = MATCH_ERROR;
3818 4 : gfc_free_expr (len);
3819 4 : return m;
3820 :
3821 31866 : done:
3822 : /* Deal with character functions after USE and IMPORT statements. */
3823 31866 : if (gfc_matching_function)
3824 : {
3825 1424 : gfc_free_expr (len);
3826 1424 : gfc_undo_symbols ();
3827 1424 : return MATCH_YES;
3828 : }
3829 :
3830 30442 : if (m != MATCH_YES)
3831 : {
3832 65 : gfc_free_expr (len);
3833 65 : return m;
3834 : }
3835 :
3836 : /* Do some final massaging of the length values. */
3837 30377 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3838 :
3839 30377 : if (seen_length == 0)
3840 2379 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3841 : else
3842 : {
3843 : /* If gfortran ends up here, then len may be reducible to a constant.
3844 : Try to do that here. If it does not reduce, simply assign len to
3845 : charlen. A complication occurs with user-defined generic functions,
3846 : which are not resolved. Use a private namespace to deal with
3847 : generic functions. */
3848 :
3849 27998 : if (len && len->expr_type != EXPR_CONSTANT)
3850 : {
3851 3045 : gfc_namespace *old_ns;
3852 3045 : gfc_expr *e;
3853 :
3854 3045 : old_ns = gfc_current_ns;
3855 3045 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3856 :
3857 3045 : e = gfc_copy_expr (len);
3858 3045 : gfc_push_suppress_errors ();
3859 3045 : gfc_reduce_init_expr (e);
3860 3045 : gfc_pop_suppress_errors ();
3861 3045 : if (e->expr_type == EXPR_CONSTANT)
3862 : {
3863 294 : gfc_replace_expr (len, e);
3864 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3865 7 : mpz_set_ui (len->value.integer, 0);
3866 : }
3867 : else
3868 2751 : gfc_free_expr (e);
3869 :
3870 3045 : gfc_free_namespace (gfc_current_ns);
3871 3045 : gfc_current_ns = old_ns;
3872 : }
3873 :
3874 27998 : cl->length = len;
3875 : }
3876 :
3877 30377 : ts->u.cl = cl;
3878 30377 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3879 30377 : ts->deferred = deferred;
3880 :
3881 : /* We have to know if it was a C interoperable kind so we can
3882 : do accurate type checking of bind(c) procs, etc. */
3883 30377 : if (kind != 0)
3884 : /* Mark this as C interoperable if being declared with one
3885 : of the named constants from iso_c_binding. */
3886 4748 : ts->is_c_interop = is_iso_c;
3887 25629 : else if (len != NULL)
3888 : /* Here, we might have parsed something such as: character(c_char)
3889 : In this case, the parsing code above grabs the c_char when
3890 : looking for the length (line 1690, roughly). it's the last
3891 : testcase for parsing the kind params of a character variable.
3892 : However, it's not actually the length. this seems like it
3893 : could be an error.
3894 : To see if the user used a C interop kind, test the expr
3895 : of the so called length, and see if it's C interoperable. */
3896 16506 : ts->is_c_interop = len->ts.is_iso_c;
3897 :
3898 : return MATCH_YES;
3899 : }
3900 :
3901 :
3902 : /* Matches a RECORD declaration. */
3903 :
3904 : static match
3905 959815 : match_record_decl (char *name)
3906 : {
3907 959815 : locus old_loc;
3908 959815 : old_loc = gfc_current_locus;
3909 959815 : match m;
3910 :
3911 959815 : m = gfc_match (" record /");
3912 959815 : if (m == MATCH_YES)
3913 : {
3914 353 : if (!flag_dec_structure)
3915 : {
3916 6 : gfc_current_locus = old_loc;
3917 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3918 : "%<-fdec-structure%>");
3919 6 : return MATCH_ERROR;
3920 : }
3921 347 : m = gfc_match (" %n/", name);
3922 347 : if (m == MATCH_YES)
3923 : return MATCH_YES;
3924 : }
3925 :
3926 959465 : gfc_current_locus = old_loc;
3927 959465 : if (flag_dec_structure
3928 959465 : && (gfc_match (" record% ") == MATCH_YES
3929 8026 : || gfc_match (" record%t") == MATCH_YES))
3930 6 : gfc_error ("Structure name expected after RECORD at %C");
3931 959465 : if (m == MATCH_NO)
3932 : return MATCH_NO;
3933 :
3934 : return MATCH_ERROR;
3935 : }
3936 :
3937 :
3938 : /* In parsing a PDT, it is possible that one of the type parameters has the
3939 : same name as a previously declared symbol that is not a type parameter.
3940 : Intercept this now by looking for the symtree in f2k_derived. */
3941 :
3942 : static bool
3943 874 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3944 : {
3945 874 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3946 : return false;
3947 :
3948 705 : if (!(e->symtree->n.sym->attr.pdt_len
3949 122 : || e->symtree->n.sym->attr.pdt_kind))
3950 : {
3951 38 : gfc_symtree *st;
3952 38 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3953 : e->symtree->n.sym->name);
3954 38 : if (st && st->n.sym
3955 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3956 : {
3957 30 : gfc_expr *new_expr;
3958 30 : gfc_set_sym_referenced (st->n.sym);
3959 30 : new_expr = gfc_get_expr ();
3960 30 : new_expr->ts = st->n.sym->ts;
3961 30 : new_expr->expr_type = EXPR_VARIABLE;
3962 30 : new_expr->symtree = st;
3963 30 : new_expr->where = e->where;
3964 30 : gfc_replace_expr (e, new_expr);
3965 : }
3966 : }
3967 :
3968 : return false;
3969 : }
3970 :
3971 :
3972 : void
3973 642 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3974 : {
3975 642 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3976 : return;
3977 611 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3978 : }
3979 :
3980 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3981 : of expressions to substitute into the possibly parameterized expression
3982 : 'e'. Using a list is inefficient but should not be too bad since the
3983 : number of type parameters is not likely to be large. */
3984 : static bool
3985 3151 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3986 : int* f)
3987 : {
3988 3151 : gfc_actual_arglist *param;
3989 3151 : gfc_expr *copy;
3990 :
3991 3151 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
3992 : return false;
3993 :
3994 1405 : gcc_assert (e->symtree);
3995 1405 : if (e->symtree->n.sym->attr.pdt_kind
3996 1026 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
3997 507 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
3998 : {
3999 1396 : for (param = type_param_spec_list; param; param = param->next)
4000 1348 : if (!strcmp (e->symtree->n.sym->name, param->name))
4001 : break;
4002 :
4003 945 : if (param && param->expr)
4004 : {
4005 896 : copy = gfc_copy_expr (param->expr);
4006 896 : gfc_replace_expr (e, copy);
4007 : /* Catch variables declared without a value expression. */
4008 896 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
4009 21 : e->ts = e->symtree->n.sym->ts;
4010 : }
4011 : }
4012 :
4013 : return false;
4014 : }
4015 :
4016 :
4017 : static bool
4018 941 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
4019 : {
4020 941 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
4021 : }
4022 :
4023 :
4024 : bool
4025 1761 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
4026 : {
4027 1761 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
4028 1761 : type_param_spec_list = param_list;
4029 1761 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
4030 1761 : type_param_spec_list = old_param_spec_list;
4031 1761 : return res;
4032 : }
4033 :
4034 : /* Determines the instance of a parameterized derived type to be used by
4035 : matching determining the values of the kind parameters and using them
4036 : in the name of the instance. If the instance exists, it is used, otherwise
4037 : a new derived type is created. */
4038 : match
4039 2651 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
4040 : gfc_actual_arglist **ext_param_list)
4041 : {
4042 : /* The PDT template symbol. */
4043 2651 : gfc_symbol *pdt = *sym;
4044 : /* The symbol for the parameter in the template f2k_namespace. */
4045 2651 : gfc_symbol *param;
4046 : /* The hoped for instance of the PDT. */
4047 2651 : gfc_symbol *instance = NULL;
4048 : /* The list of parameters appearing in the PDT declaration. */
4049 2651 : gfc_formal_arglist *type_param_name_list;
4050 : /* Used to store the parameter specification list during recursive calls. */
4051 2651 : gfc_actual_arglist *old_param_spec_list;
4052 : /* Pointers to the parameter specification being used. */
4053 2651 : gfc_actual_arglist *actual_param;
4054 2651 : gfc_actual_arglist *tail = NULL;
4055 : /* Used to build up the name of the PDT instance. */
4056 2651 : char *name;
4057 2651 : bool name_seen = (param_list == NULL);
4058 2651 : bool assumed_seen = false;
4059 2651 : bool deferred_seen = false;
4060 2651 : bool spec_error = false;
4061 2651 : bool alloc_seen = false;
4062 2651 : bool ptr_seen = false;
4063 2651 : int i;
4064 2651 : gfc_expr *kind_expr;
4065 2651 : gfc_component *c1, *c2;
4066 2651 : match m;
4067 2651 : gfc_symtree *s = NULL;
4068 :
4069 2651 : type_param_spec_list = NULL;
4070 :
4071 2651 : type_param_name_list = pdt->formal;
4072 2651 : actual_param = param_list;
4073 :
4074 : /* Prevent a PDT component of the same type as the template from being
4075 : converted into an instance. Doing this results in the component being
4076 : lost. */
4077 2651 : if (gfc_current_state () == COMP_DERIVED
4078 101 : && !(gfc_state_stack->previous
4079 101 : && gfc_state_stack->previous->state == COMP_DERIVED)
4080 101 : && gfc_current_block ()->attr.pdt_template)
4081 : {
4082 100 : if (ext_param_list)
4083 100 : *ext_param_list = gfc_copy_actual_arglist (param_list);
4084 100 : return MATCH_YES;
4085 : }
4086 :
4087 2551 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
4088 :
4089 : /* Run through the parameter name list and pick up the actual
4090 : parameter values or use the default values in the PDT declaration. */
4091 5977 : for (; type_param_name_list;
4092 3426 : type_param_name_list = type_param_name_list->next)
4093 : {
4094 3494 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4095 : {
4096 3098 : if (actual_param->spec_type == SPEC_ASSUMED)
4097 : spec_error = deferred_seen;
4098 : else
4099 3098 : spec_error = assumed_seen;
4100 :
4101 3098 : if (spec_error)
4102 : {
4103 : gfc_error ("The type parameter spec list at %C cannot contain "
4104 : "both ASSUMED and DEFERRED parameters");
4105 : goto error_return;
4106 : }
4107 : }
4108 :
4109 3098 : if (actual_param && actual_param->name)
4110 3494 : name_seen = true;
4111 3494 : param = type_param_name_list->sym;
4112 :
4113 3494 : if (!param || !param->name)
4114 2 : continue;
4115 :
4116 3492 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4117 : /* An error should already have been thrown in resolve.cc
4118 : (resolve_fl_derived0). */
4119 3492 : if (!pdt->attr.use_assoc && !c1)
4120 8 : goto error_return;
4121 :
4122 : /* Resolution PDT class components of derived types are handled here.
4123 : They can arrive without a parameter list and no KIND parameters. */
4124 3484 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4125 14 : continue;
4126 :
4127 3470 : kind_expr = NULL;
4128 3470 : if (!name_seen)
4129 : {
4130 2026 : if (!actual_param && !(c1 && c1->initializer))
4131 : {
4132 2 : gfc_error ("The type parameter spec list at %C does not contain "
4133 : "enough parameter expressions");
4134 2 : goto error_return;
4135 : }
4136 2024 : else if (!actual_param && c1 && c1->initializer)
4137 5 : kind_expr = gfc_copy_expr (c1->initializer);
4138 2019 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4139 1818 : kind_expr = gfc_copy_expr (actual_param->expr);
4140 : }
4141 : else
4142 : {
4143 : actual_param = param_list;
4144 1904 : for (;actual_param; actual_param = actual_param->next)
4145 1514 : if (actual_param->name
4146 1494 : && strcmp (actual_param->name, param->name) == 0)
4147 : break;
4148 1444 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4149 893 : kind_expr = gfc_copy_expr (actual_param->expr);
4150 : else
4151 : {
4152 551 : if (c1->initializer)
4153 487 : kind_expr = gfc_copy_expr (c1->initializer);
4154 64 : else if (!(actual_param && param->attr.pdt_len))
4155 : {
4156 9 : gfc_error ("The derived parameter %qs at %C does not "
4157 : "have a default value", param->name);
4158 9 : goto error_return;
4159 : }
4160 : }
4161 : }
4162 :
4163 3203 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4164 252 : && kind_expr->ts.type != BT_INTEGER
4165 118 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4166 : {
4167 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4168 : "type and not %s", &kind_expr->where,
4169 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4170 12 : goto error_return;
4171 : }
4172 :
4173 : /* Store the current parameter expressions in a temporary actual
4174 : arglist 'list' so that they can be substituted in the corresponding
4175 : expressions in the PDT instance. */
4176 3447 : if (type_param_spec_list == NULL)
4177 : {
4178 2514 : type_param_spec_list = gfc_get_actual_arglist ();
4179 2514 : tail = type_param_spec_list;
4180 : }
4181 : else
4182 : {
4183 933 : tail->next = gfc_get_actual_arglist ();
4184 933 : tail = tail->next;
4185 : }
4186 3447 : tail->name = param->name;
4187 :
4188 3447 : if (kind_expr)
4189 : {
4190 : /* Try simplification even for LEN expressions. */
4191 3191 : bool ok;
4192 3191 : gfc_resolve_expr (kind_expr);
4193 :
4194 3191 : if (c1->attr.pdt_kind
4195 1634 : && kind_expr->expr_type != EXPR_CONSTANT
4196 28 : && type_param_spec_list)
4197 28 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4198 :
4199 3191 : ok = gfc_simplify_expr (kind_expr, 1);
4200 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4201 : initializer so allow for this. */
4202 3191 : if (kind_expr->ts.type != BT_INTEGER
4203 135 : && kind_expr->ts.type != BT_PROCEDURE)
4204 : {
4205 29 : gfc_error ("The parameter expression at %C must be of "
4206 : "INTEGER type and not %s type",
4207 : gfc_basic_typename (kind_expr->ts.type));
4208 29 : goto error_return;
4209 : }
4210 3162 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4211 : {
4212 4 : gfc_error ("The parameter expression at %C does not "
4213 : "simplify to an INTEGER constant");
4214 4 : goto error_return;
4215 : }
4216 :
4217 3158 : tail->expr = gfc_copy_expr (kind_expr);
4218 : }
4219 :
4220 3414 : if (actual_param)
4221 3026 : tail->spec_type = actual_param->spec_type;
4222 :
4223 3414 : if (!param->attr.pdt_kind)
4224 : {
4225 1805 : if (!name_seen && actual_param)
4226 1084 : actual_param = actual_param->next;
4227 1805 : if (kind_expr)
4228 : {
4229 1551 : gfc_free_expr (kind_expr);
4230 1551 : kind_expr = NULL;
4231 : }
4232 1805 : continue;
4233 : }
4234 :
4235 1609 : if (actual_param
4236 1265 : && (actual_param->spec_type == SPEC_ASSUMED
4237 1265 : || actual_param->spec_type == SPEC_DEFERRED))
4238 : {
4239 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4240 : "ASSUMED or DEFERRED", param->name);
4241 2 : goto error_return;
4242 : }
4243 :
4244 1607 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4245 : {
4246 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4247 : "reduce to a constant expression", param->name);
4248 2 : goto error_return;
4249 : }
4250 :
4251 : /* This can come about during the parsing of nested pdt_templates. An
4252 : error arises because the KIND parameter expression has not been
4253 : provided. Use the template instead of an incorrect instance. */
4254 1605 : if (kind_expr->expr_type != EXPR_CONSTANT
4255 1605 : || kind_expr->ts.type != BT_INTEGER)
4256 : {
4257 0 : gfc_free_actual_arglist (type_param_spec_list);
4258 0 : free (name);
4259 0 : return MATCH_YES;
4260 : }
4261 :
4262 1605 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4263 1605 : char *old_name = name;
4264 1605 : name = xasprintf ("%s_%s", old_name, kind_value);
4265 1605 : free (old_name);
4266 1605 : free (kind_value);
4267 :
4268 1605 : if (!name_seen && actual_param)
4269 886 : actual_param = actual_param->next;
4270 1605 : gfc_free_expr (kind_expr);
4271 : }
4272 :
4273 2483 : if (!name_seen && actual_param)
4274 : {
4275 2 : gfc_error ("The type parameter spec list at %C contains too many "
4276 : "parameter expressions");
4277 2 : goto error_return;
4278 : }
4279 :
4280 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4281 : build it, using 'pdt' as a template. */
4282 2481 : if (gfc_get_symbol (name, pdt->ns, &instance))
4283 : {
4284 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4285 0 : goto error_return;
4286 : }
4287 :
4288 : /* If we are in an interface body, the instance will not have been imported.
4289 : Make sure that it is imported implicitly. */
4290 2481 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4291 2481 : if (gfc_current_ns->proc_name
4292 2434 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4293 93 : && s && s->import_only && pdt->attr.imported)
4294 : {
4295 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4296 2 : if (!s)
4297 : {
4298 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4299 : &gfc_current_locus);
4300 1 : s->n.sym = instance;
4301 : }
4302 2 : s->n.sym->attr.imported = 1;
4303 2 : s->import_only = 1;
4304 : }
4305 :
4306 2481 : m = MATCH_YES;
4307 :
4308 2481 : if (instance->attr.flavor == FL_DERIVED
4309 1966 : && instance->attr.pdt_type
4310 1966 : && instance->components)
4311 : {
4312 1966 : instance->refs++;
4313 1966 : if (ext_param_list)
4314 924 : *ext_param_list = type_param_spec_list;
4315 1966 : *sym = instance;
4316 1966 : gfc_commit_symbols ();
4317 1966 : free (name);
4318 1966 : return m;
4319 : }
4320 :
4321 : /* Start building the new instance of the parameterized type. */
4322 515 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4323 515 : if (pdt->attr.use_assoc)
4324 48 : instance->module = pdt->module;
4325 515 : instance->attr.pdt_template = 0;
4326 515 : instance->attr.pdt_type = 1;
4327 515 : instance->declared_at = gfc_current_locus;
4328 :
4329 : /* In resolution, the finalizers are copied, according to the type of the
4330 : argument, to the instance finalizers. However, they are retained by the
4331 : template and procedures are freed there. */
4332 515 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4333 : {
4334 12 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4335 12 : instance->template_sym = pdt;
4336 12 : *instance->f2k_derived = *pdt->f2k_derived;
4337 : }
4338 :
4339 : /* Add the components, replacing the parameters in all expressions
4340 : with the expressions for their values in 'type_param_spec_list'. */
4341 515 : c1 = pdt->components;
4342 515 : tail = type_param_spec_list;
4343 1912 : for (; c1; c1 = c1->next)
4344 : {
4345 1399 : gfc_add_component (instance, c1->name, &c2);
4346 :
4347 1399 : c2->ts = c1->ts;
4348 1399 : c2->attr = c1->attr;
4349 1399 : if (c1->tb)
4350 : {
4351 6 : c2->tb = gfc_get_tbp ();
4352 6 : *c2->tb = *c1->tb;
4353 : }
4354 :
4355 : /* The order of declaration of the type_specs might not be the
4356 : same as that of the components. */
4357 1399 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4358 : {
4359 992 : for (tail = type_param_spec_list; tail; tail = tail->next)
4360 982 : if (strcmp (c1->name, tail->name) == 0)
4361 : break;
4362 : }
4363 :
4364 : /* Deal with type extension by recursively calling this function
4365 : to obtain the instance of the extended type. */
4366 1399 : if (gfc_current_state () != COMP_DERIVED
4367 1397 : && c1 == pdt->components
4368 514 : && c1->ts.type == BT_DERIVED
4369 42 : && c1->ts.u.derived
4370 1441 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4371 : {
4372 42 : if (c1->ts.u.derived->attr.pdt_template)
4373 : {
4374 35 : gfc_formal_arglist *f;
4375 :
4376 35 : old_param_spec_list = type_param_spec_list;
4377 :
4378 : /* Obtain a spec list appropriate to the extended type..*/
4379 35 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4380 35 : type_param_spec_list = actual_param;
4381 67 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4382 32 : actual_param = actual_param->next;
4383 35 : if (actual_param)
4384 : {
4385 35 : gfc_free_actual_arglist (actual_param->next);
4386 35 : actual_param->next = NULL;
4387 : }
4388 :
4389 : /* Now obtain the PDT instance for the extended type. */
4390 35 : c2->param_list = type_param_spec_list;
4391 35 : m = gfc_get_pdt_instance (type_param_spec_list,
4392 : &c2->ts.u.derived,
4393 : &c2->param_list);
4394 35 : type_param_spec_list = old_param_spec_list;
4395 : }
4396 : else
4397 7 : c2->ts = c1->ts;
4398 :
4399 42 : c2->ts.u.derived->refs++;
4400 42 : gfc_set_sym_referenced (c2->ts.u.derived);
4401 :
4402 : /* If the component is allocatable or the parent has allocatable
4403 : components, make sure that the new instance also is marked as
4404 : having allocatable components. */
4405 42 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4406 6 : instance->attr.alloc_comp = 1;
4407 :
4408 : /* Set extension level. */
4409 42 : if (c2->ts.u.derived->attr.extension == 255)
4410 : {
4411 : /* Since the extension field is 8 bit wide, we can only have
4412 : up to 255 extension levels. */
4413 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4414 : c2->ts.u.derived->name,
4415 : &c2->ts.u.derived->declared_at);
4416 0 : goto error_return;
4417 : }
4418 42 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4419 :
4420 42 : continue;
4421 42 : }
4422 :
4423 : /* Addressing PR82943, this will fix the issue where a function or
4424 : subroutine is declared as not a member of the PDT instance.
4425 : The reason for this is because the PDT instance did not have access
4426 : to its template's f2k_derived namespace in order to find the
4427 : typebound procedures.
4428 :
4429 : The number of references to the PDT template's f2k_derived will
4430 : ensure that f2k_derived is properly freed later on. */
4431 :
4432 1357 : if (!instance->f2k_derived && pdt->f2k_derived)
4433 : {
4434 496 : instance->f2k_derived = pdt->f2k_derived;
4435 496 : instance->f2k_derived->refs++;
4436 : }
4437 :
4438 : /* Set the component kind using the parameterized expression. */
4439 1357 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4440 471 : && c1->kind_expr != NULL)
4441 : {
4442 278 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4443 278 : gfc_insert_kind_parameter_exprs (e);
4444 278 : gfc_simplify_expr (e, 1);
4445 278 : gfc_extract_int (e, &c2->ts.kind);
4446 278 : gfc_free_expr (e);
4447 278 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4448 : {
4449 2 : gfc_error ("Kind %d not supported for type %s at %C",
4450 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4451 2 : goto error_return;
4452 : }
4453 276 : if (c2->attr.proc_pointer && c2->attr.function
4454 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4455 : {
4456 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4457 0 : c2->ts.interface->result = c2->ts.interface;
4458 0 : c2->ts.interface->ts = c2->ts;
4459 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4460 0 : c2->ts.interface->attr.function = 1;
4461 0 : c2->attr.function = 1;
4462 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4463 : }
4464 : }
4465 :
4466 : /* Set up either the KIND/LEN initializer, if constant,
4467 : or the parameterized expression. Use the template
4468 : initializer if one is not already set in this instance. */
4469 1355 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4470 : {
4471 700 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4472 584 : c2->initializer = gfc_copy_expr (tail->expr);
4473 116 : else if (tail && tail->expr)
4474 : {
4475 10 : c2->param_list = gfc_get_actual_arglist ();
4476 10 : c2->param_list->name = tail->name;
4477 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4478 10 : c2->param_list->next = NULL;
4479 : }
4480 :
4481 700 : if (!c2->initializer && c1->initializer)
4482 24 : c2->initializer = gfc_copy_expr (c1->initializer);
4483 :
4484 700 : if (c2->initializer)
4485 608 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4486 : }
4487 :
4488 : /* Copy the array spec. */
4489 1355 : c2->as = gfc_copy_array_spec (c1->as);
4490 1355 : if (c1->ts.type == BT_CLASS)
4491 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4492 :
4493 1355 : if (c1->attr.allocatable)
4494 70 : alloc_seen = true;
4495 :
4496 1355 : if (c1->attr.pointer)
4497 20 : ptr_seen = true;
4498 :
4499 : /* Determine if an array spec is parameterized. If so, substitute
4500 : in the parameter expressions for the bounds and set the pdt_array
4501 : attribute. Notice that this attribute must be unconditionally set
4502 : if this is an array of parameterized character length. */
4503 1355 : if (c1->as && c1->as->type == AS_EXPLICIT)
4504 : {
4505 : bool pdt_array = false;
4506 502 : bool all_constant = true;
4507 :
4508 : /* Are the bounds of the array parameterized? */
4509 502 : for (i = 0; i < c1->as->rank; i++)
4510 : {
4511 299 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4512 6 : pdt_array = true;
4513 299 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4514 285 : pdt_array = true;
4515 : }
4516 :
4517 : /* If they are, free the expressions for the bounds and
4518 : replace them with the template expressions with substitute
4519 : values. */
4520 488 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4521 : {
4522 285 : gfc_expr *e;
4523 285 : e = gfc_copy_expr (c1->as->lower[i]);
4524 285 : gfc_insert_kind_parameter_exprs (e);
4525 285 : if (gfc_simplify_expr (e, 1))
4526 285 : gfc_replace_expr (c2->as->lower[i], e);
4527 : else
4528 0 : gfc_free_expr (e);
4529 285 : if (c2->as->lower[i]->expr_type != EXPR_CONSTANT)
4530 6 : all_constant = false;
4531 285 : e = gfc_copy_expr (c1->as->upper[i]);
4532 285 : gfc_insert_kind_parameter_exprs (e);
4533 285 : if (gfc_simplify_expr (e, 1))
4534 285 : gfc_replace_expr (c2->as->upper[i], e);
4535 : else
4536 0 : gfc_free_expr (e);
4537 285 : if (c2->as->upper[i]->expr_type != EXPR_CONSTANT)
4538 283 : all_constant = false;
4539 : }
4540 :
4541 203 : c2->attr.pdt_array = all_constant ? 0 : 1;
4542 203 : if (c1->initializer)
4543 : {
4544 7 : c2->initializer = gfc_copy_expr (c1->initializer);
4545 7 : gfc_insert_kind_parameter_exprs (c2->initializer);
4546 7 : gfc_simplify_expr (c2->initializer, 1);
4547 : }
4548 : }
4549 :
4550 : /* Similarly, set the string length if parameterized. */
4551 1355 : if (c1->ts.type == BT_CHARACTER
4552 87 : && c1->ts.u.cl->length
4553 1441 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4554 : {
4555 86 : gfc_expr *e;
4556 86 : e = gfc_copy_expr (c1->ts.u.cl->length);
4557 86 : gfc_insert_kind_parameter_exprs (e);
4558 86 : if (gfc_simplify_expr (e, 1))
4559 86 : gfc_replace_expr (c2->ts.u.cl->length, e);
4560 : else
4561 0 : gfc_free_expr (e);
4562 86 : if (c2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4563 83 : c2->attr.pdt_string = 1;
4564 : }
4565 :
4566 : /* Recurse into this function for PDT components. */
4567 1355 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4568 131 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4569 : {
4570 123 : gfc_actual_arglist *params;
4571 : /* The component in the template has a list of specification
4572 : expressions derived from its declaration. */
4573 123 : params = gfc_copy_actual_arglist (c1->param_list);
4574 123 : actual_param = params;
4575 : /* Substitute the template parameters with the expressions
4576 : from the specification list. */
4577 384 : for (;actual_param; actual_param = actual_param->next)
4578 : {
4579 138 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4580 138 : gfc_insert_parameter_exprs (actual_param->expr,
4581 : type_param_spec_list);
4582 : }
4583 :
4584 : /* Now obtain the PDT instance for the component. */
4585 123 : old_param_spec_list = type_param_spec_list;
4586 246 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4587 123 : &c2->param_list);
4588 123 : type_param_spec_list = old_param_spec_list;
4589 :
4590 123 : if (!(c2->attr.pointer || c2->attr.allocatable))
4591 : {
4592 83 : if (!c1->initializer
4593 58 : || c1->initializer->expr_type != EXPR_FUNCTION)
4594 82 : c2->initializer = gfc_default_initializer (&c2->ts);
4595 : else
4596 : {
4597 1 : gfc_symtree *s;
4598 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4599 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4600 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4601 1 : if (s)
4602 0 : c2->initializer->symtree = s;
4603 1 : c2->initializer->ts = c2->ts;
4604 1 : if (!s)
4605 1 : gfc_insert_parameter_exprs (c2->initializer,
4606 : type_param_spec_list);
4607 1 : gfc_simplify_expr (c2->initializer, 1);
4608 : }
4609 : }
4610 :
4611 123 : if (c2->attr.allocatable)
4612 32 : instance->attr.alloc_comp = 1;
4613 : }
4614 1232 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4615 449 : || c2->attr.pdt_array) && c1->initializer)
4616 : {
4617 32 : c2->initializer = gfc_copy_expr (c1->initializer);
4618 32 : if (c2->initializer->ts.type == BT_UNKNOWN)
4619 12 : c2->initializer->ts = c2->ts;
4620 32 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4621 : /* The template initializers are parsed using gfc_match_expr rather
4622 : than gfc_match_init_expr. Apply the missing reduction to the
4623 : PDT instance initializers. */
4624 32 : if (!gfc_reduce_init_expr (c2->initializer))
4625 : {
4626 0 : gfc_free_expr (c2->initializer);
4627 0 : goto error_return;
4628 : }
4629 32 : gfc_simplify_expr (c2->initializer, 1);
4630 : }
4631 : }
4632 :
4633 513 : if (alloc_seen)
4634 67 : instance->attr.alloc_comp = 1;
4635 513 : if (ptr_seen)
4636 20 : instance->attr.pointer_comp = 1;
4637 :
4638 :
4639 513 : gfc_commit_symbol (instance);
4640 513 : if (ext_param_list)
4641 330 : *ext_param_list = type_param_spec_list;
4642 513 : *sym = instance;
4643 513 : free (name);
4644 513 : return m;
4645 :
4646 72 : error_return:
4647 72 : gfc_free_actual_arglist (type_param_spec_list);
4648 72 : free (name);
4649 72 : return MATCH_ERROR;
4650 : }
4651 :
4652 :
4653 : /* Match a legacy nonstandard BYTE type-spec. */
4654 :
4655 : static match
4656 1180152 : match_byte_typespec (gfc_typespec *ts)
4657 : {
4658 1180152 : if (gfc_match (" byte") == MATCH_YES)
4659 : {
4660 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4661 : return MATCH_ERROR;
4662 :
4663 31 : if (gfc_current_form == FORM_FREE)
4664 : {
4665 19 : char c = gfc_peek_ascii_char ();
4666 19 : if (!gfc_is_whitespace (c) && c != ',')
4667 : return MATCH_NO;
4668 : }
4669 :
4670 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4671 : {
4672 0 : gfc_error ("BYTE type used at %C "
4673 : "is not available on the target machine");
4674 0 : return MATCH_ERROR;
4675 : }
4676 :
4677 29 : ts->type = BT_INTEGER;
4678 29 : ts->kind = 1;
4679 29 : return MATCH_YES;
4680 : }
4681 : return MATCH_NO;
4682 : }
4683 :
4684 :
4685 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4686 : structure to the matched specification. This is necessary for FUNCTION and
4687 : IMPLICIT statements.
4688 :
4689 : If implicit_flag is nonzero, then we don't check for the optional
4690 : kind specification. Not doing so is needed for matching an IMPLICIT
4691 : statement correctly. */
4692 :
4693 : match
4694 1180152 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4695 : {
4696 : /* Provide sufficient space to hold "pdtsymbol". */
4697 1180152 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4698 1180152 : gfc_symbol *sym, *dt_sym;
4699 1180152 : match m;
4700 1180152 : char c;
4701 1180152 : bool seen_deferred_kind, matched_type;
4702 1180152 : const char *dt_name;
4703 :
4704 1180152 : decl_type_param_list = NULL;
4705 :
4706 : /* A belt and braces check that the typespec is correctly being treated
4707 : as a deferred characteristic association. */
4708 2360304 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4709 81985 : && (gfc_current_block ()->result->ts.kind == -1)
4710 1192037 : && (ts->kind == -1);
4711 1180152 : gfc_clear_ts (ts);
4712 1180152 : if (seen_deferred_kind)
4713 9653 : ts->kind = -1;
4714 :
4715 : /* Clear the current binding label, in case one is given. */
4716 1180152 : curr_binding_label = NULL;
4717 :
4718 : /* Match BYTE type-spec. */
4719 1180152 : m = match_byte_typespec (ts);
4720 1180152 : if (m != MATCH_NO)
4721 : return m;
4722 :
4723 1180121 : m = gfc_match (" type (");
4724 1180121 : matched_type = (m == MATCH_YES);
4725 1180121 : if (matched_type)
4726 : {
4727 31390 : gfc_gobble_whitespace ();
4728 31390 : if (gfc_peek_ascii_char () == '*')
4729 : {
4730 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4731 : return m;
4732 5617 : if (gfc_comp_struct (gfc_current_state ()))
4733 : {
4734 2 : gfc_error ("Assumed type at %C is not allowed for components");
4735 2 : return MATCH_ERROR;
4736 : }
4737 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4738 : return MATCH_ERROR;
4739 5613 : ts->type = BT_ASSUMED;
4740 5613 : return MATCH_YES;
4741 : }
4742 :
4743 25773 : m = gfc_match ("%n", name);
4744 25773 : matched_type = (m == MATCH_YES);
4745 : }
4746 :
4747 25773 : if ((matched_type && strcmp ("integer", name) == 0)
4748 1174504 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4749 : {
4750 110740 : ts->type = BT_INTEGER;
4751 110740 : ts->kind = gfc_default_integer_kind;
4752 110740 : goto get_kind;
4753 : }
4754 :
4755 1063764 : if (flag_unsigned)
4756 : {
4757 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4758 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4759 : {
4760 1036 : ts->type = BT_UNSIGNED;
4761 1036 : ts->kind = gfc_default_integer_kind;
4762 1036 : goto get_kind;
4763 : }
4764 : }
4765 :
4766 25767 : if ((matched_type && strcmp ("character", name) == 0)
4767 1062728 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4768 : {
4769 28916 : if (matched_type
4770 28916 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4771 : "intrinsic-type-spec at %C"))
4772 : return MATCH_ERROR;
4773 :
4774 28915 : ts->type = BT_CHARACTER;
4775 28915 : if (implicit_flag == 0)
4776 28809 : m = gfc_match_char_spec (ts);
4777 : else
4778 : m = MATCH_YES;
4779 :
4780 28915 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4781 : {
4782 1 : gfc_error ("Malformed type-spec at %C");
4783 1 : return MATCH_ERROR;
4784 : }
4785 :
4786 28914 : return m;
4787 : }
4788 :
4789 25763 : if ((matched_type && strcmp ("real", name) == 0)
4790 1033812 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4791 : {
4792 29980 : ts->type = BT_REAL;
4793 29980 : ts->kind = gfc_default_real_kind;
4794 29980 : goto get_kind;
4795 : }
4796 :
4797 1003832 : if ((matched_type
4798 25760 : && (strcmp ("doubleprecision", name) == 0
4799 25759 : || (strcmp ("double", name) == 0
4800 5 : && gfc_match (" precision") == MATCH_YES)))
4801 1003832 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4802 : {
4803 2613 : if (matched_type
4804 2613 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4805 : "intrinsic-type-spec at %C"))
4806 : return MATCH_ERROR;
4807 :
4808 2612 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4809 : {
4810 2 : gfc_error ("Malformed type-spec at %C");
4811 2 : return MATCH_ERROR;
4812 : }
4813 :
4814 2610 : ts->type = BT_REAL;
4815 2610 : ts->kind = gfc_default_double_kind;
4816 2610 : return MATCH_YES;
4817 : }
4818 :
4819 25756 : if ((matched_type && strcmp ("complex", name) == 0)
4820 1001219 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4821 : {
4822 4051 : ts->type = BT_COMPLEX;
4823 4051 : ts->kind = gfc_default_complex_kind;
4824 4051 : goto get_kind;
4825 : }
4826 :
4827 997168 : if ((matched_type
4828 25756 : && (strcmp ("doublecomplex", name) == 0
4829 25755 : || (strcmp ("double", name) == 0
4830 2 : && gfc_match (" complex") == MATCH_YES)))
4831 997168 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4832 : {
4833 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4834 : return MATCH_ERROR;
4835 :
4836 203 : if (matched_type
4837 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4838 : "intrinsic-type-spec at %C"))
4839 : return MATCH_ERROR;
4840 :
4841 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4842 : {
4843 2 : gfc_error ("Malformed type-spec at %C");
4844 2 : return MATCH_ERROR;
4845 : }
4846 :
4847 201 : ts->type = BT_COMPLEX;
4848 201 : ts->kind = gfc_default_double_kind;
4849 201 : return MATCH_YES;
4850 : }
4851 :
4852 25753 : if ((matched_type && strcmp ("logical", name) == 0)
4853 996964 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4854 : {
4855 11399 : ts->type = BT_LOGICAL;
4856 11399 : ts->kind = gfc_default_logical_kind;
4857 11399 : goto get_kind;
4858 : }
4859 :
4860 985565 : if (matched_type)
4861 : {
4862 25750 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4863 25750 : if (m == MATCH_ERROR)
4864 : return m;
4865 :
4866 25750 : gfc_gobble_whitespace ();
4867 25750 : if (gfc_peek_ascii_char () != ')')
4868 : {
4869 1 : gfc_error ("Malformed type-spec at %C");
4870 1 : return MATCH_ERROR;
4871 : }
4872 25749 : m = gfc_match_char (')'); /* Burn closing ')'. */
4873 : }
4874 :
4875 985564 : if (m != MATCH_YES)
4876 959815 : m = match_record_decl (name);
4877 :
4878 985564 : if (matched_type || m == MATCH_YES)
4879 : {
4880 26093 : ts->type = BT_DERIVED;
4881 : /* We accept record/s/ or type(s) where s is a structure, but we
4882 : * don't need all the extra derived-type stuff for structures. */
4883 26093 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4884 : {
4885 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4886 1 : return MATCH_ERROR;
4887 : }
4888 :
4889 26092 : if (sym && sym->attr.flavor == FL_DERIVED
4890 25327 : && sym->attr.pdt_template
4891 994 : && gfc_current_state () != COMP_DERIVED)
4892 : {
4893 879 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4894 879 : if (m != MATCH_YES)
4895 : return m;
4896 864 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4897 864 : ts->u.derived = sym;
4898 864 : const char* lower = gfc_dt_lower_string (sym->name);
4899 864 : size_t len = strlen (lower);
4900 : /* Reallocate with sufficient size. */
4901 864 : if (len > GFC_MAX_SYMBOL_LEN)
4902 2 : name = XALLOCAVEC (char, len + 1);
4903 864 : memcpy (name, lower, len);
4904 864 : name[len] = '\0';
4905 : }
4906 :
4907 26077 : if (sym && sym->attr.flavor == FL_STRUCT)
4908 : {
4909 361 : ts->u.derived = sym;
4910 361 : return MATCH_YES;
4911 : }
4912 : /* Actually a derived type. */
4913 : }
4914 :
4915 : else
4916 : {
4917 : /* Match nested STRUCTURE declarations; only valid within another
4918 : structure declaration. */
4919 959471 : if (flag_dec_structure
4920 8032 : && (gfc_current_state () == COMP_STRUCTURE
4921 7570 : || gfc_current_state () == COMP_MAP))
4922 : {
4923 732 : m = gfc_match (" structure");
4924 732 : if (m == MATCH_YES)
4925 : {
4926 27 : m = gfc_match_structure_decl ();
4927 27 : if (m == MATCH_YES)
4928 : {
4929 : /* gfc_new_block is updated by match_structure_decl. */
4930 26 : ts->type = BT_DERIVED;
4931 26 : ts->u.derived = gfc_new_block;
4932 26 : return MATCH_YES;
4933 : }
4934 : }
4935 706 : if (m == MATCH_ERROR)
4936 : return MATCH_ERROR;
4937 : }
4938 :
4939 : /* Match CLASS declarations. */
4940 959444 : m = gfc_match (" class ( * )");
4941 959444 : if (m == MATCH_ERROR)
4942 : return MATCH_ERROR;
4943 959444 : else if (m == MATCH_YES)
4944 : {
4945 1910 : gfc_symbol *upe;
4946 1910 : gfc_symtree *st;
4947 1910 : ts->type = BT_CLASS;
4948 1910 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4949 1910 : if (upe == NULL)
4950 : {
4951 1168 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4952 1168 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4953 1168 : st->n.sym = upe;
4954 1168 : gfc_set_sym_referenced (upe);
4955 1168 : upe->refs++;
4956 1168 : upe->ts.type = BT_VOID;
4957 1168 : upe->attr.unlimited_polymorphic = 1;
4958 : /* This is essential to force the construction of
4959 : unlimited polymorphic component class containers. */
4960 1168 : upe->attr.zero_comp = 1;
4961 1168 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4962 : &gfc_current_locus))
4963 : return MATCH_ERROR;
4964 : }
4965 : else
4966 : {
4967 742 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4968 742 : st->n.sym = upe;
4969 742 : upe->refs++;
4970 : }
4971 1910 : ts->u.derived = upe;
4972 1910 : return m;
4973 : }
4974 :
4975 957534 : m = gfc_match (" class (");
4976 :
4977 957534 : if (m == MATCH_YES)
4978 9015 : m = gfc_match ("%n", name);
4979 : else
4980 : return m;
4981 :
4982 9015 : if (m != MATCH_YES)
4983 : return m;
4984 9015 : ts->type = BT_CLASS;
4985 :
4986 9015 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4987 : return MATCH_ERROR;
4988 :
4989 9014 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4990 9014 : if (m == MATCH_ERROR)
4991 : return m;
4992 :
4993 9014 : m = gfc_match_char (')');
4994 9014 : if (m != MATCH_YES)
4995 : return m;
4996 : }
4997 :
4998 : /* This picks up function declarations with a PDT typespec. Since a
4999 : pdt_type has been generated, there is no more to do. Within the
5000 : function body, this type must be used for the typespec so that
5001 : the "being used before it is defined warning" does not arise. */
5002 34730 : if (ts->type == BT_DERIVED
5003 25716 : && sym && sym->attr.pdt_type
5004 35594 : && (gfc_current_state () == COMP_CONTAINS
5005 848 : || (gfc_current_state () == COMP_FUNCTION
5006 268 : && gfc_current_block ()->ts.type == BT_DERIVED
5007 60 : && gfc_current_block ()->ts.u.derived == sym
5008 30 : && !gfc_find_symtree (gfc_current_ns->sym_root,
5009 : sym->name))))
5010 : {
5011 42 : if (gfc_current_state () == COMP_FUNCTION)
5012 : {
5013 26 : gfc_symtree *pdt_st;
5014 26 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
5015 : sym->name);
5016 26 : pdt_st->n.sym = sym;
5017 26 : sym->refs++;
5018 : }
5019 42 : ts->u.derived = sym;
5020 42 : return MATCH_YES;
5021 : }
5022 :
5023 : /* Defer association of the derived type until the end of the
5024 : specification block. However, if the derived type can be
5025 : found, add it to the typespec. */
5026 34688 : if (gfc_matching_function)
5027 : {
5028 1042 : ts->u.derived = NULL;
5029 1042 : if (gfc_current_state () != COMP_INTERFACE
5030 1042 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
5031 : {
5032 512 : sym = gfc_find_dt_in_generic (sym);
5033 512 : ts->u.derived = sym;
5034 : }
5035 1042 : return MATCH_YES;
5036 : }
5037 :
5038 : /* Search for the name but allow the components to be defined later. If
5039 : type = -1, this typespec has been seen in a function declaration but
5040 : the type could not be accessed at that point. The actual derived type is
5041 : stored in a symtree with the first letter of the name capitalized; the
5042 : symtree with the all lower-case name contains the associated
5043 : generic function. */
5044 33646 : dt_name = gfc_dt_upper_string (name);
5045 33646 : sym = NULL;
5046 33646 : dt_sym = NULL;
5047 33646 : if (ts->kind != -1)
5048 : {
5049 32435 : gfc_get_ha_symbol (name, &sym);
5050 32435 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
5051 : {
5052 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5053 0 : return MATCH_ERROR;
5054 : }
5055 32435 : if (sym->generic && !dt_sym)
5056 13391 : dt_sym = gfc_find_dt_in_generic (sym);
5057 :
5058 : /* Host associated PDTs can get confused with their constructors
5059 : because they are instantiated in the template's namespace. */
5060 32435 : if (!dt_sym)
5061 : {
5062 926 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5063 : {
5064 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5065 0 : return MATCH_ERROR;
5066 : }
5067 926 : if (dt_sym && !dt_sym->attr.pdt_type)
5068 0 : dt_sym = NULL;
5069 : }
5070 : }
5071 1211 : else if (ts->kind == -1)
5072 : {
5073 2422 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
5074 1211 : || gfc_current_ns->has_import_set;
5075 1211 : gfc_find_symbol (name, NULL, iface, &sym);
5076 1211 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5077 : {
5078 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5079 0 : return MATCH_ERROR;
5080 : }
5081 1211 : if (sym && sym->generic && !dt_sym)
5082 0 : dt_sym = gfc_find_dt_in_generic (sym);
5083 :
5084 1211 : ts->kind = 0;
5085 1211 : if (sym == NULL)
5086 : return MATCH_NO;
5087 : }
5088 :
5089 33629 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
5090 32919 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
5091 33627 : || sym->attr.subroutine)
5092 : {
5093 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
5094 : "entity at %L, which has the same name", name,
5095 : &sym->declared_at);
5096 2 : return MATCH_ERROR;
5097 : }
5098 :
5099 33627 : if (dt_sym && decl_type_param_list
5100 892 : && dt_sym->attr.flavor == FL_DERIVED
5101 892 : && !dt_sym->attr.pdt_type
5102 232 : && !dt_sym->attr.pdt_template)
5103 : {
5104 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5105 : "list at %C may not appear", dt_sym->name);
5106 1 : return MATCH_ERROR;
5107 : }
5108 :
5109 33626 : if (sym && sym->attr.flavor == FL_DERIVED
5110 : && sym->attr.pdt_template
5111 : && gfc_current_state () != COMP_DERIVED)
5112 : {
5113 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5114 : if (m != MATCH_YES)
5115 : return m;
5116 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5117 : ts->u.derived = sym;
5118 : strcpy (name, gfc_dt_lower_string (sym->name));
5119 : }
5120 :
5121 33626 : gfc_save_symbol_data (sym);
5122 33626 : gfc_set_sym_referenced (sym);
5123 33626 : if (!sym->attr.generic
5124 33626 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5125 : return MATCH_ERROR;
5126 :
5127 33626 : if (!sym->attr.function
5128 33626 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5129 : return MATCH_ERROR;
5130 :
5131 33626 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5132 33494 : && dt_sym->attr.pdt_template
5133 242 : && gfc_current_state () != COMP_DERIVED)
5134 : {
5135 121 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5136 121 : if (m != MATCH_YES)
5137 : return m;
5138 121 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5139 : }
5140 :
5141 33626 : if (!dt_sym)
5142 : {
5143 132 : gfc_interface *intr, *head;
5144 :
5145 : /* Use upper case to save the actual derived-type symbol. */
5146 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5147 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5148 132 : head = sym->generic;
5149 132 : intr = gfc_get_interface ();
5150 132 : intr->sym = dt_sym;
5151 132 : intr->where = gfc_current_locus;
5152 132 : intr->next = head;
5153 132 : sym->generic = intr;
5154 132 : sym->attr.if_source = IFSRC_DECL;
5155 : }
5156 : else
5157 33494 : gfc_save_symbol_data (dt_sym);
5158 :
5159 33626 : gfc_set_sym_referenced (dt_sym);
5160 :
5161 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5162 33758 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5163 : return MATCH_ERROR;
5164 :
5165 33626 : ts->u.derived = dt_sym;
5166 :
5167 33626 : return MATCH_YES;
5168 :
5169 157206 : get_kind:
5170 157206 : if (matched_type
5171 157206 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5172 : "intrinsic-type-spec at %C"))
5173 : return MATCH_ERROR;
5174 :
5175 : /* For all types except double, derived and character, look for an
5176 : optional kind specifier. MATCH_NO is actually OK at this point. */
5177 157203 : if (implicit_flag == 1)
5178 : {
5179 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5180 : return MATCH_ERROR;
5181 :
5182 223 : return MATCH_YES;
5183 : }
5184 :
5185 156980 : if (gfc_current_form == FORM_FREE)
5186 : {
5187 142345 : c = gfc_peek_ascii_char ();
5188 142345 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5189 70675 : && c != ':' && c != ',')
5190 : {
5191 167 : if (matched_type && c == ')')
5192 : {
5193 3 : gfc_next_ascii_char ();
5194 3 : return MATCH_YES;
5195 : }
5196 164 : gfc_error ("Malformed type-spec at %C");
5197 164 : return MATCH_NO;
5198 : }
5199 : }
5200 :
5201 156813 : m = gfc_match_kind_spec (ts, false);
5202 156813 : if (m == MATCH_ERROR)
5203 : return MATCH_ERROR;
5204 :
5205 156777 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5206 : {
5207 107249 : m = gfc_match_old_kind_spec (ts);
5208 107249 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5209 : return MATCH_ERROR;
5210 : }
5211 :
5212 156769 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5213 : {
5214 0 : gfc_error ("Malformed type-spec at %C");
5215 0 : return MATCH_ERROR;
5216 : }
5217 :
5218 : /* Defer association of the KIND expression of function results
5219 : until after USE and IMPORT statements. */
5220 4450 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5221 161192 : || gfc_matching_function)
5222 7229 : return MATCH_YES;
5223 :
5224 149540 : if (m == MATCH_NO)
5225 151607 : m = MATCH_YES; /* No kind specifier found. */
5226 :
5227 : return m;
5228 : }
5229 :
5230 :
5231 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5232 : already matched in parse.cc, or we would not end up here in the
5233 : first place. So the only thing we need to check, is if there is
5234 : trailing garbage. If not, the match is successful. */
5235 :
5236 : match
5237 23883 : gfc_match_implicit_none (void)
5238 : {
5239 23883 : char c;
5240 23883 : match m;
5241 23883 : char name[GFC_MAX_SYMBOL_LEN + 1];
5242 23883 : bool type = false;
5243 23883 : bool external = false;
5244 23883 : locus cur_loc = gfc_current_locus;
5245 :
5246 23883 : if (gfc_current_ns->seen_implicit_none
5247 23881 : || gfc_current_ns->has_implicit_none_export)
5248 : {
5249 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5250 4 : return MATCH_ERROR;
5251 : }
5252 :
5253 23879 : gfc_gobble_whitespace ();
5254 23879 : c = gfc_peek_ascii_char ();
5255 23879 : if (c == '(')
5256 : {
5257 1106 : (void) gfc_next_ascii_char ();
5258 1106 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5259 : return MATCH_ERROR;
5260 :
5261 1105 : gfc_gobble_whitespace ();
5262 1105 : if (gfc_peek_ascii_char () == ')')
5263 : {
5264 1 : (void) gfc_next_ascii_char ();
5265 1 : type = true;
5266 : }
5267 : else
5268 3288 : for(;;)
5269 : {
5270 2196 : m = gfc_match (" %n", name);
5271 2196 : if (m != MATCH_YES)
5272 : return MATCH_ERROR;
5273 :
5274 2196 : if (strcmp (name, "type") == 0)
5275 : type = true;
5276 1104 : else if (strcmp (name, "external") == 0)
5277 : external = true;
5278 : else
5279 : return MATCH_ERROR;
5280 :
5281 2196 : gfc_gobble_whitespace ();
5282 2196 : c = gfc_next_ascii_char ();
5283 2196 : if (c == ',')
5284 1092 : continue;
5285 1104 : if (c == ')')
5286 : break;
5287 : return MATCH_ERROR;
5288 : }
5289 : }
5290 : else
5291 : type = true;
5292 :
5293 23878 : if (gfc_match_eos () != MATCH_YES)
5294 : return MATCH_ERROR;
5295 :
5296 23878 : gfc_set_implicit_none (type, external, &cur_loc);
5297 :
5298 23878 : return MATCH_YES;
5299 : }
5300 :
5301 :
5302 : /* Match the letter range(s) of an IMPLICIT statement. */
5303 :
5304 : static match
5305 600 : match_implicit_range (void)
5306 : {
5307 600 : char c, c1, c2;
5308 600 : int inner;
5309 600 : locus cur_loc;
5310 :
5311 600 : cur_loc = gfc_current_locus;
5312 :
5313 600 : gfc_gobble_whitespace ();
5314 600 : c = gfc_next_ascii_char ();
5315 600 : if (c != '(')
5316 : {
5317 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5318 59 : goto bad;
5319 : }
5320 :
5321 : inner = 1;
5322 1195 : while (inner)
5323 : {
5324 722 : gfc_gobble_whitespace ();
5325 722 : c1 = gfc_next_ascii_char ();
5326 722 : if (!ISALPHA (c1))
5327 33 : goto bad;
5328 :
5329 689 : gfc_gobble_whitespace ();
5330 689 : c = gfc_next_ascii_char ();
5331 :
5332 689 : switch (c)
5333 : {
5334 201 : case ')':
5335 201 : inner = 0; /* Fall through. */
5336 :
5337 : case ',':
5338 : c2 = c1;
5339 : break;
5340 :
5341 439 : case '-':
5342 439 : gfc_gobble_whitespace ();
5343 439 : c2 = gfc_next_ascii_char ();
5344 439 : if (!ISALPHA (c2))
5345 0 : goto bad;
5346 :
5347 439 : gfc_gobble_whitespace ();
5348 439 : c = gfc_next_ascii_char ();
5349 :
5350 439 : if ((c != ',') && (c != ')'))
5351 0 : goto bad;
5352 439 : if (c == ')')
5353 272 : inner = 0;
5354 :
5355 : break;
5356 :
5357 35 : default:
5358 35 : goto bad;
5359 : }
5360 :
5361 654 : if (c1 > c2)
5362 : {
5363 0 : gfc_error ("Letters must be in alphabetic order in "
5364 : "IMPLICIT statement at %C");
5365 0 : goto bad;
5366 : }
5367 :
5368 : /* See if we can add the newly matched range to the pending
5369 : implicits from this IMPLICIT statement. We do not check for
5370 : conflicts with whatever earlier IMPLICIT statements may have
5371 : set. This is done when we've successfully finished matching
5372 : the current one. */
5373 654 : if (!gfc_add_new_implicit_range (c1, c2))
5374 0 : goto bad;
5375 : }
5376 :
5377 : return MATCH_YES;
5378 :
5379 127 : bad:
5380 127 : gfc_syntax_error (ST_IMPLICIT);
5381 :
5382 127 : gfc_current_locus = cur_loc;
5383 127 : return MATCH_ERROR;
5384 : }
5385 :
5386 :
5387 : /* Match an IMPLICIT statement, storing the types for
5388 : gfc_set_implicit() if the statement is accepted by the parser.
5389 : There is a strange looking, but legal syntactic construction
5390 : possible. It looks like:
5391 :
5392 : IMPLICIT INTEGER (a-b) (c-d)
5393 :
5394 : This is legal if "a-b" is a constant expression that happens to
5395 : equal one of the legal kinds for integers. The real problem
5396 : happens with an implicit specification that looks like:
5397 :
5398 : IMPLICIT INTEGER (a-b)
5399 :
5400 : In this case, a typespec matcher that is "greedy" (as most of the
5401 : matchers are) gobbles the character range as a kindspec, leaving
5402 : nothing left. We therefore have to go a bit more slowly in the
5403 : matching process by inhibiting the kindspec checking during
5404 : typespec matching and checking for a kind later. */
5405 :
5406 : match
5407 24309 : gfc_match_implicit (void)
5408 : {
5409 24309 : gfc_typespec ts;
5410 24309 : locus cur_loc;
5411 24309 : char c;
5412 24309 : match m;
5413 :
5414 24309 : if (gfc_current_ns->seen_implicit_none)
5415 : {
5416 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5417 : "statement");
5418 4 : return MATCH_ERROR;
5419 : }
5420 :
5421 24305 : gfc_clear_ts (&ts);
5422 :
5423 : /* We don't allow empty implicit statements. */
5424 24305 : if (gfc_match_eos () == MATCH_YES)
5425 : {
5426 0 : gfc_error ("Empty IMPLICIT statement at %C");
5427 0 : return MATCH_ERROR;
5428 : }
5429 :
5430 24334 : do
5431 : {
5432 : /* First cleanup. */
5433 24334 : gfc_clear_new_implicit ();
5434 :
5435 : /* A basic type is mandatory here. */
5436 24334 : m = gfc_match_decl_type_spec (&ts, 1);
5437 24334 : if (m == MATCH_ERROR)
5438 0 : goto error;
5439 24334 : if (m == MATCH_NO)
5440 23881 : goto syntax;
5441 :
5442 453 : cur_loc = gfc_current_locus;
5443 453 : m = match_implicit_range ();
5444 :
5445 453 : if (m == MATCH_YES)
5446 : {
5447 : /* We may have <TYPE> (<RANGE>). */
5448 326 : gfc_gobble_whitespace ();
5449 326 : c = gfc_peek_ascii_char ();
5450 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5451 : {
5452 : /* Check for CHARACTER with no length parameter. */
5453 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5454 : {
5455 32 : ts.kind = gfc_default_character_kind;
5456 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5457 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5458 : NULL, 1);
5459 : }
5460 :
5461 : /* Record the Successful match. */
5462 299 : if (!gfc_merge_new_implicit (&ts))
5463 : return MATCH_ERROR;
5464 297 : if (c == ',')
5465 28 : c = gfc_next_ascii_char ();
5466 269 : else if (gfc_match_eos () == MATCH_ERROR)
5467 0 : goto error;
5468 297 : continue;
5469 : }
5470 :
5471 27 : gfc_current_locus = cur_loc;
5472 : }
5473 :
5474 : /* Discard the (incorrectly) matched range. */
5475 154 : gfc_clear_new_implicit ();
5476 :
5477 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5478 154 : if (ts.type == BT_CHARACTER)
5479 74 : m = gfc_match_char_spec (&ts);
5480 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5481 : {
5482 76 : m = gfc_match_kind_spec (&ts, false);
5483 76 : if (m == MATCH_NO)
5484 : {
5485 40 : m = gfc_match_old_kind_spec (&ts);
5486 40 : if (m == MATCH_ERROR)
5487 0 : goto error;
5488 40 : if (m == MATCH_NO)
5489 0 : goto syntax;
5490 : }
5491 : }
5492 154 : if (m == MATCH_ERROR)
5493 7 : goto error;
5494 :
5495 147 : m = match_implicit_range ();
5496 147 : if (m == MATCH_ERROR)
5497 0 : goto error;
5498 147 : if (m == MATCH_NO)
5499 : goto syntax;
5500 :
5501 147 : gfc_gobble_whitespace ();
5502 147 : c = gfc_next_ascii_char ();
5503 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5504 0 : goto syntax;
5505 :
5506 147 : if (!gfc_merge_new_implicit (&ts))
5507 : return MATCH_ERROR;
5508 : }
5509 444 : while (c == ',');
5510 :
5511 : return MATCH_YES;
5512 :
5513 23881 : syntax:
5514 23881 : gfc_syntax_error (ST_IMPLICIT);
5515 :
5516 : error:
5517 : return MATCH_ERROR;
5518 : }
5519 :
5520 :
5521 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5522 :
5523 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5524 :
5525 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5526 :
5527 : C1211 (R1209) Each import-name shall be the name of an entity in the
5528 : host scoping unit.
5529 :
5530 : under the description of an interface block. Under F2008, IMPORT was
5531 : split out of the interface block description to 12.4.3.3 and C1210
5532 : became
5533 :
5534 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5535 : that is not a module procedure interface body.
5536 :
5537 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5538 :
5539 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5540 : or IMPORT, ONLY : import-name-list
5541 : or IMPORT, NONE
5542 : or IMPORT, ALL
5543 :
5544 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5545 : a main-program, external-subprogram, module, or block-data.
5546 :
5547 : C897 (R867) Each import-name shall be the name of an entity in the host
5548 : scoping unit.
5549 :
5550 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5551 : all IMPORT statements in that scoping unit shall have an ONLY
5552 : specifier.
5553 :
5554 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5555 :
5556 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5557 : unit, no other IMPORT statement shall appear in that scoping unit.
5558 :
5559 : C8101 Within an interface body, an entity that is accessed by host
5560 : association shall be accessible by host or use association within
5561 : the host scoping unit, or explicitly declared prior to the interface
5562 : body.
5563 :
5564 : C8102 An entity whose name appears as an import-name or which is made
5565 : accessible by an IMPORT, ALL statement shall not appear in any
5566 : context described in 19.5.1.4 that would cause the host entity
5567 : of that name to be inaccessible. */
5568 :
5569 : match
5570 4025 : gfc_match_import (void)
5571 : {
5572 4025 : char name[GFC_MAX_SYMBOL_LEN + 1];
5573 4025 : match m;
5574 4025 : gfc_symbol *sym;
5575 4025 : gfc_symtree *st;
5576 4025 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5577 4025 : importstate current_import_state = gfc_current_ns->import_state;
5578 :
5579 4025 : if (!f2018_allowed
5580 13 : && (gfc_current_ns->proc_name == NULL
5581 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5582 : {
5583 3 : gfc_error ("IMPORT statement at %C only permitted in "
5584 : "an INTERFACE body");
5585 3 : return MATCH_ERROR;
5586 : }
5587 : else if (f2018_allowed
5588 4012 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5589 4 : goto C897;
5590 :
5591 4008 : if (f2018_allowed
5592 4008 : && (current_import_state == IMPORT_ALL
5593 4008 : || current_import_state == IMPORT_NONE))
5594 2 : goto C8100;
5595 :
5596 4016 : if (gfc_current_ns->proc_name
5597 4015 : && gfc_current_ns->proc_name->attr.module_procedure)
5598 : {
5599 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5600 : "in a module procedure interface body");
5601 1 : return MATCH_ERROR;
5602 : }
5603 :
5604 4015 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5605 : return MATCH_ERROR;
5606 :
5607 4011 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5608 4011 : if (f2018_allowed)
5609 : {
5610 4005 : if (gfc_match (" , none") == MATCH_YES)
5611 : {
5612 8 : if (current_import_state == IMPORT_ONLY)
5613 0 : goto C898;
5614 8 : if (gfc_current_state () == COMP_SUBMODULE)
5615 0 : goto C899;
5616 8 : gfc_current_ns->import_state = IMPORT_NONE;
5617 : }
5618 3997 : else if (gfc_match (" , only :") == MATCH_YES)
5619 : {
5620 19 : if (current_import_state != IMPORT_NOT_SET
5621 19 : && current_import_state != IMPORT_ONLY)
5622 0 : goto C898;
5623 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5624 : }
5625 3978 : else if (gfc_match (" , all") == MATCH_YES)
5626 : {
5627 1 : if (current_import_state == IMPORT_ONLY)
5628 0 : goto C898;
5629 1 : gfc_current_ns->import_state = IMPORT_ALL;
5630 : }
5631 :
5632 4005 : if (current_import_state != IMPORT_NOT_SET
5633 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5634 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5635 0 : goto C8100;
5636 : }
5637 :
5638 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5639 4011 : if (gfc_match_eos () == MATCH_YES)
5640 : {
5641 : /* This is the F2008 variant. */
5642 336 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5643 : {
5644 327 : if (current_import_state == IMPORT_ONLY)
5645 0 : goto C898;
5646 327 : gfc_current_ns->import_state = IMPORT_F2008;
5647 : }
5648 :
5649 : /* Host variables should be imported. */
5650 336 : if (gfc_current_ns->import_state != IMPORT_NONE)
5651 328 : gfc_current_ns->has_import_set = 1;
5652 336 : return MATCH_YES;
5653 : }
5654 :
5655 3675 : if (gfc_match (" ::") == MATCH_YES
5656 3675 : && gfc_current_ns->import_state != IMPORT_ONLY)
5657 : {
5658 1167 : if (gfc_match_eos () == MATCH_YES)
5659 1 : goto expecting_list;
5660 1166 : gfc_current_ns->import_state = IMPORT_F2008;
5661 : }
5662 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5663 : {
5664 19 : if (gfc_match_eos () == MATCH_YES)
5665 0 : goto expecting_list;
5666 : }
5667 :
5668 4363 : for(;;)
5669 : {
5670 4363 : sym = NULL;
5671 4363 : m = gfc_match (" %n", name);
5672 4363 : switch (m)
5673 : {
5674 4363 : case MATCH_YES:
5675 : /* Before checking if the symbol is available from host
5676 : association into a SUBROUTINE or FUNCTION within an
5677 : INTERFACE, check if it is already in local scope. */
5678 4363 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5679 4363 : if (sym
5680 25 : && gfc_state_stack->previous
5681 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5682 : {
5683 2 : gfc_error ("import-name %qs at %C is in the "
5684 : "local scope", name);
5685 2 : return MATCH_ERROR;
5686 : }
5687 :
5688 4361 : if (gfc_current_ns->parent != NULL
5689 4361 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5690 : {
5691 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5692 0 : return MATCH_ERROR;
5693 : }
5694 4361 : else if (!sym
5695 5 : && gfc_current_ns->proc_name
5696 4 : && gfc_current_ns->proc_name->ns->parent
5697 4362 : && gfc_find_symbol (name,
5698 : gfc_current_ns->proc_name->ns->parent,
5699 : 1, &sym))
5700 : {
5701 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5702 0 : return MATCH_ERROR;
5703 : }
5704 :
5705 4361 : if (sym == NULL)
5706 : {
5707 5 : if (gfc_current_ns->proc_name
5708 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5709 : {
5710 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5711 : "at %C - does not exist.", name);
5712 1 : return MATCH_ERROR;
5713 : }
5714 : else
5715 : {
5716 : /* This might be a procedure that has not yet been parsed. If
5717 : so gfc_fixup_sibling_symbols will replace this symbol with
5718 : that of the procedure. */
5719 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5720 : &gfc_current_locus);
5721 4 : st->n.sym->refs++;
5722 4 : st->n.sym->attr.imported = 1;
5723 4 : st->import_only = 1;
5724 4 : goto next_item;
5725 : }
5726 : }
5727 :
5728 4356 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5729 4356 : if (st && st->n.sym && st->n.sym->attr.imported)
5730 : {
5731 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5732 : "at %C", name);
5733 0 : goto next_item;
5734 : }
5735 :
5736 4356 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5737 4356 : st->n.sym = sym;
5738 4356 : sym->refs++;
5739 4356 : sym->attr.imported = 1;
5740 4356 : st->import_only = 1;
5741 :
5742 4356 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5743 : {
5744 : /* The actual derived type is stored in a symtree with the first
5745 : letter of the name capitalized; the symtree with the all
5746 : lower-case name contains the associated generic function. */
5747 599 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5748 : gfc_dt_upper_string (name));
5749 599 : st->n.sym = sym;
5750 599 : sym->refs++;
5751 599 : sym->attr.imported = 1;
5752 599 : st->import_only = 1;
5753 : }
5754 :
5755 4356 : goto next_item;
5756 :
5757 : case MATCH_NO:
5758 : break;
5759 :
5760 : case MATCH_ERROR:
5761 : return MATCH_ERROR;
5762 : }
5763 :
5764 4360 : next_item:
5765 4360 : if (gfc_match_eos () == MATCH_YES)
5766 : break;
5767 689 : if (gfc_match_char (',') != MATCH_YES)
5768 0 : goto syntax;
5769 : }
5770 :
5771 : return MATCH_YES;
5772 :
5773 0 : syntax:
5774 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5775 0 : return MATCH_ERROR;
5776 :
5777 4 : C897:
5778 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5779 : "program, an external subprogram, a module or block data");
5780 4 : return MATCH_ERROR;
5781 :
5782 0 : C898:
5783 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5784 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5785 : "with an ONLY specifier");
5786 0 : return MATCH_ERROR;
5787 :
5788 0 : C899:
5789 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5790 : " of a submodule as at %C");
5791 0 : return MATCH_ERROR;
5792 :
5793 2 : C8100:
5794 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5795 : "%s has already been declared, which must be unique in the "
5796 : "scoping unit",
5797 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5798 : "IMPORT, NONE");
5799 2 : return MATCH_ERROR;
5800 :
5801 1 : expecting_list:
5802 1 : gfc_error ("Expecting list of named entities at %C");
5803 1 : return MATCH_ERROR;
5804 : }
5805 :
5806 :
5807 : /* A minimal implementation of gfc_match without whitespace, escape
5808 : characters or variable arguments. Returns true if the next
5809 : characters match the TARGET template exactly. */
5810 :
5811 : static bool
5812 145033 : match_string_p (const char *target)
5813 : {
5814 145033 : const char *p;
5815 :
5816 914537 : for (p = target; *p; p++)
5817 769505 : if ((char) gfc_next_ascii_char () != *p)
5818 : return false;
5819 : return true;
5820 : }
5821 :
5822 : /* Matches an attribute specification including array specs. If
5823 : successful, leaves the variables current_attr and current_as
5824 : holding the specification. Also sets the colon_seen variable for
5825 : later use by matchers associated with initializations.
5826 :
5827 : This subroutine is a little tricky in the sense that we don't know
5828 : if we really have an attr-spec until we hit the double colon.
5829 : Until that time, we can only return MATCH_NO. This forces us to
5830 : check for duplicate specification at this level. */
5831 :
5832 : static match
5833 215289 : match_attr_spec (void)
5834 : {
5835 : /* Modifiers that can exist in a type statement. */
5836 215289 : enum
5837 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5838 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5839 : DECL_DIMENSION, DECL_EXTERNAL,
5840 : DECL_INTRINSIC, DECL_OPTIONAL,
5841 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5842 : DECL_STATIC, DECL_AUTOMATIC,
5843 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5844 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5845 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5846 : };
5847 :
5848 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5849 : #define NUM_DECL GFC_DECL_END
5850 :
5851 : /* Make sure that values from sym_intent are safe to be used here. */
5852 215289 : gcc_assert (INTENT_IN > 0);
5853 :
5854 215289 : locus start, seen_at[NUM_DECL];
5855 215289 : int seen[NUM_DECL];
5856 215289 : unsigned int d;
5857 215289 : const char *attr;
5858 215289 : match m;
5859 215289 : bool t;
5860 :
5861 215289 : gfc_clear_attr (¤t_attr);
5862 215289 : start = gfc_current_locus;
5863 :
5864 215289 : current_as = NULL;
5865 215289 : colon_seen = 0;
5866 215289 : attr_seen = 0;
5867 :
5868 : /* See if we get all of the keywords up to the final double colon. */
5869 5812803 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5870 5597514 : seen[d] = 0;
5871 :
5872 333090 : for (;;)
5873 : {
5874 333090 : char ch;
5875 :
5876 333090 : d = DECL_NONE;
5877 333090 : gfc_gobble_whitespace ();
5878 :
5879 333090 : ch = gfc_next_ascii_char ();
5880 333090 : if (ch == ':')
5881 : {
5882 : /* This is the successful exit condition for the loop. */
5883 181622 : if (gfc_next_ascii_char () == ':')
5884 : break;
5885 : }
5886 151468 : else if (ch == ',')
5887 : {
5888 117813 : gfc_gobble_whitespace ();
5889 117813 : switch (gfc_peek_ascii_char ())
5890 : {
5891 18387 : case 'a':
5892 18387 : gfc_next_ascii_char ();
5893 18387 : switch (gfc_next_ascii_char ())
5894 : {
5895 18321 : case 'l':
5896 18321 : if (match_string_p ("locatable"))
5897 : {
5898 : /* Matched "allocatable". */
5899 : d = DECL_ALLOCATABLE;
5900 : }
5901 : break;
5902 :
5903 25 : case 's':
5904 25 : if (match_string_p ("ynchronous"))
5905 : {
5906 : /* Matched "asynchronous". */
5907 : d = DECL_ASYNCHRONOUS;
5908 : }
5909 : break;
5910 :
5911 41 : case 'u':
5912 41 : if (match_string_p ("tomatic"))
5913 : {
5914 : /* Matched "automatic". */
5915 : d = DECL_AUTOMATIC;
5916 : }
5917 : break;
5918 : }
5919 : break;
5920 :
5921 163 : case 'b':
5922 : /* Try and match the bind(c). */
5923 163 : m = gfc_match_bind_c (NULL, true);
5924 163 : if (m == MATCH_YES)
5925 : d = DECL_IS_BIND_C;
5926 0 : else if (m == MATCH_ERROR)
5927 0 : goto cleanup;
5928 : break;
5929 :
5930 2146 : case 'c':
5931 2146 : gfc_next_ascii_char ();
5932 2146 : if ('o' != gfc_next_ascii_char ())
5933 : break;
5934 2145 : switch (gfc_next_ascii_char ())
5935 : {
5936 68 : case 'd':
5937 68 : if (match_string_p ("imension"))
5938 : {
5939 : d = DECL_CODIMENSION;
5940 : break;
5941 : }
5942 : /* FALLTHRU */
5943 2077 : case 'n':
5944 2077 : if (match_string_p ("tiguous"))
5945 : {
5946 : d = DECL_CONTIGUOUS;
5947 : break;
5948 : }
5949 : }
5950 : break;
5951 :
5952 19645 : case 'd':
5953 19645 : if (match_string_p ("dimension"))
5954 : d = DECL_DIMENSION;
5955 : break;
5956 :
5957 177 : case 'e':
5958 177 : if (match_string_p ("external"))
5959 : d = DECL_EXTERNAL;
5960 : break;
5961 :
5962 27384 : case 'i':
5963 27384 : if (match_string_p ("int"))
5964 : {
5965 27384 : ch = gfc_next_ascii_char ();
5966 27384 : if (ch == 'e')
5967 : {
5968 27378 : if (match_string_p ("nt"))
5969 : {
5970 : /* Matched "intent". */
5971 27377 : d = match_intent_spec ();
5972 27377 : if (d == INTENT_UNKNOWN)
5973 : {
5974 2 : m = MATCH_ERROR;
5975 2 : goto cleanup;
5976 : }
5977 : }
5978 : }
5979 6 : else if (ch == 'r')
5980 : {
5981 6 : if (match_string_p ("insic"))
5982 : {
5983 : /* Matched "intrinsic". */
5984 : d = DECL_INTRINSIC;
5985 : }
5986 : }
5987 : }
5988 : break;
5989 :
5990 293 : case 'k':
5991 293 : if (match_string_p ("kind"))
5992 : d = DECL_KIND;
5993 : break;
5994 :
5995 301 : case 'l':
5996 301 : if (match_string_p ("len"))
5997 : d = DECL_LEN;
5998 : break;
5999 :
6000 5054 : case 'o':
6001 5054 : if (match_string_p ("optional"))
6002 : d = DECL_OPTIONAL;
6003 : break;
6004 :
6005 27046 : case 'p':
6006 27046 : gfc_next_ascii_char ();
6007 27046 : switch (gfc_next_ascii_char ())
6008 : {
6009 14259 : case 'a':
6010 14259 : if (match_string_p ("rameter"))
6011 : {
6012 : /* Matched "parameter". */
6013 : d = DECL_PARAMETER;
6014 : }
6015 : break;
6016 :
6017 12268 : case 'o':
6018 12268 : if (match_string_p ("inter"))
6019 : {
6020 : /* Matched "pointer". */
6021 : d = DECL_POINTER;
6022 : }
6023 : break;
6024 :
6025 267 : case 'r':
6026 267 : ch = gfc_next_ascii_char ();
6027 267 : if (ch == 'i')
6028 : {
6029 216 : if (match_string_p ("vate"))
6030 : {
6031 : /* Matched "private". */
6032 : d = DECL_PRIVATE;
6033 : }
6034 : }
6035 51 : else if (ch == 'o')
6036 : {
6037 51 : if (match_string_p ("tected"))
6038 : {
6039 : /* Matched "protected". */
6040 : d = DECL_PROTECTED;
6041 : }
6042 : }
6043 : break;
6044 :
6045 252 : case 'u':
6046 252 : if (match_string_p ("blic"))
6047 : {
6048 : /* Matched "public". */
6049 : d = DECL_PUBLIC;
6050 : }
6051 : break;
6052 : }
6053 : break;
6054 :
6055 1216 : case 's':
6056 1216 : gfc_next_ascii_char ();
6057 1216 : switch (gfc_next_ascii_char ())
6058 : {
6059 1203 : case 'a':
6060 1203 : if (match_string_p ("ve"))
6061 : {
6062 : /* Matched "save". */
6063 : d = DECL_SAVE;
6064 : }
6065 : break;
6066 :
6067 13 : case 't':
6068 13 : if (match_string_p ("atic"))
6069 : {
6070 : /* Matched "static". */
6071 : d = DECL_STATIC;
6072 : }
6073 : break;
6074 : }
6075 : break;
6076 :
6077 5337 : case 't':
6078 5337 : if (match_string_p ("target"))
6079 : d = DECL_TARGET;
6080 : break;
6081 :
6082 10664 : case 'v':
6083 10664 : gfc_next_ascii_char ();
6084 10664 : ch = gfc_next_ascii_char ();
6085 10664 : if (ch == 'a')
6086 : {
6087 10155 : if (match_string_p ("lue"))
6088 : {
6089 : /* Matched "value". */
6090 : d = DECL_VALUE;
6091 : }
6092 : }
6093 509 : else if (ch == 'o')
6094 : {
6095 509 : if (match_string_p ("latile"))
6096 : {
6097 : /* Matched "volatile". */
6098 : d = DECL_VOLATILE;
6099 : }
6100 : }
6101 : break;
6102 : }
6103 : }
6104 :
6105 : /* No double colon and no recognizable decl_type, so assume that
6106 : we've been looking at something else the whole time. */
6107 : if (d == DECL_NONE)
6108 : {
6109 33658 : m = MATCH_NO;
6110 33658 : goto cleanup;
6111 : }
6112 :
6113 : /* Check to make sure any parens are paired up correctly. */
6114 117809 : if (gfc_match_parens () == MATCH_ERROR)
6115 : {
6116 1 : m = MATCH_ERROR;
6117 1 : goto cleanup;
6118 : }
6119 :
6120 117808 : seen[d]++;
6121 117808 : seen_at[d] = gfc_current_locus;
6122 :
6123 117808 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6124 : {
6125 19712 : gfc_array_spec *as = NULL;
6126 :
6127 19712 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6128 : d == DECL_CODIMENSION);
6129 :
6130 19712 : if (current_as == NULL)
6131 19687 : current_as = as;
6132 25 : else if (m == MATCH_YES)
6133 : {
6134 25 : if (!merge_array_spec (as, current_as, false))
6135 2 : m = MATCH_ERROR;
6136 25 : free (as);
6137 : }
6138 :
6139 19712 : if (m == MATCH_NO)
6140 : {
6141 0 : if (d == DECL_CODIMENSION)
6142 0 : gfc_error ("Missing codimension specification at %C");
6143 : else
6144 0 : gfc_error ("Missing dimension specification at %C");
6145 : m = MATCH_ERROR;
6146 : }
6147 :
6148 19712 : if (m == MATCH_ERROR)
6149 7 : goto cleanup;
6150 : }
6151 : }
6152 :
6153 : /* Since we've seen a double colon, we have to be looking at an
6154 : attr-spec. This means that we can now issue errors. */
6155 4903746 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6156 4722127 : if (seen[d] > 1)
6157 : {
6158 2 : switch (d)
6159 : {
6160 : case DECL_ALLOCATABLE:
6161 : attr = "ALLOCATABLE";
6162 : break;
6163 0 : case DECL_ASYNCHRONOUS:
6164 0 : attr = "ASYNCHRONOUS";
6165 0 : break;
6166 0 : case DECL_CODIMENSION:
6167 0 : attr = "CODIMENSION";
6168 0 : break;
6169 0 : case DECL_CONTIGUOUS:
6170 0 : attr = "CONTIGUOUS";
6171 0 : break;
6172 0 : case DECL_DIMENSION:
6173 0 : attr = "DIMENSION";
6174 0 : break;
6175 0 : case DECL_EXTERNAL:
6176 0 : attr = "EXTERNAL";
6177 0 : break;
6178 0 : case DECL_IN:
6179 0 : attr = "INTENT (IN)";
6180 0 : break;
6181 0 : case DECL_OUT:
6182 0 : attr = "INTENT (OUT)";
6183 0 : break;
6184 0 : case DECL_INOUT:
6185 0 : attr = "INTENT (IN OUT)";
6186 0 : break;
6187 0 : case DECL_INTRINSIC:
6188 0 : attr = "INTRINSIC";
6189 0 : break;
6190 0 : case DECL_OPTIONAL:
6191 0 : attr = "OPTIONAL";
6192 0 : break;
6193 0 : case DECL_KIND:
6194 0 : attr = "KIND";
6195 0 : break;
6196 0 : case DECL_LEN:
6197 0 : attr = "LEN";
6198 0 : break;
6199 0 : case DECL_PARAMETER:
6200 0 : attr = "PARAMETER";
6201 0 : break;
6202 0 : case DECL_POINTER:
6203 0 : attr = "POINTER";
6204 0 : break;
6205 0 : case DECL_PROTECTED:
6206 0 : attr = "PROTECTED";
6207 0 : break;
6208 0 : case DECL_PRIVATE:
6209 0 : attr = "PRIVATE";
6210 0 : break;
6211 0 : case DECL_PUBLIC:
6212 0 : attr = "PUBLIC";
6213 0 : break;
6214 0 : case DECL_SAVE:
6215 0 : attr = "SAVE";
6216 0 : break;
6217 0 : case DECL_STATIC:
6218 0 : attr = "STATIC";
6219 0 : break;
6220 1 : case DECL_AUTOMATIC:
6221 1 : attr = "AUTOMATIC";
6222 1 : break;
6223 0 : case DECL_TARGET:
6224 0 : attr = "TARGET";
6225 0 : break;
6226 0 : case DECL_IS_BIND_C:
6227 0 : attr = "IS_BIND_C";
6228 0 : break;
6229 0 : case DECL_VALUE:
6230 0 : attr = "VALUE";
6231 0 : break;
6232 1 : case DECL_VOLATILE:
6233 1 : attr = "VOLATILE";
6234 1 : break;
6235 0 : default:
6236 0 : attr = NULL; /* This shouldn't happen. */
6237 : }
6238 :
6239 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6240 2 : m = MATCH_ERROR;
6241 2 : goto cleanup;
6242 : }
6243 :
6244 : /* Now that we've dealt with duplicate attributes, add the attributes
6245 : to the current attribute. */
6246 4902926 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6247 : {
6248 4721380 : if (seen[d] == 0)
6249 4603588 : continue;
6250 : else
6251 117792 : attr_seen = 1;
6252 :
6253 117792 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6254 52 : && !flag_dec_static)
6255 : {
6256 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6257 : "%<-fdec-static%>",
6258 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6259 2 : m = MATCH_ERROR;
6260 2 : goto cleanup;
6261 : }
6262 : /* Allow SAVE with STATIC, but don't complain. */
6263 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6264 0 : continue;
6265 :
6266 117790 : if (gfc_comp_struct (gfc_current_state ())
6267 6830 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6268 5866 : && d != DECL_POINTER && d != DECL_PRIVATE
6269 4177 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6270 : {
6271 4120 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6272 4120 : if (d == DECL_ALLOCATABLE)
6273 : {
6274 3513 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6275 : ? G_("ALLOCATABLE attribute at %C in a "
6276 : "TYPE definition")
6277 : : G_("ALLOCATABLE attribute at %C in a "
6278 : "STRUCTURE definition")))
6279 : {
6280 2 : m = MATCH_ERROR;
6281 2 : goto cleanup;
6282 : }
6283 : }
6284 607 : else if (d == DECL_KIND)
6285 : {
6286 291 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6287 : ? G_("KIND attribute at %C in a "
6288 : "TYPE definition")
6289 : : G_("KIND attribute at %C in a "
6290 : "STRUCTURE definition")))
6291 : {
6292 1 : m = MATCH_ERROR;
6293 1 : goto cleanup;
6294 : }
6295 290 : if (current_ts.type != BT_INTEGER)
6296 : {
6297 2 : gfc_error ("Component with KIND attribute at %C must be "
6298 : "INTEGER");
6299 2 : m = MATCH_ERROR;
6300 2 : goto cleanup;
6301 : }
6302 : }
6303 316 : else if (d == DECL_LEN)
6304 : {
6305 300 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6306 : ? G_("LEN attribute at %C in a "
6307 : "TYPE definition")
6308 : : G_("LEN attribute at %C in a "
6309 : "STRUCTURE definition")))
6310 : {
6311 0 : m = MATCH_ERROR;
6312 0 : goto cleanup;
6313 : }
6314 300 : if (current_ts.type != BT_INTEGER)
6315 : {
6316 1 : gfc_error ("Component with LEN attribute at %C must be "
6317 : "INTEGER");
6318 1 : m = MATCH_ERROR;
6319 1 : goto cleanup;
6320 : }
6321 : }
6322 : else
6323 : {
6324 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6325 : "TYPE definition")
6326 : : G_("Attribute at %L is not allowed in a "
6327 : "STRUCTURE definition"), &seen_at[d]);
6328 16 : m = MATCH_ERROR;
6329 16 : goto cleanup;
6330 : }
6331 : }
6332 :
6333 117768 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6334 468 : && gfc_current_state () != COMP_MODULE)
6335 : {
6336 147 : if (d == DECL_PRIVATE)
6337 : attr = "PRIVATE";
6338 : else
6339 43 : attr = "PUBLIC";
6340 147 : if (gfc_current_state () == COMP_DERIVED
6341 141 : && gfc_state_stack->previous
6342 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6343 : {
6344 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6345 : "at %L in a TYPE definition", attr,
6346 : &seen_at[d]))
6347 : {
6348 2 : m = MATCH_ERROR;
6349 2 : goto cleanup;
6350 : }
6351 : }
6352 : else
6353 : {
6354 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6355 : "specification part of a module", attr, &seen_at[d]);
6356 9 : m = MATCH_ERROR;
6357 9 : goto cleanup;
6358 : }
6359 : }
6360 :
6361 117757 : if (gfc_current_state () != COMP_DERIVED
6362 110958 : && (d == DECL_KIND || d == DECL_LEN))
6363 : {
6364 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6365 : "definition", &seen_at[d]);
6366 3 : m = MATCH_ERROR;
6367 3 : goto cleanup;
6368 : }
6369 :
6370 117754 : switch (d)
6371 : {
6372 18319 : case DECL_ALLOCATABLE:
6373 18319 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6374 18319 : break;
6375 :
6376 24 : case DECL_ASYNCHRONOUS:
6377 24 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6378 : t = false;
6379 : else
6380 24 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6381 : break;
6382 :
6383 66 : case DECL_CODIMENSION:
6384 66 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6385 66 : break;
6386 :
6387 2077 : case DECL_CONTIGUOUS:
6388 2077 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6389 : t = false;
6390 : else
6391 2076 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6392 : break;
6393 :
6394 19637 : case DECL_DIMENSION:
6395 19637 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6396 19637 : break;
6397 :
6398 176 : case DECL_EXTERNAL:
6399 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6400 176 : break;
6401 :
6402 20588 : case DECL_IN:
6403 20588 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6404 20588 : break;
6405 :
6406 3655 : case DECL_OUT:
6407 3655 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6408 3655 : break;
6409 :
6410 3128 : case DECL_INOUT:
6411 3128 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6412 3128 : break;
6413 :
6414 5 : case DECL_INTRINSIC:
6415 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6416 5 : break;
6417 :
6418 5053 : case DECL_OPTIONAL:
6419 5053 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6420 5053 : break;
6421 :
6422 288 : case DECL_KIND:
6423 288 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6424 288 : break;
6425 :
6426 299 : case DECL_LEN:
6427 299 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6428 299 : break;
6429 :
6430 14258 : case DECL_PARAMETER:
6431 14258 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6432 14258 : break;
6433 :
6434 12267 : case DECL_POINTER:
6435 12267 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6436 12267 : break;
6437 :
6438 50 : case DECL_PROTECTED:
6439 50 : if (gfc_current_state () != COMP_MODULE
6440 48 : || (gfc_current_ns->proc_name
6441 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6442 : {
6443 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6444 : "part of a module");
6445 2 : t = false;
6446 2 : break;
6447 : }
6448 :
6449 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6450 : t = false;
6451 : else
6452 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6453 : break;
6454 :
6455 213 : case DECL_PRIVATE:
6456 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6457 : &seen_at[d]);
6458 213 : break;
6459 :
6460 244 : case DECL_PUBLIC:
6461 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6462 : &seen_at[d]);
6463 244 : break;
6464 :
6465 1213 : case DECL_STATIC:
6466 1213 : case DECL_SAVE:
6467 1213 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6468 1213 : break;
6469 :
6470 37 : case DECL_AUTOMATIC:
6471 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6472 37 : break;
6473 :
6474 5335 : case DECL_TARGET:
6475 5335 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6476 5335 : break;
6477 :
6478 162 : case DECL_IS_BIND_C:
6479 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6480 162 : break;
6481 :
6482 10154 : case DECL_VALUE:
6483 10154 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6484 : t = false;
6485 : else
6486 10154 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6487 : break;
6488 :
6489 506 : case DECL_VOLATILE:
6490 506 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6491 : t = false;
6492 : else
6493 505 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6494 : break;
6495 :
6496 0 : default:
6497 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6498 : }
6499 :
6500 117748 : if (!t)
6501 : {
6502 35 : m = MATCH_ERROR;
6503 35 : goto cleanup;
6504 : }
6505 : }
6506 :
6507 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6508 181546 : if ((gfc_current_state () == COMP_MODULE
6509 181546 : || gfc_current_state () == COMP_SUBMODULE)
6510 5767 : && !current_attr.save
6511 5585 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6512 5493 : current_attr.save = SAVE_IMPLICIT;
6513 :
6514 181546 : colon_seen = 1;
6515 181546 : return MATCH_YES;
6516 :
6517 33743 : cleanup:
6518 33743 : gfc_current_locus = start;
6519 33743 : gfc_free_array_spec (current_as);
6520 33743 : current_as = NULL;
6521 33743 : attr_seen = 0;
6522 33743 : return m;
6523 : }
6524 :
6525 :
6526 : /* Set the binding label, dest_label, either with the binding label
6527 : stored in the given gfc_typespec, ts, or if none was provided, it
6528 : will be the symbol name in all lower case, as required by the draft
6529 : (J3/04-007, section 15.4.1). If a binding label was given and
6530 : there is more than one argument (num_idents), it is an error. */
6531 :
6532 : static bool
6533 346 : set_binding_label (const char **dest_label, const char *sym_name,
6534 : int num_idents)
6535 : {
6536 346 : if (num_idents > 1 && has_name_equals)
6537 : {
6538 4 : gfc_error ("Multiple identifiers provided with "
6539 : "single NAME= specifier at %C");
6540 4 : return false;
6541 : }
6542 :
6543 342 : if (curr_binding_label)
6544 : /* Binding label given; store in temp holder till have sym. */
6545 107 : *dest_label = curr_binding_label;
6546 : else
6547 : {
6548 : /* No binding label given, and the NAME= specifier did not exist,
6549 : which means there was no NAME="". */
6550 235 : if (sym_name != NULL && has_name_equals == 0)
6551 205 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6552 : }
6553 :
6554 : return true;
6555 : }
6556 :
6557 :
6558 : /* Set the status of the given common block as being BIND(C) or not,
6559 : depending on the given parameter, is_bind_c. */
6560 :
6561 : static void
6562 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6563 : {
6564 76 : com_block->is_bind_c = is_bind_c;
6565 76 : return;
6566 : }
6567 :
6568 :
6569 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6570 :
6571 : bool
6572 20377 : gfc_verify_c_interop (gfc_typespec *ts)
6573 : {
6574 20377 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6575 4307 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6576 8571 : ? true : false;
6577 16086 : else if (ts->type == BT_CLASS)
6578 : return false;
6579 16078 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6580 3979 : return false;
6581 :
6582 : return true;
6583 : }
6584 :
6585 :
6586 : /* Verify that the variables of a given common block, which has been
6587 : defined with the attribute specifier bind(c), to be of a C
6588 : interoperable type. Errors will be reported here, if
6589 : encountered. */
6590 :
6591 : bool
6592 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6593 : {
6594 1 : gfc_symbol *curr_sym = NULL;
6595 1 : bool retval = true;
6596 :
6597 1 : curr_sym = com_block->head;
6598 :
6599 : /* Make sure we have at least one symbol. */
6600 1 : if (curr_sym == NULL)
6601 : return retval;
6602 :
6603 : /* Here we know we have a symbol, so we'll execute this loop
6604 : at least once. */
6605 1 : do
6606 : {
6607 : /* The second to last param, 1, says this is in a common block. */
6608 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6609 1 : curr_sym = curr_sym->common_next;
6610 1 : } while (curr_sym != NULL);
6611 :
6612 : return retval;
6613 : }
6614 :
6615 :
6616 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6617 : an appropriate error message is reported. */
6618 :
6619 : bool
6620 6970 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6621 : int is_in_common, gfc_common_head *com_block)
6622 : {
6623 6970 : bool bind_c_function = false;
6624 6970 : bool retval = true;
6625 :
6626 6970 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6627 6970 : bind_c_function = true;
6628 :
6629 6970 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6630 : {
6631 2730 : tmp_sym = tmp_sym->result;
6632 : /* Make sure it wasn't an implicitly typed result. */
6633 2730 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6634 : {
6635 1 : gfc_warning (OPT_Wc_binding_type,
6636 : "Implicitly declared BIND(C) function %qs at "
6637 : "%L may not be C interoperable", tmp_sym->name,
6638 : &tmp_sym->declared_at);
6639 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6640 : /* Mark it as C interoperable to prevent duplicate warnings. */
6641 1 : tmp_sym->ts.is_c_interop = 1;
6642 1 : tmp_sym->attr.is_c_interop = 1;
6643 : }
6644 : }
6645 :
6646 : /* Here, we know we have the bind(c) attribute, so if we have
6647 : enough type info, then verify that it's a C interop kind.
6648 : The info could be in the symbol already, or possibly still in
6649 : the given ts (current_ts), so look in both. */
6650 6970 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6651 : {
6652 2888 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6653 : {
6654 : /* See if we're dealing with a sym in a common block or not. */
6655 237 : if (is_in_common == 1 && warn_c_binding_type)
6656 : {
6657 0 : gfc_warning (OPT_Wc_binding_type,
6658 : "Variable %qs in common block %qs at %L "
6659 : "may not be a C interoperable "
6660 : "kind though common block %qs is BIND(C)",
6661 : tmp_sym->name, com_block->name,
6662 0 : &(tmp_sym->declared_at), com_block->name);
6663 : }
6664 : else
6665 : {
6666 237 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6667 235 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6668 : {
6669 3 : gfc_error ("Type declaration %qs at %L is not C "
6670 : "interoperable but it is BIND(C)",
6671 : tmp_sym->name, &(tmp_sym->declared_at));
6672 3 : retval = false;
6673 : }
6674 234 : else if (warn_c_binding_type)
6675 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6676 : "may not be a C interoperable "
6677 : "kind but it is BIND(C)",
6678 : tmp_sym->name, &(tmp_sym->declared_at));
6679 : }
6680 : }
6681 :
6682 : /* Variables declared w/in a common block can't be bind(c)
6683 : since there's no way for C to see these variables, so there's
6684 : semantically no reason for the attribute. */
6685 2888 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6686 : {
6687 1 : gfc_error ("Variable %qs in common block %qs at "
6688 : "%L cannot be declared with BIND(C) "
6689 : "since it is not a global",
6690 1 : tmp_sym->name, com_block->name,
6691 : &(tmp_sym->declared_at));
6692 1 : retval = false;
6693 : }
6694 :
6695 : /* Scalar variables that are bind(c) cannot have the pointer
6696 : or allocatable attributes. */
6697 2888 : if (tmp_sym->attr.is_bind_c == 1)
6698 : {
6699 2350 : if (tmp_sym->attr.pointer == 1)
6700 : {
6701 1 : gfc_error ("Variable %qs at %L cannot have both the "
6702 : "POINTER and BIND(C) attributes",
6703 : tmp_sym->name, &(tmp_sym->declared_at));
6704 1 : retval = false;
6705 : }
6706 :
6707 2350 : if (tmp_sym->attr.allocatable == 1)
6708 : {
6709 0 : gfc_error ("Variable %qs at %L cannot have both the "
6710 : "ALLOCATABLE and BIND(C) attributes",
6711 : tmp_sym->name, &(tmp_sym->declared_at));
6712 0 : retval = false;
6713 : }
6714 :
6715 : }
6716 :
6717 : /* If it is a BIND(C) function, make sure the return value is a
6718 : scalar value. The previous tests in this function made sure
6719 : the type is interoperable. */
6720 2888 : if (bind_c_function && tmp_sym->as != NULL)
6721 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6722 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6723 :
6724 : /* BIND(C) functions cannot return a character string. */
6725 2730 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6726 116 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6727 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6728 : "type at %L must have length 1", tmp_sym->name,
6729 : &(tmp_sym->declared_at));
6730 : }
6731 :
6732 : /* See if the symbol has been marked as private. If it has, warn if
6733 : there is a binding label with default binding name. */
6734 6970 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6735 11 : && tmp_sym->binding_label
6736 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6737 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6738 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6739 4 : gfc_warning (OPT_Wsurprising,
6740 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6741 : "via its default binding name %qs", tmp_sym->name,
6742 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6743 :
6744 6970 : return retval;
6745 : }
6746 :
6747 :
6748 : /* Set the appropriate fields for a symbol that's been declared as
6749 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6750 : the type is C interoperable. Errors are reported by the functions
6751 : used to set/test these fields. */
6752 :
6753 : static bool
6754 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6755 : {
6756 47 : bool retval = true;
6757 :
6758 : /* TODO: Do we need to make sure the vars aren't marked private? */
6759 :
6760 : /* Set the is_bind_c bit in symbol_attribute. */
6761 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6762 :
6763 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6764 : return false;
6765 :
6766 : return retval;
6767 : }
6768 :
6769 :
6770 : /* Set the fields marking the given common block as BIND(C), including
6771 : a binding label, and report any errors encountered. */
6772 :
6773 : static bool
6774 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6775 : {
6776 76 : bool retval = true;
6777 :
6778 : /* destLabel, common name, typespec (which may have binding label). */
6779 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6780 : num_idents))
6781 : return false;
6782 :
6783 : /* Set the given common block (com_block) to being bind(c) (1). */
6784 76 : set_com_block_bind_c (com_block, 1);
6785 :
6786 76 : return retval;
6787 : }
6788 :
6789 :
6790 : /* Retrieve the list of one or more identifiers that the given bind(c)
6791 : attribute applies to. */
6792 :
6793 : static bool
6794 102 : get_bind_c_idents (void)
6795 : {
6796 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6797 102 : int num_idents = 0;
6798 102 : gfc_symbol *tmp_sym = NULL;
6799 102 : match found_id;
6800 102 : gfc_common_head *com_block = NULL;
6801 :
6802 102 : if (gfc_match_name (name) == MATCH_YES)
6803 : {
6804 38 : found_id = MATCH_YES;
6805 38 : gfc_get_ha_symbol (name, &tmp_sym);
6806 : }
6807 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6808 : {
6809 64 : found_id = MATCH_YES;
6810 64 : com_block = gfc_get_common (name, 0);
6811 : }
6812 : else
6813 : {
6814 0 : gfc_error ("Need either entity or common block name for "
6815 : "attribute specification statement at %C");
6816 0 : return false;
6817 : }
6818 :
6819 : /* Save the current identifier and look for more. */
6820 123 : do
6821 : {
6822 : /* Increment the number of identifiers found for this spec stmt. */
6823 123 : num_idents++;
6824 :
6825 : /* Make sure we have a sym or com block, and verify that it can
6826 : be bind(c). Set the appropriate field(s) and look for more
6827 : identifiers. */
6828 123 : if (tmp_sym != NULL || com_block != NULL)
6829 : {
6830 123 : if (tmp_sym != NULL)
6831 : {
6832 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6833 : return false;
6834 : }
6835 : else
6836 : {
6837 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6838 : return false;
6839 : }
6840 :
6841 : /* Look to see if we have another identifier. */
6842 122 : tmp_sym = NULL;
6843 122 : if (gfc_match_eos () == MATCH_YES)
6844 : found_id = MATCH_NO;
6845 21 : else if (gfc_match_char (',') != MATCH_YES)
6846 : found_id = MATCH_NO;
6847 21 : else if (gfc_match_name (name) == MATCH_YES)
6848 : {
6849 9 : found_id = MATCH_YES;
6850 9 : gfc_get_ha_symbol (name, &tmp_sym);
6851 : }
6852 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6853 : {
6854 12 : found_id = MATCH_YES;
6855 12 : com_block = gfc_get_common (name, 0);
6856 : }
6857 : else
6858 : {
6859 0 : gfc_error ("Missing entity or common block name for "
6860 : "attribute specification statement at %C");
6861 0 : return false;
6862 : }
6863 : }
6864 : else
6865 : {
6866 0 : gfc_internal_error ("Missing symbol");
6867 : }
6868 122 : } while (found_id == MATCH_YES);
6869 :
6870 : /* if we get here we were successful */
6871 : return true;
6872 : }
6873 :
6874 :
6875 : /* Try and match a BIND(C) attribute specification statement. */
6876 :
6877 : match
6878 140 : gfc_match_bind_c_stmt (void)
6879 : {
6880 140 : match found_match = MATCH_NO;
6881 140 : gfc_typespec *ts;
6882 :
6883 140 : ts = ¤t_ts;
6884 :
6885 : /* This may not be necessary. */
6886 140 : gfc_clear_ts (ts);
6887 : /* Clear the temporary binding label holder. */
6888 140 : curr_binding_label = NULL;
6889 :
6890 : /* Look for the bind(c). */
6891 140 : found_match = gfc_match_bind_c (NULL, true);
6892 :
6893 140 : if (found_match == MATCH_YES)
6894 : {
6895 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6896 : return MATCH_ERROR;
6897 :
6898 : /* Look for the :: now, but it is not required. */
6899 102 : gfc_match (" :: ");
6900 :
6901 : /* Get the identifier(s) that needs to be updated. This may need to
6902 : change to hand the flag(s) for the attr specified so all identifiers
6903 : found can have all appropriate parts updated (assuming that the same
6904 : spec stmt can have multiple attrs, such as both bind(c) and
6905 : allocatable...). */
6906 102 : if (!get_bind_c_idents ())
6907 : /* Error message should have printed already. */
6908 : return MATCH_ERROR;
6909 : }
6910 :
6911 : return found_match;
6912 : }
6913 :
6914 :
6915 : /* Match a data declaration statement. */
6916 :
6917 : match
6918 1019670 : gfc_match_data_decl (void)
6919 : {
6920 1019670 : gfc_symbol *sym;
6921 1019670 : match m;
6922 1019670 : int elem;
6923 1019670 : gfc_component *comp_tail = NULL;
6924 :
6925 1019670 : type_param_spec_list = NULL;
6926 1019670 : decl_type_param_list = NULL;
6927 :
6928 1019670 : num_idents_on_line = 0;
6929 :
6930 : /* Record the last component before we start, so that we can roll back
6931 : any components added during this statement on error. PR106946.
6932 : Must be set before any 'goto cleanup' with m == MATCH_ERROR. */
6933 1019670 : if (gfc_comp_struct (gfc_current_state ()))
6934 : {
6935 31573 : gfc_symbol *block = gfc_current_block ();
6936 31573 : if (block)
6937 : {
6938 31573 : comp_tail = block->components;
6939 31573 : if (comp_tail)
6940 32933 : while (comp_tail->next)
6941 : comp_tail = comp_tail->next;
6942 : }
6943 : }
6944 :
6945 1019670 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6946 1019670 : if (m != MATCH_YES)
6947 : return m;
6948 :
6949 214122 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6950 34852 : && !gfc_comp_struct (gfc_current_state ()))
6951 : {
6952 31514 : sym = gfc_use_derived (current_ts.u.derived);
6953 :
6954 31514 : if (sym == NULL)
6955 : {
6956 22 : m = MATCH_ERROR;
6957 22 : goto cleanup;
6958 : }
6959 :
6960 31492 : current_ts.u.derived = sym;
6961 : }
6962 :
6963 214100 : m = match_attr_spec ();
6964 214100 : if (m == MATCH_ERROR)
6965 : {
6966 84 : m = MATCH_NO;
6967 84 : goto cleanup;
6968 : }
6969 :
6970 : /* F2018:C708. */
6971 214016 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6972 : {
6973 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6974 6 : m = MATCH_ERROR;
6975 6 : goto cleanup;
6976 : }
6977 :
6978 214010 : if (current_ts.type == BT_CLASS
6979 10851 : && current_ts.u.derived->attr.unlimited_polymorphic)
6980 1882 : goto ok;
6981 :
6982 212128 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6983 32941 : && current_ts.u.derived->components == NULL
6984 2808 : && !current_ts.u.derived->attr.zero_comp)
6985 : {
6986 :
6987 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6988 136 : goto ok;
6989 :
6990 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6991 47 : goto ok;
6992 :
6993 27 : gfc_find_symbol (current_ts.u.derived->name,
6994 27 : current_ts.u.derived->ns, 1, &sym);
6995 :
6996 : /* Any symbol that we find had better be a type definition
6997 : which has its components defined, or be a structure definition
6998 : actively being parsed. */
6999 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
7000 26 : && (current_ts.u.derived->components != NULL
7001 26 : || current_ts.u.derived->attr.zero_comp
7002 26 : || current_ts.u.derived == gfc_new_block))
7003 26 : goto ok;
7004 :
7005 1 : gfc_error ("Derived type at %C has not been previously defined "
7006 : "and so cannot appear in a derived type definition");
7007 1 : m = MATCH_ERROR;
7008 1 : goto cleanup;
7009 : }
7010 :
7011 211918 : ok:
7012 : /* If we have an old-style character declaration, and no new-style
7013 : attribute specifications, then there a comma is optional between
7014 : the type specification and the variable list. */
7015 214009 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
7016 1407 : gfc_match_char (',');
7017 :
7018 : /* Give the types/attributes to symbols that follow. Give the element
7019 : a number so that repeat character length expressions can be copied. */
7020 : elem = 1;
7021 278964 : for (;;)
7022 : {
7023 278964 : num_idents_on_line++;
7024 278964 : m = variable_decl (elem++);
7025 278962 : if (m == MATCH_ERROR)
7026 415 : goto cleanup;
7027 278547 : if (m == MATCH_NO)
7028 : break;
7029 :
7030 278536 : if (gfc_match_eos () == MATCH_YES)
7031 213557 : goto cleanup;
7032 64979 : if (gfc_match_char (',') != MATCH_YES)
7033 : break;
7034 : }
7035 :
7036 35 : if (!gfc_error_flag_test ())
7037 : {
7038 : /* An anonymous structure declaration is unambiguous; if we matched one
7039 : according to gfc_match_structure_decl, we need to return MATCH_YES
7040 : here to avoid confusing the remaining matchers, even if there was an
7041 : error during variable_decl. We must flush any such errors. Note this
7042 : causes the parser to gracefully continue parsing the remaining input
7043 : as a structure body, which likely follows. */
7044 11 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
7045 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
7046 : {
7047 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
7048 : " at %C");
7049 : /* Skip the bad variable_decl and line up for the start of the
7050 : structure body. */
7051 1 : gfc_error_recovery ();
7052 1 : m = MATCH_YES;
7053 1 : goto cleanup;
7054 : }
7055 :
7056 10 : gfc_error ("Syntax error in data declaration at %C");
7057 : }
7058 :
7059 34 : m = MATCH_ERROR;
7060 :
7061 34 : gfc_free_data_all (gfc_current_ns);
7062 :
7063 214120 : cleanup:
7064 : /* If we failed inside a derived type definition, remove any CLASS
7065 : components that were added during this failed statement. For CLASS
7066 : components, gfc_build_class_symbol creates an extra container symbol in
7067 : the namespace outside the normal undo machinery. When reject_statement
7068 : later calls gfc_undo_symbols, the declaration state is rolled back but
7069 : that helper symbol survives and leaves the component dangling. Ordinary
7070 : components do not create that extra helper symbol, so leave them in
7071 : place for the usual follow-up diagnostics. PR106946.
7072 :
7073 : CLASS containers are shared between components of the same class type
7074 : and attributes (gfc_build_class_symbol reuses existing containers).
7075 : We must not free a container that is still referenced by a previously
7076 : committed component. Unlink and free the components first, then clean
7077 : up only orphaned containers. PR124482. */
7078 214120 : if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
7079 : {
7080 86 : gfc_symbol *block = gfc_current_block ();
7081 86 : if (block)
7082 : {
7083 86 : gfc_component **prev;
7084 86 : if (comp_tail)
7085 43 : prev = &comp_tail->next;
7086 : else
7087 43 : prev = &block->components;
7088 :
7089 : /* Record the CLASS container from the removed components.
7090 : Normally all components in one declaration share a single
7091 : container, but per-variable array specs can produce
7092 : additional ones; any beyond the first are harmlessly
7093 : leaked until namespace destruction. */
7094 86 : gfc_symbol *fclass_container = NULL;
7095 :
7096 120 : while (*prev)
7097 : {
7098 34 : gfc_component *c = *prev;
7099 34 : if (c->ts.type == BT_CLASS && c->ts.u.derived
7100 6 : && c->ts.u.derived->attr.is_class)
7101 : {
7102 3 : *prev = c->next;
7103 3 : if (!fclass_container)
7104 3 : fclass_container = c->ts.u.derived;
7105 3 : c->ts.u.derived = NULL;
7106 3 : gfc_free_component (c);
7107 : }
7108 : else
7109 31 : prev = &c->next;
7110 : }
7111 :
7112 : /* Free the container only if no remaining component still
7113 : references it. CLASS containers are shared between
7114 : components of the same class type and attributes
7115 : (gfc_build_class_symbol reuses existing ones). */
7116 86 : if (fclass_container)
7117 : {
7118 3 : bool shared = false;
7119 3 : for (gfc_component *q = block->components; q; q = q->next)
7120 1 : if (q->ts.type == BT_CLASS
7121 1 : && q->ts.u.derived == fclass_container)
7122 : {
7123 : shared = true;
7124 : break;
7125 : }
7126 3 : if (!shared)
7127 : {
7128 2 : if (gfc_find_symtree (fclass_container->ns->sym_root,
7129 : fclass_container->name))
7130 2 : gfc_delete_symtree (&fclass_container->ns->sym_root,
7131 : fclass_container->name);
7132 2 : gfc_release_symbol (fclass_container);
7133 : }
7134 : }
7135 : }
7136 : }
7137 :
7138 214120 : if (saved_kind_expr)
7139 180 : gfc_free_expr (saved_kind_expr);
7140 214120 : if (type_param_spec_list)
7141 931 : gfc_free_actual_arglist (type_param_spec_list);
7142 214120 : if (decl_type_param_list)
7143 894 : gfc_free_actual_arglist (decl_type_param_list);
7144 214120 : saved_kind_expr = NULL;
7145 214120 : gfc_free_array_spec (current_as);
7146 214120 : current_as = NULL;
7147 214120 : return m;
7148 : }
7149 :
7150 : static bool
7151 24399 : in_module_or_interface(void)
7152 : {
7153 24399 : if (gfc_current_state () == COMP_MODULE
7154 24399 : || gfc_current_state () == COMP_SUBMODULE
7155 24399 : || gfc_current_state () == COMP_INTERFACE)
7156 : return true;
7157 :
7158 20396 : if (gfc_state_stack->state == COMP_CONTAINS
7159 19516 : || gfc_state_stack->state == COMP_FUNCTION
7160 19410 : || gfc_state_stack->state == COMP_SUBROUTINE)
7161 : {
7162 986 : gfc_state_data *p;
7163 1030 : for (p = gfc_state_stack->previous; p ; p = p->previous)
7164 : {
7165 1026 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
7166 118 : || p->state == COMP_INTERFACE)
7167 : return true;
7168 : }
7169 : }
7170 : return false;
7171 : }
7172 :
7173 : /* Match a prefix associated with a function or subroutine
7174 : declaration. If the typespec pointer is nonnull, then a typespec
7175 : can be matched. Note that if nothing matches, MATCH_YES is
7176 : returned (the null string was matched). */
7177 :
7178 : match
7179 240313 : gfc_match_prefix (gfc_typespec *ts)
7180 : {
7181 240313 : bool seen_type;
7182 240313 : bool seen_impure;
7183 240313 : bool found_prefix;
7184 :
7185 240313 : gfc_clear_attr (¤t_attr);
7186 240313 : seen_type = false;
7187 240313 : seen_impure = false;
7188 :
7189 240313 : gcc_assert (!gfc_matching_prefix);
7190 240313 : gfc_matching_prefix = true;
7191 :
7192 250167 : do
7193 : {
7194 269881 : found_prefix = false;
7195 :
7196 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7197 : corresponding attribute seems natural and distinguishes these
7198 : procedures from procedure types of PROC_MODULE, which these are
7199 : as well. */
7200 269881 : if (gfc_match ("module% ") == MATCH_YES)
7201 : {
7202 24674 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7203 275 : goto error;
7204 :
7205 24399 : if (!in_module_or_interface ())
7206 : {
7207 19414 : gfc_error ("MODULE prefix at %C found outside of a module, "
7208 : "submodule, or interface");
7209 19414 : goto error;
7210 : }
7211 :
7212 4985 : current_attr.module_procedure = 1;
7213 4985 : found_prefix = true;
7214 : }
7215 :
7216 250192 : if (!seen_type && ts != NULL)
7217 : {
7218 134531 : match m;
7219 134531 : m = gfc_match_decl_type_spec (ts, 0);
7220 134531 : if (m == MATCH_ERROR)
7221 15 : goto error;
7222 134516 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7223 : {
7224 : seen_type = true;
7225 : found_prefix = true;
7226 : }
7227 : }
7228 :
7229 250177 : if (gfc_match ("elemental% ") == MATCH_YES)
7230 : {
7231 5241 : if (!gfc_add_elemental (¤t_attr, NULL))
7232 2 : goto error;
7233 :
7234 : found_prefix = true;
7235 : }
7236 :
7237 250175 : if (gfc_match ("pure% ") == MATCH_YES)
7238 : {
7239 2447 : if (!gfc_add_pure (¤t_attr, NULL))
7240 2 : goto error;
7241 :
7242 : found_prefix = true;
7243 : }
7244 :
7245 250173 : if (gfc_match ("recursive% ") == MATCH_YES)
7246 : {
7247 469 : if (!gfc_add_recursive (¤t_attr, NULL))
7248 2 : goto error;
7249 :
7250 : found_prefix = true;
7251 : }
7252 :
7253 : /* IMPURE is a somewhat special case, as it needs not set an actual
7254 : attribute but rather only prevents ELEMENTAL routines from being
7255 : automatically PURE. */
7256 250171 : if (gfc_match ("impure% ") == MATCH_YES)
7257 : {
7258 693 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7259 4 : goto error;
7260 :
7261 : seen_impure = true;
7262 : found_prefix = true;
7263 : }
7264 : }
7265 : while (found_prefix);
7266 :
7267 : /* IMPURE and PURE must not both appear, of course. */
7268 220599 : if (seen_impure && current_attr.pure)
7269 : {
7270 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7271 4 : goto error;
7272 : }
7273 :
7274 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7275 219910 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7276 : {
7277 4570 : if (!gfc_add_pure (¤t_attr, NULL))
7278 0 : goto error;
7279 : }
7280 :
7281 : /* At this point, the next item is not a prefix. */
7282 220595 : gcc_assert (gfc_matching_prefix);
7283 :
7284 220595 : gfc_matching_prefix = false;
7285 220595 : return MATCH_YES;
7286 :
7287 19718 : error:
7288 19718 : gcc_assert (gfc_matching_prefix);
7289 19718 : gfc_matching_prefix = false;
7290 19718 : return MATCH_ERROR;
7291 : }
7292 :
7293 :
7294 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7295 :
7296 : static bool
7297 62439 : copy_prefix (symbol_attribute *dest, locus *where)
7298 : {
7299 62439 : if (dest->module_procedure)
7300 : {
7301 730 : if (current_attr.elemental)
7302 13 : dest->elemental = 1;
7303 :
7304 730 : if (current_attr.pure)
7305 61 : dest->pure = 1;
7306 :
7307 730 : if (current_attr.recursive)
7308 8 : dest->recursive = 1;
7309 :
7310 : /* Module procedures are unusual in that the 'dest' is copied from
7311 : the interface declaration. However, this is an opportunity to
7312 : check that the submodule declaration is compliant with the
7313 : interface. */
7314 730 : if (dest->elemental && !current_attr.elemental)
7315 : {
7316 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7317 : "missing at %L", where);
7318 1 : return false;
7319 : }
7320 :
7321 729 : if (dest->pure && !current_attr.pure)
7322 : {
7323 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7324 : "missing at %L", where);
7325 1 : return false;
7326 : }
7327 :
7328 728 : if (dest->recursive && !current_attr.recursive)
7329 : {
7330 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7331 : "missing at %L", where);
7332 1 : return false;
7333 : }
7334 :
7335 : return true;
7336 : }
7337 :
7338 61709 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7339 : return false;
7340 :
7341 61707 : if (current_attr.pure && !gfc_add_pure (dest, where))
7342 : return false;
7343 :
7344 61707 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7345 : return false;
7346 :
7347 : return true;
7348 : }
7349 :
7350 :
7351 : /* Match a formal argument list or, if typeparam is true, a
7352 : type_param_name_list. */
7353 :
7354 : match
7355 482908 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7356 : int null_flag, bool typeparam)
7357 : {
7358 482908 : gfc_formal_arglist *head, *tail, *p, *q;
7359 482908 : char name[GFC_MAX_SYMBOL_LEN + 1];
7360 482908 : gfc_symbol *sym;
7361 482908 : match m;
7362 482908 : gfc_formal_arglist *formal = NULL;
7363 :
7364 482908 : head = tail = NULL;
7365 :
7366 : /* Keep the interface formal argument list and null it so that the
7367 : matching for the new declaration can be done. The numbers and
7368 : names of the arguments are checked here. The interface formal
7369 : arguments are retained in formal_arglist and the characteristics
7370 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7371 : in get_proc_name about the eventual need to copy the formal_arglist
7372 : and populate the formal namespace of the interface symbol. */
7373 482908 : if (progname->attr.module_procedure
7374 734 : && progname->attr.host_assoc)
7375 : {
7376 195 : formal = progname->formal;
7377 195 : progname->formal = NULL;
7378 : }
7379 :
7380 482908 : if (gfc_match_char ('(') != MATCH_YES)
7381 : {
7382 285960 : if (null_flag)
7383 6568 : goto ok;
7384 : return MATCH_NO;
7385 : }
7386 :
7387 196948 : if (gfc_match_char (')') == MATCH_YES)
7388 : {
7389 10445 : if (typeparam)
7390 : {
7391 1 : gfc_error_now ("A type parameter list is required at %C");
7392 1 : m = MATCH_ERROR;
7393 1 : goto cleanup;
7394 : }
7395 : else
7396 10444 : goto ok;
7397 : }
7398 :
7399 248342 : for (;;)
7400 : {
7401 248342 : gfc_gobble_whitespace ();
7402 248342 : if (gfc_match_char ('*') == MATCH_YES)
7403 : {
7404 10302 : sym = NULL;
7405 10302 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7406 : "Alternate-return argument at %C"))
7407 : {
7408 1 : m = MATCH_ERROR;
7409 1 : goto cleanup;
7410 : }
7411 10301 : else if (typeparam)
7412 2 : gfc_error_now ("A parameter name is required at %C");
7413 : }
7414 : else
7415 : {
7416 238040 : locus loc = gfc_current_locus;
7417 238040 : m = gfc_match_name (name);
7418 238040 : if (m != MATCH_YES)
7419 : {
7420 16170 : if(typeparam)
7421 1 : gfc_error_now ("A parameter name is required at %C");
7422 16186 : goto cleanup;
7423 : }
7424 221870 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7425 :
7426 221870 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7427 16 : goto cleanup;
7428 221854 : else if (typeparam
7429 221854 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7430 0 : goto cleanup;
7431 : }
7432 :
7433 232155 : p = gfc_get_formal_arglist ();
7434 :
7435 232155 : if (head == NULL)
7436 : head = tail = p;
7437 : else
7438 : {
7439 61136 : tail->next = p;
7440 61136 : tail = p;
7441 : }
7442 :
7443 232155 : tail->sym = sym;
7444 :
7445 : /* We don't add the VARIABLE flavor because the name could be a
7446 : dummy procedure. We don't apply these attributes to formal
7447 : arguments of statement functions. */
7448 221854 : if (sym != NULL && !st_flag
7449 332029 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7450 99874 : || !gfc_missing_attr (&sym->attr, NULL)))
7451 : {
7452 0 : m = MATCH_ERROR;
7453 0 : goto cleanup;
7454 : }
7455 :
7456 : /* The name of a program unit can be in a different namespace,
7457 : so check for it explicitly. After the statement is accepted,
7458 : the name is checked for especially in gfc_get_symbol(). */
7459 232155 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7460 98622 : && strcmp (sym->name, gfc_new_block->name) == 0)
7461 : {
7462 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7463 : sym->name);
7464 0 : m = MATCH_ERROR;
7465 0 : goto cleanup;
7466 : }
7467 :
7468 232155 : if (gfc_match_char (')') == MATCH_YES)
7469 122605 : goto ok;
7470 :
7471 109550 : m = gfc_match_char (',');
7472 109550 : if (m != MATCH_YES)
7473 : {
7474 47711 : if (typeparam)
7475 1 : gfc_error_now ("Expected parameter list in type declaration "
7476 : "at %C");
7477 : else
7478 47710 : gfc_error ("Unexpected junk in formal argument list at %C");
7479 47711 : goto cleanup;
7480 : }
7481 : }
7482 :
7483 139617 : ok:
7484 : /* Check for duplicate symbols in the formal argument list. */
7485 139617 : if (head != NULL)
7486 : {
7487 182119 : for (p = head; p->next; p = p->next)
7488 : {
7489 59562 : if (p->sym == NULL)
7490 336 : continue;
7491 :
7492 235563 : for (q = p->next; q; q = q->next)
7493 176385 : if (p->sym == q->sym)
7494 : {
7495 48 : if (typeparam)
7496 1 : gfc_error_now ("Duplicate name %qs in parameter "
7497 : "list at %C", p->sym->name);
7498 : else
7499 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7500 : "list at %C", p->sym->name);
7501 :
7502 48 : m = MATCH_ERROR;
7503 48 : goto cleanup;
7504 : }
7505 : }
7506 : }
7507 :
7508 139569 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7509 : {
7510 0 : m = MATCH_ERROR;
7511 0 : goto cleanup;
7512 : }
7513 :
7514 : /* gfc_error_now used in following and return with MATCH_YES because
7515 : doing otherwise results in a cascade of extraneous errors and in
7516 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7517 139569 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7518 : {
7519 194 : bool arg_count_mismatch = false;
7520 :
7521 194 : if (!formal && head)
7522 : arg_count_mismatch = true;
7523 :
7524 : /* Abbreviated module procedure declaration is not meant to have any
7525 : formal arguments! */
7526 194 : if (!progname->abr_modproc_decl && formal && !head)
7527 1 : arg_count_mismatch = true;
7528 :
7529 375 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7530 : {
7531 181 : if ((p->next != NULL && q->next == NULL)
7532 180 : || (p->next == NULL && q->next != NULL))
7533 : arg_count_mismatch = true;
7534 179 : else if ((p->sym == NULL && q->sym == NULL)
7535 179 : || (p->sym && q->sym
7536 177 : && strcmp (p->sym->name, q->sym->name) == 0))
7537 175 : continue;
7538 : else
7539 : {
7540 4 : if (q->sym == NULL)
7541 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7542 : "conflicts with alternate return at %C",
7543 : p->sym->name);
7544 3 : else if (p->sym == NULL)
7545 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7546 : "alternate return and conflicts with "
7547 : "%qs in the separate declaration at %C",
7548 : q->sym->name);
7549 : else
7550 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7551 : "argument names (%s/%s) at %C",
7552 : p->sym->name, q->sym->name);
7553 : }
7554 : }
7555 :
7556 194 : if (arg_count_mismatch)
7557 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7558 : "formal arguments at %C");
7559 : }
7560 :
7561 : return MATCH_YES;
7562 :
7563 63947 : cleanup:
7564 63947 : gfc_free_formal_arglist (head);
7565 63947 : return m;
7566 : }
7567 :
7568 :
7569 : /* Match a RESULT specification following a function declaration or
7570 : ENTRY statement. Also matches the end-of-statement. */
7571 :
7572 : static match
7573 8161 : match_result (gfc_symbol *function, gfc_symbol **result)
7574 : {
7575 8161 : char name[GFC_MAX_SYMBOL_LEN + 1];
7576 8161 : gfc_symbol *r;
7577 8161 : match m;
7578 :
7579 8161 : if (gfc_match (" result (") != MATCH_YES)
7580 : return MATCH_NO;
7581 :
7582 6025 : m = gfc_match_name (name);
7583 6025 : if (m != MATCH_YES)
7584 : return m;
7585 :
7586 : /* Get the right paren, and that's it because there could be the
7587 : bind(c) attribute after the result clause. */
7588 6025 : if (gfc_match_char (')') != MATCH_YES)
7589 : {
7590 : /* TODO: should report the missing right paren here. */
7591 : return MATCH_ERROR;
7592 : }
7593 :
7594 6025 : if (strcmp (function->name, name) == 0)
7595 : {
7596 1 : gfc_error ("RESULT variable at %C must be different than function name");
7597 1 : return MATCH_ERROR;
7598 : }
7599 :
7600 6024 : if (gfc_get_symbol (name, NULL, &r))
7601 : return MATCH_ERROR;
7602 :
7603 6024 : if (!gfc_add_result (&r->attr, r->name, NULL))
7604 : return MATCH_ERROR;
7605 :
7606 6024 : *result = r;
7607 :
7608 6024 : return MATCH_YES;
7609 : }
7610 :
7611 :
7612 : /* Match a function suffix, which could be a combination of a result
7613 : clause and BIND(C), either one, or neither. The draft does not
7614 : require them to come in a specific order. */
7615 :
7616 : static match
7617 8165 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7618 : {
7619 8165 : match is_bind_c; /* Found bind(c). */
7620 8165 : match is_result; /* Found result clause. */
7621 8165 : match found_match; /* Status of whether we've found a good match. */
7622 8165 : char peek_char; /* Character we're going to peek at. */
7623 8165 : bool allow_binding_name;
7624 :
7625 : /* Initialize to having found nothing. */
7626 8165 : found_match = MATCH_NO;
7627 8165 : is_bind_c = MATCH_NO;
7628 8165 : is_result = MATCH_NO;
7629 :
7630 : /* Get the next char to narrow between result and bind(c). */
7631 8165 : gfc_gobble_whitespace ();
7632 8165 : peek_char = gfc_peek_ascii_char ();
7633 :
7634 : /* C binding names are not allowed for internal procedures. */
7635 8165 : if (gfc_current_state () == COMP_CONTAINS
7636 4771 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7637 : allow_binding_name = false;
7638 : else
7639 6485 : allow_binding_name = true;
7640 :
7641 8165 : switch (peek_char)
7642 : {
7643 5654 : case 'r':
7644 : /* Look for result clause. */
7645 5654 : is_result = match_result (sym, result);
7646 5654 : if (is_result == MATCH_YES)
7647 : {
7648 : /* Now see if there is a bind(c) after it. */
7649 5653 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7650 : /* We've found the result clause and possibly bind(c). */
7651 5653 : found_match = MATCH_YES;
7652 : }
7653 : else
7654 : /* This should only be MATCH_ERROR. */
7655 : found_match = is_result;
7656 : break;
7657 2511 : case 'b':
7658 : /* Look for bind(c) first. */
7659 2511 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7660 2511 : if (is_bind_c == MATCH_YES)
7661 : {
7662 : /* Now see if a result clause followed it. */
7663 2507 : is_result = match_result (sym, result);
7664 2507 : found_match = MATCH_YES;
7665 : }
7666 : else
7667 : {
7668 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7669 : found_match = MATCH_ERROR;
7670 : }
7671 : break;
7672 0 : default:
7673 0 : gfc_error ("Unexpected junk after function declaration at %C");
7674 0 : found_match = MATCH_ERROR;
7675 0 : break;
7676 : }
7677 :
7678 8160 : if (is_bind_c == MATCH_YES)
7679 : {
7680 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7681 2674 : if (gfc_current_state () == COMP_CONTAINS
7682 423 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7683 2692 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7684 : "at %L may not be specified for an internal "
7685 : "procedure", &gfc_current_locus))
7686 : return MATCH_ERROR;
7687 :
7688 2671 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7689 : return MATCH_ERROR;
7690 : }
7691 :
7692 : return found_match;
7693 : }
7694 :
7695 :
7696 : /* Procedure pointer return value without RESULT statement:
7697 : Add "hidden" result variable named "ppr@". */
7698 :
7699 : static bool
7700 74021 : add_hidden_procptr_result (gfc_symbol *sym)
7701 : {
7702 74021 : bool case1,case2;
7703 :
7704 74021 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7705 : return false;
7706 :
7707 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7708 1532 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7709 1532 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7710 74413 : && sym->attr.external;
7711 : /* Second usage case: INTERFACE statements. */
7712 14307 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7713 14307 : && gfc_state_stack->previous->state == COMP_FUNCTION
7714 74068 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7715 :
7716 73837 : if (case1 || case2)
7717 : {
7718 124 : gfc_symtree *stree;
7719 124 : if (case1)
7720 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7721 : else
7722 : {
7723 30 : gfc_symtree *st2;
7724 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7725 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7726 30 : st2->n.sym = stree->n.sym;
7727 30 : stree->n.sym->refs++;
7728 : }
7729 124 : sym->result = stree->n.sym;
7730 :
7731 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7732 124 : sym->result->attr.pointer = sym->attr.pointer;
7733 124 : sym->result->attr.external = sym->attr.external;
7734 124 : sym->result->attr.referenced = sym->attr.referenced;
7735 124 : sym->result->ts = sym->ts;
7736 124 : sym->attr.proc_pointer = 0;
7737 124 : sym->attr.pointer = 0;
7738 124 : sym->attr.external = 0;
7739 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7740 : {
7741 4 : sym->result->attr.pointer = 0;
7742 4 : sym->result->attr.proc_pointer = 1;
7743 : }
7744 :
7745 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7746 : }
7747 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7748 73743 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7749 405 : && sym->result && sym->result != sym && sym->result->attr.external
7750 28 : && sym == gfc_current_ns->proc_name
7751 28 : && sym == sym->result->ns->proc_name
7752 28 : && strcmp ("ppr@", sym->result->name) == 0)
7753 : {
7754 28 : sym->result->attr.proc_pointer = 1;
7755 28 : sym->attr.pointer = 0;
7756 28 : return true;
7757 : }
7758 : else
7759 : return false;
7760 : }
7761 :
7762 :
7763 : /* Match the interface for a PROCEDURE declaration,
7764 : including brackets (R1212). */
7765 :
7766 : static match
7767 1618 : match_procedure_interface (gfc_symbol **proc_if)
7768 : {
7769 1618 : match m;
7770 1618 : gfc_symtree *st;
7771 1618 : locus old_loc, entry_loc;
7772 1618 : gfc_namespace *old_ns = gfc_current_ns;
7773 1618 : char name[GFC_MAX_SYMBOL_LEN + 1];
7774 :
7775 1618 : old_loc = entry_loc = gfc_current_locus;
7776 1618 : gfc_clear_ts (¤t_ts);
7777 :
7778 1618 : if (gfc_match (" (") != MATCH_YES)
7779 : {
7780 1 : gfc_current_locus = entry_loc;
7781 1 : return MATCH_NO;
7782 : }
7783 :
7784 : /* Get the type spec. for the procedure interface. */
7785 1617 : old_loc = gfc_current_locus;
7786 1617 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7787 1617 : gfc_gobble_whitespace ();
7788 1617 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7789 395 : goto got_ts;
7790 :
7791 1222 : if (m == MATCH_ERROR)
7792 : return m;
7793 :
7794 : /* Procedure interface is itself a procedure. */
7795 1222 : gfc_current_locus = old_loc;
7796 1222 : m = gfc_match_name (name);
7797 :
7798 : /* First look to see if it is already accessible in the current
7799 : namespace because it is use associated or contained. */
7800 1222 : st = NULL;
7801 1222 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7802 : return MATCH_ERROR;
7803 :
7804 : /* If it is still not found, then try the parent namespace, if it
7805 : exists and create the symbol there if it is still not found. */
7806 1222 : if (gfc_current_ns->parent)
7807 427 : gfc_current_ns = gfc_current_ns->parent;
7808 1222 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7809 : return MATCH_ERROR;
7810 :
7811 1222 : gfc_current_ns = old_ns;
7812 1222 : *proc_if = st->n.sym;
7813 :
7814 1222 : if (*proc_if)
7815 : {
7816 1222 : (*proc_if)->refs++;
7817 : /* Resolve interface if possible. That way, attr.procedure is only set
7818 : if it is declared by a later procedure-declaration-stmt, which is
7819 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7820 1222 : while ((*proc_if)->ts.interface
7821 1229 : && *proc_if != (*proc_if)->ts.interface)
7822 7 : *proc_if = (*proc_if)->ts.interface;
7823 :
7824 1222 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7825 389 : && (*proc_if)->ts.type == BT_UNKNOWN
7826 1611 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7827 : (*proc_if)->name, NULL))
7828 : return MATCH_ERROR;
7829 : }
7830 :
7831 0 : got_ts:
7832 1617 : if (gfc_match (" )") != MATCH_YES)
7833 : {
7834 0 : gfc_current_locus = entry_loc;
7835 0 : return MATCH_NO;
7836 : }
7837 :
7838 : return MATCH_YES;
7839 : }
7840 :
7841 :
7842 : /* Match a PROCEDURE declaration (R1211). */
7843 :
7844 : static match
7845 1189 : match_procedure_decl (void)
7846 : {
7847 1189 : match m;
7848 1189 : gfc_symbol *sym, *proc_if = NULL;
7849 1189 : int num;
7850 1189 : gfc_expr *initializer = NULL;
7851 :
7852 : /* Parse interface (with brackets). */
7853 1189 : m = match_procedure_interface (&proc_if);
7854 1189 : if (m != MATCH_YES)
7855 : return m;
7856 :
7857 : /* Parse attributes (with colons). */
7858 1189 : m = match_attr_spec();
7859 1189 : if (m == MATCH_ERROR)
7860 : return MATCH_ERROR;
7861 :
7862 1188 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7863 : {
7864 53 : current_attr.is_bind_c = 1;
7865 53 : has_name_equals = 0;
7866 53 : curr_binding_label = NULL;
7867 : }
7868 :
7869 : /* Get procedure symbols. */
7870 79 : for(num=1;;num++)
7871 : {
7872 1267 : m = gfc_match_symbol (&sym, 0);
7873 1267 : if (m == MATCH_NO)
7874 1 : goto syntax;
7875 1266 : else if (m == MATCH_ERROR)
7876 : return m;
7877 :
7878 : /* Add current_attr to the symbol attributes. */
7879 1266 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7880 : return MATCH_ERROR;
7881 :
7882 1264 : if (sym->attr.is_bind_c)
7883 : {
7884 : /* Check for C1218. */
7885 90 : if (!proc_if || !proc_if->attr.is_bind_c)
7886 : {
7887 1 : gfc_error ("BIND(C) attribute at %C requires "
7888 : "an interface with BIND(C)");
7889 1 : return MATCH_ERROR;
7890 : }
7891 : /* Check for C1217. */
7892 89 : if (has_name_equals && sym->attr.pointer)
7893 : {
7894 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7895 : "POINTER attribute at %C");
7896 1 : return MATCH_ERROR;
7897 : }
7898 88 : if (has_name_equals && sym->attr.dummy)
7899 : {
7900 1 : gfc_error ("Dummy procedure at %C may not have "
7901 : "BIND(C) attribute with NAME");
7902 1 : return MATCH_ERROR;
7903 : }
7904 : /* Set binding label for BIND(C). */
7905 87 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7906 : return MATCH_ERROR;
7907 : }
7908 :
7909 1260 : if (!gfc_add_external (&sym->attr, NULL))
7910 : return MATCH_ERROR;
7911 :
7912 1256 : if (add_hidden_procptr_result (sym))
7913 67 : sym = sym->result;
7914 :
7915 1256 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7916 : return MATCH_ERROR;
7917 :
7918 : /* Set interface. */
7919 1255 : if (proc_if != NULL)
7920 : {
7921 912 : if (sym->ts.type != BT_UNKNOWN)
7922 : {
7923 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7924 : sym->name, &gfc_current_locus,
7925 : gfc_basic_typename (sym->ts.type));
7926 1 : return MATCH_ERROR;
7927 : }
7928 911 : sym->ts.interface = proc_if;
7929 911 : sym->attr.untyped = 1;
7930 911 : sym->attr.if_source = IFSRC_IFBODY;
7931 : }
7932 343 : else if (current_ts.type != BT_UNKNOWN)
7933 : {
7934 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7935 : return MATCH_ERROR;
7936 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7937 198 : sym->ts.interface->ts = current_ts;
7938 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7939 198 : sym->ts.interface->attr.function = 1;
7940 198 : sym->attr.function = 1;
7941 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7942 : }
7943 :
7944 1253 : if (gfc_match (" =>") == MATCH_YES)
7945 : {
7946 110 : if (!current_attr.pointer)
7947 : {
7948 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7949 0 : m = MATCH_ERROR;
7950 0 : goto cleanup;
7951 : }
7952 :
7953 110 : m = match_pointer_init (&initializer, 1);
7954 110 : if (m != MATCH_YES)
7955 1 : goto cleanup;
7956 :
7957 109 : if (!add_init_expr_to_sym (sym->name, &initializer,
7958 : &gfc_current_locus,
7959 : gfc_current_ns->cl_list))
7960 0 : goto cleanup;
7961 :
7962 : }
7963 :
7964 1252 : if (gfc_match_eos () == MATCH_YES)
7965 : return MATCH_YES;
7966 79 : if (gfc_match_char (',') != MATCH_YES)
7967 0 : goto syntax;
7968 : }
7969 :
7970 1 : syntax:
7971 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7972 1 : return MATCH_ERROR;
7973 :
7974 1 : cleanup:
7975 : /* Free stuff up and return. */
7976 1 : gfc_free_expr (initializer);
7977 1 : return m;
7978 : }
7979 :
7980 :
7981 : static match
7982 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7983 :
7984 :
7985 : /* Match a procedure pointer component declaration (R445). */
7986 :
7987 : static match
7988 429 : match_ppc_decl (void)
7989 : {
7990 429 : match m;
7991 429 : gfc_symbol *proc_if = NULL;
7992 429 : gfc_typespec ts;
7993 429 : int num;
7994 429 : gfc_component *c;
7995 429 : gfc_expr *initializer = NULL;
7996 429 : gfc_typebound_proc* tb;
7997 429 : char name[GFC_MAX_SYMBOL_LEN + 1];
7998 :
7999 : /* Parse interface (with brackets). */
8000 429 : m = match_procedure_interface (&proc_if);
8001 429 : if (m != MATCH_YES)
8002 1 : goto syntax;
8003 :
8004 : /* Parse attributes. */
8005 428 : tb = XCNEW (gfc_typebound_proc);
8006 428 : tb->where = gfc_current_locus;
8007 428 : m = match_binding_attributes (tb, false, true);
8008 428 : if (m == MATCH_ERROR)
8009 : return m;
8010 :
8011 425 : gfc_clear_attr (¤t_attr);
8012 425 : current_attr.procedure = 1;
8013 425 : current_attr.proc_pointer = 1;
8014 425 : current_attr.access = tb->access;
8015 425 : current_attr.flavor = FL_PROCEDURE;
8016 :
8017 : /* Match the colons (required). */
8018 425 : if (gfc_match (" ::") != MATCH_YES)
8019 : {
8020 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
8021 1 : return MATCH_ERROR;
8022 : }
8023 :
8024 : /* Check for C450. */
8025 424 : if (!tb->nopass && proc_if == NULL)
8026 : {
8027 2 : gfc_error("NOPASS or explicit interface required at %C");
8028 2 : return MATCH_ERROR;
8029 : }
8030 :
8031 422 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
8032 : return MATCH_ERROR;
8033 :
8034 : /* Match PPC names. */
8035 421 : ts = current_ts;
8036 421 : for(num=1;;num++)
8037 : {
8038 422 : m = gfc_match_name (name);
8039 422 : if (m == MATCH_NO)
8040 0 : goto syntax;
8041 422 : else if (m == MATCH_ERROR)
8042 : return m;
8043 :
8044 422 : if (!gfc_add_component (gfc_current_block(), name, &c))
8045 : return MATCH_ERROR;
8046 :
8047 : /* Add current_attr to the symbol attributes. */
8048 422 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
8049 : return MATCH_ERROR;
8050 :
8051 422 : if (!gfc_add_external (&c->attr, NULL))
8052 : return MATCH_ERROR;
8053 :
8054 422 : if (!gfc_add_proc (&c->attr, name, NULL))
8055 : return MATCH_ERROR;
8056 :
8057 422 : if (num == 1)
8058 421 : c->tb = tb;
8059 : else
8060 : {
8061 1 : c->tb = XCNEW (gfc_typebound_proc);
8062 1 : c->tb->where = gfc_current_locus;
8063 1 : *c->tb = *tb;
8064 : }
8065 :
8066 422 : if (saved_kind_expr)
8067 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
8068 :
8069 : /* Set interface. */
8070 422 : if (proc_if != NULL)
8071 : {
8072 355 : c->ts.interface = proc_if;
8073 355 : c->attr.untyped = 1;
8074 355 : c->attr.if_source = IFSRC_IFBODY;
8075 : }
8076 67 : else if (ts.type != BT_UNKNOWN)
8077 : {
8078 29 : c->ts = ts;
8079 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
8080 29 : c->ts.interface->result = c->ts.interface;
8081 29 : c->ts.interface->ts = ts;
8082 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
8083 29 : c->ts.interface->attr.function = 1;
8084 29 : c->attr.function = 1;
8085 29 : c->attr.if_source = IFSRC_UNKNOWN;
8086 : }
8087 :
8088 422 : if (gfc_match (" =>") == MATCH_YES)
8089 : {
8090 69 : m = match_pointer_init (&initializer, 1);
8091 69 : if (m != MATCH_YES)
8092 : {
8093 0 : gfc_free_expr (initializer);
8094 0 : return m;
8095 : }
8096 69 : c->initializer = initializer;
8097 : }
8098 :
8099 422 : if (gfc_match_eos () == MATCH_YES)
8100 : return MATCH_YES;
8101 1 : if (gfc_match_char (',') != MATCH_YES)
8102 0 : goto syntax;
8103 : }
8104 :
8105 1 : syntax:
8106 1 : gfc_error ("Syntax error in procedure pointer component at %C");
8107 1 : return MATCH_ERROR;
8108 : }
8109 :
8110 :
8111 : /* Match a PROCEDURE declaration inside an interface (R1206). */
8112 :
8113 : static match
8114 1561 : match_procedure_in_interface (void)
8115 : {
8116 1561 : match m;
8117 1561 : gfc_symbol *sym;
8118 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
8119 1561 : locus old_locus;
8120 :
8121 1561 : if (current_interface.type == INTERFACE_NAMELESS
8122 1561 : || current_interface.type == INTERFACE_ABSTRACT)
8123 : {
8124 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
8125 1 : return MATCH_ERROR;
8126 : }
8127 :
8128 : /* Check if the F2008 optional double colon appears. */
8129 1560 : gfc_gobble_whitespace ();
8130 1560 : old_locus = gfc_current_locus;
8131 1560 : if (gfc_match ("::") == MATCH_YES)
8132 : {
8133 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8134 : "MODULE PROCEDURE statement at %L", &old_locus))
8135 : return MATCH_ERROR;
8136 : }
8137 : else
8138 685 : gfc_current_locus = old_locus;
8139 :
8140 2214 : for(;;)
8141 : {
8142 2214 : m = gfc_match_name (name);
8143 2214 : if (m == MATCH_NO)
8144 0 : goto syntax;
8145 2214 : else if (m == MATCH_ERROR)
8146 : return m;
8147 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
8148 : return MATCH_ERROR;
8149 :
8150 2214 : if (!gfc_add_interface (sym))
8151 : return MATCH_ERROR;
8152 :
8153 2213 : if (gfc_match_eos () == MATCH_YES)
8154 : break;
8155 655 : if (gfc_match_char (',') != MATCH_YES)
8156 0 : goto syntax;
8157 : }
8158 :
8159 : return MATCH_YES;
8160 :
8161 0 : syntax:
8162 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8163 0 : return MATCH_ERROR;
8164 : }
8165 :
8166 :
8167 : /* General matcher for PROCEDURE declarations. */
8168 :
8169 : static match match_procedure_in_type (void);
8170 :
8171 : match
8172 6415 : gfc_match_procedure (void)
8173 : {
8174 6415 : match m;
8175 :
8176 6415 : switch (gfc_current_state ())
8177 : {
8178 1189 : case COMP_NONE:
8179 1189 : case COMP_PROGRAM:
8180 1189 : case COMP_MODULE:
8181 1189 : case COMP_SUBMODULE:
8182 1189 : case COMP_SUBROUTINE:
8183 1189 : case COMP_FUNCTION:
8184 1189 : case COMP_BLOCK:
8185 1189 : m = match_procedure_decl ();
8186 1189 : break;
8187 1561 : case COMP_INTERFACE:
8188 1561 : m = match_procedure_in_interface ();
8189 1561 : break;
8190 429 : case COMP_DERIVED:
8191 429 : m = match_ppc_decl ();
8192 429 : break;
8193 3236 : case COMP_DERIVED_CONTAINS:
8194 3236 : m = match_procedure_in_type ();
8195 3236 : break;
8196 : default:
8197 : return MATCH_NO;
8198 : }
8199 :
8200 6415 : if (m != MATCH_YES)
8201 : return m;
8202 :
8203 6359 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8204 4 : return MATCH_ERROR;
8205 :
8206 : return m;
8207 : }
8208 :
8209 :
8210 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8211 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8212 : parser-state-stack to find out whether we're in a module. */
8213 :
8214 : static void
8215 62436 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8216 : {
8217 62436 : bool in_module;
8218 :
8219 124872 : in_module = (gfc_state_stack->previous
8220 62436 : && (gfc_state_stack->previous->state == COMP_MODULE
8221 50901 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8222 :
8223 62436 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8224 62436 : }
8225 :
8226 :
8227 : /* Match a function declaration. */
8228 :
8229 : match
8230 127864 : gfc_match_function_decl (void)
8231 : {
8232 127864 : char name[GFC_MAX_SYMBOL_LEN + 1];
8233 127864 : gfc_symbol *sym, *result;
8234 127864 : locus old_loc;
8235 127864 : match m;
8236 127864 : match suffix_match;
8237 127864 : match found_match; /* Status returned by match func. */
8238 :
8239 127864 : if (gfc_current_state () != COMP_NONE
8240 80397 : && gfc_current_state () != COMP_INTERFACE
8241 52104 : && gfc_current_state () != COMP_CONTAINS)
8242 : return MATCH_NO;
8243 :
8244 127864 : gfc_clear_ts (¤t_ts);
8245 :
8246 127864 : old_loc = gfc_current_locus;
8247 :
8248 127864 : m = gfc_match_prefix (¤t_ts);
8249 127864 : if (m != MATCH_YES)
8250 : {
8251 9861 : gfc_current_locus = old_loc;
8252 9861 : return m;
8253 : }
8254 :
8255 118003 : if (gfc_match ("function% %n", name) != MATCH_YES)
8256 : {
8257 98576 : gfc_current_locus = old_loc;
8258 98576 : return MATCH_NO;
8259 : }
8260 :
8261 19427 : if (get_proc_name (name, &sym, false))
8262 : return MATCH_ERROR;
8263 :
8264 19422 : if (add_hidden_procptr_result (sym))
8265 20 : sym = sym->result;
8266 :
8267 19422 : if (current_attr.module_procedure)
8268 : {
8269 304 : sym->attr.module_procedure = 1;
8270 304 : if (gfc_current_state () == COMP_INTERFACE)
8271 215 : gfc_current_ns->has_import_set = 1;
8272 : }
8273 :
8274 19422 : gfc_new_block = sym;
8275 :
8276 19422 : m = gfc_match_formal_arglist (sym, 0, 0);
8277 19422 : if (m == MATCH_NO)
8278 : {
8279 6 : gfc_error ("Expected formal argument list in function "
8280 : "definition at %C");
8281 6 : m = MATCH_ERROR;
8282 6 : goto cleanup;
8283 : }
8284 19416 : else if (m == MATCH_ERROR)
8285 0 : goto cleanup;
8286 :
8287 19416 : result = NULL;
8288 :
8289 : /* According to the draft, the bind(c) and result clause can
8290 : come in either order after the formal_arg_list (i.e., either
8291 : can be first, both can exist together or by themselves or neither
8292 : one). Therefore, the match_result can't match the end of the
8293 : string, and check for the bind(c) or result clause in either order. */
8294 19416 : found_match = gfc_match_eos ();
8295 :
8296 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8297 : must have been marked BIND(C) with a BIND(C) attribute and that is
8298 : not allowed for procedures. */
8299 19416 : if (sym->attr.is_bind_c == 1)
8300 : {
8301 3 : sym->attr.is_bind_c = 0;
8302 :
8303 3 : if (gfc_state_stack->previous
8304 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8305 : {
8306 1 : locus loc;
8307 1 : loc = sym->old_symbol != NULL
8308 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8309 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8310 : "variables or common blocks", &loc);
8311 : }
8312 : }
8313 :
8314 19416 : if (found_match != MATCH_YES)
8315 : {
8316 : /* If we haven't found the end-of-statement, look for a suffix. */
8317 7916 : suffix_match = gfc_match_suffix (sym, &result);
8318 7916 : if (suffix_match == MATCH_YES)
8319 : /* Need to get the eos now. */
8320 7908 : found_match = gfc_match_eos ();
8321 : else
8322 : found_match = suffix_match;
8323 : }
8324 :
8325 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8326 : subprogram and a binding label is specified, it shall be the
8327 : same as the binding label specified in the corresponding module
8328 : procedure interface body. */
8329 19416 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8330 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8331 3 : && sym->binding_label && sym->old_symbol->binding_label
8332 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8333 : {
8334 1 : const char *null = "NULL", *s1, *s2;
8335 1 : s1 = sym->binding_label;
8336 1 : if (!s1) s1 = null;
8337 1 : s2 = sym->old_symbol->binding_label;
8338 1 : if (!s2) s2 = null;
8339 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8340 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8341 1 : return MATCH_ERROR;
8342 : }
8343 :
8344 19415 : if(found_match != MATCH_YES)
8345 : m = MATCH_ERROR;
8346 : else
8347 : {
8348 : /* Make changes to the symbol. */
8349 19407 : m = MATCH_ERROR;
8350 :
8351 19407 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8352 0 : goto cleanup;
8353 :
8354 19407 : if (!gfc_missing_attr (&sym->attr, NULL))
8355 0 : goto cleanup;
8356 :
8357 19407 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8358 : {
8359 1 : if(!sym->attr.module_procedure)
8360 1 : goto cleanup;
8361 : else
8362 0 : gfc_error_check ();
8363 : }
8364 :
8365 : /* Delay matching the function characteristics until after the
8366 : specification block by signalling kind=-1. */
8367 19406 : sym->declared_at = old_loc;
8368 19406 : if (current_ts.type != BT_UNKNOWN)
8369 6922 : current_ts.kind = -1;
8370 : else
8371 12484 : current_ts.kind = 0;
8372 :
8373 19406 : if (result == NULL)
8374 : {
8375 13594 : if (current_ts.type != BT_UNKNOWN
8376 13594 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8377 1 : goto cleanup;
8378 13593 : sym->result = sym;
8379 : }
8380 : else
8381 : {
8382 5812 : if (current_ts.type != BT_UNKNOWN
8383 5812 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8384 0 : goto cleanup;
8385 5812 : sym->result = result;
8386 : }
8387 :
8388 : /* Warn if this procedure has the same name as an intrinsic. */
8389 19405 : do_warn_intrinsic_shadow (sym, true);
8390 :
8391 19405 : return MATCH_YES;
8392 : }
8393 :
8394 16 : cleanup:
8395 16 : gfc_current_locus = old_loc;
8396 16 : return m;
8397 : }
8398 :
8399 :
8400 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8401 : pass the name of the entry, rather than the gfc_current_block name, and
8402 : to return false upon finding an existing global entry. */
8403 :
8404 : static bool
8405 539 : add_global_entry (const char *name, const char *binding_label, bool sub,
8406 : locus *where)
8407 : {
8408 539 : gfc_gsymbol *s;
8409 539 : enum gfc_symbol_type type;
8410 :
8411 539 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8412 :
8413 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8414 : name is a global identifier. */
8415 539 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8416 : {
8417 516 : s = gfc_get_gsymbol (name, false);
8418 :
8419 516 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8420 : {
8421 2 : gfc_global_used (s, where);
8422 2 : return false;
8423 : }
8424 : else
8425 : {
8426 514 : s->type = type;
8427 514 : s->sym_name = name;
8428 514 : s->where = *where;
8429 514 : s->defined = 1;
8430 514 : s->ns = gfc_current_ns;
8431 : }
8432 : }
8433 :
8434 : /* Don't add the symbol multiple times. */
8435 537 : if (binding_label
8436 537 : && (!gfc_notification_std (GFC_STD_F2008)
8437 0 : || strcmp (name, binding_label) != 0))
8438 : {
8439 23 : s = gfc_get_gsymbol (binding_label, true);
8440 :
8441 23 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8442 : {
8443 1 : gfc_global_used (s, where);
8444 1 : return false;
8445 : }
8446 : else
8447 : {
8448 22 : s->type = type;
8449 22 : s->sym_name = gfc_get_string ("%s", name);
8450 22 : s->binding_label = binding_label;
8451 22 : s->where = *where;
8452 22 : s->defined = 1;
8453 22 : s->ns = gfc_current_ns;
8454 : }
8455 : }
8456 :
8457 : return true;
8458 : }
8459 :
8460 :
8461 : /* Match an ENTRY statement. */
8462 :
8463 : match
8464 805 : gfc_match_entry (void)
8465 : {
8466 805 : gfc_symbol *proc;
8467 805 : gfc_symbol *result;
8468 805 : gfc_symbol *entry;
8469 805 : char name[GFC_MAX_SYMBOL_LEN + 1];
8470 805 : gfc_compile_state state;
8471 805 : match m;
8472 805 : gfc_entry_list *el;
8473 805 : locus old_loc;
8474 805 : bool module_procedure;
8475 805 : char peek_char;
8476 805 : match is_bind_c;
8477 :
8478 805 : m = gfc_match_name (name);
8479 805 : if (m != MATCH_YES)
8480 : return m;
8481 :
8482 805 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8483 : return MATCH_ERROR;
8484 :
8485 805 : state = gfc_current_state ();
8486 805 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8487 : {
8488 3 : switch (state)
8489 : {
8490 0 : case COMP_PROGRAM:
8491 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8492 0 : break;
8493 0 : case COMP_MODULE:
8494 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8495 0 : break;
8496 0 : case COMP_SUBMODULE:
8497 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8498 0 : break;
8499 0 : case COMP_BLOCK_DATA:
8500 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8501 : "a BLOCK DATA");
8502 0 : break;
8503 0 : case COMP_INTERFACE:
8504 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8505 : "an INTERFACE");
8506 0 : break;
8507 1 : case COMP_STRUCTURE:
8508 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8509 : "a STRUCTURE block");
8510 1 : break;
8511 0 : case COMP_DERIVED:
8512 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8513 : "a DERIVED TYPE block");
8514 0 : break;
8515 0 : case COMP_IF:
8516 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8517 : "an IF-THEN block");
8518 0 : break;
8519 0 : case COMP_DO:
8520 0 : case COMP_DO_CONCURRENT:
8521 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8522 : "a DO block");
8523 0 : break;
8524 0 : case COMP_SELECT:
8525 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8526 : "a SELECT block");
8527 0 : break;
8528 0 : case COMP_FORALL:
8529 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8530 : "a FORALL block");
8531 0 : break;
8532 0 : case COMP_WHERE:
8533 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8534 : "a WHERE block");
8535 0 : break;
8536 0 : case COMP_CONTAINS:
8537 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8538 : "a contained subprogram");
8539 0 : break;
8540 2 : default:
8541 2 : gfc_error ("Unexpected ENTRY statement at %C");
8542 : }
8543 3 : return MATCH_ERROR;
8544 : }
8545 :
8546 802 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8547 802 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8548 : {
8549 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8550 1 : return MATCH_ERROR;
8551 : }
8552 :
8553 1602 : module_procedure = gfc_current_ns->parent != NULL
8554 260 : && gfc_current_ns->parent->proc_name
8555 801 : && gfc_current_ns->parent->proc_name->attr.flavor
8556 260 : == FL_MODULE;
8557 :
8558 801 : if (gfc_current_ns->parent != NULL
8559 260 : && gfc_current_ns->parent->proc_name
8560 260 : && !module_procedure)
8561 : {
8562 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8563 : "contained procedure");
8564 0 : return MATCH_ERROR;
8565 : }
8566 :
8567 : /* Module function entries need special care in get_proc_name
8568 : because previous references within the function will have
8569 : created symbols attached to the current namespace. */
8570 801 : if (get_proc_name (name, &entry,
8571 : gfc_current_ns->parent != NULL
8572 801 : && module_procedure))
8573 : return MATCH_ERROR;
8574 :
8575 799 : proc = gfc_current_block ();
8576 :
8577 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8578 : must have been marked BIND(C) with a BIND(C) attribute and that is
8579 : not allowed for procedures. */
8580 799 : if (entry->attr.is_bind_c == 1)
8581 : {
8582 0 : locus loc;
8583 :
8584 0 : entry->attr.is_bind_c = 0;
8585 :
8586 0 : loc = entry->old_symbol != NULL
8587 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8588 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8589 : "variables or common blocks", &loc);
8590 : }
8591 :
8592 : /* Check what next non-whitespace character is so we can tell if there
8593 : is the required parens if we have a BIND(C). */
8594 799 : old_loc = gfc_current_locus;
8595 799 : gfc_gobble_whitespace ();
8596 799 : peek_char = gfc_peek_ascii_char ();
8597 :
8598 799 : if (state == COMP_SUBROUTINE)
8599 : {
8600 138 : m = gfc_match_formal_arglist (entry, 0, 1);
8601 138 : if (m != MATCH_YES)
8602 : return MATCH_ERROR;
8603 :
8604 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8605 : never be an internal procedure. */
8606 138 : is_bind_c = gfc_match_bind_c (entry, true);
8607 138 : if (is_bind_c == MATCH_ERROR)
8608 : return MATCH_ERROR;
8609 138 : if (is_bind_c == MATCH_YES)
8610 : {
8611 22 : if (peek_char != '(')
8612 : {
8613 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8614 0 : return MATCH_ERROR;
8615 : }
8616 :
8617 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8618 22 : &(entry->declared_at), 1))
8619 : return MATCH_ERROR;
8620 :
8621 : }
8622 :
8623 138 : if (!gfc_current_ns->parent
8624 138 : && !add_global_entry (name, entry->binding_label, true,
8625 : &old_loc))
8626 : return MATCH_ERROR;
8627 :
8628 : /* An entry in a subroutine. */
8629 135 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8630 135 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8631 3 : return MATCH_ERROR;
8632 : }
8633 : else
8634 : {
8635 : /* An entry in a function.
8636 : We need to take special care because writing
8637 : ENTRY f()
8638 : as
8639 : ENTRY f
8640 : is allowed, whereas
8641 : ENTRY f() RESULT (r)
8642 : can't be written as
8643 : ENTRY f RESULT (r). */
8644 661 : if (gfc_match_eos () == MATCH_YES)
8645 : {
8646 24 : gfc_current_locus = old_loc;
8647 : /* Match the empty argument list, and add the interface to
8648 : the symbol. */
8649 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8650 : }
8651 : else
8652 637 : m = gfc_match_formal_arglist (entry, 0, 0);
8653 :
8654 661 : if (m != MATCH_YES)
8655 : return MATCH_ERROR;
8656 :
8657 660 : result = NULL;
8658 :
8659 660 : if (gfc_match_eos () == MATCH_YES)
8660 : {
8661 411 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8662 411 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8663 2 : return MATCH_ERROR;
8664 :
8665 409 : entry->result = entry;
8666 : }
8667 : else
8668 : {
8669 249 : m = gfc_match_suffix (entry, &result);
8670 249 : if (m == MATCH_NO)
8671 0 : gfc_syntax_error (ST_ENTRY);
8672 249 : if (m != MATCH_YES)
8673 : return MATCH_ERROR;
8674 :
8675 249 : if (result)
8676 : {
8677 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8678 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8679 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8680 0 : return MATCH_ERROR;
8681 212 : entry->result = result;
8682 : }
8683 : else
8684 : {
8685 37 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8686 37 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8687 0 : return MATCH_ERROR;
8688 37 : entry->result = entry;
8689 : }
8690 : }
8691 :
8692 658 : if (!gfc_current_ns->parent
8693 658 : && !add_global_entry (name, entry->binding_label, false,
8694 : &old_loc))
8695 : return MATCH_ERROR;
8696 : }
8697 :
8698 790 : if (gfc_match_eos () != MATCH_YES)
8699 : {
8700 0 : gfc_syntax_error (ST_ENTRY);
8701 0 : return MATCH_ERROR;
8702 : }
8703 :
8704 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8705 790 : if (proc->attr.elemental && entry->attr.is_bind_c)
8706 : {
8707 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8708 : "elemental procedure", &entry->declared_at);
8709 2 : return MATCH_ERROR;
8710 : }
8711 :
8712 788 : entry->attr.recursive = proc->attr.recursive;
8713 788 : entry->attr.elemental = proc->attr.elemental;
8714 788 : entry->attr.pure = proc->attr.pure;
8715 :
8716 788 : el = gfc_get_entry_list ();
8717 788 : el->sym = entry;
8718 788 : el->next = gfc_current_ns->entries;
8719 788 : gfc_current_ns->entries = el;
8720 788 : if (el->next)
8721 85 : el->id = el->next->id + 1;
8722 : else
8723 703 : el->id = 1;
8724 :
8725 788 : new_st.op = EXEC_ENTRY;
8726 788 : new_st.ext.entry = el;
8727 :
8728 788 : return MATCH_YES;
8729 : }
8730 :
8731 :
8732 : /* Match a subroutine statement, including optional prefixes. */
8733 :
8734 : match
8735 804576 : gfc_match_subroutine (void)
8736 : {
8737 804576 : char name[GFC_MAX_SYMBOL_LEN + 1];
8738 804576 : gfc_symbol *sym;
8739 804576 : match m;
8740 804576 : match is_bind_c;
8741 804576 : char peek_char;
8742 804576 : bool allow_binding_name;
8743 804576 : locus loc;
8744 :
8745 804576 : if (gfc_current_state () != COMP_NONE
8746 762892 : && gfc_current_state () != COMP_INTERFACE
8747 740626 : && gfc_current_state () != COMP_CONTAINS)
8748 : return MATCH_NO;
8749 :
8750 105529 : m = gfc_match_prefix (NULL);
8751 105529 : if (m != MATCH_YES)
8752 : return m;
8753 :
8754 95678 : loc = gfc_current_locus;
8755 95678 : m = gfc_match ("subroutine% %n", name);
8756 95678 : if (m != MATCH_YES)
8757 : return m;
8758 :
8759 43067 : if (get_proc_name (name, &sym, false))
8760 : return MATCH_ERROR;
8761 :
8762 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8763 : the symbol existed before. */
8764 43056 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8765 : &gfc_current_locus);
8766 :
8767 43056 : if (current_attr.module_procedure)
8768 : {
8769 427 : sym->attr.module_procedure = 1;
8770 427 : if (gfc_current_state () == COMP_INTERFACE)
8771 301 : gfc_current_ns->has_import_set = 1;
8772 : }
8773 :
8774 43056 : if (add_hidden_procptr_result (sym))
8775 9 : sym = sym->result;
8776 :
8777 43056 : gfc_new_block = sym;
8778 :
8779 : /* Check what next non-whitespace character is so we can tell if there
8780 : is the required parens if we have a BIND(C). */
8781 43056 : gfc_gobble_whitespace ();
8782 43056 : peek_char = gfc_peek_ascii_char ();
8783 :
8784 43056 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8785 : return MATCH_ERROR;
8786 :
8787 43053 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8788 : return MATCH_ERROR;
8789 :
8790 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8791 : must have been marked BIND(C) with a BIND(C) attribute and that is
8792 : not allowed for procedures. */
8793 43053 : if (sym->attr.is_bind_c == 1)
8794 : {
8795 4 : sym->attr.is_bind_c = 0;
8796 :
8797 4 : if (gfc_state_stack->previous
8798 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8799 : {
8800 2 : locus loc;
8801 2 : loc = sym->old_symbol != NULL
8802 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8803 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8804 : "variables or common blocks", &loc);
8805 : }
8806 : }
8807 :
8808 : /* C binding names are not allowed for internal procedures. */
8809 43053 : if (gfc_current_state () == COMP_CONTAINS
8810 26096 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8811 : allow_binding_name = false;
8812 : else
8813 28101 : allow_binding_name = true;
8814 :
8815 : /* Here, we are just checking if it has the bind(c) attribute, and if
8816 : so, then we need to make sure it's all correct. If it doesn't,
8817 : we still need to continue matching the rest of the subroutine line. */
8818 43053 : gfc_gobble_whitespace ();
8819 43053 : loc = gfc_current_locus;
8820 43053 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8821 43053 : if (is_bind_c == MATCH_ERROR)
8822 : {
8823 : /* There was an attempt at the bind(c), but it was wrong. An
8824 : error message should have been printed w/in the gfc_match_bind_c
8825 : so here we'll just return the MATCH_ERROR. */
8826 : return MATCH_ERROR;
8827 : }
8828 :
8829 43040 : if (is_bind_c == MATCH_YES)
8830 : {
8831 4045 : gfc_formal_arglist *arg;
8832 :
8833 : /* The following is allowed in the Fortran 2008 draft. */
8834 4045 : if (gfc_current_state () == COMP_CONTAINS
8835 1297 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8836 4456 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8837 : "at %L may not be specified for an internal "
8838 : "procedure", &gfc_current_locus))
8839 : return MATCH_ERROR;
8840 :
8841 4042 : if (peek_char != '(')
8842 : {
8843 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8844 1 : return MATCH_ERROR;
8845 : }
8846 :
8847 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8848 : subprogram and a binding label is specified, it shall be the
8849 : same as the binding label specified in the corresponding module
8850 : procedure interface body. */
8851 4041 : if (sym->attr.module_procedure && sym->old_symbol
8852 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8853 3 : && sym->binding_label && sym->old_symbol->binding_label
8854 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8855 : {
8856 1 : const char *null = "NULL", *s1, *s2;
8857 1 : s1 = sym->binding_label;
8858 1 : if (!s1) s1 = null;
8859 1 : s2 = sym->old_symbol->binding_label;
8860 1 : if (!s2) s2 = null;
8861 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8862 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8863 1 : return MATCH_ERROR;
8864 : }
8865 :
8866 : /* Scan the dummy arguments for an alternate return. */
8867 12509 : for (arg = sym->formal; arg; arg = arg->next)
8868 8470 : if (!arg->sym)
8869 : {
8870 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8871 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8872 1 : return MATCH_ERROR;
8873 : }
8874 :
8875 4039 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8876 : return MATCH_ERROR;
8877 : }
8878 :
8879 43033 : if (gfc_match_eos () != MATCH_YES)
8880 : {
8881 1 : gfc_syntax_error (ST_SUBROUTINE);
8882 1 : return MATCH_ERROR;
8883 : }
8884 :
8885 43032 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8886 : {
8887 4 : if(!sym->attr.module_procedure)
8888 : return MATCH_ERROR;
8889 : else
8890 3 : gfc_error_check ();
8891 : }
8892 :
8893 : /* Warn if it has the same name as an intrinsic. */
8894 43031 : do_warn_intrinsic_shadow (sym, false);
8895 :
8896 43031 : return MATCH_YES;
8897 : }
8898 :
8899 :
8900 : /* Check that the NAME identifier in a BIND attribute or statement
8901 : is conform to C identifier rules. */
8902 :
8903 : match
8904 1185 : check_bind_name_identifier (char **name)
8905 : {
8906 1185 : char *n = *name, *p;
8907 :
8908 : /* Remove leading spaces. */
8909 1211 : while (*n == ' ')
8910 26 : n++;
8911 :
8912 : /* On an empty string, free memory and set name to NULL. */
8913 1185 : if (*n == '\0')
8914 : {
8915 42 : free (*name);
8916 42 : *name = NULL;
8917 42 : return MATCH_YES;
8918 : }
8919 :
8920 : /* Remove trailing spaces. */
8921 1143 : p = n + strlen(n) - 1;
8922 1159 : while (*p == ' ')
8923 16 : *(p--) = '\0';
8924 :
8925 : /* Insert the identifier into the symbol table. */
8926 1143 : p = xstrdup (n);
8927 1143 : free (*name);
8928 1143 : *name = p;
8929 :
8930 : /* Now check that identifier is valid under C rules. */
8931 1143 : if (ISDIGIT (*p))
8932 : {
8933 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8934 2 : return MATCH_ERROR;
8935 : }
8936 :
8937 12496 : for (; *p; p++)
8938 11358 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8939 : {
8940 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8941 3 : return MATCH_ERROR;
8942 : }
8943 :
8944 : return MATCH_YES;
8945 : }
8946 :
8947 :
8948 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8949 : given, and set the binding label in either the given symbol (if not
8950 : NULL), or in the current_ts. The symbol may be NULL because we may
8951 : encounter the BIND(C) before the declaration itself. Return
8952 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8953 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8954 : or MATCH_YES if the specifier was correct and the binding label and
8955 : bind(c) fields were set correctly for the given symbol or the
8956 : current_ts. If allow_binding_name is false, no binding name may be
8957 : given. */
8958 :
8959 : match
8960 51658 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8961 : {
8962 51658 : char *binding_label = NULL;
8963 51658 : gfc_expr *e = NULL;
8964 :
8965 : /* Initialize the flag that specifies whether we encountered a NAME=
8966 : specifier or not. */
8967 51658 : has_name_equals = 0;
8968 :
8969 : /* This much we have to be able to match, in this order, if
8970 : there is a bind(c) label. */
8971 51658 : if (gfc_match (" bind ( c ") != MATCH_YES)
8972 : return MATCH_NO;
8973 :
8974 : /* Now see if there is a binding label, or if we've reached the
8975 : end of the bind(c) attribute without one. */
8976 7029 : if (gfc_match_char (',') == MATCH_YES)
8977 : {
8978 1192 : if (gfc_match (" name = ") != MATCH_YES)
8979 : {
8980 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8981 : "at %C");
8982 : /* should give an error message here */
8983 1 : return MATCH_ERROR;
8984 : }
8985 :
8986 1191 : has_name_equals = 1;
8987 :
8988 1191 : if (gfc_match_init_expr (&e) != MATCH_YES)
8989 : {
8990 2 : gfc_free_expr (e);
8991 2 : return MATCH_ERROR;
8992 : }
8993 :
8994 1189 : if (!gfc_simplify_expr(e, 0))
8995 : {
8996 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8997 0 : gfc_free_expr (e);
8998 0 : return MATCH_ERROR;
8999 : }
9000 :
9001 1189 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
9002 1186 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
9003 : {
9004 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
9005 : "default character kind");
9006 4 : gfc_free_expr(e);
9007 4 : return MATCH_ERROR;
9008 : }
9009 :
9010 : // Get a C string from the Fortran string constant
9011 2370 : binding_label = gfc_widechar_to_char (e->value.character.string,
9012 1185 : e->value.character.length);
9013 1185 : gfc_free_expr(e);
9014 :
9015 : // Check that it is valid (old gfc_match_name_C)
9016 1185 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
9017 : return MATCH_ERROR;
9018 : }
9019 :
9020 : /* Get the required right paren. */
9021 7017 : if (gfc_match_char (')') != MATCH_YES)
9022 : {
9023 1 : gfc_error ("Missing closing paren for binding label at %C");
9024 1 : return MATCH_ERROR;
9025 : }
9026 :
9027 7016 : if (has_name_equals && !allow_binding_name)
9028 : {
9029 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
9030 6 : return MATCH_ERROR;
9031 : }
9032 :
9033 7010 : if (has_name_equals && sym != NULL && sym->attr.dummy)
9034 : {
9035 2 : gfc_error ("For dummy procedure %s, no binding name is "
9036 : "allowed in BIND(C) at %C", sym->name);
9037 2 : return MATCH_ERROR;
9038 : }
9039 :
9040 :
9041 : /* Save the binding label to the symbol. If sym is null, we're
9042 : probably matching the typespec attributes of a declaration and
9043 : haven't gotten the name yet, and therefore, no symbol yet. */
9044 7008 : if (binding_label)
9045 : {
9046 1131 : if (sym != NULL)
9047 1022 : sym->binding_label = binding_label;
9048 : else
9049 109 : curr_binding_label = binding_label;
9050 : }
9051 5877 : else if (allow_binding_name)
9052 : {
9053 : /* No binding label, but if symbol isn't null, we
9054 : can set the label for it here.
9055 : If name="" or allow_binding_name is false, no C binding name is
9056 : created. */
9057 5448 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
9058 5281 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
9059 : }
9060 :
9061 7008 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
9062 741 : && current_interface.type == INTERFACE_ABSTRACT)
9063 : {
9064 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
9065 1 : return MATCH_ERROR;
9066 : }
9067 :
9068 : return MATCH_YES;
9069 : }
9070 :
9071 :
9072 : /* Return nonzero if we're currently compiling a contained procedure. */
9073 :
9074 : static int
9075 62760 : contained_procedure (void)
9076 : {
9077 62760 : gfc_state_data *s = gfc_state_stack;
9078 :
9079 62760 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
9080 61844 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
9081 36542 : return 1;
9082 :
9083 : return 0;
9084 : }
9085 :
9086 : /* Set the kind of each enumerator. The kind is selected such that it is
9087 : interoperable with the corresponding C enumeration type, making
9088 : sure that -fshort-enums is honored. */
9089 :
9090 : static void
9091 158 : set_enum_kind(void)
9092 : {
9093 158 : enumerator_history *current_history = NULL;
9094 158 : int kind;
9095 158 : int i;
9096 :
9097 158 : if (max_enum == NULL || enum_history == NULL)
9098 : return;
9099 :
9100 150 : if (!flag_short_enums)
9101 : return;
9102 :
9103 : i = 0;
9104 48 : do
9105 : {
9106 48 : kind = gfc_integer_kinds[i++].kind;
9107 : }
9108 48 : while (kind < gfc_c_int_kind
9109 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
9110 : kind) != ARITH_OK);
9111 :
9112 24 : current_history = enum_history;
9113 96 : while (current_history != NULL)
9114 : {
9115 72 : current_history->sym->ts.kind = kind;
9116 72 : current_history = current_history->next;
9117 : }
9118 : }
9119 :
9120 :
9121 : /* Match any of the various end-block statements. Returns the type of
9122 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
9123 : and END BLOCK statements cannot be replaced by a single END statement. */
9124 :
9125 : match
9126 184640 : gfc_match_end (gfc_statement *st)
9127 : {
9128 184640 : char name[GFC_MAX_SYMBOL_LEN + 1];
9129 184640 : gfc_compile_state state;
9130 184640 : locus old_loc;
9131 184640 : const char *block_name;
9132 184640 : const char *target;
9133 184640 : int eos_ok;
9134 184640 : match m;
9135 184640 : gfc_namespace *parent_ns, *ns, *prev_ns;
9136 184640 : gfc_namespace **nsp;
9137 184640 : bool abbreviated_modproc_decl = false;
9138 184640 : bool got_matching_end = false;
9139 :
9140 184640 : old_loc = gfc_current_locus;
9141 184640 : if (gfc_match ("end") != MATCH_YES)
9142 : return MATCH_NO;
9143 :
9144 179542 : state = gfc_current_state ();
9145 98060 : block_name = gfc_current_block () == NULL
9146 179542 : ? NULL : gfc_current_block ()->name;
9147 :
9148 179542 : switch (state)
9149 : {
9150 2971 : case COMP_ASSOCIATE:
9151 2971 : case COMP_BLOCK:
9152 2971 : case COMP_CHANGE_TEAM:
9153 2971 : if (startswith (block_name, "block@"))
9154 : block_name = NULL;
9155 : break;
9156 :
9157 17492 : case COMP_CONTAINS:
9158 17492 : case COMP_DERIVED_CONTAINS:
9159 17492 : case COMP_OMP_BEGIN_METADIRECTIVE:
9160 17492 : state = gfc_state_stack->previous->state;
9161 15946 : block_name = gfc_state_stack->previous->sym == NULL
9162 17492 : ? NULL : gfc_state_stack->previous->sym->name;
9163 17492 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
9164 17492 : && gfc_state_stack->previous->sym->abr_modproc_decl;
9165 : break;
9166 :
9167 : case COMP_OMP_METADIRECTIVE:
9168 : {
9169 : /* Metadirectives can be nested, so we need to drill down to the
9170 : first state that is not COMP_OMP_METADIRECTIVE. */
9171 : gfc_state_data *state_data = gfc_state_stack;
9172 :
9173 85 : do
9174 : {
9175 85 : state_data = state_data->previous;
9176 85 : state = state_data->state;
9177 77 : block_name = (state_data->sym == NULL
9178 85 : ? NULL : state_data->sym->name);
9179 170 : abbreviated_modproc_decl = (state_data->sym
9180 85 : && state_data->sym->abr_modproc_decl);
9181 : }
9182 85 : while (state == COMP_OMP_METADIRECTIVE);
9183 :
9184 83 : if (block_name && startswith (block_name, "block@"))
9185 : block_name = NULL;
9186 : }
9187 : break;
9188 :
9189 : default:
9190 : break;
9191 : }
9192 :
9193 83 : if (!abbreviated_modproc_decl)
9194 179541 : abbreviated_modproc_decl = gfc_current_block ()
9195 179541 : && gfc_current_block ()->abr_modproc_decl;
9196 :
9197 179542 : switch (state)
9198 : {
9199 27949 : case COMP_NONE:
9200 27949 : case COMP_PROGRAM:
9201 27949 : *st = ST_END_PROGRAM;
9202 27949 : target = " program";
9203 27949 : eos_ok = 1;
9204 27949 : break;
9205 :
9206 43221 : case COMP_SUBROUTINE:
9207 43221 : *st = ST_END_SUBROUTINE;
9208 43221 : if (!abbreviated_modproc_decl)
9209 : target = " subroutine";
9210 : else
9211 148 : target = " procedure";
9212 43221 : eos_ok = !contained_procedure ();
9213 43221 : break;
9214 :
9215 19539 : case COMP_FUNCTION:
9216 19539 : *st = ST_END_FUNCTION;
9217 19539 : if (!abbreviated_modproc_decl)
9218 : target = " function";
9219 : else
9220 117 : target = " procedure";
9221 19539 : eos_ok = !contained_procedure ();
9222 19539 : break;
9223 :
9224 87 : case COMP_BLOCK_DATA:
9225 87 : *st = ST_END_BLOCK_DATA;
9226 87 : target = " block data";
9227 87 : eos_ok = 1;
9228 87 : break;
9229 :
9230 9843 : case COMP_MODULE:
9231 9843 : *st = ST_END_MODULE;
9232 9843 : target = " module";
9233 9843 : eos_ok = 1;
9234 9843 : break;
9235 :
9236 266 : case COMP_SUBMODULE:
9237 266 : *st = ST_END_SUBMODULE;
9238 266 : target = " submodule";
9239 266 : eos_ok = 1;
9240 266 : break;
9241 :
9242 10793 : case COMP_INTERFACE:
9243 10793 : *st = ST_END_INTERFACE;
9244 10793 : target = " interface";
9245 10793 : eos_ok = 0;
9246 10793 : break;
9247 :
9248 257 : case COMP_MAP:
9249 257 : *st = ST_END_MAP;
9250 257 : target = " map";
9251 257 : eos_ok = 0;
9252 257 : break;
9253 :
9254 132 : case COMP_UNION:
9255 132 : *st = ST_END_UNION;
9256 132 : target = " union";
9257 132 : eos_ok = 0;
9258 132 : break;
9259 :
9260 313 : case COMP_STRUCTURE:
9261 313 : *st = ST_END_STRUCTURE;
9262 313 : target = " structure";
9263 313 : eos_ok = 0;
9264 313 : break;
9265 :
9266 12953 : case COMP_DERIVED:
9267 12953 : case COMP_DERIVED_CONTAINS:
9268 12953 : *st = ST_END_TYPE;
9269 12953 : target = " type";
9270 12953 : eos_ok = 0;
9271 12953 : break;
9272 :
9273 1549 : case COMP_ASSOCIATE:
9274 1549 : *st = ST_END_ASSOCIATE;
9275 1549 : target = " associate";
9276 1549 : eos_ok = 0;
9277 1549 : break;
9278 :
9279 1378 : case COMP_BLOCK:
9280 1378 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9281 1378 : *st = ST_END_BLOCK;
9282 1378 : target = " block";
9283 1378 : eos_ok = 0;
9284 1378 : break;
9285 :
9286 14811 : case COMP_IF:
9287 14811 : *st = ST_ENDIF;
9288 14811 : target = " if";
9289 14811 : eos_ok = 0;
9290 14811 : break;
9291 :
9292 30663 : case COMP_DO:
9293 30663 : case COMP_DO_CONCURRENT:
9294 30663 : *st = ST_ENDDO;
9295 30663 : target = " do";
9296 30663 : eos_ok = 0;
9297 30663 : break;
9298 :
9299 54 : case COMP_CRITICAL:
9300 54 : *st = ST_END_CRITICAL;
9301 54 : target = " critical";
9302 54 : eos_ok = 0;
9303 54 : break;
9304 :
9305 4611 : case COMP_SELECT:
9306 4611 : case COMP_SELECT_TYPE:
9307 4611 : case COMP_SELECT_RANK:
9308 4611 : *st = ST_END_SELECT;
9309 4611 : target = " select";
9310 4611 : eos_ok = 0;
9311 4611 : break;
9312 :
9313 509 : case COMP_FORALL:
9314 509 : *st = ST_END_FORALL;
9315 509 : target = " forall";
9316 509 : eos_ok = 0;
9317 509 : break;
9318 :
9319 373 : case COMP_WHERE:
9320 373 : *st = ST_END_WHERE;
9321 373 : target = " where";
9322 373 : eos_ok = 0;
9323 373 : break;
9324 :
9325 158 : case COMP_ENUM:
9326 158 : *st = ST_END_ENUM;
9327 158 : target = " enum";
9328 158 : eos_ok = 0;
9329 158 : last_initializer = NULL;
9330 158 : set_enum_kind ();
9331 158 : gfc_free_enum_history ();
9332 158 : break;
9333 :
9334 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9335 0 : *st = ST_OMP_END_METADIRECTIVE;
9336 0 : target = " metadirective";
9337 0 : eos_ok = 0;
9338 0 : break;
9339 :
9340 74 : case COMP_CHANGE_TEAM:
9341 74 : *st = ST_END_TEAM;
9342 74 : target = " team";
9343 74 : eos_ok = 0;
9344 74 : break;
9345 :
9346 9 : default:
9347 9 : gfc_error ("Unexpected END statement at %C");
9348 9 : goto cleanup;
9349 : }
9350 :
9351 179533 : old_loc = gfc_current_locus;
9352 179533 : if (gfc_match_eos () == MATCH_YES)
9353 : {
9354 20673 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9355 : {
9356 8077 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9357 : "instead of %s statement at %L",
9358 : abbreviated_modproc_decl ? "END PROCEDURE"
9359 4026 : : gfc_ascii_statement(*st), &old_loc))
9360 4 : goto cleanup;
9361 : }
9362 9 : else if (!eos_ok)
9363 : {
9364 : /* We would have required END [something]. */
9365 9 : gfc_error ("%s statement expected at %L",
9366 : gfc_ascii_statement (*st), &old_loc);
9367 9 : goto cleanup;
9368 : }
9369 :
9370 20660 : return MATCH_YES;
9371 : }
9372 :
9373 : /* Verify that we've got the sort of end-block that we're expecting. */
9374 158860 : if (gfc_match (target) != MATCH_YES)
9375 : {
9376 331 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9377 165 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9378 166 : goto cleanup;
9379 : }
9380 : else
9381 158694 : got_matching_end = true;
9382 :
9383 158694 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9384 : /* Emit errors of stat and errmsg parsing now to finish the block and
9385 : continue analysis of compilation unit. */
9386 2 : gfc_error_check ();
9387 :
9388 158694 : old_loc = gfc_current_locus;
9389 : /* If we're at the end, make sure a block name wasn't required. */
9390 158694 : if (gfc_match_eos () == MATCH_YES)
9391 : {
9392 104939 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9393 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9394 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9395 : && *st != ST_END_TEAM)
9396 : return MATCH_YES;
9397 :
9398 53526 : if (!block_name)
9399 : return MATCH_YES;
9400 :
9401 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9402 : block_name, gfc_ascii_statement (*st), &old_loc);
9403 :
9404 8 : return MATCH_ERROR;
9405 : }
9406 :
9407 : /* END INTERFACE has a special handler for its several possible endings. */
9408 53755 : if (*st == ST_END_INTERFACE)
9409 693 : return gfc_match_end_interface ();
9410 :
9411 : /* We haven't hit the end of statement, so what is left must be an
9412 : end-name. */
9413 53062 : m = gfc_match_space ();
9414 53062 : if (m == MATCH_YES)
9415 53062 : m = gfc_match_name (name);
9416 :
9417 53062 : if (m == MATCH_NO)
9418 0 : gfc_error ("Expected terminating name at %C");
9419 53062 : if (m != MATCH_YES)
9420 0 : goto cleanup;
9421 :
9422 53062 : if (block_name == NULL)
9423 15 : goto syntax;
9424 :
9425 : /* We have to pick out the declared submodule name from the composite
9426 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9427 53047 : if (state == COMP_SUBMODULE)
9428 137 : block_name = strchr (block_name, '.') + 1;
9429 :
9430 53047 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9431 : {
9432 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9433 : gfc_ascii_statement (*st));
9434 8 : goto cleanup;
9435 : }
9436 : /* Procedure pointer as function result. */
9437 53039 : else if (strcmp (block_name, "ppr@") == 0
9438 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9439 : {
9440 0 : gfc_error ("Expected label %qs for %s statement at %C",
9441 0 : gfc_current_block ()->ns->proc_name->name,
9442 : gfc_ascii_statement (*st));
9443 0 : goto cleanup;
9444 : }
9445 :
9446 53039 : if (gfc_match_eos () == MATCH_YES)
9447 : return MATCH_YES;
9448 :
9449 0 : syntax:
9450 15 : gfc_syntax_error (*st);
9451 :
9452 211 : cleanup:
9453 211 : gfc_current_locus = old_loc;
9454 :
9455 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9456 : Remove it from the parent namespace's sibling list. */
9457 :
9458 211 : if (state == COMP_BLOCK && !got_matching_end)
9459 : {
9460 7 : parent_ns = gfc_current_ns->parent;
9461 :
9462 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9463 :
9464 7 : prev_ns = NULL;
9465 7 : ns = *nsp;
9466 14 : while (ns)
9467 : {
9468 7 : if (ns == gfc_current_ns)
9469 : {
9470 7 : if (prev_ns == NULL)
9471 7 : *nsp = NULL;
9472 : else
9473 0 : prev_ns->sibling = ns->sibling;
9474 : }
9475 7 : prev_ns = ns;
9476 7 : ns = ns->sibling;
9477 : }
9478 :
9479 : /* The namespace can still be referenced by parser state and code nodes;
9480 : let normal block unwinding/freeing own its lifetime. */
9481 7 : gfc_current_ns = parent_ns;
9482 7 : gfc_state_stack = gfc_state_stack->previous;
9483 7 : state = gfc_current_state ();
9484 : }
9485 :
9486 : return MATCH_ERROR;
9487 : }
9488 :
9489 :
9490 :
9491 : /***************** Attribute declaration statements ****************/
9492 :
9493 : /* Set the attribute of a single variable. */
9494 :
9495 : static match
9496 10337 : attr_decl1 (void)
9497 : {
9498 10337 : char name[GFC_MAX_SYMBOL_LEN + 1];
9499 10337 : gfc_array_spec *as;
9500 :
9501 : /* Workaround -Wmaybe-uninitialized false positive during
9502 : profiledbootstrap by initializing them. */
9503 10337 : gfc_symbol *sym = NULL;
9504 10337 : locus var_locus;
9505 10337 : match m;
9506 :
9507 10337 : as = NULL;
9508 :
9509 10337 : m = gfc_match_name (name);
9510 10337 : if (m != MATCH_YES)
9511 0 : goto cleanup;
9512 :
9513 10337 : if (find_special (name, &sym, false))
9514 : return MATCH_ERROR;
9515 :
9516 10337 : if (!check_function_name (name))
9517 : {
9518 7 : m = MATCH_ERROR;
9519 7 : goto cleanup;
9520 : }
9521 :
9522 10330 : var_locus = gfc_current_locus;
9523 :
9524 : /* Deal with possible array specification for certain attributes. */
9525 10330 : if (current_attr.dimension
9526 8751 : || current_attr.codimension
9527 8729 : || current_attr.allocatable
9528 8305 : || current_attr.pointer
9529 7588 : || current_attr.target)
9530 : {
9531 2968 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9532 : !current_attr.dimension
9533 1389 : && !current_attr.pointer
9534 3640 : && !current_attr.target);
9535 2968 : if (m == MATCH_ERROR)
9536 2 : goto cleanup;
9537 :
9538 2966 : if (current_attr.dimension && m == MATCH_NO)
9539 : {
9540 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9541 : "statement", &var_locus);
9542 0 : m = MATCH_ERROR;
9543 0 : goto cleanup;
9544 : }
9545 :
9546 2966 : if (current_attr.dimension && sym->value)
9547 : {
9548 1 : gfc_error ("Dimensions specified for %s at %L after its "
9549 : "initialization", sym->name, &var_locus);
9550 1 : m = MATCH_ERROR;
9551 1 : goto cleanup;
9552 : }
9553 :
9554 2965 : if (current_attr.codimension && m == MATCH_NO)
9555 : {
9556 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9557 : "statement", &var_locus);
9558 0 : m = MATCH_ERROR;
9559 0 : goto cleanup;
9560 : }
9561 :
9562 2965 : if ((current_attr.allocatable || current_attr.pointer)
9563 1141 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9564 : {
9565 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9566 0 : m = MATCH_ERROR;
9567 0 : goto cleanup;
9568 : }
9569 : }
9570 :
9571 10327 : if (sym->ts.type == BT_CLASS
9572 200 : && sym->ts.u.derived
9573 200 : && sym->ts.u.derived->attr.is_class)
9574 : {
9575 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9576 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9577 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9578 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9579 177 : if (CLASS_DATA (sym)->as)
9580 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9581 : }
9582 8750 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9583 19056 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9584 : {
9585 22 : m = MATCH_ERROR;
9586 22 : goto cleanup;
9587 : }
9588 10305 : if (!gfc_set_array_spec (sym, as, &var_locus))
9589 : {
9590 18 : m = MATCH_ERROR;
9591 18 : goto cleanup;
9592 : }
9593 :
9594 10287 : if (sym->attr.cray_pointee && sym->as != NULL)
9595 : {
9596 : /* Fix the array spec. */
9597 2 : m = gfc_mod_pointee_as (sym->as);
9598 2 : if (m == MATCH_ERROR)
9599 0 : goto cleanup;
9600 : }
9601 :
9602 10287 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9603 : {
9604 0 : m = MATCH_ERROR;
9605 0 : goto cleanup;
9606 : }
9607 :
9608 5719 : if ((current_attr.external || current_attr.intrinsic)
9609 6205 : && sym->attr.flavor != FL_PROCEDURE
9610 16460 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9611 : {
9612 0 : m = MATCH_ERROR;
9613 0 : goto cleanup;
9614 : }
9615 :
9616 10287 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9617 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9618 136 : && !current_attr.external)
9619 : {
9620 136 : sym->attr.pointer = 0;
9621 136 : sym->attr.allocatable = 0;
9622 136 : sym->attr.dimension = 0;
9623 136 : sym->attr.codimension = 0;
9624 136 : gfc_free_array_spec (sym->as);
9625 136 : sym->as = NULL;
9626 : }
9627 10151 : else if (sym->ts.type == BT_CLASS
9628 10151 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9629 : {
9630 0 : m = MATCH_ERROR;
9631 0 : goto cleanup;
9632 : }
9633 :
9634 10287 : add_hidden_procptr_result (sym);
9635 :
9636 10287 : return MATCH_YES;
9637 :
9638 50 : cleanup:
9639 50 : gfc_free_array_spec (as);
9640 50 : return m;
9641 : }
9642 :
9643 :
9644 : /* Generic attribute declaration subroutine. Used for attributes that
9645 : just have a list of names. */
9646 :
9647 : static match
9648 6653 : attr_decl (void)
9649 : {
9650 6653 : match m;
9651 :
9652 : /* Gobble the optional double colon, by simply ignoring the result
9653 : of gfc_match(). */
9654 6653 : gfc_match (" ::");
9655 :
9656 10337 : for (;;)
9657 : {
9658 10337 : m = attr_decl1 ();
9659 10337 : if (m != MATCH_YES)
9660 : break;
9661 :
9662 10287 : if (gfc_match_eos () == MATCH_YES)
9663 : {
9664 : m = MATCH_YES;
9665 : break;
9666 : }
9667 :
9668 3684 : if (gfc_match_char (',') != MATCH_YES)
9669 : {
9670 0 : gfc_error ("Unexpected character in variable list at %C");
9671 0 : m = MATCH_ERROR;
9672 0 : break;
9673 : }
9674 : }
9675 :
9676 6653 : return m;
9677 : }
9678 :
9679 :
9680 : /* This routine matches Cray Pointer declarations of the form:
9681 : pointer ( <pointer>, <pointee> )
9682 : or
9683 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9684 : The pointer, if already declared, should be an integer. Otherwise, we
9685 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9686 : be either a scalar, or an array declaration. No space is allocated for
9687 : the pointee. For the statement
9688 : pointer (ipt, ar(10))
9689 : any subsequent uses of ar will be translated (in C-notation) as
9690 : ar(i) => ((<type> *) ipt)(i)
9691 : After gimplification, pointee variable will disappear in the code. */
9692 :
9693 : static match
9694 334 : cray_pointer_decl (void)
9695 : {
9696 334 : match m;
9697 334 : gfc_array_spec *as = NULL;
9698 334 : gfc_symbol *cptr; /* Pointer symbol. */
9699 334 : gfc_symbol *cpte; /* Pointee symbol. */
9700 334 : locus var_locus;
9701 334 : bool done = false;
9702 :
9703 334 : while (!done)
9704 : {
9705 347 : if (gfc_match_char ('(') != MATCH_YES)
9706 : {
9707 1 : gfc_error ("Expected %<(%> at %C");
9708 1 : return MATCH_ERROR;
9709 : }
9710 :
9711 : /* Match pointer. */
9712 346 : var_locus = gfc_current_locus;
9713 346 : gfc_clear_attr (¤t_attr);
9714 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9715 346 : current_ts.type = BT_INTEGER;
9716 346 : current_ts.kind = gfc_index_integer_kind;
9717 :
9718 346 : m = gfc_match_symbol (&cptr, 0);
9719 346 : if (m != MATCH_YES)
9720 : {
9721 2 : gfc_error ("Expected variable name at %C");
9722 2 : return m;
9723 : }
9724 :
9725 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9726 : return MATCH_ERROR;
9727 :
9728 341 : gfc_set_sym_referenced (cptr);
9729 :
9730 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9731 : {
9732 327 : cptr->ts.type = BT_INTEGER;
9733 327 : cptr->ts.kind = gfc_index_integer_kind;
9734 : }
9735 14 : else if (cptr->ts.type != BT_INTEGER)
9736 : {
9737 1 : gfc_error ("Cray pointer at %C must be an integer");
9738 1 : return MATCH_ERROR;
9739 : }
9740 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9741 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9742 : " memory addresses require %d bytes",
9743 : cptr->ts.kind, gfc_index_integer_kind);
9744 :
9745 340 : if (gfc_match_char (',') != MATCH_YES)
9746 : {
9747 2 : gfc_error ("Expected \",\" at %C");
9748 2 : return MATCH_ERROR;
9749 : }
9750 :
9751 : /* Match Pointee. */
9752 338 : var_locus = gfc_current_locus;
9753 338 : gfc_clear_attr (¤t_attr);
9754 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9755 338 : current_ts.type = BT_UNKNOWN;
9756 338 : current_ts.kind = 0;
9757 :
9758 338 : m = gfc_match_symbol (&cpte, 0);
9759 338 : if (m != MATCH_YES)
9760 : {
9761 2 : gfc_error ("Expected variable name at %C");
9762 2 : return m;
9763 : }
9764 :
9765 : /* Check for an optional array spec. */
9766 336 : m = gfc_match_array_spec (&as, true, false);
9767 336 : if (m == MATCH_ERROR)
9768 : {
9769 0 : gfc_free_array_spec (as);
9770 0 : return m;
9771 : }
9772 336 : else if (m == MATCH_NO)
9773 : {
9774 226 : gfc_free_array_spec (as);
9775 226 : as = NULL;
9776 : }
9777 :
9778 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9779 : return MATCH_ERROR;
9780 :
9781 329 : gfc_set_sym_referenced (cpte);
9782 :
9783 329 : if (cpte->as == NULL)
9784 : {
9785 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9786 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9787 : }
9788 82 : else if (as != NULL)
9789 : {
9790 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9791 1 : gfc_free_array_spec (as);
9792 1 : return MATCH_ERROR;
9793 : }
9794 :
9795 328 : as = NULL;
9796 :
9797 328 : if (cpte->as != NULL)
9798 : {
9799 : /* Fix array spec. */
9800 190 : m = gfc_mod_pointee_as (cpte->as);
9801 190 : if (m == MATCH_ERROR)
9802 : return m;
9803 : }
9804 :
9805 : /* Point the Pointee at the Pointer. */
9806 328 : cpte->cp_pointer = cptr;
9807 :
9808 328 : if (gfc_match_char (')') != MATCH_YES)
9809 : {
9810 2 : gfc_error ("Expected \")\" at %C");
9811 2 : return MATCH_ERROR;
9812 : }
9813 326 : m = gfc_match_char (',');
9814 326 : if (m != MATCH_YES)
9815 313 : done = true; /* Stop searching for more declarations. */
9816 :
9817 : }
9818 :
9819 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9820 313 : || gfc_match_eos () != MATCH_YES)
9821 : {
9822 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9823 0 : return MATCH_ERROR;
9824 : }
9825 : return MATCH_YES;
9826 : }
9827 :
9828 :
9829 : match
9830 3167 : gfc_match_external (void)
9831 : {
9832 :
9833 3167 : gfc_clear_attr (¤t_attr);
9834 3167 : current_attr.external = 1;
9835 :
9836 3167 : return attr_decl ();
9837 : }
9838 :
9839 :
9840 : match
9841 208 : gfc_match_intent (void)
9842 : {
9843 208 : sym_intent intent;
9844 :
9845 : /* This is not allowed within a BLOCK construct! */
9846 208 : if (gfc_current_state () == COMP_BLOCK)
9847 : {
9848 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9849 2 : return MATCH_ERROR;
9850 : }
9851 :
9852 206 : intent = match_intent_spec ();
9853 206 : if (intent == INTENT_UNKNOWN)
9854 : return MATCH_ERROR;
9855 :
9856 206 : gfc_clear_attr (¤t_attr);
9857 206 : current_attr.intent = intent;
9858 :
9859 206 : return attr_decl ();
9860 : }
9861 :
9862 :
9863 : match
9864 1477 : gfc_match_intrinsic (void)
9865 : {
9866 :
9867 1477 : gfc_clear_attr (¤t_attr);
9868 1477 : current_attr.intrinsic = 1;
9869 :
9870 1477 : return attr_decl ();
9871 : }
9872 :
9873 :
9874 : match
9875 220 : gfc_match_optional (void)
9876 : {
9877 : /* This is not allowed within a BLOCK construct! */
9878 220 : if (gfc_current_state () == COMP_BLOCK)
9879 : {
9880 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9881 2 : return MATCH_ERROR;
9882 : }
9883 :
9884 218 : gfc_clear_attr (¤t_attr);
9885 218 : current_attr.optional = 1;
9886 :
9887 218 : return attr_decl ();
9888 : }
9889 :
9890 :
9891 : match
9892 909 : gfc_match_pointer (void)
9893 : {
9894 909 : gfc_gobble_whitespace ();
9895 909 : if (gfc_peek_ascii_char () == '(')
9896 : {
9897 335 : if (!flag_cray_pointer)
9898 : {
9899 1 : gfc_error ("Cray pointer declaration at %C requires "
9900 : "%<-fcray-pointer%> flag");
9901 1 : return MATCH_ERROR;
9902 : }
9903 334 : return cray_pointer_decl ();
9904 : }
9905 : else
9906 : {
9907 574 : gfc_clear_attr (¤t_attr);
9908 574 : current_attr.pointer = 1;
9909 :
9910 574 : return attr_decl ();
9911 : }
9912 : }
9913 :
9914 :
9915 : match
9916 162 : gfc_match_allocatable (void)
9917 : {
9918 162 : gfc_clear_attr (¤t_attr);
9919 162 : current_attr.allocatable = 1;
9920 :
9921 162 : return attr_decl ();
9922 : }
9923 :
9924 :
9925 : match
9926 23 : gfc_match_codimension (void)
9927 : {
9928 23 : gfc_clear_attr (¤t_attr);
9929 23 : current_attr.codimension = 1;
9930 :
9931 23 : return attr_decl ();
9932 : }
9933 :
9934 :
9935 : match
9936 80 : gfc_match_contiguous (void)
9937 : {
9938 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9939 : return MATCH_ERROR;
9940 :
9941 79 : gfc_clear_attr (¤t_attr);
9942 79 : current_attr.contiguous = 1;
9943 :
9944 79 : return attr_decl ();
9945 : }
9946 :
9947 :
9948 : match
9949 648 : gfc_match_dimension (void)
9950 : {
9951 648 : gfc_clear_attr (¤t_attr);
9952 648 : current_attr.dimension = 1;
9953 :
9954 648 : return attr_decl ();
9955 : }
9956 :
9957 :
9958 : match
9959 99 : gfc_match_target (void)
9960 : {
9961 99 : gfc_clear_attr (¤t_attr);
9962 99 : current_attr.target = 1;
9963 :
9964 99 : return attr_decl ();
9965 : }
9966 :
9967 :
9968 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9969 : statement. */
9970 :
9971 : static match
9972 1759 : access_attr_decl (gfc_statement st)
9973 : {
9974 1759 : char name[GFC_MAX_SYMBOL_LEN + 1];
9975 1759 : interface_type type;
9976 1759 : gfc_user_op *uop;
9977 1759 : gfc_symbol *sym, *dt_sym;
9978 1759 : gfc_intrinsic_op op;
9979 1759 : match m;
9980 1759 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9981 :
9982 1759 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9983 0 : goto done;
9984 :
9985 2908 : for (;;)
9986 : {
9987 2908 : m = gfc_match_generic_spec (&type, name, &op);
9988 2908 : if (m == MATCH_NO)
9989 0 : goto syntax;
9990 2908 : if (m == MATCH_ERROR)
9991 0 : goto done;
9992 :
9993 2908 : switch (type)
9994 : {
9995 0 : case INTERFACE_NAMELESS:
9996 0 : case INTERFACE_ABSTRACT:
9997 0 : goto syntax;
9998 :
9999 2832 : case INTERFACE_GENERIC:
10000 2832 : case INTERFACE_DTIO:
10001 :
10002 2832 : if (gfc_get_symbol (name, NULL, &sym))
10003 0 : goto done;
10004 :
10005 2832 : if (type == INTERFACE_DTIO
10006 26 : && gfc_current_ns->proc_name
10007 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
10008 26 : && sym->attr.flavor == FL_UNKNOWN)
10009 2 : sym->attr.flavor = FL_PROCEDURE;
10010 :
10011 2832 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
10012 4 : goto done;
10013 :
10014 330 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
10015 2885 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
10016 0 : goto done;
10017 :
10018 : break;
10019 :
10020 72 : case INTERFACE_INTRINSIC_OP:
10021 72 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
10022 : {
10023 72 : gfc_intrinsic_op other_op;
10024 :
10025 72 : gfc_current_ns->operator_access[op] = access;
10026 :
10027 : /* Handle the case if there is another op with the same
10028 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
10029 72 : other_op = gfc_equivalent_op (op);
10030 :
10031 72 : if (other_op != INTRINSIC_NONE)
10032 21 : gfc_current_ns->operator_access[other_op] = access;
10033 : }
10034 : else
10035 : {
10036 0 : gfc_error ("Access specification of the %s operator at %C has "
10037 : "already been specified", gfc_op2string (op));
10038 0 : goto done;
10039 : }
10040 :
10041 : break;
10042 :
10043 4 : case INTERFACE_USER_OP:
10044 4 : uop = gfc_get_uop (name);
10045 :
10046 4 : if (uop->access == ACCESS_UNKNOWN)
10047 : {
10048 3 : uop->access = access;
10049 : }
10050 : else
10051 : {
10052 1 : gfc_error ("Access specification of the .%s. operator at %C "
10053 : "has already been specified", uop->name);
10054 1 : goto done;
10055 : }
10056 :
10057 3 : break;
10058 : }
10059 :
10060 2903 : if (gfc_match_char (',') == MATCH_NO)
10061 : break;
10062 : }
10063 :
10064 1754 : if (gfc_match_eos () != MATCH_YES)
10065 0 : goto syntax;
10066 : return MATCH_YES;
10067 :
10068 0 : syntax:
10069 0 : gfc_syntax_error (st);
10070 :
10071 : done:
10072 : return MATCH_ERROR;
10073 : }
10074 :
10075 :
10076 : match
10077 23 : gfc_match_protected (void)
10078 : {
10079 23 : gfc_symbol *sym;
10080 23 : match m;
10081 23 : char c;
10082 :
10083 : /* PROTECTED has already been seen, but must be followed by whitespace
10084 : or ::. */
10085 23 : c = gfc_peek_ascii_char ();
10086 23 : if (!gfc_is_whitespace (c) && c != ':')
10087 : return MATCH_NO;
10088 :
10089 22 : if (!gfc_current_ns->proc_name
10090 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
10091 : {
10092 3 : gfc_error ("PROTECTED at %C only allowed in specification "
10093 : "part of a module");
10094 3 : return MATCH_ERROR;
10095 :
10096 : }
10097 :
10098 19 : gfc_match (" ::");
10099 :
10100 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
10101 : return MATCH_ERROR;
10102 :
10103 : /* PROTECTED has an entity-list. */
10104 18 : if (gfc_match_eos () == MATCH_YES)
10105 0 : goto syntax;
10106 :
10107 26 : for(;;)
10108 : {
10109 26 : m = gfc_match_symbol (&sym, 0);
10110 26 : switch (m)
10111 : {
10112 26 : case MATCH_YES:
10113 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
10114 : return MATCH_ERROR;
10115 25 : goto next_item;
10116 :
10117 : case MATCH_NO:
10118 : break;
10119 :
10120 : case MATCH_ERROR:
10121 : return MATCH_ERROR;
10122 : }
10123 :
10124 25 : next_item:
10125 25 : if (gfc_match_eos () == MATCH_YES)
10126 : break;
10127 8 : if (gfc_match_char (',') != MATCH_YES)
10128 0 : goto syntax;
10129 : }
10130 :
10131 : return MATCH_YES;
10132 :
10133 0 : syntax:
10134 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
10135 0 : return MATCH_ERROR;
10136 : }
10137 :
10138 :
10139 : /* The PRIVATE statement is a bit weird in that it can be an attribute
10140 : declaration, but also works as a standalone statement inside of a
10141 : type declaration or a module. */
10142 :
10143 : match
10144 29099 : gfc_match_private (gfc_statement *st)
10145 : {
10146 29099 : gfc_state_data *prev;
10147 :
10148 29099 : if (gfc_match ("private") != MATCH_YES)
10149 : return MATCH_NO;
10150 :
10151 : /* Try matching PRIVATE without an access-list. */
10152 1627 : if (gfc_match_eos () == MATCH_YES)
10153 : {
10154 1340 : prev = gfc_state_stack->previous;
10155 1340 : if (gfc_current_state () != COMP_MODULE
10156 367 : && !(gfc_current_state () == COMP_DERIVED
10157 334 : && prev && prev->state == COMP_MODULE)
10158 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10159 32 : && prev->previous && prev->previous->state == COMP_MODULE))
10160 : {
10161 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10162 : "specification part of a module");
10163 2 : return MATCH_ERROR;
10164 : }
10165 :
10166 1338 : *st = ST_PRIVATE;
10167 1338 : return MATCH_YES;
10168 : }
10169 :
10170 : /* At this point in free-form source code, PRIVATE must be followed
10171 : by whitespace or ::. */
10172 287 : if (gfc_current_form == FORM_FREE)
10173 : {
10174 285 : char c = gfc_peek_ascii_char ();
10175 285 : if (!gfc_is_whitespace (c) && c != ':')
10176 : return MATCH_NO;
10177 : }
10178 :
10179 286 : prev = gfc_state_stack->previous;
10180 286 : if (gfc_current_state () != COMP_MODULE
10181 1 : && !(gfc_current_state () == COMP_DERIVED
10182 0 : && prev && prev->state == COMP_MODULE)
10183 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10184 0 : && prev->previous && prev->previous->state == COMP_MODULE))
10185 : {
10186 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10187 : "specification part of a module");
10188 1 : return MATCH_ERROR;
10189 : }
10190 :
10191 285 : *st = ST_ATTR_DECL;
10192 285 : return access_attr_decl (ST_PRIVATE);
10193 : }
10194 :
10195 :
10196 : match
10197 1872 : gfc_match_public (gfc_statement *st)
10198 : {
10199 1872 : if (gfc_match ("public") != MATCH_YES)
10200 : return MATCH_NO;
10201 :
10202 : /* Try matching PUBLIC without an access-list. */
10203 1521 : if (gfc_match_eos () == MATCH_YES)
10204 : {
10205 45 : if (gfc_current_state () != COMP_MODULE)
10206 : {
10207 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10208 : "specification part of a module");
10209 2 : return MATCH_ERROR;
10210 : }
10211 :
10212 43 : *st = ST_PUBLIC;
10213 43 : return MATCH_YES;
10214 : }
10215 :
10216 : /* At this point in free-form source code, PUBLIC must be followed
10217 : by whitespace or ::. */
10218 1476 : if (gfc_current_form == FORM_FREE)
10219 : {
10220 1474 : char c = gfc_peek_ascii_char ();
10221 1474 : if (!gfc_is_whitespace (c) && c != ':')
10222 : return MATCH_NO;
10223 : }
10224 :
10225 1475 : if (gfc_current_state () != COMP_MODULE)
10226 : {
10227 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10228 : "specification part of a module");
10229 1 : return MATCH_ERROR;
10230 : }
10231 :
10232 1474 : *st = ST_ATTR_DECL;
10233 1474 : return access_attr_decl (ST_PUBLIC);
10234 : }
10235 :
10236 :
10237 : /* Workhorse for gfc_match_parameter. */
10238 :
10239 : static match
10240 8406 : do_parm (void)
10241 : {
10242 8406 : gfc_symbol *sym;
10243 8406 : gfc_expr *init;
10244 8406 : gfc_charlen *saved_cl_list;
10245 8406 : match m;
10246 8406 : bool t;
10247 :
10248 8406 : saved_cl_list = gfc_current_ns->cl_list;
10249 :
10250 8406 : m = gfc_match_symbol (&sym, 0);
10251 8406 : if (m == MATCH_NO)
10252 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10253 :
10254 8406 : if (m != MATCH_YES)
10255 : return m;
10256 :
10257 8406 : if (gfc_match_char ('=') == MATCH_NO)
10258 : {
10259 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10260 0 : return MATCH_ERROR;
10261 : }
10262 :
10263 8406 : m = gfc_match_init_expr (&init);
10264 8406 : if (m == MATCH_NO)
10265 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10266 8406 : if (m != MATCH_YES)
10267 : return m;
10268 :
10269 8405 : if (sym->ts.type == BT_UNKNOWN
10270 8405 : && !gfc_set_default_type (sym, 1, NULL))
10271 : {
10272 1 : m = MATCH_ERROR;
10273 1 : goto cleanup;
10274 : }
10275 :
10276 8404 : if (!gfc_check_assign_symbol (sym, NULL, init)
10277 8404 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10278 : {
10279 1 : m = MATCH_ERROR;
10280 1 : goto cleanup;
10281 : }
10282 :
10283 8403 : if (sym->value)
10284 : {
10285 1 : gfc_error ("Initializing already initialized variable at %C");
10286 1 : m = MATCH_ERROR;
10287 1 : goto cleanup;
10288 : }
10289 :
10290 8402 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus,
10291 : saved_cl_list);
10292 8402 : return (t) ? MATCH_YES : MATCH_ERROR;
10293 :
10294 3 : cleanup:
10295 3 : gfc_free_expr (init);
10296 3 : return m;
10297 : }
10298 :
10299 :
10300 : /* Match a parameter statement, with the weird syntax that these have. */
10301 :
10302 : match
10303 7693 : gfc_match_parameter (void)
10304 : {
10305 7693 : const char *term = " )%t";
10306 7693 : match m;
10307 :
10308 7693 : if (gfc_match_char ('(') == MATCH_NO)
10309 : {
10310 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10311 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10312 : return MATCH_NO;
10313 7692 : term = " %t";
10314 : }
10315 :
10316 8406 : for (;;)
10317 : {
10318 8406 : m = do_parm ();
10319 8406 : if (m != MATCH_YES)
10320 : break;
10321 :
10322 8402 : if (gfc_match (term) == MATCH_YES)
10323 : break;
10324 :
10325 714 : if (gfc_match_char (',') != MATCH_YES)
10326 : {
10327 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10328 0 : m = MATCH_ERROR;
10329 0 : break;
10330 : }
10331 : }
10332 :
10333 : return m;
10334 : }
10335 :
10336 :
10337 : match
10338 8 : gfc_match_automatic (void)
10339 : {
10340 8 : gfc_symbol *sym;
10341 8 : match m;
10342 8 : bool seen_symbol = false;
10343 :
10344 8 : if (!flag_dec_static)
10345 : {
10346 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10347 : "%<-fdec-static%>",
10348 : "AUTOMATIC"
10349 : );
10350 2 : return MATCH_ERROR;
10351 : }
10352 :
10353 6 : gfc_match (" ::");
10354 :
10355 6 : for (;;)
10356 : {
10357 6 : m = gfc_match_symbol (&sym, 0);
10358 6 : switch (m)
10359 : {
10360 : case MATCH_NO:
10361 : break;
10362 :
10363 : case MATCH_ERROR:
10364 : return MATCH_ERROR;
10365 :
10366 4 : case MATCH_YES:
10367 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10368 : return MATCH_ERROR;
10369 : seen_symbol = true;
10370 : break;
10371 : }
10372 :
10373 4 : if (gfc_match_eos () == MATCH_YES)
10374 : break;
10375 0 : if (gfc_match_char (',') != MATCH_YES)
10376 0 : goto syntax;
10377 : }
10378 :
10379 4 : if (!seen_symbol)
10380 : {
10381 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10382 2 : return MATCH_ERROR;
10383 : }
10384 :
10385 : return MATCH_YES;
10386 :
10387 0 : syntax:
10388 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10389 0 : return MATCH_ERROR;
10390 : }
10391 :
10392 :
10393 : match
10394 7 : gfc_match_static (void)
10395 : {
10396 7 : gfc_symbol *sym;
10397 7 : match m;
10398 7 : bool seen_symbol = false;
10399 :
10400 7 : if (!flag_dec_static)
10401 : {
10402 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10403 : "%<-fdec-static%>",
10404 : "STATIC");
10405 2 : return MATCH_ERROR;
10406 : }
10407 :
10408 5 : gfc_match (" ::");
10409 :
10410 5 : for (;;)
10411 : {
10412 5 : m = gfc_match_symbol (&sym, 0);
10413 5 : switch (m)
10414 : {
10415 : case MATCH_NO:
10416 : break;
10417 :
10418 : case MATCH_ERROR:
10419 : return MATCH_ERROR;
10420 :
10421 3 : case MATCH_YES:
10422 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10423 : &gfc_current_locus))
10424 : return MATCH_ERROR;
10425 : seen_symbol = true;
10426 : break;
10427 : }
10428 :
10429 3 : if (gfc_match_eos () == MATCH_YES)
10430 : break;
10431 0 : if (gfc_match_char (',') != MATCH_YES)
10432 0 : goto syntax;
10433 : }
10434 :
10435 3 : if (!seen_symbol)
10436 : {
10437 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10438 2 : return MATCH_ERROR;
10439 : }
10440 :
10441 : return MATCH_YES;
10442 :
10443 0 : syntax:
10444 0 : gfc_error ("Syntax error in STATIC statement at %C");
10445 0 : return MATCH_ERROR;
10446 : }
10447 :
10448 :
10449 : /* Save statements have a special syntax. */
10450 :
10451 : match
10452 272 : gfc_match_save (void)
10453 : {
10454 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10455 272 : gfc_common_head *c;
10456 272 : gfc_symbol *sym;
10457 272 : match m;
10458 :
10459 272 : if (gfc_match_eos () == MATCH_YES)
10460 : {
10461 150 : if (gfc_current_ns->seen_save)
10462 : {
10463 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10464 : "follows previous SAVE statement"))
10465 : return MATCH_ERROR;
10466 : }
10467 :
10468 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10469 149 : return MATCH_YES;
10470 : }
10471 :
10472 122 : if (gfc_current_ns->save_all)
10473 : {
10474 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10475 : "blanket SAVE statement"))
10476 : return MATCH_ERROR;
10477 : }
10478 :
10479 121 : gfc_match (" ::");
10480 :
10481 183 : for (;;)
10482 : {
10483 183 : m = gfc_match_symbol (&sym, 0);
10484 183 : switch (m)
10485 : {
10486 181 : case MATCH_YES:
10487 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10488 : &gfc_current_locus))
10489 : return MATCH_ERROR;
10490 179 : goto next_item;
10491 :
10492 : case MATCH_NO:
10493 : break;
10494 :
10495 : case MATCH_ERROR:
10496 : return MATCH_ERROR;
10497 : }
10498 :
10499 2 : m = gfc_match (" / %n /", &n);
10500 2 : if (m == MATCH_ERROR)
10501 : return MATCH_ERROR;
10502 2 : if (m == MATCH_NO)
10503 0 : goto syntax;
10504 :
10505 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10506 : saved-entity-list that does not specify a common-block-name. */
10507 2 : if (gfc_current_state () == COMP_BLOCK)
10508 : {
10509 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10510 : "in a BLOCK construct", n);
10511 1 : return MATCH_ERROR;
10512 : }
10513 :
10514 1 : c = gfc_get_common (n, 0);
10515 1 : c->saved = 1;
10516 :
10517 1 : gfc_current_ns->seen_save = 1;
10518 :
10519 180 : next_item:
10520 180 : if (gfc_match_eos () == MATCH_YES)
10521 : break;
10522 62 : if (gfc_match_char (',') != MATCH_YES)
10523 0 : goto syntax;
10524 : }
10525 :
10526 : return MATCH_YES;
10527 :
10528 0 : syntax:
10529 0 : if (gfc_current_ns->seen_save)
10530 : {
10531 0 : gfc_error ("Syntax error in SAVE statement at %C");
10532 0 : return MATCH_ERROR;
10533 : }
10534 : else
10535 : return MATCH_NO;
10536 : }
10537 :
10538 :
10539 : match
10540 93 : gfc_match_value (void)
10541 : {
10542 93 : gfc_symbol *sym;
10543 93 : match m;
10544 :
10545 : /* This is not allowed within a BLOCK construct! */
10546 93 : if (gfc_current_state () == COMP_BLOCK)
10547 : {
10548 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10549 2 : return MATCH_ERROR;
10550 : }
10551 :
10552 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10553 : return MATCH_ERROR;
10554 :
10555 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10556 : {
10557 : return MATCH_ERROR;
10558 : }
10559 :
10560 90 : if (gfc_match_eos () == MATCH_YES)
10561 0 : goto syntax;
10562 :
10563 116 : for(;;)
10564 : {
10565 116 : m = gfc_match_symbol (&sym, 0);
10566 116 : switch (m)
10567 : {
10568 116 : case MATCH_YES:
10569 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10570 : return MATCH_ERROR;
10571 109 : goto next_item;
10572 :
10573 : case MATCH_NO:
10574 : break;
10575 :
10576 : case MATCH_ERROR:
10577 : return MATCH_ERROR;
10578 : }
10579 :
10580 109 : next_item:
10581 109 : if (gfc_match_eos () == MATCH_YES)
10582 : break;
10583 26 : if (gfc_match_char (',') != MATCH_YES)
10584 0 : goto syntax;
10585 : }
10586 :
10587 : return MATCH_YES;
10588 :
10589 0 : syntax:
10590 0 : gfc_error ("Syntax error in VALUE statement at %C");
10591 0 : return MATCH_ERROR;
10592 : }
10593 :
10594 :
10595 : match
10596 45 : gfc_match_volatile (void)
10597 : {
10598 45 : gfc_symbol *sym;
10599 45 : char *name;
10600 45 : match m;
10601 :
10602 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10603 : return MATCH_ERROR;
10604 :
10605 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10606 : {
10607 : return MATCH_ERROR;
10608 : }
10609 :
10610 44 : if (gfc_match_eos () == MATCH_YES)
10611 1 : goto syntax;
10612 :
10613 48 : for(;;)
10614 : {
10615 : /* VOLATILE is special because it can be added to host-associated
10616 : symbols locally. Except for coarrays. */
10617 48 : m = gfc_match_symbol (&sym, 1);
10618 48 : switch (m)
10619 : {
10620 48 : case MATCH_YES:
10621 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10622 48 : strcpy (name, sym->name);
10623 48 : if (!check_function_name (name))
10624 : return MATCH_ERROR;
10625 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10626 : for variable in a BLOCK which is defined outside of the BLOCK. */
10627 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10628 : {
10629 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10630 : "%C, which is use-/host-associated", sym->name);
10631 2 : return MATCH_ERROR;
10632 : }
10633 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10634 : return MATCH_ERROR;
10635 42 : goto next_item;
10636 :
10637 : case MATCH_NO:
10638 : break;
10639 :
10640 : case MATCH_ERROR:
10641 : return MATCH_ERROR;
10642 : }
10643 :
10644 42 : next_item:
10645 42 : if (gfc_match_eos () == MATCH_YES)
10646 : break;
10647 5 : if (gfc_match_char (',') != MATCH_YES)
10648 0 : goto syntax;
10649 : }
10650 :
10651 : return MATCH_YES;
10652 :
10653 1 : syntax:
10654 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10655 1 : return MATCH_ERROR;
10656 : }
10657 :
10658 :
10659 : match
10660 11 : gfc_match_asynchronous (void)
10661 : {
10662 11 : gfc_symbol *sym;
10663 11 : char *name;
10664 11 : match m;
10665 :
10666 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10667 : return MATCH_ERROR;
10668 :
10669 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10670 : {
10671 : return MATCH_ERROR;
10672 : }
10673 :
10674 10 : if (gfc_match_eos () == MATCH_YES)
10675 0 : goto syntax;
10676 :
10677 10 : for(;;)
10678 : {
10679 : /* ASYNCHRONOUS is special because it can be added to host-associated
10680 : symbols locally. */
10681 10 : m = gfc_match_symbol (&sym, 1);
10682 10 : switch (m)
10683 : {
10684 10 : case MATCH_YES:
10685 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10686 10 : strcpy (name, sym->name);
10687 10 : if (!check_function_name (name))
10688 : return MATCH_ERROR;
10689 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10690 : return MATCH_ERROR;
10691 7 : goto next_item;
10692 :
10693 : case MATCH_NO:
10694 : break;
10695 :
10696 : case MATCH_ERROR:
10697 : return MATCH_ERROR;
10698 : }
10699 :
10700 7 : next_item:
10701 7 : if (gfc_match_eos () == MATCH_YES)
10702 : break;
10703 0 : if (gfc_match_char (',') != MATCH_YES)
10704 0 : goto syntax;
10705 : }
10706 :
10707 : return MATCH_YES;
10708 :
10709 0 : syntax:
10710 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10711 0 : return MATCH_ERROR;
10712 : }
10713 :
10714 :
10715 : /* Match a module procedure statement in a submodule. */
10716 :
10717 : match
10718 761545 : gfc_match_submod_proc (void)
10719 : {
10720 761545 : char name[GFC_MAX_SYMBOL_LEN + 1];
10721 761545 : gfc_symbol *sym, *fsym;
10722 761545 : match m;
10723 761545 : gfc_formal_arglist *formal, *head, *tail;
10724 :
10725 761545 : if (gfc_current_state () != COMP_CONTAINS
10726 15498 : || !(gfc_state_stack->previous
10727 15498 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10728 15498 : || gfc_state_stack->previous->state == COMP_MODULE)))
10729 : return MATCH_NO;
10730 :
10731 7744 : m = gfc_match (" module% procedure% %n", name);
10732 7744 : if (m != MATCH_YES)
10733 : return m;
10734 :
10735 267 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10736 : "at %C"))
10737 : return MATCH_ERROR;
10738 :
10739 267 : if (get_proc_name (name, &sym, false))
10740 : return MATCH_ERROR;
10741 :
10742 : /* Make sure that the result field is appropriately filled. */
10743 267 : if (sym->tlink && sym->tlink->attr.function)
10744 : {
10745 117 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10746 : {
10747 67 : sym->result = sym->tlink->result;
10748 67 : if (!sym->result->attr.use_assoc)
10749 : {
10750 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10751 : sym->result->name);
10752 20 : st->n.sym = sym->result;
10753 20 : sym->result->refs++;
10754 : }
10755 : }
10756 : else
10757 50 : sym->result = sym;
10758 : }
10759 :
10760 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10761 : the symbol existed before. */
10762 267 : sym->declared_at = gfc_current_locus;
10763 :
10764 267 : if (!sym->attr.module_procedure)
10765 : return MATCH_ERROR;
10766 :
10767 : /* Signal match_end to expect "end procedure". */
10768 265 : sym->abr_modproc_decl = 1;
10769 :
10770 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10771 265 : sym->attr.if_source = IFSRC_DECL;
10772 :
10773 265 : gfc_new_block = sym;
10774 :
10775 : /* Make a new formal arglist with the symbols in the procedure
10776 : namespace. */
10777 265 : head = tail = NULL;
10778 600 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10779 : {
10780 335 : if (formal == sym->formal)
10781 238 : head = tail = gfc_get_formal_arglist ();
10782 : else
10783 : {
10784 97 : tail->next = gfc_get_formal_arglist ();
10785 97 : tail = tail->next;
10786 : }
10787 :
10788 335 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10789 0 : goto cleanup;
10790 :
10791 335 : tail->sym = fsym;
10792 335 : gfc_set_sym_referenced (fsym);
10793 : }
10794 :
10795 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10796 : interface declaration is cleared. This allows us to add the
10797 : explicit interface as is done for other type of procedure. */
10798 265 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10799 : &gfc_current_locus))
10800 : return MATCH_ERROR;
10801 :
10802 265 : if (gfc_match_eos () != MATCH_YES)
10803 : {
10804 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10805 : undone, such that the st->n.sym->formal points to the original symbol;
10806 : if now this namespace is finalized, the formal namespace is freed,
10807 : but it might be still needed in the parent namespace. */
10808 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10809 1 : st->n.sym = NULL;
10810 1 : gfc_free_symbol (sym->tlink);
10811 1 : sym->tlink = NULL;
10812 1 : sym->refs--;
10813 1 : gfc_syntax_error (ST_MODULE_PROC);
10814 1 : return MATCH_ERROR;
10815 : }
10816 :
10817 : return MATCH_YES;
10818 :
10819 0 : cleanup:
10820 0 : gfc_free_formal_arglist (head);
10821 0 : return MATCH_ERROR;
10822 : }
10823 :
10824 :
10825 : /* Match a module procedure statement. Note that we have to modify
10826 : symbols in the parent's namespace because the current one was there
10827 : to receive symbols that are in an interface's formal argument list. */
10828 :
10829 : match
10830 1619 : gfc_match_modproc (void)
10831 : {
10832 1619 : char name[GFC_MAX_SYMBOL_LEN + 1];
10833 1619 : gfc_symbol *sym;
10834 1619 : match m;
10835 1619 : locus old_locus;
10836 1619 : gfc_namespace *module_ns;
10837 1619 : gfc_interface *old_interface_head, *interface;
10838 :
10839 1619 : if (gfc_state_stack->previous == NULL
10840 1617 : || (gfc_state_stack->state != COMP_INTERFACE
10841 5 : && (gfc_state_stack->state != COMP_CONTAINS
10842 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10843 1612 : || current_interface.type == INTERFACE_NAMELESS
10844 1612 : || current_interface.type == INTERFACE_ABSTRACT)
10845 : {
10846 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10847 : "interface");
10848 8 : return MATCH_ERROR;
10849 : }
10850 :
10851 1611 : module_ns = gfc_current_ns->parent;
10852 1617 : for (; module_ns; module_ns = module_ns->parent)
10853 1617 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10854 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10855 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10856 12 : && !module_ns->proc_name->attr.contained))
10857 : break;
10858 :
10859 1611 : if (module_ns == NULL)
10860 : return MATCH_ERROR;
10861 :
10862 : /* Store the current state of the interface. We will need it if we
10863 : end up with a syntax error and need to recover. */
10864 1611 : old_interface_head = gfc_current_interface_head ();
10865 :
10866 : /* Check if the F2008 optional double colon appears. */
10867 1611 : gfc_gobble_whitespace ();
10868 1611 : old_locus = gfc_current_locus;
10869 1611 : if (gfc_match ("::") == MATCH_YES)
10870 : {
10871 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10872 : "MODULE PROCEDURE statement at %L", &old_locus))
10873 : return MATCH_ERROR;
10874 : }
10875 : else
10876 1586 : gfc_current_locus = old_locus;
10877 :
10878 1966 : for (;;)
10879 : {
10880 1966 : bool last = false;
10881 1966 : old_locus = gfc_current_locus;
10882 :
10883 1966 : m = gfc_match_name (name);
10884 1966 : if (m == MATCH_NO)
10885 1 : goto syntax;
10886 1965 : if (m != MATCH_YES)
10887 : return MATCH_ERROR;
10888 :
10889 : /* Check for syntax error before starting to add symbols to the
10890 : current namespace. */
10891 1965 : if (gfc_match_eos () == MATCH_YES)
10892 : last = true;
10893 :
10894 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10895 2 : goto syntax;
10896 :
10897 : /* Now we're sure the syntax is valid, we process this item
10898 : further. */
10899 1963 : if (gfc_get_symbol (name, module_ns, &sym))
10900 : return MATCH_ERROR;
10901 :
10902 1963 : if (sym->attr.intrinsic)
10903 : {
10904 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10905 : "PROCEDURE", &old_locus);
10906 1 : return MATCH_ERROR;
10907 : }
10908 :
10909 1962 : if (sym->attr.proc != PROC_MODULE
10910 1962 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10911 : return MATCH_ERROR;
10912 :
10913 1959 : if (!gfc_add_interface (sym))
10914 : return MATCH_ERROR;
10915 :
10916 1956 : sym->attr.mod_proc = 1;
10917 1956 : sym->declared_at = old_locus;
10918 :
10919 1956 : if (last)
10920 : break;
10921 : }
10922 :
10923 : return MATCH_YES;
10924 :
10925 3 : syntax:
10926 : /* Restore the previous state of the interface. */
10927 3 : interface = gfc_current_interface_head ();
10928 3 : gfc_set_current_interface_head (old_interface_head);
10929 :
10930 : /* Free the new interfaces. */
10931 10 : while (interface != old_interface_head)
10932 : {
10933 4 : gfc_interface *i = interface->next;
10934 4 : free (interface);
10935 4 : interface = i;
10936 : }
10937 :
10938 : /* And issue a syntax error. */
10939 3 : gfc_syntax_error (ST_MODULE_PROC);
10940 3 : return MATCH_ERROR;
10941 : }
10942 :
10943 :
10944 : /* Check a derived type that is being extended. */
10945 :
10946 : static gfc_symbol*
10947 1485 : check_extended_derived_type (char *name)
10948 : {
10949 1485 : gfc_symbol *extended;
10950 :
10951 1485 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10952 : {
10953 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10954 0 : return NULL;
10955 : }
10956 :
10957 1485 : extended = gfc_find_dt_in_generic (extended);
10958 :
10959 : /* F08:C428. */
10960 1485 : if (!extended)
10961 : {
10962 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10963 2 : return NULL;
10964 : }
10965 :
10966 1483 : if (extended->attr.flavor != FL_DERIVED)
10967 : {
10968 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10969 : "derived type", name);
10970 0 : return NULL;
10971 : }
10972 :
10973 1483 : if (extended->attr.is_bind_c)
10974 : {
10975 1 : gfc_error ("%qs cannot be extended at %C because it "
10976 : "is BIND(C)", extended->name);
10977 1 : return NULL;
10978 : }
10979 :
10980 1482 : if (extended->attr.sequence)
10981 : {
10982 1 : gfc_error ("%qs cannot be extended at %C because it "
10983 : "is a SEQUENCE type", extended->name);
10984 1 : return NULL;
10985 : }
10986 :
10987 : return extended;
10988 : }
10989 :
10990 :
10991 : /* Match the optional attribute specifiers for a type declaration.
10992 : Return MATCH_ERROR if an error is encountered in one of the handled
10993 : attributes (public, private, bind(c)), MATCH_NO if what's found is
10994 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10995 : checking on attribute conflicts needs to be done. */
10996 :
10997 : static match
10998 19333 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10999 : {
11000 : /* See if the derived type is marked as private. */
11001 19333 : if (gfc_match (" , private") == MATCH_YES)
11002 : {
11003 15 : if (gfc_current_state () != COMP_MODULE)
11004 : {
11005 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
11006 : "specification part of a module");
11007 1 : return MATCH_ERROR;
11008 : }
11009 :
11010 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
11011 : return MATCH_ERROR;
11012 : }
11013 19318 : else if (gfc_match (" , public") == MATCH_YES)
11014 : {
11015 546 : if (gfc_current_state () != COMP_MODULE)
11016 : {
11017 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
11018 : "specification part of a module");
11019 0 : return MATCH_ERROR;
11020 : }
11021 :
11022 546 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
11023 : return MATCH_ERROR;
11024 : }
11025 18772 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
11026 : {
11027 : /* If the type is defined to be bind(c) it then needs to make
11028 : sure that all fields are interoperable. This will
11029 : need to be a semantic check on the finished derived type.
11030 : See 15.2.3 (lines 9-12) of F2003 draft. */
11031 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
11032 : return MATCH_ERROR;
11033 :
11034 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
11035 : }
11036 18365 : else if (gfc_match (" , abstract") == MATCH_YES)
11037 : {
11038 331 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
11039 : return MATCH_ERROR;
11040 :
11041 330 : if (!gfc_add_abstract (attr, &gfc_current_locus))
11042 : return MATCH_ERROR;
11043 : }
11044 18034 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
11045 : {
11046 1486 : if (!gfc_add_extension (attr, &gfc_current_locus))
11047 : return MATCH_ERROR;
11048 : }
11049 : else
11050 16548 : return MATCH_NO;
11051 :
11052 : /* If we get here, something matched. */
11053 : return MATCH_YES;
11054 : }
11055 :
11056 :
11057 : /* Common function for type declaration blocks similar to derived types, such
11058 : as STRUCTURES and MAPs. Unlike derived types, a structure type
11059 : does NOT have a generic symbol matching the name given by the user.
11060 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
11061 : for the creation of an independent symbol.
11062 : Other parameters are a message to prefix errors with, the name of the new
11063 : type to be created, and the flavor to add to the resulting symbol. */
11064 :
11065 : static bool
11066 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
11067 : gfc_symbol **result)
11068 : {
11069 717 : gfc_symbol *sym;
11070 717 : locus where;
11071 :
11072 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
11073 :
11074 717 : if (decl)
11075 717 : where = *decl;
11076 : else
11077 0 : where = gfc_current_locus;
11078 :
11079 717 : if (gfc_get_symbol (name, NULL, &sym))
11080 : return false;
11081 :
11082 717 : if (!sym)
11083 : {
11084 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
11085 : return false;
11086 : }
11087 :
11088 717 : if (sym->components != NULL || sym->attr.zero_comp)
11089 : {
11090 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
11091 : sym->name, &sym->declared_at);
11092 3 : return false;
11093 : }
11094 :
11095 714 : sym->declared_at = where;
11096 :
11097 714 : if (sym->attr.flavor != fl
11098 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
11099 : return false;
11100 :
11101 714 : if (!sym->hash_value)
11102 : /* Set the hash for the compound name for this type. */
11103 713 : sym->hash_value = gfc_hash_value (sym);
11104 :
11105 : /* Normally the type is expected to have been completely parsed by the time
11106 : a field declaration with this type is seen. For unions, maps, and nested
11107 : structure declarations, we need to indicate that it is okay that we
11108 : haven't seen any components yet. This will be updated after the structure
11109 : is fully parsed. */
11110 714 : sym->attr.zero_comp = 0;
11111 :
11112 : /* Structures always act like derived-types with the SEQUENCE attribute */
11113 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
11114 :
11115 714 : if (result) *result = sym;
11116 :
11117 : return true;
11118 : }
11119 :
11120 :
11121 : /* Match the opening of a MAP block. Like a struct within a union in C;
11122 : behaves identical to STRUCTURE blocks. */
11123 :
11124 : match
11125 259 : gfc_match_map (void)
11126 : {
11127 : /* Counter used to give unique internal names to map structures. */
11128 259 : static unsigned int gfc_map_id = 0;
11129 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
11130 259 : gfc_symbol *sym;
11131 259 : locus old_loc;
11132 :
11133 259 : old_loc = gfc_current_locus;
11134 :
11135 259 : if (gfc_match_eos () != MATCH_YES)
11136 : {
11137 1 : gfc_error ("Junk after MAP statement at %C");
11138 1 : gfc_current_locus = old_loc;
11139 1 : return MATCH_ERROR;
11140 : }
11141 :
11142 : /* Map blocks are anonymous so we make up unique names for the symbol table
11143 : which are invalid Fortran identifiers. */
11144 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
11145 :
11146 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
11147 : return MATCH_ERROR;
11148 :
11149 258 : gfc_new_block = sym;
11150 :
11151 258 : return MATCH_YES;
11152 : }
11153 :
11154 :
11155 : /* Match the opening of a UNION block. */
11156 :
11157 : match
11158 133 : gfc_match_union (void)
11159 : {
11160 : /* Counter used to give unique internal names to union types. */
11161 133 : static unsigned int gfc_union_id = 0;
11162 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
11163 133 : gfc_symbol *sym;
11164 133 : locus old_loc;
11165 :
11166 133 : old_loc = gfc_current_locus;
11167 :
11168 133 : if (gfc_match_eos () != MATCH_YES)
11169 : {
11170 1 : gfc_error ("Junk after UNION statement at %C");
11171 1 : gfc_current_locus = old_loc;
11172 1 : return MATCH_ERROR;
11173 : }
11174 :
11175 : /* Unions are anonymous so we make up unique names for the symbol table
11176 : which are invalid Fortran identifiers. */
11177 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
11178 :
11179 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
11180 : return MATCH_ERROR;
11181 :
11182 132 : gfc_new_block = sym;
11183 :
11184 132 : return MATCH_YES;
11185 : }
11186 :
11187 :
11188 : /* Match the beginning of a STRUCTURE declaration. This is similar to
11189 : matching the beginning of a derived type declaration with a few
11190 : twists. The resulting type symbol has no access control or other
11191 : interesting attributes. */
11192 :
11193 : match
11194 336 : gfc_match_structure_decl (void)
11195 : {
11196 : /* Counter used to give unique internal names to anonymous structures. */
11197 336 : static unsigned int gfc_structure_id = 0;
11198 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
11199 336 : gfc_symbol *sym;
11200 336 : match m;
11201 336 : locus where;
11202 :
11203 336 : if (!flag_dec_structure)
11204 : {
11205 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11206 : "%<-fdec-structure%>",
11207 : "STRUCTURE");
11208 3 : return MATCH_ERROR;
11209 : }
11210 :
11211 333 : name[0] = '\0';
11212 :
11213 333 : m = gfc_match (" /%n/", name);
11214 333 : if (m != MATCH_YES)
11215 : {
11216 : /* Non-nested structure declarations require a structure name. */
11217 24 : if (!gfc_comp_struct (gfc_current_state ()))
11218 : {
11219 4 : gfc_error ("Structure name expected in non-nested structure "
11220 : "declaration at %C");
11221 4 : return MATCH_ERROR;
11222 : }
11223 : /* This is an anonymous structure; make up a unique name for it
11224 : (upper-case letters never make it to symbol names from the source).
11225 : The important thing is initializing the type variable
11226 : and setting gfc_new_symbol, which is immediately used by
11227 : parse_structure () and variable_decl () to add components of
11228 : this type. */
11229 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11230 : }
11231 :
11232 329 : where = gfc_current_locus;
11233 : /* No field list allowed after non-nested structure declaration. */
11234 329 : if (!gfc_comp_struct (gfc_current_state ())
11235 296 : && gfc_match_eos () != MATCH_YES)
11236 : {
11237 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11238 1 : return MATCH_ERROR;
11239 : }
11240 :
11241 : /* Make sure the name is not the name of an intrinsic type. */
11242 328 : if (gfc_is_intrinsic_typename (name))
11243 : {
11244 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11245 : " intrinsic type", name);
11246 1 : return MATCH_ERROR;
11247 : }
11248 :
11249 : /* Store the actual type symbol for the structure with an upper-case first
11250 : letter (an invalid Fortran identifier). */
11251 :
11252 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11253 : return MATCH_ERROR;
11254 :
11255 324 : gfc_new_block = sym;
11256 324 : return MATCH_YES;
11257 : }
11258 :
11259 :
11260 : /* This function does some work to determine which matcher should be used to
11261 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11262 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11263 : * and [parameterized] derived type declarations. */
11264 :
11265 : match
11266 527242 : gfc_match_type (gfc_statement *st)
11267 : {
11268 527242 : char name[GFC_MAX_SYMBOL_LEN + 1];
11269 527242 : match m;
11270 527242 : locus old_loc;
11271 :
11272 : /* Requires -fdec. */
11273 527242 : if (!flag_dec)
11274 : return MATCH_NO;
11275 :
11276 2483 : m = gfc_match ("type");
11277 2483 : if (m != MATCH_YES)
11278 : return m;
11279 : /* If we already have an error in the buffer, it is probably from failing to
11280 : * match a derived type data declaration. Let it happen. */
11281 20 : else if (gfc_error_flag_test ())
11282 : return MATCH_NO;
11283 :
11284 20 : old_loc = gfc_current_locus;
11285 20 : *st = ST_NONE;
11286 :
11287 : /* If we see an attribute list before anything else it's definitely a derived
11288 : * type declaration. */
11289 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11290 8 : goto derived;
11291 :
11292 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11293 : * be something like "TYPE *" or "TYPE <fmt>". */
11294 12 : m = gfc_match_name (name);
11295 12 : if (m != MATCH_YES)
11296 : {
11297 : /* Let print match if it can, otherwise throw an error from
11298 : * gfc_match_derived_decl. */
11299 7 : gfc_current_locus = old_loc;
11300 7 : if (gfc_match_print () == MATCH_YES)
11301 : {
11302 7 : *st = ST_WRITE;
11303 7 : return MATCH_YES;
11304 : }
11305 0 : goto derived;
11306 : }
11307 :
11308 : /* Check for EOS. */
11309 5 : if (gfc_match_eos () == MATCH_YES)
11310 : {
11311 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11312 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11313 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11314 : * symbol which can be printed. */
11315 3 : gfc_current_locus = old_loc;
11316 3 : m = gfc_match_derived_decl ();
11317 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11318 : {
11319 2 : *st = ST_DERIVED_DECL;
11320 2 : return m;
11321 : }
11322 : }
11323 : else
11324 : {
11325 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11326 : like <type name(parameter)>. */
11327 2 : gfc_gobble_whitespace ();
11328 2 : bool paren = gfc_peek_ascii_char () == '(';
11329 2 : if (paren)
11330 : {
11331 1 : if (strcmp ("is", name) == 0)
11332 1 : goto typeis;
11333 : else
11334 0 : goto derived;
11335 : }
11336 : }
11337 :
11338 : /* Treat TYPE... like PRINT... */
11339 2 : gfc_current_locus = old_loc;
11340 2 : *st = ST_WRITE;
11341 2 : return gfc_match_print ();
11342 :
11343 8 : derived:
11344 8 : gfc_current_locus = old_loc;
11345 8 : *st = ST_DERIVED_DECL;
11346 8 : return gfc_match_derived_decl ();
11347 :
11348 1 : typeis:
11349 1 : gfc_current_locus = old_loc;
11350 1 : *st = ST_TYPE_IS;
11351 1 : return gfc_match_type_is ();
11352 : }
11353 :
11354 :
11355 : /* Match the beginning of a derived type declaration. If a type name
11356 : was the result of a function, then it is possible to have a symbol
11357 : already to be known as a derived type yet have no components. */
11358 :
11359 : match
11360 16555 : gfc_match_derived_decl (void)
11361 : {
11362 16555 : char name[GFC_MAX_SYMBOL_LEN + 1];
11363 16555 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11364 16555 : symbol_attribute attr;
11365 16555 : gfc_symbol *sym, *gensym;
11366 16555 : gfc_symbol *extended;
11367 16555 : match m;
11368 16555 : match is_type_attr_spec = MATCH_NO;
11369 16555 : bool seen_attr = false;
11370 16555 : gfc_interface *intr = NULL, *head;
11371 16555 : bool parameterized_type = false;
11372 16555 : bool seen_colons = false;
11373 :
11374 16555 : if (gfc_comp_struct (gfc_current_state ()))
11375 : return MATCH_NO;
11376 :
11377 16551 : name[0] = '\0';
11378 16551 : parent[0] = '\0';
11379 16551 : gfc_clear_attr (&attr);
11380 16551 : extended = NULL;
11381 :
11382 19333 : do
11383 : {
11384 19333 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11385 19333 : if (is_type_attr_spec == MATCH_ERROR)
11386 : return MATCH_ERROR;
11387 19330 : if (is_type_attr_spec == MATCH_YES)
11388 2782 : seen_attr = true;
11389 19330 : } while (is_type_attr_spec == MATCH_YES);
11390 :
11391 : /* Deal with derived type extensions. The extension attribute has
11392 : been added to 'attr' but now the parent type must be found and
11393 : checked. */
11394 16548 : if (parent[0])
11395 1485 : extended = check_extended_derived_type (parent);
11396 :
11397 16548 : if (parent[0] && !extended)
11398 : return MATCH_ERROR;
11399 :
11400 16544 : m = gfc_match (" ::");
11401 16544 : if (m == MATCH_YES)
11402 : {
11403 : seen_colons = true;
11404 : }
11405 10430 : else if (seen_attr)
11406 : {
11407 5 : gfc_error ("Expected :: in TYPE definition at %C");
11408 5 : return MATCH_ERROR;
11409 : }
11410 :
11411 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11412 : But, we need to simply return for TYPE(. */
11413 10425 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11414 : {
11415 10376 : char c = gfc_peek_ascii_char ();
11416 10376 : if (c == '(')
11417 : return m;
11418 10295 : if (!gfc_is_whitespace (c))
11419 : {
11420 4 : gfc_error ("Mangled derived type definition at %C");
11421 4 : return MATCH_NO;
11422 : }
11423 : }
11424 :
11425 16454 : m = gfc_match (" %n ", name);
11426 16454 : if (m != MATCH_YES)
11427 : return m;
11428 :
11429 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11430 : derived type named 'is'.
11431 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11432 : and checking if this is a(n intrinsic) typename. This picks up
11433 : misplaced TYPE IS statements such as in select_type_1.f03. */
11434 16442 : if (gfc_peek_ascii_char () == '(')
11435 : {
11436 3899 : if (gfc_current_state () == COMP_SELECT_TYPE
11437 447 : || (!seen_colons && !strcmp (name, "is")))
11438 : return MATCH_NO;
11439 : parameterized_type = true;
11440 : }
11441 :
11442 12988 : m = gfc_match_eos ();
11443 12988 : if (m != MATCH_YES && !parameterized_type)
11444 : return m;
11445 :
11446 : /* Make sure the name is not the name of an intrinsic type. */
11447 12985 : if (gfc_is_intrinsic_typename (name))
11448 : {
11449 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11450 : "type", name);
11451 18 : return MATCH_ERROR;
11452 : }
11453 :
11454 12967 : if (gfc_get_symbol (name, NULL, &gensym))
11455 : return MATCH_ERROR;
11456 :
11457 12967 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11458 : {
11459 5 : if (gensym->ts.u.derived)
11460 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11461 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11462 : else
11463 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11464 : gensym->name);
11465 5 : return MATCH_ERROR;
11466 : }
11467 :
11468 12962 : if (!gensym->attr.generic
11469 12962 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11470 : return MATCH_ERROR;
11471 :
11472 12958 : if (!gensym->attr.function
11473 12958 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11474 : return MATCH_ERROR;
11475 :
11476 12957 : if (gensym->attr.dummy)
11477 : {
11478 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11479 : name, &gensym->declared_at);
11480 1 : return MATCH_ERROR;
11481 : }
11482 :
11483 12956 : sym = gfc_find_dt_in_generic (gensym);
11484 :
11485 12956 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11486 : {
11487 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11488 : "defined", sym->name);
11489 1 : return MATCH_ERROR;
11490 : }
11491 :
11492 12955 : if (!sym)
11493 : {
11494 : /* Use upper case to save the actual derived-type symbol. */
11495 12865 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11496 12865 : sym->name = gfc_get_string ("%s", gensym->name);
11497 12865 : head = gensym->generic;
11498 12865 : intr = gfc_get_interface ();
11499 12865 : intr->sym = sym;
11500 12865 : intr->where = gfc_current_locus;
11501 12865 : intr->sym->declared_at = gfc_current_locus;
11502 12865 : intr->next = head;
11503 12865 : gensym->generic = intr;
11504 12865 : gensym->attr.if_source = IFSRC_DECL;
11505 : }
11506 :
11507 : /* The symbol may already have the derived attribute without the
11508 : components. The ways this can happen is via a function
11509 : definition, an INTRINSIC statement or a subtype in another
11510 : derived type that is a pointer. The first part of the AND clause
11511 : is true if the symbol is not the return value of a function. */
11512 12955 : if (sym->attr.flavor != FL_DERIVED
11513 12955 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11514 : return MATCH_ERROR;
11515 :
11516 12955 : if (attr.access != ACCESS_UNKNOWN
11517 12955 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11518 : return MATCH_ERROR;
11519 12955 : else if (sym->attr.access == ACCESS_UNKNOWN
11520 12399 : && gensym->attr.access != ACCESS_UNKNOWN
11521 13302 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11522 : sym->name, NULL))
11523 : return MATCH_ERROR;
11524 :
11525 12955 : if (sym->attr.access != ACCESS_UNKNOWN
11526 903 : && gensym->attr.access == ACCESS_UNKNOWN)
11527 556 : gensym->attr.access = sym->attr.access;
11528 :
11529 : /* See if the derived type was labeled as bind(c). */
11530 12955 : if (attr.is_bind_c != 0)
11531 404 : sym->attr.is_bind_c = attr.is_bind_c;
11532 :
11533 : /* Construct the f2k_derived namespace if it is not yet there. */
11534 12955 : if (!sym->f2k_derived)
11535 12955 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11536 :
11537 12955 : if (parameterized_type)
11538 : {
11539 : /* Ignore error or mismatches by going to the end of the statement
11540 : in order to avoid the component declarations causing problems. */
11541 445 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11542 445 : if (m != MATCH_YES)
11543 4 : gfc_error_recovery ();
11544 : else
11545 441 : sym->attr.pdt_template = 1;
11546 445 : m = gfc_match_eos ();
11547 445 : if (m != MATCH_YES)
11548 : {
11549 1 : gfc_error_recovery ();
11550 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11551 : }
11552 : }
11553 :
11554 12955 : if (extended && !sym->components)
11555 : {
11556 1481 : gfc_component *p;
11557 1481 : gfc_formal_arglist *f, *g, *h;
11558 :
11559 : /* Add the extended derived type as the first component. */
11560 1481 : gfc_add_component (sym, parent, &p);
11561 1481 : extended->refs++;
11562 1481 : gfc_set_sym_referenced (extended);
11563 :
11564 1481 : p->ts.type = BT_DERIVED;
11565 1481 : p->ts.u.derived = extended;
11566 1481 : p->initializer = gfc_default_initializer (&p->ts);
11567 :
11568 : /* Set extension level. */
11569 1481 : if (extended->attr.extension == 255)
11570 : {
11571 : /* Since the extension field is 8 bit wide, we can only have
11572 : up to 255 extension levels. */
11573 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11574 : extended->name, &extended->declared_at);
11575 0 : return MATCH_ERROR;
11576 : }
11577 1481 : sym->attr.extension = extended->attr.extension + 1;
11578 :
11579 : /* Provide the links between the extended type and its extension. */
11580 1481 : if (!extended->f2k_derived)
11581 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11582 :
11583 : /* Copy the extended type-param-name-list from the extended type,
11584 : append those of the extension and add the whole lot to the
11585 : extension. */
11586 1481 : if (extended->attr.pdt_template)
11587 : {
11588 34 : g = h = NULL;
11589 34 : sym->attr.pdt_template = 1;
11590 99 : for (f = extended->formal; f; f = f->next)
11591 : {
11592 65 : if (f == extended->formal)
11593 : {
11594 34 : g = gfc_get_formal_arglist ();
11595 34 : h = g;
11596 : }
11597 : else
11598 : {
11599 31 : g->next = gfc_get_formal_arglist ();
11600 31 : g = g->next;
11601 : }
11602 65 : g->sym = f->sym;
11603 : }
11604 34 : g->next = sym->formal;
11605 34 : sym->formal = h;
11606 : }
11607 : }
11608 :
11609 12955 : if (!sym->hash_value)
11610 : /* Set the hash for the compound name for this type. */
11611 12955 : sym->hash_value = gfc_hash_value (sym);
11612 :
11613 : /* Take over the ABSTRACT attribute. */
11614 12955 : sym->attr.abstract = attr.abstract;
11615 :
11616 12955 : gfc_new_block = sym;
11617 :
11618 12955 : return MATCH_YES;
11619 : }
11620 :
11621 :
11622 : /* Cray Pointees can be declared as:
11623 : pointer (ipt, a (n,m,...,*)) */
11624 :
11625 : match
11626 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11627 : {
11628 240 : as->cray_pointee = true; /* This will be useful to know later. */
11629 240 : if (as->type == AS_ASSUMED_SIZE)
11630 72 : as->cp_was_assumed = true;
11631 168 : else if (as->type == AS_ASSUMED_SHAPE)
11632 : {
11633 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11634 0 : return MATCH_ERROR;
11635 : }
11636 : return MATCH_YES;
11637 : }
11638 :
11639 :
11640 : /* Match the enum definition statement, here we are trying to match
11641 : the first line of enum definition statement.
11642 : Returns MATCH_YES if match is found. */
11643 :
11644 : match
11645 158 : gfc_match_enum (void)
11646 : {
11647 158 : match m;
11648 :
11649 158 : m = gfc_match_eos ();
11650 158 : if (m != MATCH_YES)
11651 : return m;
11652 :
11653 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11654 0 : return MATCH_ERROR;
11655 :
11656 : return MATCH_YES;
11657 : }
11658 :
11659 :
11660 : /* Returns an initializer whose value is one higher than the value of the
11661 : LAST_INITIALIZER argument. If the argument is NULL, the
11662 : initializers value will be set to zero. The initializer's kind
11663 : will be set to gfc_c_int_kind.
11664 :
11665 : If -fshort-enums is given, the appropriate kind will be selected
11666 : later after all enumerators have been parsed. A warning is issued
11667 : here if an initializer exceeds gfc_c_int_kind. */
11668 :
11669 : static gfc_expr *
11670 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11671 : {
11672 377 : gfc_expr *result;
11673 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11674 :
11675 377 : mpz_init (result->value.integer);
11676 :
11677 377 : if (last_initializer != NULL)
11678 : {
11679 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11680 266 : result->where = last_initializer->where;
11681 :
11682 266 : if (gfc_check_integer_range (result->value.integer,
11683 : gfc_c_int_kind) != ARITH_OK)
11684 : {
11685 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11686 0 : return NULL;
11687 : }
11688 : }
11689 : else
11690 : {
11691 : /* Control comes here, if it's the very first enumerator and no
11692 : initializer has been given. It will be initialized to zero. */
11693 111 : mpz_set_si (result->value.integer, 0);
11694 : }
11695 :
11696 : return result;
11697 : }
11698 :
11699 :
11700 : /* Match a variable name with an optional initializer. When this
11701 : subroutine is called, a variable is expected to be parsed next.
11702 : Depending on what is happening at the moment, updates either the
11703 : symbol table or the current interface. */
11704 :
11705 : static match
11706 549 : enumerator_decl (void)
11707 : {
11708 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11709 549 : gfc_expr *initializer;
11710 549 : gfc_array_spec *as = NULL;
11711 549 : gfc_charlen *saved_cl_list;
11712 549 : gfc_symbol *sym;
11713 549 : locus var_locus;
11714 549 : match m;
11715 549 : bool t;
11716 549 : locus old_locus;
11717 :
11718 549 : initializer = NULL;
11719 549 : saved_cl_list = gfc_current_ns->cl_list;
11720 549 : old_locus = gfc_current_locus;
11721 :
11722 : /* When we get here, we've just matched a list of attributes and
11723 : maybe a type and a double colon. The next thing we expect to see
11724 : is the name of the symbol. */
11725 549 : m = gfc_match_name (name);
11726 549 : if (m != MATCH_YES)
11727 1 : goto cleanup;
11728 :
11729 548 : var_locus = gfc_current_locus;
11730 :
11731 : /* OK, we've successfully matched the declaration. Now put the
11732 : symbol in the current namespace. If we fail to create the symbol,
11733 : bail out. */
11734 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11735 : {
11736 1 : m = MATCH_ERROR;
11737 1 : goto cleanup;
11738 : }
11739 :
11740 : /* The double colon must be present in order to have initializers.
11741 : Otherwise the statement is ambiguous with an assignment statement. */
11742 547 : if (colon_seen)
11743 : {
11744 471 : if (gfc_match_char ('=') == MATCH_YES)
11745 : {
11746 170 : m = gfc_match_init_expr (&initializer);
11747 170 : if (m == MATCH_NO)
11748 : {
11749 0 : gfc_error ("Expected an initialization expression at %C");
11750 0 : m = MATCH_ERROR;
11751 : }
11752 :
11753 170 : if (m != MATCH_YES)
11754 2 : goto cleanup;
11755 : }
11756 : }
11757 :
11758 : /* If we do not have an initializer, the initialization value of the
11759 : previous enumerator (stored in last_initializer) is incremented
11760 : by 1 and is used to initialize the current enumerator. */
11761 545 : if (initializer == NULL)
11762 377 : initializer = enum_initializer (last_initializer, old_locus);
11763 :
11764 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11765 : {
11766 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11767 : &var_locus);
11768 2 : m = MATCH_ERROR;
11769 2 : goto cleanup;
11770 : }
11771 :
11772 : /* Store this current initializer, for the next enumerator variable
11773 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11774 : use last_initializer below. */
11775 543 : last_initializer = initializer;
11776 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
11777 : saved_cl_list);
11778 :
11779 : /* Maintain enumerator history. */
11780 543 : gfc_find_symbol (name, NULL, 0, &sym);
11781 543 : create_enum_history (sym, last_initializer);
11782 :
11783 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11784 :
11785 6 : cleanup:
11786 : /* Free stuff up and return. */
11787 6 : gfc_free_expr (initializer);
11788 :
11789 6 : return m;
11790 : }
11791 :
11792 :
11793 : /* Match the enumerator definition statement. */
11794 :
11795 : match
11796 806110 : gfc_match_enumerator_def (void)
11797 : {
11798 806110 : match m;
11799 806110 : bool t;
11800 :
11801 806110 : gfc_clear_ts (¤t_ts);
11802 :
11803 806110 : m = gfc_match (" enumerator");
11804 806110 : if (m != MATCH_YES)
11805 : return m;
11806 :
11807 269 : m = gfc_match (" :: ");
11808 269 : if (m == MATCH_ERROR)
11809 : return m;
11810 :
11811 269 : colon_seen = (m == MATCH_YES);
11812 :
11813 269 : if (gfc_current_state () != COMP_ENUM)
11814 : {
11815 4 : gfc_error ("ENUM definition statement expected before %C");
11816 4 : gfc_free_enum_history ();
11817 4 : return MATCH_ERROR;
11818 : }
11819 :
11820 265 : (¤t_ts)->type = BT_INTEGER;
11821 265 : (¤t_ts)->kind = gfc_c_int_kind;
11822 :
11823 265 : gfc_clear_attr (¤t_attr);
11824 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11825 265 : if (!t)
11826 : {
11827 0 : m = MATCH_ERROR;
11828 0 : goto cleanup;
11829 : }
11830 :
11831 549 : for (;;)
11832 : {
11833 549 : m = enumerator_decl ();
11834 549 : if (m == MATCH_ERROR)
11835 : {
11836 6 : gfc_free_enum_history ();
11837 6 : goto cleanup;
11838 : }
11839 543 : if (m == MATCH_NO)
11840 : break;
11841 :
11842 542 : if (gfc_match_eos () == MATCH_YES)
11843 256 : goto cleanup;
11844 286 : if (gfc_match_char (',') != MATCH_YES)
11845 : break;
11846 : }
11847 :
11848 3 : if (gfc_current_state () == COMP_ENUM)
11849 : {
11850 3 : gfc_free_enum_history ();
11851 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11852 3 : m = MATCH_ERROR;
11853 : }
11854 :
11855 0 : cleanup:
11856 265 : gfc_free_array_spec (current_as);
11857 265 : current_as = NULL;
11858 265 : return m;
11859 :
11860 : }
11861 :
11862 :
11863 : /* Match binding attributes. */
11864 :
11865 : static match
11866 4710 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11867 : {
11868 4710 : bool found_passing = false;
11869 4710 : bool seen_ptr = false;
11870 4710 : match m = MATCH_YES;
11871 :
11872 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11873 : this case the defaults are in there. */
11874 4710 : ba->access = ACCESS_UNKNOWN;
11875 4710 : ba->pass_arg = NULL;
11876 4710 : ba->pass_arg_num = 0;
11877 4710 : ba->nopass = 0;
11878 4710 : ba->non_overridable = 0;
11879 4710 : ba->deferred = 0;
11880 4710 : ba->ppc = ppc;
11881 :
11882 : /* If we find a comma, we believe there are binding attributes. */
11883 4710 : m = gfc_match_char (',');
11884 4710 : if (m == MATCH_NO)
11885 2470 : goto done;
11886 :
11887 2785 : do
11888 : {
11889 : /* Access specifier. */
11890 :
11891 2785 : m = gfc_match (" public");
11892 2785 : if (m == MATCH_ERROR)
11893 0 : goto error;
11894 2785 : if (m == MATCH_YES)
11895 : {
11896 250 : if (ba->access != ACCESS_UNKNOWN)
11897 : {
11898 0 : gfc_error ("Duplicate access-specifier at %C");
11899 0 : goto error;
11900 : }
11901 :
11902 250 : ba->access = ACCESS_PUBLIC;
11903 250 : continue;
11904 : }
11905 :
11906 2535 : m = gfc_match (" private");
11907 2535 : if (m == MATCH_ERROR)
11908 0 : goto error;
11909 2535 : if (m == MATCH_YES)
11910 : {
11911 181 : if (ba->access != ACCESS_UNKNOWN)
11912 : {
11913 1 : gfc_error ("Duplicate access-specifier at %C");
11914 1 : goto error;
11915 : }
11916 :
11917 180 : ba->access = ACCESS_PRIVATE;
11918 180 : continue;
11919 : }
11920 :
11921 : /* If inside GENERIC, the following is not allowed. */
11922 2354 : if (!generic)
11923 : {
11924 :
11925 : /* NOPASS flag. */
11926 2353 : m = gfc_match (" nopass");
11927 2353 : if (m == MATCH_ERROR)
11928 0 : goto error;
11929 2353 : if (m == MATCH_YES)
11930 : {
11931 703 : if (found_passing)
11932 : {
11933 1 : gfc_error ("Binding attributes already specify passing,"
11934 : " illegal NOPASS at %C");
11935 1 : goto error;
11936 : }
11937 :
11938 702 : found_passing = true;
11939 702 : ba->nopass = 1;
11940 702 : continue;
11941 : }
11942 :
11943 : /* PASS possibly including argument. */
11944 1650 : m = gfc_match (" pass");
11945 1650 : if (m == MATCH_ERROR)
11946 0 : goto error;
11947 1650 : if (m == MATCH_YES)
11948 : {
11949 901 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11950 :
11951 901 : if (found_passing)
11952 : {
11953 2 : gfc_error ("Binding attributes already specify passing,"
11954 : " illegal PASS at %C");
11955 2 : goto error;
11956 : }
11957 :
11958 899 : m = gfc_match (" ( %n )", arg);
11959 899 : if (m == MATCH_ERROR)
11960 0 : goto error;
11961 899 : if (m == MATCH_YES)
11962 490 : ba->pass_arg = gfc_get_string ("%s", arg);
11963 899 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11964 :
11965 899 : found_passing = true;
11966 899 : ba->nopass = 0;
11967 899 : continue;
11968 899 : }
11969 :
11970 749 : if (ppc)
11971 : {
11972 : /* POINTER flag. */
11973 427 : m = gfc_match (" pointer");
11974 427 : if (m == MATCH_ERROR)
11975 0 : goto error;
11976 427 : if (m == MATCH_YES)
11977 : {
11978 427 : if (seen_ptr)
11979 : {
11980 1 : gfc_error ("Duplicate POINTER attribute at %C");
11981 1 : goto error;
11982 : }
11983 :
11984 426 : seen_ptr = true;
11985 426 : continue;
11986 : }
11987 : }
11988 : else
11989 : {
11990 : /* NON_OVERRIDABLE flag. */
11991 322 : m = gfc_match (" non_overridable");
11992 322 : if (m == MATCH_ERROR)
11993 0 : goto error;
11994 322 : if (m == MATCH_YES)
11995 : {
11996 62 : if (ba->non_overridable)
11997 : {
11998 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11999 1 : goto error;
12000 : }
12001 :
12002 61 : ba->non_overridable = 1;
12003 61 : continue;
12004 : }
12005 :
12006 : /* DEFERRED flag. */
12007 260 : m = gfc_match (" deferred");
12008 260 : if (m == MATCH_ERROR)
12009 0 : goto error;
12010 260 : if (m == MATCH_YES)
12011 : {
12012 260 : if (ba->deferred)
12013 : {
12014 1 : gfc_error ("Duplicate DEFERRED at %C");
12015 1 : goto error;
12016 : }
12017 :
12018 259 : ba->deferred = 1;
12019 259 : continue;
12020 : }
12021 : }
12022 :
12023 : }
12024 :
12025 : /* Nothing matching found. */
12026 1 : if (generic)
12027 1 : gfc_error ("Expected access-specifier at %C");
12028 : else
12029 0 : gfc_error ("Expected binding attribute at %C");
12030 1 : goto error;
12031 : }
12032 2777 : while (gfc_match_char (',') == MATCH_YES);
12033 :
12034 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
12035 2232 : if (ba->non_overridable && ba->deferred)
12036 : {
12037 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
12038 1 : goto error;
12039 : }
12040 :
12041 : m = MATCH_YES;
12042 :
12043 4701 : done:
12044 4701 : if (ba->access == ACCESS_UNKNOWN)
12045 4272 : ba->access = ppc ? gfc_current_block()->component_access
12046 : : gfc_typebound_default_access;
12047 :
12048 4701 : if (ppc && !seen_ptr)
12049 : {
12050 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
12051 : " at %C");
12052 2 : goto error;
12053 : }
12054 :
12055 : return m;
12056 :
12057 : error:
12058 : return MATCH_ERROR;
12059 : }
12060 :
12061 :
12062 : /* Match a PROCEDURE specific binding inside a derived type. */
12063 :
12064 : static match
12065 3236 : match_procedure_in_type (void)
12066 : {
12067 3236 : char name[GFC_MAX_SYMBOL_LEN + 1];
12068 3236 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
12069 3236 : char* target = NULL, *ifc = NULL;
12070 3236 : gfc_typebound_proc tb;
12071 3236 : bool seen_colons;
12072 3236 : bool seen_attrs;
12073 3236 : match m;
12074 3236 : gfc_symtree* stree;
12075 3236 : gfc_namespace* ns;
12076 3236 : gfc_symbol* block;
12077 3236 : int num;
12078 :
12079 : /* Check current state. */
12080 3236 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
12081 3236 : block = gfc_state_stack->previous->sym;
12082 3236 : gcc_assert (block);
12083 :
12084 : /* Try to match PROCEDURE(interface). */
12085 3236 : if (gfc_match (" (") == MATCH_YES)
12086 : {
12087 261 : m = gfc_match_name (target_buf);
12088 261 : if (m == MATCH_ERROR)
12089 : return m;
12090 261 : if (m != MATCH_YES)
12091 : {
12092 1 : gfc_error ("Interface-name expected after %<(%> at %C");
12093 1 : return MATCH_ERROR;
12094 : }
12095 :
12096 260 : if (gfc_match (" )") != MATCH_YES)
12097 : {
12098 1 : gfc_error ("%<)%> expected at %C");
12099 1 : return MATCH_ERROR;
12100 : }
12101 :
12102 : ifc = target_buf;
12103 : }
12104 :
12105 : /* Construct the data structure. */
12106 3234 : memset (&tb, 0, sizeof (tb));
12107 3234 : tb.where = gfc_current_locus;
12108 :
12109 : /* Match binding attributes. */
12110 3234 : m = match_binding_attributes (&tb, false, false);
12111 3234 : if (m == MATCH_ERROR)
12112 : return m;
12113 3227 : seen_attrs = (m == MATCH_YES);
12114 :
12115 : /* Check that attribute DEFERRED is given if an interface is specified. */
12116 3227 : if (tb.deferred && !ifc)
12117 : {
12118 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
12119 1 : return MATCH_ERROR;
12120 : }
12121 3226 : if (ifc && !tb.deferred)
12122 : {
12123 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
12124 1 : return MATCH_ERROR;
12125 : }
12126 :
12127 : /* Match the colons. */
12128 3225 : m = gfc_match (" ::");
12129 3225 : if (m == MATCH_ERROR)
12130 : return m;
12131 3225 : seen_colons = (m == MATCH_YES);
12132 3225 : if (seen_attrs && !seen_colons)
12133 : {
12134 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
12135 4 : return MATCH_ERROR;
12136 : }
12137 :
12138 : /* Match the binding names. */
12139 19 : for(num=1;;num++)
12140 : {
12141 3240 : m = gfc_match_name (name);
12142 3240 : if (m == MATCH_ERROR)
12143 : return m;
12144 3240 : if (m == MATCH_NO)
12145 : {
12146 5 : gfc_error ("Expected binding name at %C");
12147 5 : return MATCH_ERROR;
12148 : }
12149 :
12150 3235 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
12151 : return MATCH_ERROR;
12152 :
12153 : /* Try to match the '=> target', if it's there. */
12154 3234 : target = ifc;
12155 3234 : m = gfc_match (" =>");
12156 3234 : if (m == MATCH_ERROR)
12157 : return m;
12158 3234 : if (m == MATCH_YES)
12159 : {
12160 1250 : if (tb.deferred)
12161 : {
12162 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
12163 1 : return MATCH_ERROR;
12164 : }
12165 :
12166 1249 : if (!seen_colons)
12167 : {
12168 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
12169 : " at %C");
12170 1 : return MATCH_ERROR;
12171 : }
12172 :
12173 1248 : m = gfc_match_name (target_buf);
12174 1248 : if (m == MATCH_ERROR)
12175 : return m;
12176 1248 : if (m == MATCH_NO)
12177 : {
12178 2 : gfc_error ("Expected binding target after %<=>%> at %C");
12179 2 : return MATCH_ERROR;
12180 : }
12181 : target = target_buf;
12182 : }
12183 :
12184 : /* If no target was found, it has the same name as the binding. */
12185 1984 : if (!target)
12186 1729 : target = name;
12187 :
12188 : /* Get the namespace to insert the symbols into. */
12189 3230 : ns = block->f2k_derived;
12190 3230 : gcc_assert (ns);
12191 :
12192 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
12193 3230 : if (tb.deferred && !block->attr.abstract)
12194 : {
12195 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
12196 : "is not ABSTRACT", block->name);
12197 1 : return MATCH_ERROR;
12198 : }
12199 :
12200 : /* See if we already have a binding with this name in the symtree which
12201 : would be an error. If a GENERIC already targeted this binding, it may
12202 : be already there but then typebound is still NULL. */
12203 3229 : stree = gfc_find_symtree (ns->tb_sym_root, name);
12204 3229 : if (stree && stree->n.tb)
12205 : {
12206 2 : gfc_error ("There is already a procedure with binding name %qs for "
12207 : "the derived type %qs at %C", name, block->name);
12208 2 : return MATCH_ERROR;
12209 : }
12210 :
12211 : /* Insert it and set attributes. */
12212 :
12213 3108 : if (!stree)
12214 : {
12215 3108 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12216 3108 : gcc_assert (stree);
12217 : }
12218 3227 : stree->n.tb = gfc_get_typebound_proc (&tb);
12219 :
12220 3227 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12221 : false))
12222 : return MATCH_ERROR;
12223 3227 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12224 3227 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12225 3227 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12226 :
12227 3227 : if (gfc_match_eos () == MATCH_YES)
12228 : return MATCH_YES;
12229 20 : if (gfc_match_char (',') != MATCH_YES)
12230 1 : goto syntax;
12231 : }
12232 :
12233 1 : syntax:
12234 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12235 1 : return MATCH_ERROR;
12236 : }
12237 :
12238 :
12239 : /* Match a GENERIC statement.
12240 : F2018 15.4.3.3 GENERIC statement
12241 :
12242 : A GENERIC statement specifies a generic identifier for one or more specific
12243 : procedures, in the same way as a generic interface block that does not contain
12244 : interface bodies.
12245 :
12246 : R1510 generic-stmt is:
12247 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12248 :
12249 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12250 : procedure that was specified previously in any accessible interface with the
12251 : same generic identifier.
12252 :
12253 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12254 :
12255 : For GENERIC statements outside of a derived type, use is made of the existing,
12256 : typebound matching functions to obtain access-spec and generic-spec. After
12257 : this the standard INTERFACE machinery is used. */
12258 :
12259 : static match
12260 100 : match_generic_stmt (void)
12261 : {
12262 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12263 : /* Allow space for OPERATOR(...). */
12264 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12265 : /* Generics other than uops */
12266 100 : gfc_symbol* generic_spec = NULL;
12267 : /* Generic uops */
12268 100 : gfc_user_op *generic_uop = NULL;
12269 : /* For the matching calls */
12270 100 : gfc_typebound_proc tbattr;
12271 100 : gfc_namespace* ns = gfc_current_ns;
12272 100 : interface_type op_type;
12273 100 : gfc_intrinsic_op op;
12274 100 : match m;
12275 100 : gfc_symtree* st;
12276 : /* The specific-procedure-list */
12277 100 : gfc_interface *generic = NULL;
12278 : /* The head of the specific-procedure-list */
12279 100 : gfc_interface **generic_tail = NULL;
12280 :
12281 100 : memset (&tbattr, 0, sizeof (tbattr));
12282 100 : tbattr.where = gfc_current_locus;
12283 :
12284 : /* See if we get an access-specifier. */
12285 100 : m = match_binding_attributes (&tbattr, true, false);
12286 100 : tbattr.where = gfc_current_locus;
12287 100 : if (m == MATCH_ERROR)
12288 0 : goto error;
12289 :
12290 : /* Now the colons, those are required. */
12291 100 : if (gfc_match (" ::") != MATCH_YES)
12292 : {
12293 0 : gfc_error ("Expected %<::%> at %C");
12294 0 : goto error;
12295 : }
12296 :
12297 : /* Match the generic-spec name; depending on type (operator / generic) format
12298 : it for future error messages in 'generic_spec_name'. */
12299 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12300 100 : if (m == MATCH_ERROR)
12301 : return MATCH_ERROR;
12302 100 : if (m == MATCH_NO)
12303 : {
12304 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12305 0 : goto error;
12306 : }
12307 :
12308 100 : switch (op_type)
12309 : {
12310 63 : case INTERFACE_GENERIC:
12311 63 : case INTERFACE_DTIO:
12312 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12313 63 : break;
12314 :
12315 22 : case INTERFACE_USER_OP:
12316 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12317 22 : break;
12318 :
12319 13 : case INTERFACE_INTRINSIC_OP:
12320 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12321 : gfc_op2string (op));
12322 13 : break;
12323 :
12324 2 : case INTERFACE_NAMELESS:
12325 2 : gfc_error ("Malformed GENERIC statement at %C");
12326 2 : goto error;
12327 0 : break;
12328 :
12329 0 : default:
12330 0 : gcc_unreachable ();
12331 : }
12332 :
12333 : /* Match the required =>. */
12334 98 : if (gfc_match (" =>") != MATCH_YES)
12335 : {
12336 1 : gfc_error ("Expected %<=>%> at %C");
12337 1 : goto error;
12338 : }
12339 :
12340 :
12341 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12342 : {
12343 1 : gfc_error ("The access specification at %L not in a module",
12344 : &tbattr.where);
12345 1 : goto error;
12346 : }
12347 :
12348 : /* Try to find existing generic-spec with this name for this operator;
12349 : if there is something, check that it is another generic-spec and then
12350 : extend it rather than building a new symbol. Otherwise, create a new
12351 : one with the right attributes. */
12352 :
12353 96 : switch (op_type)
12354 : {
12355 61 : case INTERFACE_DTIO:
12356 61 : case INTERFACE_GENERIC:
12357 61 : st = gfc_find_symtree (ns->sym_root, name);
12358 61 : generic_spec = st ? st->n.sym : NULL;
12359 61 : if (generic_spec)
12360 : {
12361 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12362 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12363 : {
12364 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12365 : "name of an entity declared at %L that is not a "
12366 : "procedure", name, &generic_spec->declared_at);
12367 1 : goto error;
12368 : }
12369 :
12370 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12371 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12372 : {
12373 0 : gfc_error ("There's already a non-generic procedure with "
12374 : "name %qs at %C", generic_spec->name);
12375 0 : goto error;
12376 : }
12377 :
12378 24 : if (tbattr.access != ACCESS_UNKNOWN)
12379 : {
12380 2 : if (generic_spec->attr.access != tbattr.access)
12381 : {
12382 1 : gfc_error ("The access specification at %L conflicts with "
12383 : "that already given to %qs", &tbattr.where,
12384 : generic_spec->name);
12385 1 : goto error;
12386 : }
12387 : else
12388 : {
12389 1 : gfc_error ("The access specification at %L repeats that "
12390 : "already given to %qs", &tbattr.where,
12391 : generic_spec->name);
12392 1 : goto error;
12393 : }
12394 : }
12395 :
12396 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12397 : {
12398 1 : gfc_error ("The generic-spec in the generic statement at %C "
12399 : "has a type from the declaration at %L",
12400 : &generic_spec->declared_at);
12401 1 : goto error;
12402 : }
12403 : }
12404 :
12405 : /* Now create the generic_spec if it doesn't already exist and provide
12406 : is with the appropriate attributes. */
12407 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12408 : {
12409 45 : if (!generic_spec)
12410 : {
12411 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12412 36 : gfc_set_sym_referenced (generic_spec);
12413 36 : generic_spec->attr.access = tbattr.access;
12414 : }
12415 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12416 0 : generic_spec->attr.access = tbattr.access;
12417 45 : generic_spec->refs++;
12418 45 : generic_spec->attr.generic = 1;
12419 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12420 :
12421 45 : generic_spec->declared_at = gfc_current_locus;
12422 : }
12423 :
12424 : /* Prepare to add the specific procedures. */
12425 57 : generic = generic_spec->generic;
12426 57 : generic_tail = &generic_spec->generic;
12427 57 : break;
12428 :
12429 22 : case INTERFACE_USER_OP:
12430 22 : st = gfc_find_symtree (ns->uop_root, name);
12431 22 : generic_uop = st ? st->n.uop : NULL;
12432 2 : if (generic_uop)
12433 : {
12434 2 : if (generic_uop->access != ACCESS_UNKNOWN
12435 2 : && tbattr.access != ACCESS_UNKNOWN)
12436 : {
12437 2 : if (generic_uop->access != tbattr.access)
12438 : {
12439 1 : gfc_error ("The user operator at %L must have the same "
12440 : "access specification as already defined user "
12441 : "operator %qs", &tbattr.where, generic_spec_name);
12442 1 : goto error;
12443 : }
12444 : else
12445 : {
12446 1 : gfc_error ("The user operator at %L repeats the access "
12447 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12448 1 : goto error;
12449 : }
12450 : }
12451 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12452 0 : generic_uop->access = tbattr.access;
12453 : }
12454 : else
12455 : {
12456 20 : generic_uop = gfc_get_uop (name);
12457 20 : generic_uop->access = tbattr.access;
12458 : }
12459 :
12460 : /* Prepare to add the specific procedures. */
12461 20 : generic = generic_uop->op;
12462 20 : generic_tail = &generic_uop->op;
12463 20 : break;
12464 :
12465 13 : case INTERFACE_INTRINSIC_OP:
12466 13 : generic = ns->op[op];
12467 13 : generic_tail = &ns->op[op];
12468 13 : break;
12469 :
12470 0 : default:
12471 0 : gcc_unreachable ();
12472 : }
12473 :
12474 : /* Now, match all following names in the specific-procedure-list. */
12475 154 : do
12476 : {
12477 154 : m = gfc_match_name (name);
12478 154 : if (m == MATCH_ERROR)
12479 0 : goto error;
12480 154 : if (m == MATCH_NO)
12481 : {
12482 0 : gfc_error ("Expected specific procedure name at %C");
12483 0 : goto error;
12484 : }
12485 :
12486 154 : if (op_type == INTERFACE_GENERIC
12487 95 : && !strcmp (generic_spec->name, name))
12488 : {
12489 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12490 : "with that of the generic-spec", name);
12491 2 : goto error;
12492 : }
12493 :
12494 152 : generic = *generic_tail;
12495 242 : for (; generic; generic = generic->next)
12496 : {
12497 90 : if (!strcmp (generic->sym->name, name))
12498 : {
12499 0 : gfc_error ("%qs already defined as a specific procedure for the"
12500 : " generic %qs at %C", name, generic_spec->name);
12501 0 : goto error;
12502 : }
12503 : }
12504 :
12505 152 : gfc_find_sym_tree (name, ns, 1, &st);
12506 152 : if (!st)
12507 : {
12508 : /* This might be a procedure that has not yet been parsed. If
12509 : so gfc_fixup_sibling_symbols will replace this symbol with
12510 : that of the procedure. */
12511 75 : gfc_get_sym_tree (name, ns, &st, false);
12512 75 : st->n.sym->refs++;
12513 : }
12514 :
12515 152 : generic = gfc_get_interface();
12516 152 : generic->next = *generic_tail;
12517 152 : *generic_tail = generic;
12518 152 : generic->where = gfc_current_locus;
12519 152 : generic->sym = st->n.sym;
12520 : }
12521 152 : while (gfc_match (" ,") == MATCH_YES);
12522 :
12523 88 : if (gfc_match_eos () != MATCH_YES)
12524 : {
12525 0 : gfc_error ("Junk after GENERIC statement at %C");
12526 0 : goto error;
12527 : }
12528 :
12529 88 : gfc_commit_symbols ();
12530 88 : return MATCH_YES;
12531 :
12532 : error:
12533 : return MATCH_ERROR;
12534 : }
12535 :
12536 :
12537 : /* Match a GENERIC procedure binding inside a derived type. */
12538 :
12539 : static match
12540 948 : match_typebound_generic (void)
12541 : {
12542 948 : char name[GFC_MAX_SYMBOL_LEN + 1];
12543 948 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12544 948 : gfc_symbol* block;
12545 948 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12546 948 : gfc_typebound_proc* tb;
12547 948 : gfc_namespace* ns;
12548 948 : interface_type op_type;
12549 948 : gfc_intrinsic_op op;
12550 948 : match m;
12551 :
12552 : /* Check current state. */
12553 948 : if (gfc_current_state () == COMP_DERIVED)
12554 : {
12555 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12556 0 : return MATCH_ERROR;
12557 : }
12558 948 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12559 : return MATCH_NO;
12560 948 : block = gfc_state_stack->previous->sym;
12561 948 : ns = block->f2k_derived;
12562 948 : gcc_assert (block && ns);
12563 :
12564 948 : memset (&tbattr, 0, sizeof (tbattr));
12565 948 : tbattr.where = gfc_current_locus;
12566 :
12567 : /* See if we get an access-specifier. */
12568 948 : m = match_binding_attributes (&tbattr, true, false);
12569 948 : if (m == MATCH_ERROR)
12570 1 : goto error;
12571 :
12572 : /* Now the colons, those are required. */
12573 947 : if (gfc_match (" ::") != MATCH_YES)
12574 : {
12575 0 : gfc_error ("Expected %<::%> at %C");
12576 0 : goto error;
12577 : }
12578 :
12579 : /* Match the binding name; depending on type (operator / generic) format
12580 : it for future error messages into bind_name. */
12581 :
12582 947 : m = gfc_match_generic_spec (&op_type, name, &op);
12583 947 : if (m == MATCH_ERROR)
12584 : return MATCH_ERROR;
12585 947 : if (m == MATCH_NO)
12586 : {
12587 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12588 0 : goto error;
12589 : }
12590 :
12591 947 : switch (op_type)
12592 : {
12593 470 : case INTERFACE_GENERIC:
12594 470 : case INTERFACE_DTIO:
12595 470 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12596 470 : break;
12597 :
12598 47 : case INTERFACE_USER_OP:
12599 47 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12600 47 : break;
12601 :
12602 429 : case INTERFACE_INTRINSIC_OP:
12603 429 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12604 : gfc_op2string (op));
12605 429 : break;
12606 :
12607 1 : case INTERFACE_NAMELESS:
12608 1 : gfc_error ("Malformed GENERIC statement at %C");
12609 1 : goto error;
12610 0 : break;
12611 :
12612 0 : default:
12613 0 : gcc_unreachable ();
12614 : }
12615 :
12616 : /* Match the required =>. */
12617 946 : if (gfc_match (" =>") != MATCH_YES)
12618 : {
12619 0 : gfc_error ("Expected %<=>%> at %C");
12620 0 : goto error;
12621 : }
12622 :
12623 : /* Try to find existing GENERIC binding with this name / for this operator;
12624 : if there is something, check that it is another GENERIC and then extend
12625 : it rather than building a new node. Otherwise, create it and put it
12626 : at the right position. */
12627 :
12628 946 : switch (op_type)
12629 : {
12630 517 : case INTERFACE_DTIO:
12631 517 : case INTERFACE_USER_OP:
12632 517 : case INTERFACE_GENERIC:
12633 517 : {
12634 517 : const bool is_op = (op_type == INTERFACE_USER_OP);
12635 517 : gfc_symtree* st;
12636 :
12637 517 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12638 517 : tb = st ? st->n.tb : NULL;
12639 : break;
12640 : }
12641 :
12642 429 : case INTERFACE_INTRINSIC_OP:
12643 429 : tb = ns->tb_op[op];
12644 429 : break;
12645 :
12646 0 : default:
12647 0 : gcc_unreachable ();
12648 : }
12649 :
12650 440 : if (tb)
12651 : {
12652 9 : if (!tb->is_generic)
12653 : {
12654 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12655 1 : gfc_error ("There's already a non-generic procedure with binding name"
12656 : " %qs for the derived type %qs at %C",
12657 : bind_name, block->name);
12658 1 : goto error;
12659 : }
12660 :
12661 8 : if (tb->access != tbattr.access)
12662 : {
12663 2 : gfc_error ("Binding at %C must have the same access as already"
12664 : " defined binding %qs", bind_name);
12665 2 : goto error;
12666 : }
12667 : }
12668 : else
12669 : {
12670 937 : tb = gfc_get_typebound_proc (NULL);
12671 937 : tb->where = gfc_current_locus;
12672 937 : tb->access = tbattr.access;
12673 937 : tb->is_generic = 1;
12674 937 : tb->u.generic = NULL;
12675 :
12676 937 : switch (op_type)
12677 : {
12678 508 : case INTERFACE_DTIO:
12679 508 : case INTERFACE_GENERIC:
12680 508 : case INTERFACE_USER_OP:
12681 508 : {
12682 508 : const bool is_op = (op_type == INTERFACE_USER_OP);
12683 508 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12684 : &ns->tb_sym_root, name);
12685 508 : gcc_assert (st);
12686 508 : st->n.tb = tb;
12687 :
12688 508 : break;
12689 : }
12690 :
12691 429 : case INTERFACE_INTRINSIC_OP:
12692 429 : ns->tb_op[op] = tb;
12693 429 : break;
12694 :
12695 0 : default:
12696 0 : gcc_unreachable ();
12697 : }
12698 : }
12699 :
12700 : /* Now, match all following names as specific targets. */
12701 1100 : do
12702 : {
12703 1100 : gfc_symtree* target_st;
12704 1100 : gfc_tbp_generic* target;
12705 :
12706 1100 : m = gfc_match_name (name);
12707 1100 : if (m == MATCH_ERROR)
12708 0 : goto error;
12709 1100 : if (m == MATCH_NO)
12710 : {
12711 1 : gfc_error ("Expected specific binding name at %C");
12712 1 : goto error;
12713 : }
12714 :
12715 1099 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12716 :
12717 : /* See if this is a duplicate specification. */
12718 1334 : for (target = tb->u.generic; target; target = target->next)
12719 236 : if (target_st == target->specific_st)
12720 : {
12721 1 : gfc_error ("%qs already defined as specific binding for the"
12722 : " generic %qs at %C", name, bind_name);
12723 1 : goto error;
12724 : }
12725 :
12726 1098 : target = gfc_get_tbp_generic ();
12727 1098 : target->specific_st = target_st;
12728 1098 : target->specific = NULL;
12729 1098 : target->next = tb->u.generic;
12730 1098 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12731 1098 : || (op_type == INTERFACE_INTRINSIC_OP));
12732 1098 : tb->u.generic = target;
12733 : }
12734 1098 : while (gfc_match (" ,") == MATCH_YES);
12735 :
12736 : /* Here should be the end. */
12737 941 : if (gfc_match_eos () != MATCH_YES)
12738 : {
12739 1 : gfc_error ("Junk after GENERIC binding at %C");
12740 1 : goto error;
12741 : }
12742 :
12743 : return MATCH_YES;
12744 :
12745 : error:
12746 : return MATCH_ERROR;
12747 : }
12748 :
12749 :
12750 : match
12751 1048 : gfc_match_generic ()
12752 : {
12753 1048 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12754 1046 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12755 100 : return match_generic_stmt ();
12756 : else
12757 948 : return match_typebound_generic ();
12758 : }
12759 :
12760 :
12761 : /* Match a FINAL declaration inside a derived type. */
12762 :
12763 : match
12764 460 : gfc_match_final_decl (void)
12765 : {
12766 460 : char name[GFC_MAX_SYMBOL_LEN + 1];
12767 460 : gfc_symbol* sym;
12768 460 : match m;
12769 460 : gfc_namespace* module_ns;
12770 460 : bool first, last;
12771 460 : gfc_symbol* block;
12772 :
12773 460 : if (gfc_current_form == FORM_FREE)
12774 : {
12775 460 : char c = gfc_peek_ascii_char ();
12776 460 : if (!gfc_is_whitespace (c) && c != ':')
12777 : return MATCH_NO;
12778 : }
12779 :
12780 459 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12781 : {
12782 1 : if (gfc_current_form == FORM_FIXED)
12783 : return MATCH_NO;
12784 :
12785 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12786 : "CONTAINS section");
12787 1 : return MATCH_ERROR;
12788 : }
12789 :
12790 458 : block = gfc_state_stack->previous->sym;
12791 458 : gcc_assert (block);
12792 :
12793 458 : if (gfc_state_stack->previous->previous
12794 458 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12795 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12796 : {
12797 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12798 : " specification part of a MODULE");
12799 0 : return MATCH_ERROR;
12800 : }
12801 :
12802 458 : module_ns = gfc_current_ns;
12803 458 : gcc_assert (module_ns);
12804 458 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12805 :
12806 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12807 458 : if (gfc_match (" ::") == MATCH_ERROR)
12808 : return MATCH_ERROR;
12809 :
12810 : /* Match the sequence of procedure names. */
12811 : first = true;
12812 : last = false;
12813 544 : do
12814 : {
12815 544 : gfc_finalizer* f;
12816 :
12817 544 : if (first && gfc_match_eos () == MATCH_YES)
12818 : {
12819 2 : gfc_error ("Empty FINAL at %C");
12820 2 : return MATCH_ERROR;
12821 : }
12822 :
12823 542 : m = gfc_match_name (name);
12824 542 : if (m == MATCH_NO)
12825 : {
12826 1 : gfc_error ("Expected module procedure name at %C");
12827 1 : return MATCH_ERROR;
12828 : }
12829 541 : else if (m != MATCH_YES)
12830 : return MATCH_ERROR;
12831 :
12832 541 : if (gfc_match_eos () == MATCH_YES)
12833 : last = true;
12834 87 : if (!last && gfc_match_char (',') != MATCH_YES)
12835 : {
12836 1 : gfc_error ("Expected %<,%> at %C");
12837 1 : return MATCH_ERROR;
12838 : }
12839 :
12840 540 : if (gfc_get_symbol (name, module_ns, &sym))
12841 : {
12842 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12843 0 : return MATCH_ERROR;
12844 : }
12845 :
12846 : /* Mark the symbol as module procedure. */
12847 540 : if (sym->attr.proc != PROC_MODULE
12848 540 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12849 : return MATCH_ERROR;
12850 :
12851 : /* Check if we already have this symbol in the list, this is an error. */
12852 721 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12853 182 : if (f->proc_sym == sym)
12854 : {
12855 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12856 : name);
12857 1 : return MATCH_ERROR;
12858 : }
12859 :
12860 : /* Add this symbol to the list of finalizers. */
12861 539 : gcc_assert (block->f2k_derived);
12862 539 : sym->refs++;
12863 539 : f = XCNEW (gfc_finalizer);
12864 539 : f->proc_sym = sym;
12865 539 : f->proc_tree = NULL;
12866 539 : f->where = gfc_current_locus;
12867 539 : f->next = block->f2k_derived->finalizers;
12868 539 : block->f2k_derived->finalizers = f;
12869 :
12870 539 : first = false;
12871 : }
12872 539 : while (!last);
12873 :
12874 : return MATCH_YES;
12875 : }
12876 :
12877 :
12878 : const ext_attr_t ext_attr_list[] = {
12879 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12880 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12881 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12882 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12883 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12884 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12885 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12886 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12887 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12888 : { "weak", EXT_ATTR_WEAK, NULL },
12889 : { "inline", EXT_ATTR_INLINE, NULL },
12890 : { "always_inline",EXT_ATTR_ALWAYS_INLINE,NULL },
12891 : { NULL, EXT_ATTR_LAST, NULL }
12892 : };
12893 :
12894 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12895 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12896 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12897 :
12898 : TODO: We should support all GCC attributes using the same syntax for
12899 : the attribute list, i.e. the list in C
12900 : __attributes(( attribute-list ))
12901 : matches then
12902 : !GCC$ ATTRIBUTES attribute-list ::
12903 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12904 : saved into a TREE.
12905 :
12906 : As there is absolutely no risk of confusion, we should never return
12907 : MATCH_NO. */
12908 : match
12909 2984 : gfc_match_gcc_attributes (void)
12910 : {
12911 2984 : symbol_attribute attr;
12912 2984 : char name[GFC_MAX_SYMBOL_LEN + 1];
12913 2984 : unsigned id;
12914 2984 : gfc_symbol *sym;
12915 2984 : match m;
12916 :
12917 2984 : gfc_clear_attr (&attr);
12918 2988 : for(;;)
12919 : {
12920 2986 : char ch;
12921 :
12922 2986 : if (gfc_match_name (name) != MATCH_YES)
12923 : return MATCH_ERROR;
12924 :
12925 18042 : for (id = 0; id < EXT_ATTR_LAST; id++)
12926 18042 : if (strcmp (name, ext_attr_list[id].name) == 0)
12927 : break;
12928 :
12929 2986 : if (id == EXT_ATTR_LAST)
12930 : {
12931 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12932 0 : return MATCH_ERROR;
12933 : }
12934 :
12935 2986 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12936 : return MATCH_ERROR;
12937 :
12938 2986 : gfc_gobble_whitespace ();
12939 2986 : ch = gfc_next_ascii_char ();
12940 2986 : if (ch == ':')
12941 : {
12942 : /* This is the successful exit condition for the loop. */
12943 2984 : if (gfc_next_ascii_char () == ':')
12944 : break;
12945 : }
12946 :
12947 2 : if (ch == ',')
12948 2 : continue;
12949 :
12950 0 : goto syntax;
12951 2 : }
12952 :
12953 2984 : if (gfc_match_eos () == MATCH_YES)
12954 0 : goto syntax;
12955 :
12956 2999 : for(;;)
12957 : {
12958 2999 : m = gfc_match_name (name);
12959 2999 : if (m != MATCH_YES)
12960 : return m;
12961 :
12962 2999 : if (find_special (name, &sym, true))
12963 : return MATCH_ERROR;
12964 :
12965 2999 : sym->attr.ext_attr |= attr.ext_attr;
12966 :
12967 : /* INLINE and ALWAYS_INLINE are incompatible with NOINLINE. In the
12968 : middle-end the DECL_UNINLINABLE flag set by NOINLINE always wins, so
12969 : the inline request would be silently ignored. Warn and drop it. */
12970 2999 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NOINLINE))
12971 : {
12972 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_ALWAYS_INLINE))
12973 : {
12974 2 : gfc_warning (0, "Attribute %<ALWAYS_INLINE%> at %C is "
12975 : "incompatible with %<NOINLINE%> for %qs and will "
12976 : "be ignored", sym->name);
12977 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_ALWAYS_INLINE);
12978 : }
12979 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_INLINE))
12980 : {
12981 2 : gfc_warning (0, "Attribute %<INLINE%> at %C is incompatible "
12982 : "with %<NOINLINE%> for %qs and will be ignored",
12983 : sym->name);
12984 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_INLINE);
12985 : }
12986 : }
12987 :
12988 2999 : if (gfc_match_eos () == MATCH_YES)
12989 : break;
12990 :
12991 15 : if (gfc_match_char (',') != MATCH_YES)
12992 0 : goto syntax;
12993 : }
12994 :
12995 : return MATCH_YES;
12996 :
12997 0 : syntax:
12998 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
12999 0 : return MATCH_ERROR;
13000 : }
13001 :
13002 :
13003 : /* Match a !GCC$ UNROLL statement of the form:
13004 : !GCC$ UNROLL n
13005 :
13006 : The parameter n is the number of times we are supposed to unroll.
13007 :
13008 : When we come here, we have already matched the !GCC$ UNROLL string. */
13009 : match
13010 19 : gfc_match_gcc_unroll (void)
13011 : {
13012 19 : int value;
13013 :
13014 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
13015 19 : if (gfc_match_small_int (&value) == MATCH_YES)
13016 : {
13017 19 : if (value < 0 || value > USHRT_MAX)
13018 : {
13019 2 : gfc_error ("%<GCC unroll%> directive requires a"
13020 : " non-negative integral constant"
13021 : " less than or equal to %u at %C",
13022 : USHRT_MAX
13023 : );
13024 2 : return MATCH_ERROR;
13025 : }
13026 17 : if (gfc_match_eos () == MATCH_YES)
13027 : {
13028 17 : directive_unroll = value == 0 ? 1 : value;
13029 17 : return MATCH_YES;
13030 : }
13031 : }
13032 :
13033 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
13034 0 : return MATCH_ERROR;
13035 : }
13036 :
13037 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
13038 :
13039 : The parameter b is name of a middle-end built-in.
13040 : FLAGS is optional and must be one of:
13041 : - (inbranch)
13042 : - (notinbranch)
13043 :
13044 : IF('target') is optional and TARGET is a name of a multilib ABI.
13045 :
13046 : When we come here, we have already matched the !GCC$ builtin string. */
13047 :
13048 : match
13049 3430005 : gfc_match_gcc_builtin (void)
13050 : {
13051 3430005 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
13052 3430005 : char target[GFC_MAX_SYMBOL_LEN + 1];
13053 :
13054 3430005 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
13055 : return MATCH_ERROR;
13056 :
13057 3430005 : gfc_simd_clause clause = SIMD_NONE;
13058 3430005 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
13059 : clause = SIMD_NOTINBRANCH;
13060 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
13061 15 : clause = SIMD_INBRANCH;
13062 :
13063 3430005 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
13064 : {
13065 3429975 : if (strcmp (target, "fastmath") == 0)
13066 : {
13067 0 : if (!fast_math_flags_set_p (&global_options))
13068 : return MATCH_YES;
13069 : }
13070 : else
13071 : {
13072 3429975 : const char *abi = targetm.get_multilib_abi_name ();
13073 3429975 : if (abi == NULL || strcmp (abi, target) != 0)
13074 : return MATCH_YES;
13075 : }
13076 : }
13077 :
13078 1693040 : if (gfc_vectorized_builtins == NULL)
13079 31358 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
13080 :
13081 1693040 : char *r = XNEWVEC (char, strlen (builtin) + 32);
13082 1693040 : sprintf (r, "__builtin_%s", builtin);
13083 :
13084 1693040 : bool existed;
13085 1693040 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
13086 1693040 : value |= clause;
13087 1693040 : if (existed)
13088 23 : free (r);
13089 :
13090 : return MATCH_YES;
13091 : }
13092 :
13093 : /* Match an !GCC$ IVDEP statement.
13094 : When we come here, we have already matched the !GCC$ IVDEP string. */
13095 :
13096 : match
13097 3 : gfc_match_gcc_ivdep (void)
13098 : {
13099 3 : if (gfc_match_eos () == MATCH_YES)
13100 : {
13101 3 : directive_ivdep = true;
13102 3 : return MATCH_YES;
13103 : }
13104 :
13105 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
13106 0 : return MATCH_ERROR;
13107 : }
13108 :
13109 : /* Match an !GCC$ VECTOR statement.
13110 : When we come here, we have already matched the !GCC$ VECTOR string. */
13111 :
13112 : match
13113 3 : gfc_match_gcc_vector (void)
13114 : {
13115 3 : if (gfc_match_eos () == MATCH_YES)
13116 : {
13117 3 : directive_vector = true;
13118 3 : directive_novector = false;
13119 3 : return MATCH_YES;
13120 : }
13121 :
13122 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
13123 0 : return MATCH_ERROR;
13124 : }
13125 :
13126 : /* Match an !GCC$ NOVECTOR statement.
13127 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
13128 :
13129 : match
13130 3 : gfc_match_gcc_novector (void)
13131 : {
13132 3 : if (gfc_match_eos () == MATCH_YES)
13133 : {
13134 3 : directive_novector = true;
13135 3 : directive_vector = false;
13136 3 : return MATCH_YES;
13137 : }
13138 :
13139 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
13140 0 : return MATCH_ERROR;
13141 : }
|
