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 8309 : gfc_in_match_data (void)
161 : {
162 8309 : 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 535054 : gfc_free_data (gfc_data *p)
210 : {
211 535054 : gfc_data *q;
212 :
213 537628 : 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 535054 : }
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 9124995 : gfc_reject_data (gfc_namespace *ns)
242 : {
243 9124995 : gfc_data *d;
244 :
245 9124997 : 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 9124995 : }
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 28140 : match_intent_spec (void)
1078 : {
1079 :
1080 28140 : if (gfc_match (" ( in out )") == MATCH_YES)
1081 : return INTENT_INOUT;
1082 24948 : if (gfc_match (" ( in )") == MATCH_YES)
1083 : return INTENT_IN;
1084 3689 : 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 27809 : char_len_param_value (gfc_expr **expr, bool *deferred)
1097 : {
1098 27809 : match m;
1099 27809 : gfc_expr *p;
1100 :
1101 27809 : *expr = NULL;
1102 27809 : *deferred = false;
1103 :
1104 27809 : if (gfc_match_char ('*') == MATCH_YES)
1105 : return MATCH_YES;
1106 :
1107 21286 : if (gfc_match_char (':') == MATCH_YES)
1108 : {
1109 3371 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1110 : return MATCH_ERROR;
1111 :
1112 3369 : *deferred = true;
1113 :
1114 3369 : return MATCH_YES;
1115 : }
1116 :
1117 17915 : m = gfc_match_expr (expr);
1118 :
1119 17915 : if (m == MATCH_NO || m == MATCH_ERROR)
1120 : return m;
1121 :
1122 17910 : 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 17904 : p = gfc_copy_expr (*expr);
1127 17904 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1128 14872 : gfc_replace_expr (*expr, p);
1129 : else
1130 3032 : gfc_free_expr (p);
1131 :
1132 17904 : 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 16889 : 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 14800 : if ((*expr)->ts.type == BT_INTEGER)
1150 : {
1151 14782 : 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 16852 : 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 62992 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1212 : {
1213 62992 : int length;
1214 62992 : match m;
1215 :
1216 62992 : *deferred = false;
1217 62992 : m = gfc_match_char ('*');
1218 62992 : 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 285343 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1276 : {
1277 285343 : gfc_state_data *s;
1278 285343 : gfc_symtree *st;
1279 285343 : int i;
1280 :
1281 285343 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1282 285343 : if (i == 0)
1283 : {
1284 285343 : *result = st ? st->n.sym : NULL;
1285 285343 : 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 64404 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1320 : {
1321 64404 : gfc_symtree *st;
1322 64404 : gfc_symbol *sym;
1323 64404 : 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 64404 : 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 64144 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1369 :
1370 64404 : if (rc)
1371 : return rc;
1372 :
1373 64403 : sym = *result;
1374 64403 : if (sym->attr.proc == PROC_ST_FUNCTION)
1375 : return rc;
1376 :
1377 64402 : 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 63931 : else if (sym && !sym->gfc_new
1403 24681 : && 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 23347 : if (sym->attr.flavor != 0
1411 21264 : && sym->attr.proc != 0
1412 2392 : && (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 23340 : if (sym->attr.flavor != 0
1420 21257 : && 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 23339 : 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 23338 : 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 23337 : if ((sym->ts.kind != 0
1452 22964 : || sym->ts.type == BT_CLASS
1453 22963 : || 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 64387 : 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 64387 : 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 64387 : if (sym && !sym->gfc_new
1495 25137 : && sym->attr.flavor != FL_UNKNOWN
1496 22654 : && 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 64386 : 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 52172 : 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 51914 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1519 :
1520 52172 : st->n.sym = sym;
1521 52172 : sym->refs++;
1522 :
1523 : /* See if the procedure should be a module procedure. */
1524 :
1525 52172 : if (((sym->ns->proc_name != NULL
1526 52172 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1527 21162 : && sym->attr.proc != PROC_MODULE)
1528 52172 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1529 70500 : && !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 17315 : gfc_verify_c_interop_param (gfc_symbol *sym)
1555 : {
1556 17315 : int is_c_interop = 0;
1557 17315 : 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 17315 : 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 17315 : 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 17311 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1589 : {
1590 17311 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1591 : {
1592 17272 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1593 17272 : bool f2018_added = false;
1594 :
1595 17272 : 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 3731 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1614 : {
1615 2364 : bool as_ar = (sym->as
1616 2364 : && (sym->as->type == AS_ASSUMED_SHAPE
1617 2117 : || sym->as->type == AS_ASSUMED_RANK));
1618 4728 : bool cond1 = (sym->ts.type == BT_CHARACTER
1619 1565 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1620 905 : && !sym->attr.allocatable
1621 3251 : && !sym->attr.pointer);
1622 4728 : bool cond2 = (sym->attr.allocatable
1623 2267 : || as_ar
1624 3389 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1625 4728 : bool cond3 = (sym->ts.type == BT_ASSUMED
1626 0 : && !sym->attr.allocatable
1627 0 : && !sym->attr.pointer
1628 2364 : && !as_ar);
1629 2364 : f2018_added = cond1 || cond2 || cond3;
1630 : }
1631 :
1632 17272 : if (is_c_interop != 1 && !f2018_added)
1633 : {
1634 : /* Make personalized messages to give better feedback. */
1635 1837 : 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 1836 : 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 1830 : 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 17272 : 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 16632 : if ((sym->attr.pointer || sym->attr.allocatable)
1666 1041 : && sym->ts.type == BT_DERIVED
1667 17650 : && 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 17272 : if (sym->ts.type == BT_CHARACTER)
1681 : {
1682 2344 : gfc_charlen *cl = sym->ts.u.cl;
1683 :
1684 2344 : if (sym->attr.allocatable || sym->attr.pointer)
1685 : {
1686 : /* F2018, 18.3.6 (6). */
1687 195 : 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 131 : 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 131 : sym->ns->proc_name->name))
1707 102 : retval = false;
1708 : }
1709 2149 : 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 2148 : 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 959 : 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 959 : sym->ns->proc_name->name))
1729 102 : retval = false;
1730 : }
1731 1189 : else if (cl->length->expr_type != EXPR_CONSTANT
1732 875 : || 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 17272 : if (sym->attr.allocatable == 1
1757 17673 : && !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 401 : sym->ns->proc_name->name))
1762 : retval = false;
1763 :
1764 17272 : if (sym->attr.pointer == 1
1765 17912 : && !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 640 : sym->ns->proc_name->name))
1770 : retval = false;
1771 :
1772 17272 : 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 17263 : else if (sym->attr.optional == 1
1781 18217 : && !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 954 : 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 5551 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1792 18605 : && !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 1333 : &(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 263568 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1811 : gfc_array_spec **as, locus *var_locus)
1812 : {
1813 263568 : symbol_attribute attr;
1814 263568 : gfc_symbol *sym;
1815 263568 : int upper;
1816 263568 : 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 263568 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1823 263568 : 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 263568 : 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 263556 : 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 263554 : 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 263566 : upper = TOUPPER(name[0]);
1863 263566 : if (upper != name[0])
1864 : {
1865 262816 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1866 262816 : gfc_symtree *st;
1867 :
1868 262816 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1869 262816 : strcpy (u_name, name);
1870 262816 : u_name[0] = upper;
1871 :
1872 262816 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1873 :
1874 : /* STRUCTURE types can alias symbol names */
1875 262816 : 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 263565 : if (current_ts.type != BT_UNKNOWN
1885 263565 : && (sym->attr.implicit_type == 0
1886 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1887 526948 : && !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 263538 : if (sym->ts.type == BT_CHARACTER)
1904 : {
1905 29039 : if (elem > 1)
1906 4153 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1907 : else
1908 24886 : sym->ts.u.cl = cl;
1909 29039 : sym->ts.deferred = cl_deferred;
1910 : }
1911 :
1912 : /* Add dimension attribute if present. */
1913 263538 : if (!gfc_set_array_spec (sym, *as, var_locus))
1914 : return false;
1915 263536 : *as = NULL;
1916 :
1917 : /* Add attribute to symbol. The copy is so that we can reset the
1918 : dimension attribute. */
1919 263536 : attr = current_attr;
1920 263536 : attr.dimension = 0;
1921 263536 : attr.codimension = 0;
1922 :
1923 263536 : 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 263522 : if (sym->attr.is_bind_c == 1)
1933 : {
1934 1786 : 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 263520 : 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 263520 : sym->attr.implied_index = 0;
1962 :
1963 : /* Use the parameter expressions for a parameterized derived type. */
1964 263520 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1965 37123 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1966 1122 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1967 :
1968 263520 : if (sym->ts.type == BT_CLASS)
1969 11132 : 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 14485 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1982 : gfc_charlen_t check_len)
1983 : {
1984 14485 : gfc_char_t *s;
1985 14485 : gfc_charlen_t slen;
1986 :
1987 14485 : if (expr->ts.type != BT_CHARACTER)
1988 : return;
1989 :
1990 14483 : 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 14482 : slen = expr->value.character.length;
1997 14482 : if (len != slen)
1998 : {
1999 2147 : s = gfc_get_wide_string (len + 1);
2000 2147 : memcpy (s, expr->value.character.string,
2001 2147 : MIN (len, slen) * sizeof (gfc_char_t));
2002 2147 : if (len > slen)
2003 1856 : gfc_wide_memset (&s[slen], ' ', len - slen);
2004 :
2005 2147 : 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 2147 : 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 2147 : s[len] = '\0';
2029 2147 : free (expr->value.character.string);
2030 2147 : expr->value.character.string = s;
2031 2147 : expr->value.character.length = len;
2032 : /* If explicit representation was given, clear it
2033 : as it is no longer needed after padding. */
2034 2147 : 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 2753 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2105 : {
2106 2753 : if (!gfc_specification_expr (ts->u.cl->length))
2107 : return false;
2108 :
2109 2753 : 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 2753 : if (mpz_cmp (ts->u.cl->length->value.integer,
2114 2753 : gfc_integer_kinds[k].huge) <= 0)
2115 : {
2116 2752 : HOST_WIDE_INT len
2117 2752 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2118 :
2119 2752 : if (init->expr_type == EXPR_CONSTANT)
2120 2006 : gfc_set_constant_character_len (len, init, -1);
2121 746 : else if (init->expr_type == EXPR_ARRAY)
2122 : {
2123 745 : gfc_constructor *cons;
2124 :
2125 : /* Build a new charlen to prevent simplification from
2126 : deleting the length before it is resolved. */
2127 745 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2128 745 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2129 745 : cons = gfc_constructor_first (init->value.constructor);
2130 5049 : for (; cons; cons = gfc_constructor_next (cons))
2131 3559 : 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 271917 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus,
2144 : gfc_charlen *saved_cl_list)
2145 : {
2146 271917 : symbol_attribute attr;
2147 271917 : gfc_symbol *sym;
2148 271917 : gfc_expr *init;
2149 :
2150 271917 : init = *initp;
2151 271917 : if (find_special (name, &sym, false))
2152 : return false;
2153 :
2154 271917 : attr = sym->attr;
2155 :
2156 : /* If this symbol is confirming an implicit parameter type,
2157 : then an initialization expression is not allowed. */
2158 271917 : 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 271916 : if (init == NULL)
2171 : {
2172 : /* An initializer is required for PARAMETER declarations. */
2173 238538 : 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 33378 : 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 32197 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2193 32174 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2194 32124 : && !sym->attr.proc_pointer
2195 65393 : && !gfc_check_assign_symbol (sym, NULL, init))
2196 : return false;
2197 :
2198 33347 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2199 3446 : && init->ts.type == BT_CHARACTER)
2200 : {
2201 : /* Update symbol character length according initializer. */
2202 3282 : if (!gfc_check_assign_symbol (sym, NULL, init))
2203 : return false;
2204 :
2205 3282 : 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 2431 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2265 2431 : && !fix_initializer_charlen (&sym->ts, init))
2266 : return false;
2267 : }
2268 :
2269 33344 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2270 3801 : && 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 33341 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2279 3798 : && sym->as && sym->as->type == AS_IMPLIED_SHAPE)
2280 : {
2281 1041 : int dim;
2282 :
2283 1041 : 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 1040 : 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 2175 : for (dim = 0; dim < sym->as->rank; ++dim)
2311 : {
2312 1139 : int k;
2313 1139 : gfc_expr *e, *lower;
2314 :
2315 1139 : 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 1139 : if (lower->expr_type == EXPR_VARIABLE)
2321 7 : gfc_reduce_init_expr (lower);
2322 :
2323 1139 : if (lower->expr_type == EXPR_CONSTANT)
2324 : {
2325 : /* All dimensions must be without upper bound. */
2326 1138 : gcc_assert (!sym->as->upper[dim]);
2327 :
2328 1138 : k = lower->ts.kind;
2329 1138 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2330 1138 : mpz_add (e->value.integer, lower->value.integer,
2331 1138 : init->shape[dim]);
2332 1138 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2333 1138 : 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 1036 : sym->as->type = AS_EXPLICIT;
2344 : }
2345 :
2346 : /* Ensure that explicit bounds are simplified. */
2347 33336 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2348 3793 : && sym->as && sym->as->type == AS_EXPLICIT)
2349 : {
2350 8420 : for (int dim = 0; dim < sym->as->rank; ++dim)
2351 : {
2352 4639 : gfc_expr *e;
2353 :
2354 4639 : e = sym->as->lower[dim];
2355 4639 : if (e->expr_type != EXPR_CONSTANT)
2356 12 : gfc_reduce_init_expr (e);
2357 :
2358 4639 : e = sym->as->upper[dim];
2359 4639 : 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 33336 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2374 : {
2375 28715 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2376 28715 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2377 : /* attr bits needed for module files. */
2378 28715 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2379 28715 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2380 28715 : if (init->ts.is_iso_c)
2381 118 : sym->ts.f90_type = init->ts.f90_type;
2382 : }
2383 :
2384 : /* Catch the case: type(t), parameter :: x = z'1'. */
2385 33336 : 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 33335 : if (sym->attr.dimension && init->rank == 0)
2394 : {
2395 1271 : mpz_t size;
2396 1271 : gfc_expr *array;
2397 1271 : int n;
2398 1271 : if (sym->attr.flavor == FL_PARAMETER
2399 468 : && gfc_is_constant_expr (init)
2400 467 : && (init->expr_type == EXPR_CONSTANT
2401 48 : || init->expr_type == EXPR_STRUCTURE)
2402 1738 : && spec_size (sym->as, &size))
2403 : {
2404 463 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2405 : &init->where);
2406 463 : if (init->ts.type == BT_DERIVED)
2407 48 : array->ts.u.derived = init->ts.u.derived;
2408 67619 : for (n = 0; n < (int)mpz_get_si (size); n++)
2409 133990 : gfc_constructor_append_expr (&array->value.constructor,
2410 : n == 0
2411 : ? init
2412 66834 : : gfc_copy_expr (init),
2413 : &init->where);
2414 :
2415 463 : array->shape = gfc_get_shape (sym->as->rank);
2416 1052 : for (n = 0; n < sym->as->rank; n++)
2417 589 : spec_dimen_size (sym->as, n, &array->shape[n]);
2418 :
2419 463 : init = array;
2420 463 : mpz_clear (size);
2421 : }
2422 1271 : init->rank = sym->as->rank;
2423 1271 : init->corank = sym->as->corank;
2424 : }
2425 :
2426 33335 : sym->value = init;
2427 33335 : if (sym->attr.save == SAVE_NONE)
2428 28783 : sym->attr.save = SAVE_IMPLICIT;
2429 33335 : *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 18217 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2441 : gfc_array_spec **as)
2442 : {
2443 18217 : gfc_state_data *s;
2444 18217 : 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 18217 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2449 3449 : && 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 18216 : if (current_ts.type == BT_CLASS
2467 851 : && !(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 18211 : 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 18211 : s = gfc_state_stack;
2495 18211 : 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 18211 : if (!gfc_add_component (gfc_current_block(), name, &c))
2514 : return false;
2515 :
2516 18205 : c->ts = current_ts;
2517 18205 : if (c->ts.type == BT_CHARACTER)
2518 1952 : c->ts.u.cl = cl;
2519 :
2520 18205 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2521 14762 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2522 2138 : && saved_kind_expr != NULL)
2523 200 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2524 :
2525 18205 : c->attr = current_attr;
2526 :
2527 18205 : c->initializer = *init;
2528 18205 : *init = NULL;
2529 :
2530 : /* Update initializer character length according to component. */
2531 1952 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2532 1545 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2533 1480 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2534 18530 : && !fix_initializer_charlen (&c->ts, c->initializer))
2535 : return false;
2536 :
2537 18205 : c->as = *as;
2538 18205 : if (c->as != NULL)
2539 : {
2540 4897 : if (c->as->corank)
2541 108 : c->attr.codimension = 1;
2542 4897 : if (c->as->rank)
2543 4821 : c->attr.dimension = 1;
2544 : }
2545 18205 : *as = NULL;
2546 :
2547 18205 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2548 :
2549 : /* Convert a class, PDT component of a non-derived type to a specific instance
2550 : before gfc_build_class_symbol gets to work on it. */
2551 18205 : if (c->ts.type == BT_CLASS
2552 846 : && !(gfc_current_block ()->attr.pdt_template
2553 846 : || gfc_current_block ()->attr.pdt_type)
2554 846 : && c->ts.u.derived->attr.pdt_template)
2555 : {
2556 12 : match m = gfc_get_pdt_instance (decl_type_param_list, &c->ts.u.derived, NULL);
2557 12 : if (m != MATCH_YES)
2558 : {
2559 0 : if (!gfc_error_check ())
2560 0 : gfc_error ("Parameterized component of a non-parameterized "
2561 : "derived type at %C could not be converted to a valid "
2562 : "instance");
2563 0 : return false;
2564 : }
2565 : }
2566 :
2567 : /* Check array components. */
2568 18205 : if (!c->attr.dimension)
2569 13384 : goto scalar;
2570 :
2571 4821 : if (c->attr.pointer)
2572 : {
2573 732 : if (c->as->type != AS_DEFERRED)
2574 : {
2575 5 : gfc_error ("Pointer array component of structure at %C must have a "
2576 : "deferred shape");
2577 5 : return false;
2578 : }
2579 : }
2580 4089 : else if (c->attr.allocatable)
2581 : {
2582 2428 : const char *err = G_("Allocatable component of structure at %C must have "
2583 : "a deferred shape");
2584 2428 : if (c->as->type != AS_DEFERRED)
2585 : {
2586 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2587 : {
2588 : /* Issue an immediate error and allow this component to pass for
2589 : the sake of clean error recovery. Set the error flag for the
2590 : containing derived type so that finalizers are not built. */
2591 4 : gfc_error_now (err);
2592 4 : s->sym->error = 1;
2593 4 : c->as->type = AS_DEFERRED;
2594 : }
2595 : else
2596 : {
2597 10 : gfc_error (err);
2598 10 : return false;
2599 : }
2600 : }
2601 : }
2602 : else
2603 : {
2604 1661 : if (c->as->type != AS_EXPLICIT)
2605 : {
2606 7 : gfc_error ("Array component of structure at %C must have an "
2607 : "explicit shape");
2608 7 : return false;
2609 : }
2610 : }
2611 :
2612 1654 : scalar:
2613 18183 : if (c->ts.type == BT_CLASS)
2614 843 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2615 :
2616 17340 : if (c->attr.pdt_kind || c->attr.pdt_len)
2617 : {
2618 604 : gfc_symbol *sym;
2619 604 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2620 : 0, &sym);
2621 604 : if (sym == NULL)
2622 : {
2623 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2624 : "in the type parameter name list at %L",
2625 0 : c->name, &gfc_current_block ()->declared_at);
2626 0 : return false;
2627 : }
2628 604 : sym->ts = c->ts;
2629 604 : sym->attr.pdt_kind = c->attr.pdt_kind;
2630 604 : sym->attr.pdt_len = c->attr.pdt_len;
2631 604 : if (c->initializer)
2632 246 : sym->value = gfc_copy_expr (c->initializer);
2633 604 : sym->attr.flavor = FL_VARIABLE;
2634 : }
2635 :
2636 17340 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2637 2597 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2638 130 : && decl_type_param_list)
2639 130 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2640 :
2641 : return true;
2642 : }
2643 :
2644 :
2645 : /* Match a 'NULL()', and possibly take care of some side effects. */
2646 :
2647 : match
2648 1716 : gfc_match_null (gfc_expr **result)
2649 : {
2650 1716 : gfc_symbol *sym;
2651 1716 : match m, m2 = MATCH_NO;
2652 :
2653 1716 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2654 : return MATCH_ERROR;
2655 :
2656 1716 : if (m == MATCH_NO)
2657 : {
2658 511 : locus old_loc;
2659 511 : char name[GFC_MAX_SYMBOL_LEN + 1];
2660 :
2661 511 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2662 505 : return m2;
2663 :
2664 6 : old_loc = gfc_current_locus;
2665 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2666 : return MATCH_ERROR;
2667 6 : if (m2 != MATCH_YES
2668 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2669 : return MATCH_ERROR;
2670 6 : if (m2 == MATCH_NO)
2671 : {
2672 0 : gfc_current_locus = old_loc;
2673 0 : return MATCH_NO;
2674 : }
2675 : }
2676 :
2677 : /* The NULL symbol now has to be/become an intrinsic function. */
2678 1211 : if (gfc_get_symbol ("null", NULL, &sym))
2679 : {
2680 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2681 0 : return MATCH_ERROR;
2682 : }
2683 :
2684 1211 : gfc_intrinsic_symbol (sym);
2685 :
2686 1211 : if (sym->attr.proc != PROC_INTRINSIC
2687 853 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2688 2063 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2689 852 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2690 0 : return MATCH_ERROR;
2691 :
2692 1211 : *result = gfc_get_null_expr (&gfc_current_locus);
2693 :
2694 : /* Invalid per F2008, C512. */
2695 1211 : if (m2 == MATCH_YES)
2696 : {
2697 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2698 6 : return MATCH_ERROR;
2699 : }
2700 :
2701 : return MATCH_YES;
2702 : }
2703 :
2704 :
2705 : /* Match the initialization expr for a data pointer or procedure pointer. */
2706 :
2707 : static match
2708 1380 : match_pointer_init (gfc_expr **init, int procptr)
2709 : {
2710 1380 : match m;
2711 :
2712 1380 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2713 : {
2714 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2715 : "a PURE procedure");
2716 1 : return MATCH_ERROR;
2717 : }
2718 1379 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2719 :
2720 : /* Match NULL() initialization. */
2721 1379 : m = gfc_match_null (init);
2722 1379 : if (m != MATCH_NO)
2723 : return m;
2724 :
2725 : /* Match non-NULL initialization. */
2726 176 : gfc_matching_ptr_assignment = !procptr;
2727 176 : gfc_matching_procptr_assignment = procptr;
2728 176 : m = gfc_match_rvalue (init);
2729 176 : gfc_matching_ptr_assignment = 0;
2730 176 : gfc_matching_procptr_assignment = 0;
2731 176 : if (m == MATCH_ERROR)
2732 : return MATCH_ERROR;
2733 175 : else if (m == MATCH_NO)
2734 : {
2735 2 : gfc_error ("Error in pointer initialization at %C");
2736 2 : return MATCH_ERROR;
2737 : }
2738 :
2739 173 : if (!procptr && !gfc_resolve_expr (*init))
2740 : return MATCH_ERROR;
2741 :
2742 172 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2743 : "initialization at %C"))
2744 : return MATCH_ERROR;
2745 :
2746 : return MATCH_YES;
2747 : }
2748 :
2749 :
2750 : static bool
2751 291703 : check_function_name (char *name)
2752 : {
2753 : /* In functions that have a RESULT variable defined, the function name always
2754 : refers to function calls. Therefore, the name is not allowed to appear in
2755 : specification statements. When checking this, be careful about
2756 : 'hidden' procedure pointer results ('ppr@'). */
2757 :
2758 291703 : if (gfc_current_state () == COMP_FUNCTION)
2759 : {
2760 47939 : gfc_symbol *block = gfc_current_block ();
2761 47939 : if (block && block->result && block->result != block
2762 15380 : && strcmp (block->result->name, "ppr@") != 0
2763 15321 : && strcmp (block->name, name) == 0)
2764 : {
2765 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2766 : "from appearing in a specification statement",
2767 : block->result->name, &block->result->declared_at, name);
2768 9 : return false;
2769 : }
2770 : }
2771 :
2772 : return true;
2773 : }
2774 :
2775 :
2776 : /* Match a variable name with an optional initializer. When this
2777 : subroutine is called, a variable is expected to be parsed next.
2778 : Depending on what is happening at the moment, updates either the
2779 : symbol table or the current interface. */
2780 :
2781 : static match
2782 281472 : variable_decl (int elem)
2783 : {
2784 281472 : char name[GFC_MAX_SYMBOL_LEN + 1];
2785 281472 : static unsigned int fill_id = 0;
2786 281472 : gfc_expr *initializer, *char_len;
2787 281472 : gfc_array_spec *as;
2788 281472 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2789 281472 : gfc_charlen *cl;
2790 281472 : gfc_charlen *saved_cl_list;
2791 281472 : bool cl_deferred;
2792 281472 : locus var_locus;
2793 281472 : match m;
2794 281472 : bool t;
2795 281472 : gfc_symbol *sym;
2796 281472 : char c;
2797 :
2798 281472 : initializer = NULL;
2799 281472 : as = NULL;
2800 281472 : cp_as = NULL;
2801 281472 : saved_cl_list = gfc_current_ns->cl_list;
2802 :
2803 : /* When we get here, we've just matched a list of attributes and
2804 : maybe a type and a double colon. The next thing we expect to see
2805 : is the name of the symbol. */
2806 :
2807 : /* If we are parsing a structure with legacy support, we allow the symbol
2808 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2809 281472 : m = MATCH_NO;
2810 281472 : gfc_gobble_whitespace ();
2811 281472 : var_locus = gfc_current_locus;
2812 281472 : c = gfc_peek_ascii_char ();
2813 281472 : if (c == '%')
2814 : {
2815 12 : gfc_next_ascii_char (); /* Burn % character. */
2816 12 : m = gfc_match ("fill");
2817 12 : if (m == MATCH_YES)
2818 : {
2819 11 : if (gfc_current_state () != COMP_STRUCTURE)
2820 : {
2821 2 : if (flag_dec_structure)
2822 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2823 : else
2824 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2825 : "%<-fdec-structure%>", "%FILL");
2826 2 : m = MATCH_ERROR;
2827 2 : goto cleanup;
2828 : }
2829 :
2830 9 : if (attr_seen)
2831 : {
2832 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2833 1 : m = MATCH_ERROR;
2834 1 : goto cleanup;
2835 : }
2836 :
2837 : /* %FILL components are given invalid fortran names. */
2838 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2839 : }
2840 : else
2841 : {
2842 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2843 1 : return MATCH_ERROR;
2844 : }
2845 : }
2846 : else
2847 : {
2848 281460 : m = gfc_match_name (name);
2849 281459 : if (m != MATCH_YES)
2850 10 : goto cleanup;
2851 : }
2852 :
2853 : /* Now we could see the optional array spec. or character length. */
2854 281457 : m = gfc_match_array_spec (&as, true, true);
2855 281456 : if (m == MATCH_ERROR)
2856 57 : goto cleanup;
2857 :
2858 281399 : if (m == MATCH_NO)
2859 219994 : as = gfc_copy_array_spec (current_as);
2860 61405 : else if (current_as
2861 61405 : && !merge_array_spec (current_as, as, true))
2862 : {
2863 4 : m = MATCH_ERROR;
2864 4 : goto cleanup;
2865 : }
2866 :
2867 281395 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2868 : &gfc_current_locus);
2869 281395 : if (flag_cray_pointer)
2870 3063 : cp_as = gfc_copy_array_spec (as);
2871 :
2872 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2873 : determine (and check) whether it can be implied-shape. If it
2874 : was parsed as assumed-size, change it because PARAMETERs cannot
2875 : be assumed-size.
2876 :
2877 : An explicit-shape-array cannot appear under several conditions.
2878 : That check is done here as well. */
2879 281395 : if (as)
2880 : {
2881 84018 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2882 : {
2883 2 : m = MATCH_ERROR;
2884 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2885 : name, &var_locus);
2886 2 : goto cleanup;
2887 : }
2888 :
2889 84016 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2890 6509 : && current_attr.flavor == FL_PARAMETER)
2891 993 : as->type = AS_IMPLIED_SHAPE;
2892 :
2893 84016 : if (as->type == AS_IMPLIED_SHAPE
2894 84016 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2895 : &var_locus))
2896 : {
2897 1 : m = MATCH_ERROR;
2898 1 : goto cleanup;
2899 : }
2900 :
2901 84015 : gfc_seen_div0 = false;
2902 :
2903 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2904 : constant expressions shall appear only in a subprogram, derived
2905 : type definition, BLOCK construct, or interface body. */
2906 84015 : if (as->type == AS_EXPLICIT
2907 41998 : && gfc_current_state () != COMP_BLOCK
2908 : && gfc_current_state () != COMP_DERIVED
2909 : && gfc_current_state () != COMP_FUNCTION
2910 : && gfc_current_state () != COMP_INTERFACE
2911 : && gfc_current_state () != COMP_SUBROUTINE)
2912 : {
2913 : gfc_expr *e;
2914 49849 : bool not_constant = false;
2915 :
2916 49849 : for (int i = 0; i < as->rank; i++)
2917 : {
2918 28380 : e = gfc_copy_expr (as->lower[i]);
2919 28380 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2920 : {
2921 0 : m = MATCH_ERROR;
2922 0 : goto cleanup;
2923 : }
2924 :
2925 28380 : gfc_simplify_expr (e, 0);
2926 28380 : if (e && (e->expr_type != EXPR_CONSTANT))
2927 : {
2928 : not_constant = true;
2929 : break;
2930 : }
2931 28380 : gfc_free_expr (e);
2932 :
2933 28380 : e = gfc_copy_expr (as->upper[i]);
2934 28380 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2935 : {
2936 4 : m = MATCH_ERROR;
2937 4 : goto cleanup;
2938 : }
2939 :
2940 28376 : gfc_simplify_expr (e, 0);
2941 28376 : if (e && (e->expr_type != EXPR_CONSTANT))
2942 : {
2943 : not_constant = true;
2944 : break;
2945 : }
2946 28363 : gfc_free_expr (e);
2947 : }
2948 :
2949 21482 : if (not_constant && e->ts.type != BT_INTEGER)
2950 : {
2951 4 : gfc_error ("Explicit array shape at %C must be constant of "
2952 : "INTEGER type and not %s type",
2953 : gfc_basic_typename (e->ts.type));
2954 4 : m = MATCH_ERROR;
2955 4 : goto cleanup;
2956 : }
2957 9 : if (not_constant)
2958 : {
2959 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2960 9 : m = MATCH_ERROR;
2961 9 : goto cleanup;
2962 : }
2963 : }
2964 83998 : if (as->type == AS_EXPLICIT)
2965 : {
2966 100457 : for (int i = 0; i < as->rank; i++)
2967 : {
2968 58476 : gfc_expr *e, *n;
2969 58476 : e = as->lower[i];
2970 58476 : if (e->expr_type != EXPR_CONSTANT)
2971 : {
2972 452 : n = gfc_copy_expr (e);
2973 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2974 : {
2975 0 : m = MATCH_ERROR;
2976 0 : goto cleanup;
2977 : }
2978 :
2979 452 : if (n->expr_type == EXPR_CONSTANT)
2980 22 : gfc_replace_expr (e, n);
2981 : else
2982 430 : gfc_free_expr (n);
2983 : }
2984 58476 : e = as->upper[i];
2985 58476 : if (e->expr_type != EXPR_CONSTANT)
2986 : {
2987 6750 : n = gfc_copy_expr (e);
2988 6750 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2989 : {
2990 0 : m = MATCH_ERROR;
2991 0 : goto cleanup;
2992 : }
2993 :
2994 6750 : if (n->expr_type == EXPR_CONSTANT)
2995 45 : gfc_replace_expr (e, n);
2996 : else
2997 6705 : gfc_free_expr (n);
2998 : }
2999 : /* For an explicit-shape spec with constant bounds, ensure
3000 : that the effective upper bound is not lower than the
3001 : respective lower bound minus one. Otherwise adjust it so
3002 : that the extent is trivially derived to be zero. */
3003 58476 : if (as->lower[i]->expr_type == EXPR_CONSTANT
3004 58046 : && as->upper[i]->expr_type == EXPR_CONSTANT
3005 51765 : && as->lower[i]->ts.type == BT_INTEGER
3006 51765 : && as->upper[i]->ts.type == BT_INTEGER
3007 51760 : && mpz_cmp (as->upper[i]->value.integer,
3008 51760 : as->lower[i]->value.integer) < 0)
3009 1212 : mpz_sub_ui (as->upper[i]->value.integer,
3010 : as->lower[i]->value.integer, 1);
3011 : }
3012 : }
3013 : }
3014 :
3015 281375 : char_len = NULL;
3016 281375 : cl = NULL;
3017 281375 : cl_deferred = false;
3018 :
3019 281375 : if (current_ts.type == BT_CHARACTER)
3020 : {
3021 31032 : switch (match_char_length (&char_len, &cl_deferred, false))
3022 : {
3023 435 : case MATCH_YES:
3024 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3025 :
3026 435 : cl->length = char_len;
3027 435 : break;
3028 :
3029 : /* Non-constant lengths need to be copied after the first
3030 : element. Also copy assumed lengths. */
3031 30596 : case MATCH_NO:
3032 30596 : if (elem > 1
3033 3922 : && (current_ts.u.cl->length == NULL
3034 2703 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
3035 : {
3036 1274 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3037 1274 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
3038 : }
3039 : else
3040 29322 : cl = current_ts.u.cl;
3041 :
3042 30596 : cl_deferred = current_ts.deferred;
3043 :
3044 30596 : break;
3045 :
3046 1 : case MATCH_ERROR:
3047 1 : goto cleanup;
3048 : }
3049 : }
3050 :
3051 : /* The dummy arguments and result of the abbreviated form of MODULE
3052 : PROCEDUREs, used in SUBMODULES should not be redefined. */
3053 281374 : if (gfc_current_ns->proc_name
3054 276889 : && gfc_current_ns->proc_name->abr_modproc_decl)
3055 : {
3056 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
3057 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
3058 : {
3059 2 : m = MATCH_ERROR;
3060 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
3061 : "in the corresponding interface for MODULE "
3062 : "PROCEDURE %qs", sym->name, &var_locus,
3063 2 : gfc_current_ns->proc_name->name);
3064 2 : goto cleanup;
3065 : }
3066 : }
3067 :
3068 : /* %FILL components may not have initializers. */
3069 281372 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
3070 : {
3071 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
3072 : &var_locus);
3073 1 : m = MATCH_ERROR;
3074 1 : goto cleanup;
3075 : }
3076 :
3077 : /* If this symbol has already shown up in a Cray Pointer declaration,
3078 : and this is not a component declaration,
3079 : then we want to set the type & bail out. */
3080 281371 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
3081 : {
3082 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3083 2959 : if (sym != NULL && sym->attr.cray_pointee)
3084 : {
3085 101 : m = MATCH_YES;
3086 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
3087 : {
3088 1 : m = MATCH_ERROR;
3089 1 : goto cleanup;
3090 : }
3091 :
3092 : /* Check to see if we have an array specification. */
3093 100 : if (cp_as != NULL)
3094 : {
3095 49 : if (sym->as != NULL)
3096 : {
3097 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3098 1 : gfc_free_array_spec (cp_as);
3099 1 : m = MATCH_ERROR;
3100 1 : goto cleanup;
3101 : }
3102 : else
3103 : {
3104 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3105 0 : gfc_internal_error ("Cannot set pointee array spec.");
3106 :
3107 : /* Fix the array spec. */
3108 48 : m = gfc_mod_pointee_as (sym->as);
3109 48 : if (m == MATCH_ERROR)
3110 0 : goto cleanup;
3111 : }
3112 : }
3113 99 : goto cleanup;
3114 : }
3115 : else
3116 : {
3117 2858 : gfc_free_array_spec (cp_as);
3118 : }
3119 : }
3120 : else
3121 : {
3122 : /* Check to see if this is the declaration of the type and/or attributes
3123 : of an implicit function result, emanating from a module function
3124 : interface declared within the parent module or submodule of a
3125 : containing submodule. */
3126 278412 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
3127 278412 : if (gfc_current_state () == COMP_FUNCTION
3128 46457 : && sym == gfc_current_block ()
3129 8259 : && sym->attr.if_source == IFSRC_DECL
3130 4940 : && sym->attr.used_in_submodule
3131 4 : && sym == sym->result
3132 4 : && sym->ts.type != BT_UNKNOWN)
3133 : {
3134 4 : m = MATCH_YES;
3135 4 : goto cleanup;
3136 : }
3137 278408 : sym = NULL;
3138 : }
3139 :
3140 : /* Procedure pointer as function result. */
3141 281266 : if (gfc_current_state () == COMP_FUNCTION
3142 46567 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3143 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3144 7 : strcpy (name, "ppr@");
3145 :
3146 281266 : if (gfc_current_state () == COMP_FUNCTION
3147 46567 : && strcmp (name, gfc_current_block ()->name) == 0
3148 8275 : && gfc_current_block ()->result
3149 8275 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3150 16 : strcpy (name, "ppr@");
3151 :
3152 : /* OK, we've successfully matched the declaration. Now put the
3153 : symbol in the current namespace, because it might be used in the
3154 : optional initialization expression for this symbol, e.g. this is
3155 : perfectly legal:
3156 :
3157 : integer, parameter :: i = huge(i)
3158 :
3159 : This is only true for parameters or variables of a basic type.
3160 : For components of derived types, it is not true, so we don't
3161 : create a symbol for those yet. If we fail to create the symbol,
3162 : bail out. */
3163 281266 : if (!gfc_comp_struct (gfc_current_state ())
3164 263020 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3165 : {
3166 48 : m = MATCH_ERROR;
3167 48 : goto cleanup;
3168 : }
3169 :
3170 281218 : if (!check_function_name (name))
3171 : {
3172 0 : m = MATCH_ERROR;
3173 0 : goto cleanup;
3174 : }
3175 :
3176 : /* We allow old-style initializations of the form
3177 : integer i /2/, j(4) /3*3, 1/
3178 : (if no colon has been seen). These are different from data
3179 : statements in that initializers are only allowed to apply to the
3180 : variable immediately preceding, i.e.
3181 : integer i, j /1, 2/
3182 : is not allowed. Therefore we have to do some work manually, that
3183 : could otherwise be left to the matchers for DATA statements. */
3184 :
3185 281218 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3186 : {
3187 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3188 : "initialization at %C"))
3189 : return MATCH_ERROR;
3190 :
3191 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3192 : but not components of derived types. */
3193 146 : else if (gfc_current_state () == COMP_DERIVED)
3194 : {
3195 2 : gfc_error ("Invalid old style initialization for derived type "
3196 : "component at %C");
3197 2 : m = MATCH_ERROR;
3198 2 : goto cleanup;
3199 : }
3200 :
3201 : /* For structure components, read the initializer as a special
3202 : expression and let the rest of this function apply the initializer
3203 : as usual. */
3204 144 : else if (gfc_comp_struct (gfc_current_state ()))
3205 : {
3206 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3207 74 : if (m == MATCH_NO)
3208 : gfc_error ("Syntax error in old style initialization of %s at %C",
3209 : name);
3210 74 : if (m != MATCH_YES)
3211 14 : goto cleanup;
3212 : }
3213 :
3214 : /* Otherwise we treat the old style initialization just like a
3215 : DATA declaration for the current variable. */
3216 : else
3217 70 : return match_old_style_init (name);
3218 : }
3219 :
3220 : /* The double colon must be present in order to have initializers.
3221 : Otherwise the statement is ambiguous with an assignment statement. */
3222 281132 : if (colon_seen)
3223 : {
3224 234906 : if (gfc_match (" =>") == MATCH_YES)
3225 : {
3226 1197 : if (!current_attr.pointer)
3227 : {
3228 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3229 0 : m = MATCH_ERROR;
3230 0 : goto cleanup;
3231 : }
3232 :
3233 1197 : m = match_pointer_init (&initializer, 0);
3234 1197 : if (m != MATCH_YES)
3235 10 : goto cleanup;
3236 :
3237 : /* The target of a pointer initialization must have the SAVE
3238 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3239 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3240 1187 : if (initializer->expr_type == EXPR_VARIABLE
3241 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3242 25 : && (gfc_current_state () == COMP_PROGRAM
3243 : || gfc_current_state () == COMP_MODULE
3244 25 : || gfc_current_state () == COMP_SUBMODULE))
3245 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3246 : }
3247 233709 : else if (gfc_match_char ('=') == MATCH_YES)
3248 : {
3249 26285 : if (current_attr.pointer)
3250 : {
3251 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3252 : "not %<=%>");
3253 0 : m = MATCH_ERROR;
3254 0 : goto cleanup;
3255 : }
3256 :
3257 26285 : if (gfc_comp_struct (gfc_current_state ())
3258 2514 : && gfc_current_block ()->attr.pdt_template)
3259 : {
3260 269 : m = gfc_match_expr (&initializer);
3261 269 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3262 115 : initializer->ts = current_ts;
3263 : }
3264 : else
3265 26016 : m = gfc_match_init_expr (&initializer);
3266 :
3267 26285 : if (m == MATCH_NO)
3268 : {
3269 1 : gfc_error ("Expected an initialization expression at %C");
3270 1 : m = MATCH_ERROR;
3271 : }
3272 :
3273 10239 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3274 26287 : && !gfc_comp_struct (gfc_state_stack->state))
3275 : {
3276 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3277 : "a PURE procedure");
3278 1 : m = MATCH_ERROR;
3279 : }
3280 :
3281 26285 : if (current_attr.flavor != FL_PARAMETER
3282 10239 : && !gfc_comp_struct (gfc_state_stack->state))
3283 7725 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3284 :
3285 26285 : if (m != MATCH_YES)
3286 160 : goto cleanup;
3287 : }
3288 : }
3289 :
3290 280962 : if (initializer != NULL && current_attr.allocatable
3291 3 : && gfc_comp_struct (gfc_current_state ()))
3292 : {
3293 2 : gfc_error ("Initialization of allocatable component at %C is not "
3294 : "allowed");
3295 2 : m = MATCH_ERROR;
3296 2 : goto cleanup;
3297 : }
3298 :
3299 280960 : if (gfc_current_state () == COMP_DERIVED
3300 17204 : && initializer && initializer->ts.type == BT_HOLLERITH)
3301 : {
3302 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3303 : "constant at %L is not allowed", &initializer->where);
3304 1 : m = MATCH_ERROR;
3305 1 : goto cleanup;
3306 : }
3307 :
3308 280959 : if (gfc_current_state () == COMP_DERIVED
3309 17203 : && gfc_current_block ()->attr.pdt_template)
3310 : {
3311 1146 : gfc_symbol *param;
3312 1146 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3313 : 0, ¶m);
3314 1146 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3315 : {
3316 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3317 : "not appear in the type parameter list at %L",
3318 1 : &gfc_current_block ()->declared_at);
3319 1 : m = MATCH_ERROR;
3320 4 : goto cleanup;
3321 : }
3322 1145 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3323 : {
3324 1 : gfc_error ("The component at %C that appears in the type parameter "
3325 : "list at %L has neither the KIND nor LEN attribute",
3326 1 : &gfc_current_block ()->declared_at);
3327 1 : m = MATCH_ERROR;
3328 1 : goto cleanup;
3329 : }
3330 1144 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3331 : {
3332 1 : gfc_error ("The component at %C which is a type parameter must be "
3333 : "a scalar");
3334 1 : m = MATCH_ERROR;
3335 1 : goto cleanup;
3336 : }
3337 1143 : else if (param && initializer)
3338 : {
3339 247 : if (initializer->ts.type == BT_BOZ)
3340 : {
3341 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3342 : "initializer", &initializer->where);
3343 1 : m = MATCH_ERROR;
3344 1 : goto cleanup;
3345 : }
3346 246 : param->value = gfc_copy_expr (initializer);
3347 : }
3348 : }
3349 :
3350 : /* Before adding a possible initializer, do a simple check for compatibility
3351 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3352 : good thing. */
3353 28565 : if (current_ts.type == BT_DERIVED && initializer
3354 282406 : && (gfc_numeric_ts (&initializer->ts)
3355 1449 : || initializer->ts.type == BT_LOGICAL
3356 1449 : || initializer->ts.type == BT_CHARACTER))
3357 : {
3358 2 : gfc_error ("Incompatible initialization between a derived type "
3359 : "entity and an entity with %qs type at %C",
3360 : gfc_typename (initializer));
3361 2 : m = MATCH_ERROR;
3362 2 : goto cleanup;
3363 : }
3364 :
3365 :
3366 : /* Add the initializer. Note that it is fine if initializer is
3367 : NULL here, because we sometimes also need to check if a
3368 : declaration *must* have an initialization expression. */
3369 280953 : if (!gfc_comp_struct (gfc_current_state ()))
3370 262736 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
3371 : saved_cl_list);
3372 : else
3373 : {
3374 18217 : if (current_ts.type == BT_DERIVED
3375 2597 : && !current_attr.pointer && !initializer)
3376 2038 : initializer = gfc_default_initializer (¤t_ts);
3377 18217 : t = build_struct (name, cl, &initializer, &as);
3378 :
3379 : /* If we match a nested structure definition we expect to see the
3380 : * body even if the variable declarations blow up, so we need to keep
3381 : * the structure declaration around. */
3382 18217 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3383 34 : gfc_commit_symbol (gfc_new_block);
3384 : }
3385 :
3386 281101 : m = (t) ? MATCH_YES : MATCH_ERROR;
3387 :
3388 281399 : cleanup:
3389 : /* Free stuff up and return. */
3390 281399 : gfc_seen_div0 = false;
3391 281399 : gfc_free_expr (initializer);
3392 281399 : gfc_free_array_spec (as);
3393 :
3394 281399 : return m;
3395 : }
3396 :
3397 :
3398 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3399 : This assumes that the byte size is equal to the kind number for
3400 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3401 :
3402 : static match
3403 107582 : gfc_match_old_kind_spec (gfc_typespec *ts)
3404 : {
3405 107582 : match m;
3406 107582 : int original_kind;
3407 :
3408 107582 : if (gfc_match_char ('*') != MATCH_YES)
3409 : return MATCH_NO;
3410 :
3411 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3412 1150 : if (m != MATCH_YES)
3413 : return MATCH_ERROR;
3414 :
3415 1150 : original_kind = ts->kind;
3416 :
3417 : /* Massage the kind numbers for complex types. */
3418 1150 : if (ts->type == BT_COMPLEX)
3419 : {
3420 79 : if (ts->kind % 2)
3421 : {
3422 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3423 : gfc_basic_typename (ts->type), original_kind);
3424 0 : return MATCH_ERROR;
3425 : }
3426 79 : ts->kind /= 2;
3427 :
3428 : }
3429 :
3430 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3431 0 : ts->kind = 8;
3432 :
3433 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3434 : {
3435 858 : if (ts->kind == 4)
3436 : {
3437 224 : if (flag_real4_kind == 8)
3438 24 : ts->kind = 8;
3439 224 : if (flag_real4_kind == 10)
3440 24 : ts->kind = 10;
3441 224 : if (flag_real4_kind == 16)
3442 24 : ts->kind = 16;
3443 : }
3444 634 : else if (ts->kind == 8)
3445 : {
3446 629 : if (flag_real8_kind == 4)
3447 24 : ts->kind = 4;
3448 629 : if (flag_real8_kind == 10)
3449 24 : ts->kind = 10;
3450 629 : if (flag_real8_kind == 16)
3451 24 : ts->kind = 16;
3452 : }
3453 : }
3454 :
3455 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3456 : {
3457 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3458 : gfc_basic_typename (ts->type), original_kind);
3459 8 : return MATCH_ERROR;
3460 : }
3461 :
3462 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3463 : "Nonstandard type declaration %s*%d at %C",
3464 : gfc_basic_typename(ts->type), original_kind))
3465 : return MATCH_ERROR;
3466 :
3467 : return MATCH_YES;
3468 : }
3469 :
3470 :
3471 : /* Match a kind specification. Since kinds are generally optional, we
3472 : usually return MATCH_NO if something goes wrong. If a "kind="
3473 : string is found, then we know we have an error. */
3474 :
3475 : match
3476 160622 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3477 : {
3478 160622 : locus where, loc;
3479 160622 : gfc_expr *e;
3480 160622 : match m, n;
3481 160622 : char c;
3482 :
3483 160622 : m = MATCH_NO;
3484 160622 : n = MATCH_YES;
3485 160622 : e = NULL;
3486 160622 : saved_kind_expr = NULL;
3487 :
3488 160622 : where = loc = gfc_current_locus;
3489 :
3490 160622 : if (kind_expr_only)
3491 0 : goto kind_expr;
3492 :
3493 160622 : if (gfc_match_char ('(') == MATCH_NO)
3494 : return MATCH_NO;
3495 :
3496 : /* Also gobbles optional text. */
3497 51563 : if (gfc_match (" kind = ") == MATCH_YES)
3498 51563 : m = MATCH_ERROR;
3499 :
3500 51563 : loc = gfc_current_locus;
3501 :
3502 51563 : kind_expr:
3503 :
3504 51563 : n = gfc_match_init_expr (&e);
3505 :
3506 51563 : if (gfc_derived_parameter_expr (e))
3507 : {
3508 166 : ts->kind = 0;
3509 166 : saved_kind_expr = gfc_copy_expr (e);
3510 166 : goto close_brackets;
3511 : }
3512 :
3513 51397 : if (n != MATCH_YES)
3514 : {
3515 465 : if (gfc_matching_function)
3516 : {
3517 : /* The function kind expression might include use associated or
3518 : imported parameters and try again after the specification
3519 : expressions..... */
3520 437 : if (gfc_match_char (')') != MATCH_YES)
3521 : {
3522 1 : gfc_error ("Missing right parenthesis at %C");
3523 1 : m = MATCH_ERROR;
3524 1 : goto no_match;
3525 : }
3526 :
3527 436 : gfc_free_expr (e);
3528 436 : gfc_undo_symbols ();
3529 436 : return MATCH_YES;
3530 : }
3531 : else
3532 : {
3533 : /* ....or else, the match is real. */
3534 28 : if (n == MATCH_NO)
3535 0 : gfc_error ("Expected initialization expression at %C");
3536 28 : if (n != MATCH_YES)
3537 28 : return MATCH_ERROR;
3538 : }
3539 : }
3540 :
3541 50932 : if (e->rank != 0)
3542 : {
3543 0 : gfc_error ("Expected scalar initialization expression at %C");
3544 0 : m = MATCH_ERROR;
3545 0 : goto no_match;
3546 : }
3547 :
3548 50932 : if (gfc_extract_int (e, &ts->kind, 1))
3549 : {
3550 0 : m = MATCH_ERROR;
3551 0 : goto no_match;
3552 : }
3553 :
3554 : /* Before throwing away the expression, let's see if we had a
3555 : C interoperable kind (and store the fact). */
3556 50932 : if (e->ts.is_c_interop == 1)
3557 : {
3558 : /* Mark this as C interoperable if being declared with one
3559 : of the named constants from iso_c_binding. */
3560 18859 : ts->is_c_interop = e->ts.is_iso_c;
3561 18859 : ts->f90_type = e->ts.f90_type;
3562 18859 : if (e->symtree)
3563 18858 : ts->interop_kind = e->symtree->n.sym;
3564 : }
3565 :
3566 50932 : gfc_free_expr (e);
3567 50932 : e = NULL;
3568 :
3569 : /* Ignore errors to this point, if we've gotten here. This means
3570 : we ignore the m=MATCH_ERROR from above. */
3571 50932 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3572 : {
3573 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3574 : gfc_basic_typename (ts->type));
3575 7 : gfc_current_locus = where;
3576 7 : return MATCH_ERROR;
3577 : }
3578 :
3579 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3580 : if, e.g., c_double is used for COMPLEX as the standard
3581 : explicitly says that the kind type parameter for complex and real
3582 : variable is the same, i.e. c_float == c_float_complex. */
3583 50925 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3584 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3585 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3586 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3587 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3588 : gfc_basic_typename (ts->type));
3589 :
3590 50912 : close_brackets:
3591 :
3592 51091 : gfc_gobble_whitespace ();
3593 51091 : if ((c = gfc_next_ascii_char ()) != ')'
3594 51091 : && (ts->type != BT_CHARACTER || c != ','))
3595 : {
3596 0 : if (ts->type == BT_CHARACTER)
3597 0 : gfc_error ("Missing right parenthesis or comma at %C");
3598 : else
3599 0 : gfc_error ("Missing right parenthesis at %C");
3600 0 : m = MATCH_ERROR;
3601 0 : goto no_match;
3602 : }
3603 : else
3604 : /* All tests passed. */
3605 51091 : m = MATCH_YES;
3606 :
3607 51091 : if(m == MATCH_ERROR)
3608 : gfc_current_locus = where;
3609 :
3610 51091 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3611 0 : ts->kind = 8;
3612 :
3613 51091 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3614 : {
3615 14363 : if (ts->kind == 4)
3616 : {
3617 4587 : if (flag_real4_kind == 8)
3618 54 : ts->kind = 8;
3619 4587 : if (flag_real4_kind == 10)
3620 54 : ts->kind = 10;
3621 4587 : if (flag_real4_kind == 16)
3622 54 : ts->kind = 16;
3623 : }
3624 9776 : else if (ts->kind == 8)
3625 : {
3626 6634 : if (flag_real8_kind == 4)
3627 48 : ts->kind = 4;
3628 6634 : if (flag_real8_kind == 10)
3629 48 : ts->kind = 10;
3630 6634 : if (flag_real8_kind == 16)
3631 48 : ts->kind = 16;
3632 : }
3633 : }
3634 :
3635 : /* Return what we know from the test(s). */
3636 : return m;
3637 :
3638 1 : no_match:
3639 1 : gfc_free_expr (e);
3640 1 : gfc_current_locus = where;
3641 1 : return m;
3642 : }
3643 :
3644 :
3645 : static match
3646 4870 : match_char_kind (int * kind, int * is_iso_c)
3647 : {
3648 4870 : locus where;
3649 4870 : gfc_expr *e;
3650 4870 : match m, n;
3651 4870 : bool fail;
3652 :
3653 4870 : m = MATCH_NO;
3654 4870 : e = NULL;
3655 4870 : where = gfc_current_locus;
3656 :
3657 4870 : n = gfc_match_init_expr (&e);
3658 :
3659 4870 : if (n != MATCH_YES && gfc_matching_function)
3660 : {
3661 : /* The expression might include use-associated or imported
3662 : parameters and try again after the specification
3663 : expressions. */
3664 7 : gfc_free_expr (e);
3665 7 : gfc_undo_symbols ();
3666 7 : return MATCH_YES;
3667 : }
3668 :
3669 7 : if (n == MATCH_NO)
3670 2 : gfc_error ("Expected initialization expression at %C");
3671 4863 : if (n != MATCH_YES)
3672 : return MATCH_ERROR;
3673 :
3674 4856 : if (e->rank != 0)
3675 : {
3676 0 : gfc_error ("Expected scalar initialization expression at %C");
3677 0 : m = MATCH_ERROR;
3678 0 : goto no_match;
3679 : }
3680 :
3681 4856 : if (gfc_derived_parameter_expr (e))
3682 : {
3683 14 : saved_kind_expr = e;
3684 14 : *kind = 0;
3685 14 : return MATCH_YES;
3686 : }
3687 :
3688 4842 : fail = gfc_extract_int (e, kind, 1);
3689 4842 : *is_iso_c = e->ts.is_iso_c;
3690 4842 : if (fail)
3691 : {
3692 0 : m = MATCH_ERROR;
3693 0 : goto no_match;
3694 : }
3695 :
3696 4842 : gfc_free_expr (e);
3697 :
3698 : /* Ignore errors to this point, if we've gotten here. This means
3699 : we ignore the m=MATCH_ERROR from above. */
3700 4842 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3701 : {
3702 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3703 14 : m = MATCH_ERROR;
3704 : }
3705 : else
3706 : /* All tests passed. */
3707 : m = MATCH_YES;
3708 :
3709 14 : if (m == MATCH_ERROR)
3710 14 : gfc_current_locus = where;
3711 :
3712 : /* Return what we know from the test(s). */
3713 : return m;
3714 :
3715 0 : no_match:
3716 0 : gfc_free_expr (e);
3717 0 : gfc_current_locus = where;
3718 0 : return m;
3719 : }
3720 :
3721 :
3722 : /* Match the various kind/length specifications in a CHARACTER
3723 : declaration. We don't return MATCH_NO. */
3724 :
3725 : match
3726 31960 : gfc_match_char_spec (gfc_typespec *ts)
3727 : {
3728 31960 : int kind, seen_length, is_iso_c;
3729 31960 : gfc_charlen *cl;
3730 31960 : gfc_expr *len;
3731 31960 : match m;
3732 31960 : bool deferred;
3733 :
3734 31960 : len = NULL;
3735 31960 : seen_length = 0;
3736 31960 : kind = 0;
3737 31960 : is_iso_c = 0;
3738 31960 : deferred = false;
3739 :
3740 : /* Try the old-style specification first. */
3741 31960 : old_char_selector = 0;
3742 :
3743 31960 : m = match_char_length (&len, &deferred, true);
3744 31960 : if (m != MATCH_NO)
3745 : {
3746 2205 : if (m == MATCH_YES)
3747 2205 : old_char_selector = 1;
3748 2205 : seen_length = 1;
3749 2205 : goto done;
3750 : }
3751 :
3752 29755 : m = gfc_match_char ('(');
3753 29755 : if (m != MATCH_YES)
3754 : {
3755 1916 : m = MATCH_YES; /* Character without length is a single char. */
3756 1916 : goto done;
3757 : }
3758 :
3759 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3760 27839 : if (gfc_match (" kind =") == MATCH_YES)
3761 : {
3762 3391 : m = match_char_kind (&kind, &is_iso_c);
3763 :
3764 3391 : if (m == MATCH_ERROR)
3765 16 : goto done;
3766 3375 : if (m == MATCH_NO)
3767 : goto syntax;
3768 :
3769 3375 : if (gfc_match (" , len =") == MATCH_NO)
3770 518 : goto rparen;
3771 :
3772 2857 : m = char_len_param_value (&len, &deferred);
3773 2857 : if (m == MATCH_NO)
3774 0 : goto syntax;
3775 2857 : if (m == MATCH_ERROR)
3776 2 : goto done;
3777 2855 : seen_length = 1;
3778 :
3779 2855 : goto rparen;
3780 : }
3781 :
3782 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3783 24448 : if (gfc_match (" len =") == MATCH_YES)
3784 : {
3785 13929 : m = char_len_param_value (&len, &deferred);
3786 13929 : if (m == MATCH_NO)
3787 2 : goto syntax;
3788 13927 : if (m == MATCH_ERROR)
3789 8 : goto done;
3790 13919 : seen_length = 1;
3791 :
3792 13919 : if (gfc_match_char (')') == MATCH_YES)
3793 12614 : goto done;
3794 :
3795 1305 : if (gfc_match (" , kind =") != MATCH_YES)
3796 0 : goto syntax;
3797 :
3798 1305 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3799 2 : goto done;
3800 :
3801 1303 : goto rparen;
3802 : }
3803 :
3804 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3805 10519 : m = char_len_param_value (&len, &deferred);
3806 10519 : if (m == MATCH_NO)
3807 0 : goto syntax;
3808 10519 : if (m == MATCH_ERROR)
3809 44 : goto done;
3810 10475 : seen_length = 1;
3811 :
3812 10475 : m = gfc_match_char (')');
3813 10475 : if (m == MATCH_YES)
3814 10299 : goto done;
3815 :
3816 176 : if (gfc_match_char (',') != MATCH_YES)
3817 2 : goto syntax;
3818 :
3819 174 : gfc_match (" kind ="); /* Gobble optional text. */
3820 :
3821 174 : m = match_char_kind (&kind, &is_iso_c);
3822 174 : if (m == MATCH_ERROR)
3823 3 : goto done;
3824 : if (m == MATCH_NO)
3825 : goto syntax;
3826 :
3827 4847 : rparen:
3828 : /* Require a right-paren at this point. */
3829 4847 : m = gfc_match_char (')');
3830 4847 : if (m == MATCH_YES)
3831 4847 : goto done;
3832 :
3833 0 : syntax:
3834 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3835 4 : m = MATCH_ERROR;
3836 4 : gfc_free_expr (len);
3837 4 : return m;
3838 :
3839 31956 : done:
3840 : /* Deal with character functions after USE and IMPORT statements. */
3841 31956 : if (gfc_matching_function)
3842 : {
3843 1431 : gfc_free_expr (len);
3844 1431 : gfc_undo_symbols ();
3845 1431 : return MATCH_YES;
3846 : }
3847 :
3848 30525 : if (m != MATCH_YES)
3849 : {
3850 65 : gfc_free_expr (len);
3851 65 : return m;
3852 : }
3853 :
3854 : /* Do some final massaging of the length values. */
3855 30460 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3856 :
3857 30460 : if (seen_length == 0)
3858 2382 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3859 : else
3860 : {
3861 : /* If gfortran ends up here, then len may be reducible to a constant.
3862 : Try to do that here. If it does not reduce, simply assign len to
3863 : charlen. A complication occurs with user-defined generic functions,
3864 : which are not resolved. Use a private namespace to deal with
3865 : generic functions. */
3866 :
3867 28078 : if (len && len->expr_type != EXPR_CONSTANT)
3868 : {
3869 3045 : gfc_namespace *old_ns;
3870 3045 : gfc_expr *e;
3871 :
3872 3045 : old_ns = gfc_current_ns;
3873 3045 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3874 :
3875 3045 : e = gfc_copy_expr (len);
3876 3045 : gfc_push_suppress_errors ();
3877 3045 : gfc_reduce_init_expr (e);
3878 3045 : gfc_pop_suppress_errors ();
3879 3045 : if (e->expr_type == EXPR_CONSTANT)
3880 : {
3881 294 : gfc_replace_expr (len, e);
3882 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3883 7 : mpz_set_ui (len->value.integer, 0);
3884 : }
3885 : else
3886 2751 : gfc_free_expr (e);
3887 :
3888 3045 : gfc_free_namespace (gfc_current_ns);
3889 3045 : gfc_current_ns = old_ns;
3890 : }
3891 :
3892 28078 : cl->length = len;
3893 : }
3894 :
3895 30460 : ts->u.cl = cl;
3896 30460 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3897 30460 : ts->deferred = deferred;
3898 :
3899 : /* We have to know if it was a C interoperable kind so we can
3900 : do accurate type checking of bind(c) procs, etc. */
3901 30460 : if (kind != 0)
3902 : /* Mark this as C interoperable if being declared with one
3903 : of the named constants from iso_c_binding. */
3904 4753 : ts->is_c_interop = is_iso_c;
3905 25707 : else if (len != NULL)
3906 : /* Here, we might have parsed something such as: character(c_char)
3907 : In this case, the parsing code above grabs the c_char when
3908 : looking for the length (line 1690, roughly). it's the last
3909 : testcase for parsing the kind params of a character variable.
3910 : However, it's not actually the length. this seems like it
3911 : could be an error.
3912 : To see if the user used a C interop kind, test the expr
3913 : of the so called length, and see if it's C interoperable. */
3914 16546 : ts->is_c_interop = len->ts.is_iso_c;
3915 :
3916 : return MATCH_YES;
3917 : }
3918 :
3919 :
3920 : /* Matches a RECORD declaration. */
3921 :
3922 : static match
3923 965989 : match_record_decl (char *name)
3924 : {
3925 965989 : locus old_loc;
3926 965989 : old_loc = gfc_current_locus;
3927 965989 : match m;
3928 :
3929 965989 : m = gfc_match (" record /");
3930 965989 : if (m == MATCH_YES)
3931 : {
3932 353 : if (!flag_dec_structure)
3933 : {
3934 6 : gfc_current_locus = old_loc;
3935 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3936 : "%<-fdec-structure%>");
3937 6 : return MATCH_ERROR;
3938 : }
3939 347 : m = gfc_match (" %n/", name);
3940 347 : if (m == MATCH_YES)
3941 : return MATCH_YES;
3942 : }
3943 :
3944 965639 : gfc_current_locus = old_loc;
3945 965639 : if (flag_dec_structure
3946 965639 : && (gfc_match (" record% ") == MATCH_YES
3947 8026 : || gfc_match (" record%t") == MATCH_YES))
3948 6 : gfc_error ("Structure name expected after RECORD at %C");
3949 965639 : if (m == MATCH_NO)
3950 : return MATCH_NO;
3951 :
3952 : return MATCH_ERROR;
3953 : }
3954 :
3955 :
3956 : /* In parsing a PDT, it is possible that one of the type parameters has the
3957 : same name as a previously declared symbol that is not a type parameter.
3958 : Intercept this now by looking for the symtree in f2k_derived. */
3959 :
3960 : static bool
3961 880 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3962 : {
3963 880 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3964 : return false;
3965 :
3966 711 : if (!(e->symtree->n.sym->attr.pdt_len
3967 122 : || e->symtree->n.sym->attr.pdt_kind))
3968 : {
3969 38 : gfc_symtree *st;
3970 38 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3971 : e->symtree->n.sym->name);
3972 38 : if (st && st->n.sym
3973 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3974 : {
3975 30 : gfc_expr *new_expr;
3976 30 : gfc_set_sym_referenced (st->n.sym);
3977 30 : new_expr = gfc_get_expr ();
3978 30 : new_expr->ts = st->n.sym->ts;
3979 30 : new_expr->expr_type = EXPR_VARIABLE;
3980 30 : new_expr->symtree = st;
3981 30 : new_expr->where = e->where;
3982 30 : gfc_replace_expr (e, new_expr);
3983 : }
3984 : }
3985 :
3986 : return false;
3987 : }
3988 :
3989 :
3990 : void
3991 648 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3992 : {
3993 648 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3994 : return;
3995 617 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3996 : }
3997 :
3998 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3999 : of expressions to substitute into the possibly parameterized expression
4000 : 'e'. Using a list is inefficient but should not be too bad since the
4001 : number of type parameters is not likely to be large. */
4002 : static bool
4003 3205 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
4004 : int* f)
4005 : {
4006 3205 : gfc_actual_arglist *param;
4007 3205 : gfc_expr *copy;
4008 :
4009 3205 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
4010 : return false;
4011 :
4012 1429 : gcc_assert (e->symtree);
4013 1429 : if (e->symtree->n.sym->attr.pdt_kind
4014 1050 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
4015 513 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
4016 : {
4017 1414 : for (param = type_param_spec_list; param; param = param->next)
4018 1366 : if (!strcmp (e->symtree->n.sym->name, param->name))
4019 : break;
4020 :
4021 963 : if (param && param->expr)
4022 : {
4023 914 : copy = gfc_copy_expr (param->expr);
4024 914 : gfc_replace_expr (e, copy);
4025 : /* Catch variables declared without a value expression. */
4026 914 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
4027 21 : e->ts = e->symtree->n.sym->ts;
4028 : }
4029 : }
4030 :
4031 : return false;
4032 : }
4033 :
4034 :
4035 : static bool
4036 953 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
4037 : {
4038 953 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
4039 : }
4040 :
4041 :
4042 : bool
4043 1803 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
4044 : {
4045 1803 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
4046 1803 : type_param_spec_list = param_list;
4047 1803 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
4048 1803 : type_param_spec_list = old_param_spec_list;
4049 1803 : return res;
4050 : }
4051 :
4052 : /* Determines the instance of a parameterized derived type to be used by
4053 : matching determining the values of the kind parameters and using them
4054 : in the name of the instance. If the instance exists, it is used, otherwise
4055 : a new derived type is created. */
4056 : match
4057 2795 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
4058 : gfc_actual_arglist **ext_param_list)
4059 : {
4060 : /* The PDT template symbol. */
4061 2795 : gfc_symbol *pdt = *sym;
4062 : /* The symbol for the parameter in the template f2k_namespace. */
4063 2795 : gfc_symbol *param;
4064 : /* The hoped for instance of the PDT. */
4065 2795 : gfc_symbol *instance = NULL;
4066 : /* The list of parameters appearing in the PDT declaration. */
4067 2795 : gfc_formal_arglist *type_param_name_list;
4068 : /* Used to store the parameter specification list during recursive calls. */
4069 2795 : gfc_actual_arglist *old_param_spec_list;
4070 : /* Pointers to the parameter specification being used. */
4071 2795 : gfc_actual_arglist *actual_param;
4072 2795 : gfc_actual_arglist *tail = NULL;
4073 : /* Used to build up the name of the PDT instance. */
4074 2795 : char *name;
4075 2795 : bool name_seen = (param_list == NULL);
4076 2795 : bool assumed_seen = false;
4077 2795 : bool deferred_seen = false;
4078 2795 : bool spec_error = false;
4079 2795 : bool alloc_seen = false;
4080 2795 : bool ptr_seen = false;
4081 2795 : int i;
4082 2795 : gfc_expr *kind_expr;
4083 2795 : gfc_component *c1, *c2;
4084 2795 : match m;
4085 2795 : gfc_symtree *s = NULL;
4086 :
4087 2795 : type_param_spec_list = NULL;
4088 :
4089 2795 : type_param_name_list = pdt->formal;
4090 2795 : actual_param = param_list;
4091 :
4092 : /* Prevent a PDT component of the same type as the template from being
4093 : converted into an instance. Doing this results in the component being
4094 : lost. */
4095 2795 : if (gfc_current_state () == COMP_DERIVED
4096 113 : && !(gfc_state_stack->previous
4097 113 : && gfc_state_stack->previous->state == COMP_DERIVED)
4098 113 : && gfc_current_block ()->attr.pdt_template)
4099 : {
4100 100 : if (ext_param_list)
4101 100 : *ext_param_list = gfc_copy_actual_arglist (param_list);
4102 100 : return MATCH_YES;
4103 : }
4104 :
4105 2695 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
4106 :
4107 : /* Run through the parameter name list and pick up the actual
4108 : parameter values or use the default values in the PDT declaration. */
4109 6265 : for (; type_param_name_list;
4110 3570 : type_param_name_list = type_param_name_list->next)
4111 : {
4112 3638 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4113 : {
4114 3236 : if (actual_param->spec_type == SPEC_ASSUMED)
4115 : spec_error = deferred_seen;
4116 : else
4117 3236 : spec_error = assumed_seen;
4118 :
4119 3236 : if (spec_error)
4120 : {
4121 : gfc_error ("The type parameter spec list at %C cannot contain "
4122 : "both ASSUMED and DEFERRED parameters");
4123 : goto error_return;
4124 : }
4125 : }
4126 :
4127 3236 : if (actual_param && actual_param->name)
4128 3638 : name_seen = true;
4129 3638 : param = type_param_name_list->sym;
4130 :
4131 3638 : if (!param || !param->name)
4132 2 : continue;
4133 :
4134 3636 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4135 : /* An error should already have been thrown in resolve.cc
4136 : (resolve_fl_derived0). */
4137 3636 : if (!pdt->attr.use_assoc && !c1)
4138 8 : goto error_return;
4139 :
4140 : /* Resolution PDT class components of derived types are handled here.
4141 : They can arrive without a parameter list and no KIND parameters. */
4142 3628 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4143 20 : continue;
4144 :
4145 3608 : kind_expr = NULL;
4146 3608 : if (!name_seen)
4147 : {
4148 2116 : if (!actual_param && !(c1 && c1->initializer))
4149 : {
4150 2 : gfc_error ("The type parameter spec list at %C does not contain "
4151 : "enough parameter expressions");
4152 2 : goto error_return;
4153 : }
4154 2114 : else if (!actual_param && c1 && c1->initializer)
4155 5 : kind_expr = gfc_copy_expr (c1->initializer);
4156 2109 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4157 1866 : kind_expr = gfc_copy_expr (actual_param->expr);
4158 : }
4159 : else
4160 : {
4161 : actual_param = param_list;
4162 1952 : for (;actual_param; actual_param = actual_param->next)
4163 1562 : if (actual_param->name
4164 1542 : && strcmp (actual_param->name, param->name) == 0)
4165 : break;
4166 1492 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4167 935 : kind_expr = gfc_copy_expr (actual_param->expr);
4168 : else
4169 : {
4170 557 : if (c1->initializer)
4171 493 : kind_expr = gfc_copy_expr (c1->initializer);
4172 64 : else if (!(actual_param && param->attr.pdt_len))
4173 : {
4174 9 : gfc_error ("The derived parameter %qs at %C does not "
4175 : "have a default value", param->name);
4176 9 : goto error_return;
4177 : }
4178 : }
4179 : }
4180 :
4181 3299 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4182 282 : && kind_expr->ts.type != BT_INTEGER
4183 136 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4184 : {
4185 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4186 : "type and not %s", &kind_expr->where,
4187 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4188 12 : goto error_return;
4189 : }
4190 :
4191 : /* Store the current parameter expressions in a temporary actual
4192 : arglist 'list' so that they can be substituted in the corresponding
4193 : expressions in the PDT instance. */
4194 3585 : if (type_param_spec_list == NULL)
4195 : {
4196 2652 : type_param_spec_list = gfc_get_actual_arglist ();
4197 2652 : tail = type_param_spec_list;
4198 : }
4199 : else
4200 : {
4201 933 : tail->next = gfc_get_actual_arglist ();
4202 933 : tail = tail->next;
4203 : }
4204 3585 : tail->name = param->name;
4205 :
4206 3585 : if (kind_expr)
4207 : {
4208 : /* Try simplification even for LEN expressions. */
4209 3287 : bool ok;
4210 3287 : gfc_resolve_expr (kind_expr);
4211 :
4212 3287 : if (c1->attr.pdt_kind
4213 1646 : && kind_expr->expr_type != EXPR_CONSTANT
4214 28 : && type_param_spec_list)
4215 28 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4216 :
4217 3287 : ok = gfc_simplify_expr (kind_expr, 1);
4218 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4219 : initializer so allow for this. */
4220 3287 : if (kind_expr->ts.type != BT_INTEGER
4221 153 : && kind_expr->ts.type != BT_PROCEDURE)
4222 : {
4223 29 : gfc_error ("The parameter expression at %C must be of "
4224 : "INTEGER type and not %s type",
4225 : gfc_basic_typename (kind_expr->ts.type));
4226 29 : goto error_return;
4227 : }
4228 3258 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4229 : {
4230 4 : gfc_error ("The parameter expression at %C does not "
4231 : "simplify to an INTEGER constant");
4232 4 : goto error_return;
4233 : }
4234 :
4235 3254 : tail->expr = gfc_copy_expr (kind_expr);
4236 : }
4237 :
4238 3552 : if (actual_param)
4239 3164 : tail->spec_type = actual_param->spec_type;
4240 :
4241 3552 : if (!param->attr.pdt_kind)
4242 : {
4243 1931 : if (!name_seen && actual_param)
4244 1162 : actual_param = actual_param->next;
4245 1931 : if (kind_expr)
4246 : {
4247 1635 : gfc_free_expr (kind_expr);
4248 1635 : kind_expr = NULL;
4249 : }
4250 1931 : continue;
4251 : }
4252 :
4253 1621 : if (actual_param
4254 1277 : && (actual_param->spec_type == SPEC_ASSUMED
4255 1277 : || actual_param->spec_type == SPEC_DEFERRED))
4256 : {
4257 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4258 : "ASSUMED or DEFERRED", param->name);
4259 2 : goto error_return;
4260 : }
4261 :
4262 1619 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4263 : {
4264 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4265 : "reduce to a constant expression", param->name);
4266 2 : goto error_return;
4267 : }
4268 :
4269 : /* This can come about during the parsing of nested pdt_templates. An
4270 : error arises because the KIND parameter expression has not been
4271 : provided. Use the template instead of an incorrect instance. */
4272 1617 : if (kind_expr->expr_type != EXPR_CONSTANT
4273 1617 : || kind_expr->ts.type != BT_INTEGER)
4274 : {
4275 0 : gfc_free_actual_arglist (type_param_spec_list);
4276 0 : free (name);
4277 0 : return MATCH_YES;
4278 : }
4279 :
4280 1617 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4281 1617 : char *old_name = name;
4282 1617 : name = xasprintf ("%s_%s", old_name, kind_value);
4283 1617 : free (old_name);
4284 1617 : free (kind_value);
4285 :
4286 1617 : if (!name_seen && actual_param)
4287 898 : actual_param = actual_param->next;
4288 1617 : gfc_free_expr (kind_expr);
4289 : }
4290 :
4291 2627 : if (!name_seen && actual_param)
4292 : {
4293 2 : gfc_error ("The type parameter spec list at %C contains too many "
4294 : "parameter expressions");
4295 2 : goto error_return;
4296 : }
4297 :
4298 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4299 : build it, using 'pdt' as a template. */
4300 2625 : if (gfc_get_symbol (name, pdt->ns, &instance))
4301 : {
4302 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4303 0 : goto error_return;
4304 : }
4305 :
4306 : /* If we are in an interface body, the instance will not have been imported.
4307 : Make sure that it is imported implicitly. */
4308 2625 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4309 2625 : if (gfc_current_ns->proc_name
4310 2578 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4311 93 : && s && s->import_only && pdt->attr.imported)
4312 : {
4313 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4314 2 : if (!s)
4315 : {
4316 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4317 : &gfc_current_locus);
4318 1 : s->n.sym = instance;
4319 : }
4320 2 : s->n.sym->attr.imported = 1;
4321 2 : s->import_only = 1;
4322 : }
4323 :
4324 2625 : m = MATCH_YES;
4325 :
4326 2625 : if (instance->attr.flavor == FL_DERIVED
4327 2086 : && instance->attr.pdt_type
4328 2086 : && instance->components)
4329 : {
4330 2086 : instance->refs++;
4331 2086 : if (ext_param_list)
4332 990 : *ext_param_list = type_param_spec_list;
4333 2086 : *sym = instance;
4334 2086 : gfc_commit_symbols ();
4335 2086 : free (name);
4336 2086 : return m;
4337 : }
4338 :
4339 : /* Start building the new instance of the parameterized type. */
4340 539 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4341 539 : if (pdt->attr.use_assoc)
4342 60 : instance->module = pdt->module;
4343 539 : instance->attr.pdt_template = 0;
4344 539 : instance->attr.pdt_type = 1;
4345 539 : instance->declared_at = gfc_current_locus;
4346 :
4347 : /* In resolution, the finalizers are copied, according to the type of the
4348 : argument, to the instance finalizers. However, they are retained by the
4349 : template and procedures are freed there. */
4350 539 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4351 : {
4352 24 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4353 24 : instance->template_sym = pdt;
4354 24 : *instance->f2k_derived = *pdt->f2k_derived;
4355 : }
4356 :
4357 : /* Add the components, replacing the parameters in all expressions
4358 : with the expressions for their values in 'type_param_spec_list'. */
4359 539 : c1 = pdt->components;
4360 539 : tail = type_param_spec_list;
4361 1972 : for (; c1; c1 = c1->next)
4362 : {
4363 1435 : gfc_add_component (instance, c1->name, &c2);
4364 :
4365 1435 : c2->ts = c1->ts;
4366 1435 : c2->attr = c1->attr;
4367 1435 : if (c1->tb)
4368 : {
4369 6 : c2->tb = gfc_get_tbp ();
4370 6 : *c2->tb = *c1->tb;
4371 : }
4372 :
4373 : /* The order of declaration of the type_specs might not be the
4374 : same as that of the components. */
4375 1435 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4376 : {
4377 1010 : for (tail = type_param_spec_list; tail; tail = tail->next)
4378 1006 : if (strcmp (c1->name, tail->name) == 0)
4379 : break;
4380 : }
4381 :
4382 : /* Deal with type extension by recursively calling this function
4383 : to obtain the instance of the extended type. */
4384 1435 : if (gfc_current_state () != COMP_DERIVED
4385 1421 : && c1 == pdt->components
4386 526 : && c1->ts.type == BT_DERIVED
4387 48 : && c1->ts.u.derived
4388 1483 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4389 : {
4390 48 : if (c1->ts.u.derived->attr.pdt_template)
4391 : {
4392 41 : gfc_formal_arglist *f;
4393 :
4394 41 : old_param_spec_list = type_param_spec_list;
4395 :
4396 : /* Obtain a spec list appropriate to the extended type..*/
4397 41 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4398 41 : type_param_spec_list = actual_param;
4399 73 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4400 32 : actual_param = actual_param->next;
4401 41 : if (actual_param)
4402 : {
4403 41 : gfc_free_actual_arglist (actual_param->next);
4404 41 : actual_param->next = NULL;
4405 : }
4406 :
4407 : /* Now obtain the PDT instance for the extended type. */
4408 41 : c2->param_list = type_param_spec_list;
4409 41 : m = gfc_get_pdt_instance (type_param_spec_list,
4410 : &c2->ts.u.derived,
4411 : &c2->param_list);
4412 41 : type_param_spec_list = old_param_spec_list;
4413 : }
4414 : else
4415 7 : c2->ts = c1->ts;
4416 :
4417 48 : c2->ts.u.derived->refs++;
4418 48 : gfc_set_sym_referenced (c2->ts.u.derived);
4419 :
4420 : /* If the component is allocatable or the parent has allocatable
4421 : components, make sure that the new instance also is marked as
4422 : having allocatable components. */
4423 48 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4424 6 : instance->attr.alloc_comp = 1;
4425 :
4426 : /* Set extension level. */
4427 48 : if (c2->ts.u.derived->attr.extension == 255)
4428 : {
4429 : /* Since the extension field is 8 bit wide, we can only have
4430 : up to 255 extension levels. */
4431 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4432 : c2->ts.u.derived->name,
4433 : &c2->ts.u.derived->declared_at);
4434 0 : goto error_return;
4435 : }
4436 48 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4437 :
4438 48 : continue;
4439 48 : }
4440 :
4441 : /* Addressing PR82943, this will fix the issue where a function or
4442 : subroutine is declared as not a member of the PDT instance.
4443 : The reason for this is because the PDT instance did not have access
4444 : to its template's f2k_derived namespace in order to find the
4445 : typebound procedures.
4446 :
4447 : The number of references to the PDT template's f2k_derived will
4448 : ensure that f2k_derived is properly freed later on. */
4449 :
4450 1387 : if (!instance->f2k_derived && pdt->f2k_derived)
4451 : {
4452 508 : instance->f2k_derived = pdt->f2k_derived;
4453 508 : instance->f2k_derived->refs++;
4454 : }
4455 :
4456 : /* Set the component kind using the parameterized expression. */
4457 1387 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4458 471 : && c1->kind_expr != NULL)
4459 : {
4460 278 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4461 278 : gfc_insert_kind_parameter_exprs (e);
4462 278 : gfc_simplify_expr (e, 1);
4463 278 : gfc_extract_int (e, &c2->ts.kind);
4464 278 : gfc_free_expr (e);
4465 278 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4466 : {
4467 2 : gfc_error ("Kind %d not supported for type %s at %C",
4468 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4469 2 : goto error_return;
4470 : }
4471 276 : if (c2->attr.proc_pointer && c2->attr.function
4472 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4473 : {
4474 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4475 0 : c2->ts.interface->result = c2->ts.interface;
4476 0 : c2->ts.interface->ts = c2->ts;
4477 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4478 0 : c2->ts.interface->attr.function = 1;
4479 0 : c2->attr.function = 1;
4480 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4481 : }
4482 : }
4483 :
4484 : /* Set up either the KIND/LEN initializer, if constant,
4485 : or the parameterized expression. Use the template
4486 : initializer if one is not already set in this instance. */
4487 1385 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4488 : {
4489 718 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4490 590 : c2->initializer = gfc_copy_expr (tail->expr);
4491 128 : else if (tail && tail->expr)
4492 : {
4493 10 : c2->param_list = gfc_get_actual_arglist ();
4494 10 : c2->param_list->name = tail->name;
4495 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4496 10 : c2->param_list->next = NULL;
4497 : }
4498 :
4499 718 : if (!c2->initializer && c1->initializer)
4500 24 : c2->initializer = gfc_copy_expr (c1->initializer);
4501 :
4502 718 : if (c2->initializer)
4503 614 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4504 : }
4505 :
4506 : /* Copy the array spec. */
4507 1385 : c2->as = gfc_copy_array_spec (c1->as);
4508 1385 : if (c1->ts.type == BT_CLASS)
4509 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4510 :
4511 1385 : if (c1->attr.allocatable)
4512 76 : alloc_seen = true;
4513 :
4514 1385 : if (c1->attr.pointer)
4515 20 : ptr_seen = true;
4516 :
4517 : /* Determine if an array spec is parameterized. If so, substitute
4518 : in the parameter expressions for the bounds and set the pdt_array
4519 : attribute. Notice that this attribute must be unconditionally set
4520 : if this is an array of parameterized character length. */
4521 1385 : if (c1->as && c1->as->type == AS_EXPLICIT)
4522 : {
4523 : bool pdt_array = false;
4524 514 : bool all_constant = true;
4525 :
4526 : /* Are the bounds of the array parameterized? */
4527 514 : for (i = 0; i < c1->as->rank; i++)
4528 : {
4529 305 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4530 6 : pdt_array = true;
4531 305 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4532 291 : pdt_array = true;
4533 : }
4534 :
4535 : /* If they are, free the expressions for the bounds and
4536 : replace them with the template expressions with substitute
4537 : values. */
4538 500 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4539 : {
4540 291 : gfc_expr *e;
4541 291 : e = gfc_copy_expr (c1->as->lower[i]);
4542 291 : gfc_insert_kind_parameter_exprs (e);
4543 291 : if (gfc_simplify_expr (e, 1))
4544 291 : gfc_replace_expr (c2->as->lower[i], e);
4545 : else
4546 0 : gfc_free_expr (e);
4547 291 : if (c2->as->lower[i]->expr_type != EXPR_CONSTANT)
4548 6 : all_constant = false;
4549 291 : e = gfc_copy_expr (c1->as->upper[i]);
4550 291 : gfc_insert_kind_parameter_exprs (e);
4551 291 : if (gfc_simplify_expr (e, 1))
4552 291 : gfc_replace_expr (c2->as->upper[i], e);
4553 : else
4554 0 : gfc_free_expr (e);
4555 291 : if (c2->as->upper[i]->expr_type != EXPR_CONSTANT)
4556 289 : all_constant = false;
4557 : }
4558 :
4559 209 : c2->attr.pdt_array = all_constant ? 0 : 1;
4560 209 : if (c1->initializer)
4561 : {
4562 7 : c2->initializer = gfc_copy_expr (c1->initializer);
4563 7 : gfc_insert_kind_parameter_exprs (c2->initializer);
4564 7 : gfc_simplify_expr (c2->initializer, 1);
4565 : }
4566 : }
4567 :
4568 : /* Similarly, set the string length if parameterized. */
4569 1385 : if (c1->ts.type == BT_CHARACTER
4570 87 : && c1->ts.u.cl->length
4571 1471 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4572 : {
4573 86 : gfc_expr *e;
4574 86 : e = gfc_copy_expr (c1->ts.u.cl->length);
4575 86 : gfc_insert_kind_parameter_exprs (e);
4576 86 : if (gfc_simplify_expr (e, 1))
4577 86 : gfc_replace_expr (c2->ts.u.cl->length, e);
4578 : else
4579 0 : gfc_free_expr (e);
4580 86 : if (c2->ts.u.cl->length->expr_type != EXPR_CONSTANT)
4581 83 : c2->attr.pdt_string = 1;
4582 : }
4583 :
4584 : /* Recurse into this function for PDT components. */
4585 1385 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4586 131 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4587 : {
4588 123 : gfc_actual_arglist *params;
4589 : /* The component in the template has a list of specification
4590 : expressions derived from its declaration. */
4591 123 : params = gfc_copy_actual_arglist (c1->param_list);
4592 123 : actual_param = params;
4593 : /* Substitute the template parameters with the expressions
4594 : from the specification list. */
4595 384 : for (;actual_param; actual_param = actual_param->next)
4596 : {
4597 138 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4598 138 : gfc_insert_parameter_exprs (actual_param->expr,
4599 : type_param_spec_list);
4600 : }
4601 :
4602 : /* Now obtain the PDT instance for the component. */
4603 123 : old_param_spec_list = type_param_spec_list;
4604 246 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4605 123 : &c2->param_list);
4606 123 : type_param_spec_list = old_param_spec_list;
4607 :
4608 123 : if (!(c2->attr.pointer || c2->attr.allocatable))
4609 : {
4610 83 : if (!c1->initializer
4611 58 : || c1->initializer->expr_type != EXPR_FUNCTION)
4612 82 : c2->initializer = gfc_default_initializer (&c2->ts);
4613 : else
4614 : {
4615 1 : gfc_symtree *s;
4616 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4617 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4618 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4619 1 : if (s)
4620 0 : c2->initializer->symtree = s;
4621 1 : c2->initializer->ts = c2->ts;
4622 1 : if (!s)
4623 1 : gfc_insert_parameter_exprs (c2->initializer,
4624 : type_param_spec_list);
4625 1 : gfc_simplify_expr (c2->initializer, 1);
4626 : }
4627 : }
4628 :
4629 123 : if (c2->attr.allocatable
4630 91 : || (c2->ts.type == BT_DERIVED && c2->ts.u.derived
4631 91 : && c2->ts.u.derived->attr.alloc_comp && !c2->attr.pointer))
4632 61 : instance->attr.alloc_comp = 1;
4633 : }
4634 1262 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4635 461 : || c2->attr.pdt_array) && c1->initializer)
4636 : {
4637 32 : c2->initializer = gfc_copy_expr (c1->initializer);
4638 32 : if (c2->initializer->ts.type == BT_UNKNOWN)
4639 12 : c2->initializer->ts = c2->ts;
4640 32 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4641 : /* The template initializers are parsed using gfc_match_expr rather
4642 : than gfc_match_init_expr. Apply the missing reduction to the
4643 : PDT instance initializers. */
4644 32 : if (!gfc_reduce_init_expr (c2->initializer))
4645 : {
4646 0 : gfc_free_expr (c2->initializer);
4647 0 : goto error_return;
4648 : }
4649 32 : gfc_simplify_expr (c2->initializer, 1);
4650 : }
4651 : }
4652 :
4653 537 : if (alloc_seen)
4654 73 : instance->attr.alloc_comp = 1;
4655 537 : if (ptr_seen)
4656 20 : instance->attr.pointer_comp = 1;
4657 :
4658 :
4659 537 : gfc_commit_symbol (instance);
4660 537 : if (ext_param_list)
4661 330 : *ext_param_list = type_param_spec_list;
4662 537 : *sym = instance;
4663 537 : free (name);
4664 537 : return m;
4665 :
4666 72 : error_return:
4667 72 : gfc_free_actual_arglist (type_param_spec_list);
4668 72 : free (name);
4669 72 : return MATCH_ERROR;
4670 : }
4671 :
4672 :
4673 : /* Match a legacy nonstandard BYTE type-spec. */
4674 :
4675 : static match
4676 1188542 : match_byte_typespec (gfc_typespec *ts)
4677 : {
4678 1188542 : if (gfc_match (" byte") == MATCH_YES)
4679 : {
4680 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4681 : return MATCH_ERROR;
4682 :
4683 31 : if (gfc_current_form == FORM_FREE)
4684 : {
4685 19 : char c = gfc_peek_ascii_char ();
4686 19 : if (!gfc_is_whitespace (c) && c != ',')
4687 : return MATCH_NO;
4688 : }
4689 :
4690 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4691 : {
4692 0 : gfc_error ("BYTE type used at %C "
4693 : "is not available on the target machine");
4694 0 : return MATCH_ERROR;
4695 : }
4696 :
4697 29 : ts->type = BT_INTEGER;
4698 29 : ts->kind = 1;
4699 29 : return MATCH_YES;
4700 : }
4701 : return MATCH_NO;
4702 : }
4703 :
4704 :
4705 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4706 : structure to the matched specification. This is necessary for FUNCTION and
4707 : IMPLICIT statements.
4708 :
4709 : If implicit_flag is nonzero, then we don't check for the optional
4710 : kind specification. Not doing so is needed for matching an IMPLICIT
4711 : statement correctly. */
4712 :
4713 : match
4714 1188542 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4715 : {
4716 : /* Provide sufficient space to hold "pdtsymbol". */
4717 1188542 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4718 1188542 : gfc_symbol *sym, *dt_sym;
4719 1188542 : match m;
4720 1188542 : char c;
4721 1188542 : bool seen_deferred_kind, matched_type;
4722 1188542 : const char *dt_name;
4723 :
4724 1188542 : decl_type_param_list = NULL;
4725 :
4726 : /* A belt and braces check that the typespec is correctly being treated
4727 : as a deferred characteristic association. */
4728 2377084 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4729 84178 : && (gfc_current_block ()->result->ts.kind == -1)
4730 1200445 : && (ts->kind == -1);
4731 1188542 : gfc_clear_ts (ts);
4732 1188542 : if (seen_deferred_kind)
4733 9668 : ts->kind = -1;
4734 :
4735 : /* Clear the current binding label, in case one is given. */
4736 1188542 : curr_binding_label = NULL;
4737 :
4738 : /* Match BYTE type-spec. */
4739 1188542 : m = match_byte_typespec (ts);
4740 1188542 : if (m != MATCH_NO)
4741 : return m;
4742 :
4743 1188511 : m = gfc_match (" type (");
4744 1188511 : matched_type = (m == MATCH_YES);
4745 1188511 : if (matched_type)
4746 : {
4747 31558 : gfc_gobble_whitespace ();
4748 31558 : if (gfc_peek_ascii_char () == '*')
4749 : {
4750 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4751 : return m;
4752 5617 : if (gfc_comp_struct (gfc_current_state ()))
4753 : {
4754 2 : gfc_error ("Assumed type at %C is not allowed for components");
4755 2 : return MATCH_ERROR;
4756 : }
4757 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4758 : return MATCH_ERROR;
4759 5613 : ts->type = BT_ASSUMED;
4760 5613 : return MATCH_YES;
4761 : }
4762 :
4763 25941 : m = gfc_match ("%n", name);
4764 25941 : matched_type = (m == MATCH_YES);
4765 : }
4766 :
4767 25941 : if ((matched_type && strcmp ("integer", name) == 0)
4768 1182894 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4769 : {
4770 112299 : ts->type = BT_INTEGER;
4771 112299 : ts->kind = gfc_default_integer_kind;
4772 112299 : goto get_kind;
4773 : }
4774 :
4775 1070595 : if (flag_unsigned)
4776 : {
4777 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4778 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4779 : {
4780 1036 : ts->type = BT_UNSIGNED;
4781 1036 : ts->kind = gfc_default_integer_kind;
4782 1036 : goto get_kind;
4783 : }
4784 : }
4785 :
4786 25935 : if ((matched_type && strcmp ("character", name) == 0)
4787 1069559 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4788 : {
4789 29000 : if (matched_type
4790 29000 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4791 : "intrinsic-type-spec at %C"))
4792 : return MATCH_ERROR;
4793 :
4794 28999 : ts->type = BT_CHARACTER;
4795 28999 : if (implicit_flag == 0)
4796 28893 : m = gfc_match_char_spec (ts);
4797 : else
4798 : m = MATCH_YES;
4799 :
4800 28999 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4801 : {
4802 1 : gfc_error ("Malformed type-spec at %C");
4803 1 : return MATCH_ERROR;
4804 : }
4805 :
4806 28998 : return m;
4807 : }
4808 :
4809 25931 : if ((matched_type && strcmp ("real", name) == 0)
4810 1040559 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4811 : {
4812 30263 : ts->type = BT_REAL;
4813 30263 : ts->kind = gfc_default_real_kind;
4814 30263 : goto get_kind;
4815 : }
4816 :
4817 1010296 : if ((matched_type
4818 25928 : && (strcmp ("doubleprecision", name) == 0
4819 25927 : || (strcmp ("double", name) == 0
4820 5 : && gfc_match (" precision") == MATCH_YES)))
4821 1010296 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4822 : {
4823 2614 : if (matched_type
4824 2614 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4825 : "intrinsic-type-spec at %C"))
4826 : return MATCH_ERROR;
4827 :
4828 2613 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4829 : {
4830 2 : gfc_error ("Malformed type-spec at %C");
4831 2 : return MATCH_ERROR;
4832 : }
4833 :
4834 2611 : ts->type = BT_REAL;
4835 2611 : ts->kind = gfc_default_double_kind;
4836 2611 : return MATCH_YES;
4837 : }
4838 :
4839 25924 : if ((matched_type && strcmp ("complex", name) == 0)
4840 1007682 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4841 : {
4842 4051 : ts->type = BT_COMPLEX;
4843 4051 : ts->kind = gfc_default_complex_kind;
4844 4051 : goto get_kind;
4845 : }
4846 :
4847 1003631 : if ((matched_type
4848 25924 : && (strcmp ("doublecomplex", name) == 0
4849 25923 : || (strcmp ("double", name) == 0
4850 2 : && gfc_match (" complex") == MATCH_YES)))
4851 1003631 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4852 : {
4853 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4854 : return MATCH_ERROR;
4855 :
4856 203 : if (matched_type
4857 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4858 : "intrinsic-type-spec at %C"))
4859 : return MATCH_ERROR;
4860 :
4861 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4862 : {
4863 2 : gfc_error ("Malformed type-spec at %C");
4864 2 : return MATCH_ERROR;
4865 : }
4866 :
4867 201 : ts->type = BT_COMPLEX;
4868 201 : ts->kind = gfc_default_double_kind;
4869 201 : return MATCH_YES;
4870 : }
4871 :
4872 25921 : if ((matched_type && strcmp ("logical", name) == 0)
4873 1003427 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4874 : {
4875 11520 : ts->type = BT_LOGICAL;
4876 11520 : ts->kind = gfc_default_logical_kind;
4877 11520 : goto get_kind;
4878 : }
4879 :
4880 991907 : if (matched_type)
4881 : {
4882 25918 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4883 25918 : if (m == MATCH_ERROR)
4884 : return m;
4885 :
4886 25918 : gfc_gobble_whitespace ();
4887 25918 : if (gfc_peek_ascii_char () != ')')
4888 : {
4889 1 : gfc_error ("Malformed type-spec at %C");
4890 1 : return MATCH_ERROR;
4891 : }
4892 25917 : m = gfc_match_char (')'); /* Burn closing ')'. */
4893 : }
4894 :
4895 991906 : if (m != MATCH_YES)
4896 965989 : m = match_record_decl (name);
4897 :
4898 991906 : if (matched_type || m == MATCH_YES)
4899 : {
4900 26261 : ts->type = BT_DERIVED;
4901 : /* We accept record/s/ or type(s) where s is a structure, but we
4902 : * don't need all the extra derived-type stuff for structures. */
4903 26261 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4904 : {
4905 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4906 1 : return MATCH_ERROR;
4907 : }
4908 :
4909 26260 : if (sym && sym->attr.flavor == FL_DERIVED
4910 25494 : && sym->attr.pdt_template
4911 1036 : && gfc_current_state () != COMP_DERIVED)
4912 : {
4913 921 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4914 921 : if (m != MATCH_YES)
4915 : return m;
4916 906 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4917 906 : ts->u.derived = sym;
4918 906 : const char* lower = gfc_dt_lower_string (sym->name);
4919 906 : size_t len = strlen (lower);
4920 : /* Reallocate with sufficient size. */
4921 906 : if (len > GFC_MAX_SYMBOL_LEN)
4922 2 : name = XALLOCAVEC (char, len + 1);
4923 906 : memcpy (name, lower, len);
4924 906 : name[len] = '\0';
4925 : }
4926 :
4927 26245 : if (sym && sym->attr.flavor == FL_STRUCT)
4928 : {
4929 361 : ts->u.derived = sym;
4930 361 : return MATCH_YES;
4931 : }
4932 : /* Actually a derived type. */
4933 : }
4934 :
4935 : else
4936 : {
4937 : /* Match nested STRUCTURE declarations; only valid within another
4938 : structure declaration. */
4939 965645 : if (flag_dec_structure
4940 8032 : && (gfc_current_state () == COMP_STRUCTURE
4941 7570 : || gfc_current_state () == COMP_MAP))
4942 : {
4943 732 : m = gfc_match (" structure");
4944 732 : if (m == MATCH_YES)
4945 : {
4946 27 : m = gfc_match_structure_decl ();
4947 27 : if (m == MATCH_YES)
4948 : {
4949 : /* gfc_new_block is updated by match_structure_decl. */
4950 26 : ts->type = BT_DERIVED;
4951 26 : ts->u.derived = gfc_new_block;
4952 26 : return MATCH_YES;
4953 : }
4954 : }
4955 706 : if (m == MATCH_ERROR)
4956 : return MATCH_ERROR;
4957 : }
4958 :
4959 : /* Match CLASS declarations. */
4960 965618 : m = gfc_match (" class ( * )");
4961 965618 : if (m == MATCH_ERROR)
4962 : return MATCH_ERROR;
4963 965618 : else if (m == MATCH_YES)
4964 : {
4965 1940 : gfc_symbol *upe;
4966 1940 : gfc_symtree *st;
4967 1940 : ts->type = BT_CLASS;
4968 1940 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4969 1940 : if (upe == NULL)
4970 : {
4971 1186 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4972 1186 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4973 1186 : st->n.sym = upe;
4974 1186 : gfc_set_sym_referenced (upe);
4975 1186 : upe->refs++;
4976 1186 : upe->ts.type = BT_VOID;
4977 1186 : upe->attr.unlimited_polymorphic = 1;
4978 : /* This is essential to force the construction of
4979 : unlimited polymorphic component class containers. */
4980 1186 : upe->attr.zero_comp = 1;
4981 1186 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4982 : &gfc_current_locus))
4983 : return MATCH_ERROR;
4984 : }
4985 : else
4986 : {
4987 754 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4988 754 : st->n.sym = upe;
4989 754 : upe->refs++;
4990 : }
4991 1940 : ts->u.derived = upe;
4992 1940 : return m;
4993 : }
4994 :
4995 963678 : m = gfc_match (" class (");
4996 :
4997 963678 : if (m == MATCH_YES)
4998 9046 : m = gfc_match ("%n", name);
4999 : else
5000 : return m;
5001 :
5002 9046 : if (m != MATCH_YES)
5003 : return m;
5004 9046 : ts->type = BT_CLASS;
5005 :
5006 9046 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
5007 : return MATCH_ERROR;
5008 :
5009 9045 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
5010 9045 : if (m == MATCH_ERROR)
5011 : return m;
5012 :
5013 9045 : m = gfc_match_char (')');
5014 9045 : if (m != MATCH_YES)
5015 : return m;
5016 : }
5017 :
5018 : /* This picks up function declarations with a PDT typespec. Since a
5019 : pdt_type has been generated, there is no more to do. Within the
5020 : function body, this type must be used for the typespec so that
5021 : the "being used before it is defined warning" does not arise. */
5022 34929 : if (ts->type == BT_DERIVED
5023 25884 : && sym && sym->attr.pdt_type
5024 35835 : && (gfc_current_state () == COMP_CONTAINS
5025 890 : || (gfc_current_state () == COMP_FUNCTION
5026 280 : && gfc_current_block ()->ts.type == BT_DERIVED
5027 60 : && gfc_current_block ()->ts.u.derived == sym
5028 30 : && !gfc_find_symtree (gfc_current_ns->sym_root,
5029 : sym->name))))
5030 : {
5031 42 : if (gfc_current_state () == COMP_FUNCTION)
5032 : {
5033 26 : gfc_symtree *pdt_st;
5034 26 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
5035 : sym->name);
5036 26 : pdt_st->n.sym = sym;
5037 26 : sym->refs++;
5038 : }
5039 42 : ts->u.derived = sym;
5040 42 : return MATCH_YES;
5041 : }
5042 :
5043 : /* Defer association of the derived type until the end of the
5044 : specification block. However, if the derived type can be
5045 : found, add it to the typespec. */
5046 34887 : if (gfc_matching_function)
5047 : {
5048 1043 : ts->u.derived = NULL;
5049 1043 : if (gfc_current_state () != COMP_INTERFACE
5050 1043 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
5051 : {
5052 512 : sym = gfc_find_dt_in_generic (sym);
5053 512 : ts->u.derived = sym;
5054 : }
5055 1043 : return MATCH_YES;
5056 : }
5057 :
5058 : /* Search for the name but allow the components to be defined later. If
5059 : type = -1, this typespec has been seen in a function declaration but
5060 : the type could not be accessed at that point. The actual derived type is
5061 : stored in a symtree with the first letter of the name capitalized; the
5062 : symtree with the all lower-case name contains the associated
5063 : generic function. */
5064 33844 : dt_name = gfc_dt_upper_string (name);
5065 33844 : sym = NULL;
5066 33844 : dt_sym = NULL;
5067 33844 : if (ts->kind != -1)
5068 : {
5069 32632 : gfc_get_ha_symbol (name, &sym);
5070 32632 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
5071 : {
5072 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5073 0 : return MATCH_ERROR;
5074 : }
5075 32632 : if (sym->generic && !dt_sym)
5076 14002 : dt_sym = gfc_find_dt_in_generic (sym);
5077 :
5078 : /* Host associated PDTs can get confused with their constructors
5079 : because they are instantiated in the template's namespace. */
5080 32632 : if (!dt_sym)
5081 : {
5082 968 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5083 : {
5084 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5085 0 : return MATCH_ERROR;
5086 : }
5087 968 : if (dt_sym && !dt_sym->attr.pdt_type)
5088 0 : dt_sym = NULL;
5089 : }
5090 : }
5091 1212 : else if (ts->kind == -1)
5092 : {
5093 2424 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
5094 1212 : || gfc_current_ns->has_import_set;
5095 1212 : gfc_find_symbol (name, NULL, iface, &sym);
5096 1212 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
5097 : {
5098 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5099 0 : return MATCH_ERROR;
5100 : }
5101 1212 : if (sym && sym->generic && !dt_sym)
5102 0 : dt_sym = gfc_find_dt_in_generic (sym);
5103 :
5104 1212 : ts->kind = 0;
5105 1212 : if (sym == NULL)
5106 : return MATCH_NO;
5107 : }
5108 :
5109 33827 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
5110 33081 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
5111 33825 : || sym->attr.subroutine)
5112 : {
5113 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
5114 : "entity at %L, which has the same name", name,
5115 : &sym->declared_at);
5116 2 : return MATCH_ERROR;
5117 : }
5118 :
5119 33825 : if (dt_sym && decl_type_param_list
5120 940 : && dt_sym->attr.flavor == FL_DERIVED
5121 940 : && !dt_sym->attr.pdt_type
5122 250 : && !dt_sym->attr.pdt_template)
5123 : {
5124 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5125 : "list at %C may not appear", dt_sym->name);
5126 1 : return MATCH_ERROR;
5127 : }
5128 :
5129 33824 : if (sym && sym->attr.flavor == FL_DERIVED
5130 : && sym->attr.pdt_template
5131 : && gfc_current_state () != COMP_DERIVED)
5132 : {
5133 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5134 : if (m != MATCH_YES)
5135 : return m;
5136 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5137 : ts->u.derived = sym;
5138 : strcpy (name, gfc_dt_lower_string (sym->name));
5139 : }
5140 :
5141 33824 : gfc_save_symbol_data (sym);
5142 33824 : gfc_set_sym_referenced (sym);
5143 33824 : if (!sym->attr.generic
5144 33824 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5145 : return MATCH_ERROR;
5146 :
5147 33824 : if (!sym->attr.function
5148 33824 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5149 : return MATCH_ERROR;
5150 :
5151 33824 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5152 33692 : && dt_sym->attr.pdt_template
5153 260 : && gfc_current_state () != COMP_DERIVED)
5154 : {
5155 133 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5156 133 : if (m != MATCH_YES)
5157 : return m;
5158 133 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5159 : }
5160 :
5161 33824 : if (!dt_sym)
5162 : {
5163 132 : gfc_interface *intr, *head;
5164 :
5165 : /* Use upper case to save the actual derived-type symbol. */
5166 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5167 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5168 132 : head = sym->generic;
5169 132 : intr = gfc_get_interface ();
5170 132 : intr->sym = dt_sym;
5171 132 : intr->where = gfc_current_locus;
5172 132 : intr->next = head;
5173 132 : sym->generic = intr;
5174 132 : sym->attr.if_source = IFSRC_DECL;
5175 : }
5176 : else
5177 33692 : gfc_save_symbol_data (dt_sym);
5178 :
5179 33824 : gfc_set_sym_referenced (dt_sym);
5180 :
5181 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5182 33956 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5183 : return MATCH_ERROR;
5184 :
5185 33824 : ts->u.derived = dt_sym;
5186 :
5187 33824 : return MATCH_YES;
5188 :
5189 159169 : get_kind:
5190 159169 : if (matched_type
5191 159169 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5192 : "intrinsic-type-spec at %C"))
5193 : return MATCH_ERROR;
5194 :
5195 : /* For all types except double, derived and character, look for an
5196 : optional kind specifier. MATCH_NO is actually OK at this point. */
5197 159166 : if (implicit_flag == 1)
5198 : {
5199 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5200 : return MATCH_ERROR;
5201 :
5202 223 : return MATCH_YES;
5203 : }
5204 :
5205 158943 : if (gfc_current_form == FORM_FREE)
5206 : {
5207 143728 : c = gfc_peek_ascii_char ();
5208 143728 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5209 70947 : && c != ':' && c != ',')
5210 : {
5211 167 : if (matched_type && c == ')')
5212 : {
5213 3 : gfc_next_ascii_char ();
5214 3 : return MATCH_YES;
5215 : }
5216 164 : gfc_error ("Malformed type-spec at %C");
5217 164 : return MATCH_NO;
5218 : }
5219 : }
5220 :
5221 158776 : m = gfc_match_kind_spec (ts, false);
5222 158776 : if (m == MATCH_ERROR)
5223 : return MATCH_ERROR;
5224 :
5225 158740 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5226 : {
5227 107542 : m = gfc_match_old_kind_spec (ts);
5228 107542 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5229 : return MATCH_ERROR;
5230 : }
5231 :
5232 158732 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5233 : {
5234 0 : gfc_error ("Malformed type-spec at %C");
5235 0 : return MATCH_ERROR;
5236 : }
5237 :
5238 : /* Defer association of the KIND expression of function results
5239 : until after USE and IMPORT statements. */
5240 4440 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5241 163145 : || gfc_matching_function)
5242 7230 : return MATCH_YES;
5243 :
5244 151502 : if (m == MATCH_NO)
5245 152101 : m = MATCH_YES; /* No kind specifier found. */
5246 :
5247 : return m;
5248 : }
5249 :
5250 :
5251 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5252 : already matched in parse.cc, or we would not end up here in the
5253 : first place. So the only thing we need to check, is if there is
5254 : trailing garbage. If not, the match is successful. */
5255 :
5256 : match
5257 23968 : gfc_match_implicit_none (void)
5258 : {
5259 23968 : char c;
5260 23968 : match m;
5261 23968 : char name[GFC_MAX_SYMBOL_LEN + 1];
5262 23968 : bool type = false;
5263 23968 : bool external = false;
5264 23968 : locus cur_loc = gfc_current_locus;
5265 :
5266 23968 : if (gfc_current_ns->seen_implicit_none
5267 23966 : || gfc_current_ns->has_implicit_none_export)
5268 : {
5269 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5270 4 : return MATCH_ERROR;
5271 : }
5272 :
5273 23964 : gfc_gobble_whitespace ();
5274 23964 : c = gfc_peek_ascii_char ();
5275 23964 : if (c == '(')
5276 : {
5277 1103 : (void) gfc_next_ascii_char ();
5278 1103 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5279 : return MATCH_ERROR;
5280 :
5281 1102 : gfc_gobble_whitespace ();
5282 1102 : if (gfc_peek_ascii_char () == ')')
5283 : {
5284 1 : (void) gfc_next_ascii_char ();
5285 1 : type = true;
5286 : }
5287 : else
5288 3279 : for(;;)
5289 : {
5290 2190 : m = gfc_match (" %n", name);
5291 2190 : if (m != MATCH_YES)
5292 : return MATCH_ERROR;
5293 :
5294 2190 : if (strcmp (name, "type") == 0)
5295 : type = true;
5296 1101 : else if (strcmp (name, "external") == 0)
5297 : external = true;
5298 : else
5299 : return MATCH_ERROR;
5300 :
5301 2190 : gfc_gobble_whitespace ();
5302 2190 : c = gfc_next_ascii_char ();
5303 2190 : if (c == ',')
5304 1089 : continue;
5305 1101 : if (c == ')')
5306 : break;
5307 : return MATCH_ERROR;
5308 : }
5309 : }
5310 : else
5311 : type = true;
5312 :
5313 23963 : if (gfc_match_eos () != MATCH_YES)
5314 : return MATCH_ERROR;
5315 :
5316 23963 : gfc_set_implicit_none (type, external, &cur_loc);
5317 :
5318 23963 : return MATCH_YES;
5319 : }
5320 :
5321 :
5322 : /* Match the letter range(s) of an IMPLICIT statement. */
5323 :
5324 : static match
5325 600 : match_implicit_range (void)
5326 : {
5327 600 : char c, c1, c2;
5328 600 : int inner;
5329 600 : locus cur_loc;
5330 :
5331 600 : cur_loc = gfc_current_locus;
5332 :
5333 600 : gfc_gobble_whitespace ();
5334 600 : c = gfc_next_ascii_char ();
5335 600 : if (c != '(')
5336 : {
5337 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5338 59 : goto bad;
5339 : }
5340 :
5341 : inner = 1;
5342 1195 : while (inner)
5343 : {
5344 722 : gfc_gobble_whitespace ();
5345 722 : c1 = gfc_next_ascii_char ();
5346 722 : if (!ISALPHA (c1))
5347 33 : goto bad;
5348 :
5349 689 : gfc_gobble_whitespace ();
5350 689 : c = gfc_next_ascii_char ();
5351 :
5352 689 : switch (c)
5353 : {
5354 201 : case ')':
5355 201 : inner = 0; /* Fall through. */
5356 :
5357 : case ',':
5358 : c2 = c1;
5359 : break;
5360 :
5361 439 : case '-':
5362 439 : gfc_gobble_whitespace ();
5363 439 : c2 = gfc_next_ascii_char ();
5364 439 : if (!ISALPHA (c2))
5365 0 : goto bad;
5366 :
5367 439 : gfc_gobble_whitespace ();
5368 439 : c = gfc_next_ascii_char ();
5369 :
5370 439 : if ((c != ',') && (c != ')'))
5371 0 : goto bad;
5372 439 : if (c == ')')
5373 272 : inner = 0;
5374 :
5375 : break;
5376 :
5377 35 : default:
5378 35 : goto bad;
5379 : }
5380 :
5381 654 : if (c1 > c2)
5382 : {
5383 0 : gfc_error ("Letters must be in alphabetic order in "
5384 : "IMPLICIT statement at %C");
5385 0 : goto bad;
5386 : }
5387 :
5388 : /* See if we can add the newly matched range to the pending
5389 : implicits from this IMPLICIT statement. We do not check for
5390 : conflicts with whatever earlier IMPLICIT statements may have
5391 : set. This is done when we've successfully finished matching
5392 : the current one. */
5393 654 : if (!gfc_add_new_implicit_range (c1, c2))
5394 0 : goto bad;
5395 : }
5396 :
5397 : return MATCH_YES;
5398 :
5399 127 : bad:
5400 127 : gfc_syntax_error (ST_IMPLICIT);
5401 :
5402 127 : gfc_current_locus = cur_loc;
5403 127 : return MATCH_ERROR;
5404 : }
5405 :
5406 :
5407 : /* Match an IMPLICIT statement, storing the types for
5408 : gfc_set_implicit() if the statement is accepted by the parser.
5409 : There is a strange looking, but legal syntactic construction
5410 : possible. It looks like:
5411 :
5412 : IMPLICIT INTEGER (a-b) (c-d)
5413 :
5414 : This is legal if "a-b" is a constant expression that happens to
5415 : equal one of the legal kinds for integers. The real problem
5416 : happens with an implicit specification that looks like:
5417 :
5418 : IMPLICIT INTEGER (a-b)
5419 :
5420 : In this case, a typespec matcher that is "greedy" (as most of the
5421 : matchers are) gobbles the character range as a kindspec, leaving
5422 : nothing left. We therefore have to go a bit more slowly in the
5423 : matching process by inhibiting the kindspec checking during
5424 : typespec matching and checking for a kind later. */
5425 :
5426 : match
5427 24394 : gfc_match_implicit (void)
5428 : {
5429 24394 : gfc_typespec ts;
5430 24394 : locus cur_loc;
5431 24394 : char c;
5432 24394 : match m;
5433 :
5434 24394 : if (gfc_current_ns->seen_implicit_none)
5435 : {
5436 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5437 : "statement");
5438 4 : return MATCH_ERROR;
5439 : }
5440 :
5441 24390 : gfc_clear_ts (&ts);
5442 :
5443 : /* We don't allow empty implicit statements. */
5444 24390 : if (gfc_match_eos () == MATCH_YES)
5445 : {
5446 0 : gfc_error ("Empty IMPLICIT statement at %C");
5447 0 : return MATCH_ERROR;
5448 : }
5449 :
5450 24419 : do
5451 : {
5452 : /* First cleanup. */
5453 24419 : gfc_clear_new_implicit ();
5454 :
5455 : /* A basic type is mandatory here. */
5456 24419 : m = gfc_match_decl_type_spec (&ts, 1);
5457 24419 : if (m == MATCH_ERROR)
5458 0 : goto error;
5459 24419 : if (m == MATCH_NO)
5460 23966 : goto syntax;
5461 :
5462 453 : cur_loc = gfc_current_locus;
5463 453 : m = match_implicit_range ();
5464 :
5465 453 : if (m == MATCH_YES)
5466 : {
5467 : /* We may have <TYPE> (<RANGE>). */
5468 326 : gfc_gobble_whitespace ();
5469 326 : c = gfc_peek_ascii_char ();
5470 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5471 : {
5472 : /* Check for CHARACTER with no length parameter. */
5473 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5474 : {
5475 32 : ts.kind = gfc_default_character_kind;
5476 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5477 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5478 : NULL, 1);
5479 : }
5480 :
5481 : /* Record the Successful match. */
5482 299 : if (!gfc_merge_new_implicit (&ts))
5483 : return MATCH_ERROR;
5484 297 : if (c == ',')
5485 28 : c = gfc_next_ascii_char ();
5486 269 : else if (gfc_match_eos () == MATCH_ERROR)
5487 0 : goto error;
5488 297 : continue;
5489 : }
5490 :
5491 27 : gfc_current_locus = cur_loc;
5492 : }
5493 :
5494 : /* Discard the (incorrectly) matched range. */
5495 154 : gfc_clear_new_implicit ();
5496 :
5497 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5498 154 : if (ts.type == BT_CHARACTER)
5499 74 : m = gfc_match_char_spec (&ts);
5500 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5501 : {
5502 76 : m = gfc_match_kind_spec (&ts, false);
5503 76 : if (m == MATCH_NO)
5504 : {
5505 40 : m = gfc_match_old_kind_spec (&ts);
5506 40 : if (m == MATCH_ERROR)
5507 0 : goto error;
5508 40 : if (m == MATCH_NO)
5509 0 : goto syntax;
5510 : }
5511 : }
5512 154 : if (m == MATCH_ERROR)
5513 7 : goto error;
5514 :
5515 147 : m = match_implicit_range ();
5516 147 : if (m == MATCH_ERROR)
5517 0 : goto error;
5518 147 : if (m == MATCH_NO)
5519 : goto syntax;
5520 :
5521 147 : gfc_gobble_whitespace ();
5522 147 : c = gfc_next_ascii_char ();
5523 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5524 0 : goto syntax;
5525 :
5526 147 : if (!gfc_merge_new_implicit (&ts))
5527 : return MATCH_ERROR;
5528 : }
5529 444 : while (c == ',');
5530 :
5531 : return MATCH_YES;
5532 :
5533 23966 : syntax:
5534 23966 : gfc_syntax_error (ST_IMPLICIT);
5535 :
5536 : error:
5537 : return MATCH_ERROR;
5538 : }
5539 :
5540 :
5541 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5542 :
5543 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5544 :
5545 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5546 :
5547 : C1211 (R1209) Each import-name shall be the name of an entity in the
5548 : host scoping unit.
5549 :
5550 : under the description of an interface block. Under F2008, IMPORT was
5551 : split out of the interface block description to 12.4.3.3 and C1210
5552 : became
5553 :
5554 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5555 : that is not a module procedure interface body.
5556 :
5557 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5558 :
5559 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5560 : or IMPORT, ONLY : import-name-list
5561 : or IMPORT, NONE
5562 : or IMPORT, ALL
5563 :
5564 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5565 : a main-program, external-subprogram, module, or block-data.
5566 :
5567 : C897 (R867) Each import-name shall be the name of an entity in the host
5568 : scoping unit.
5569 :
5570 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5571 : all IMPORT statements in that scoping unit shall have an ONLY
5572 : specifier.
5573 :
5574 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5575 :
5576 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5577 : unit, no other IMPORT statement shall appear in that scoping unit.
5578 :
5579 : C8101 Within an interface body, an entity that is accessed by host
5580 : association shall be accessible by host or use association within
5581 : the host scoping unit, or explicitly declared prior to the interface
5582 : body.
5583 :
5584 : C8102 An entity whose name appears as an import-name or which is made
5585 : accessible by an IMPORT, ALL statement shall not appear in any
5586 : context described in 19.5.1.4 that would cause the host entity
5587 : of that name to be inaccessible. */
5588 :
5589 : match
5590 4032 : gfc_match_import (void)
5591 : {
5592 4032 : char name[GFC_MAX_SYMBOL_LEN + 1];
5593 4032 : match m;
5594 4032 : gfc_symbol *sym;
5595 4032 : gfc_symtree *st;
5596 4032 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5597 4032 : importstate current_import_state = gfc_current_ns->import_state;
5598 :
5599 4032 : if (!f2018_allowed
5600 13 : && (gfc_current_ns->proc_name == NULL
5601 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5602 : {
5603 3 : gfc_error ("IMPORT statement at %C only permitted in "
5604 : "an INTERFACE body");
5605 3 : return MATCH_ERROR;
5606 : }
5607 : else if (f2018_allowed
5608 4019 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5609 4 : goto C897;
5610 :
5611 4015 : if (f2018_allowed
5612 4015 : && (current_import_state == IMPORT_ALL
5613 4015 : || current_import_state == IMPORT_NONE))
5614 2 : goto C8100;
5615 :
5616 4023 : if (gfc_current_ns->proc_name
5617 4022 : && gfc_current_ns->proc_name->attr.module_procedure)
5618 : {
5619 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5620 : "in a module procedure interface body");
5621 1 : return MATCH_ERROR;
5622 : }
5623 :
5624 4022 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5625 : return MATCH_ERROR;
5626 :
5627 4018 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5628 4018 : if (f2018_allowed)
5629 : {
5630 4012 : if (gfc_match (" , none") == MATCH_YES)
5631 : {
5632 8 : if (current_import_state == IMPORT_ONLY)
5633 0 : goto C898;
5634 8 : if (gfc_current_state () == COMP_SUBMODULE)
5635 0 : goto C899;
5636 8 : gfc_current_ns->import_state = IMPORT_NONE;
5637 : }
5638 4004 : else if (gfc_match (" , only :") == MATCH_YES)
5639 : {
5640 19 : if (current_import_state != IMPORT_NOT_SET
5641 19 : && current_import_state != IMPORT_ONLY)
5642 0 : goto C898;
5643 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5644 : }
5645 3985 : else if (gfc_match (" , all") == MATCH_YES)
5646 : {
5647 1 : if (current_import_state == IMPORT_ONLY)
5648 0 : goto C898;
5649 1 : gfc_current_ns->import_state = IMPORT_ALL;
5650 : }
5651 :
5652 4012 : if (current_import_state != IMPORT_NOT_SET
5653 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5654 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5655 0 : goto C8100;
5656 : }
5657 :
5658 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5659 4018 : if (gfc_match_eos () == MATCH_YES)
5660 : {
5661 : /* This is the F2008 variant. */
5662 340 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5663 : {
5664 331 : if (current_import_state == IMPORT_ONLY)
5665 0 : goto C898;
5666 331 : gfc_current_ns->import_state = IMPORT_F2008;
5667 : }
5668 :
5669 : /* Host variables should be imported. */
5670 340 : if (gfc_current_ns->import_state != IMPORT_NONE)
5671 332 : gfc_current_ns->has_import_set = 1;
5672 340 : return MATCH_YES;
5673 : }
5674 :
5675 3678 : if (gfc_match (" ::") == MATCH_YES
5676 3678 : && gfc_current_ns->import_state != IMPORT_ONLY)
5677 : {
5678 1170 : if (gfc_match_eos () == MATCH_YES)
5679 1 : goto expecting_list;
5680 1169 : gfc_current_ns->import_state = IMPORT_F2008;
5681 : }
5682 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5683 : {
5684 19 : if (gfc_match_eos () == MATCH_YES)
5685 0 : goto expecting_list;
5686 : }
5687 :
5688 4366 : for(;;)
5689 : {
5690 4366 : sym = NULL;
5691 4366 : m = gfc_match (" %n", name);
5692 4366 : switch (m)
5693 : {
5694 4366 : case MATCH_YES:
5695 : /* Before checking if the symbol is available from host
5696 : association into a SUBROUTINE or FUNCTION within an
5697 : INTERFACE, check if it is already in local scope. */
5698 4366 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5699 4366 : if (sym
5700 25 : && gfc_state_stack->previous
5701 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5702 : {
5703 2 : gfc_error ("import-name %qs at %C is in the "
5704 : "local scope", name);
5705 2 : return MATCH_ERROR;
5706 : }
5707 :
5708 4364 : if (gfc_current_ns->parent != NULL
5709 4364 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5710 : {
5711 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5712 0 : return MATCH_ERROR;
5713 : }
5714 4364 : else if (!sym
5715 5 : && gfc_current_ns->proc_name
5716 4 : && gfc_current_ns->proc_name->ns->parent
5717 4365 : && gfc_find_symbol (name,
5718 : gfc_current_ns->proc_name->ns->parent,
5719 : 1, &sym))
5720 : {
5721 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5722 0 : return MATCH_ERROR;
5723 : }
5724 :
5725 4364 : if (sym == NULL)
5726 : {
5727 5 : if (gfc_current_ns->proc_name
5728 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5729 : {
5730 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5731 : "at %C - does not exist.", name);
5732 1 : return MATCH_ERROR;
5733 : }
5734 : else
5735 : {
5736 : /* This might be a procedure that has not yet been parsed. If
5737 : so gfc_fixup_sibling_symbols will replace this symbol with
5738 : that of the procedure. */
5739 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5740 : &gfc_current_locus);
5741 4 : st->n.sym->refs++;
5742 4 : st->n.sym->attr.imported = 1;
5743 4 : st->import_only = 1;
5744 4 : goto next_item;
5745 : }
5746 : }
5747 :
5748 4359 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5749 4359 : if (st && st->n.sym && st->n.sym->attr.imported)
5750 : {
5751 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5752 : "at %C", name);
5753 0 : goto next_item;
5754 : }
5755 :
5756 4359 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5757 4359 : st->n.sym = sym;
5758 4359 : sym->refs++;
5759 4359 : sym->attr.imported = 1;
5760 4359 : st->import_only = 1;
5761 :
5762 4359 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5763 : {
5764 : /* The actual derived type is stored in a symtree with the first
5765 : letter of the name capitalized; the symtree with the all
5766 : lower-case name contains the associated generic function. */
5767 599 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5768 : gfc_dt_upper_string (name));
5769 599 : st->n.sym = sym;
5770 599 : sym->refs++;
5771 599 : sym->attr.imported = 1;
5772 599 : st->import_only = 1;
5773 : }
5774 :
5775 4359 : goto next_item;
5776 :
5777 : case MATCH_NO:
5778 : break;
5779 :
5780 : case MATCH_ERROR:
5781 : return MATCH_ERROR;
5782 : }
5783 :
5784 4363 : next_item:
5785 4363 : if (gfc_match_eos () == MATCH_YES)
5786 : break;
5787 689 : if (gfc_match_char (',') != MATCH_YES)
5788 0 : goto syntax;
5789 : }
5790 :
5791 : return MATCH_YES;
5792 :
5793 0 : syntax:
5794 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5795 0 : return MATCH_ERROR;
5796 :
5797 4 : C897:
5798 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5799 : "program, an external subprogram, a module or block data");
5800 4 : return MATCH_ERROR;
5801 :
5802 0 : C898:
5803 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5804 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5805 : "with an ONLY specifier");
5806 0 : return MATCH_ERROR;
5807 :
5808 0 : C899:
5809 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5810 : " of a submodule as at %C");
5811 0 : return MATCH_ERROR;
5812 :
5813 2 : C8100:
5814 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5815 : "%s has already been declared, which must be unique in the "
5816 : "scoping unit",
5817 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5818 : "IMPORT, NONE");
5819 2 : return MATCH_ERROR;
5820 :
5821 1 : expecting_list:
5822 1 : gfc_error ("Expecting list of named entities at %C");
5823 1 : return MATCH_ERROR;
5824 : }
5825 :
5826 :
5827 : /* A minimal implementation of gfc_match without whitespace, escape
5828 : characters or variable arguments. Returns true if the next
5829 : characters match the TARGET template exactly. */
5830 :
5831 : static bool
5832 146851 : match_string_p (const char *target)
5833 : {
5834 146851 : const char *p;
5835 :
5836 922308 : for (p = target; *p; p++)
5837 775458 : if ((char) gfc_next_ascii_char () != *p)
5838 : return false;
5839 : return true;
5840 : }
5841 :
5842 : /* Matches an attribute specification including array specs. If
5843 : successful, leaves the variables current_attr and current_as
5844 : holding the specification. Also sets the colon_seen variable for
5845 : later use by matchers associated with initializations.
5846 :
5847 : This subroutine is a little tricky in the sense that we don't know
5848 : if we really have an attr-spec until we hit the double colon.
5849 : Until that time, we can only return MATCH_NO. This forces us to
5850 : check for duplicate specification at this level. */
5851 :
5852 : static match
5853 217543 : match_attr_spec (void)
5854 : {
5855 : /* Modifiers that can exist in a type statement. */
5856 217543 : enum
5857 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5858 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5859 : DECL_DIMENSION, DECL_EXTERNAL,
5860 : DECL_INTRINSIC, DECL_OPTIONAL,
5861 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5862 : DECL_STATIC, DECL_AUTOMATIC,
5863 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5864 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5865 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5866 : };
5867 :
5868 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5869 : #define NUM_DECL GFC_DECL_END
5870 :
5871 : /* Make sure that values from sym_intent are safe to be used here. */
5872 217543 : gcc_assert (INTENT_IN > 0);
5873 :
5874 217543 : locus start, seen_at[NUM_DECL];
5875 217543 : int seen[NUM_DECL];
5876 217543 : unsigned int d;
5877 217543 : const char *attr;
5878 217543 : match m;
5879 217543 : bool t;
5880 :
5881 217543 : gfc_clear_attr (¤t_attr);
5882 217543 : start = gfc_current_locus;
5883 :
5884 217543 : current_as = NULL;
5885 217543 : colon_seen = 0;
5886 217543 : attr_seen = 0;
5887 :
5888 : /* See if we get all of the keywords up to the final double colon. */
5889 5873661 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5890 5656118 : seen[d] = 0;
5891 :
5892 336605 : for (;;)
5893 : {
5894 336605 : char ch;
5895 :
5896 336605 : d = DECL_NONE;
5897 336605 : gfc_gobble_whitespace ();
5898 :
5899 336605 : ch = gfc_next_ascii_char ();
5900 336605 : if (ch == ':')
5901 : {
5902 : /* This is the successful exit condition for the loop. */
5903 183711 : if (gfc_next_ascii_char () == ':')
5904 : break;
5905 : }
5906 152894 : else if (ch == ',')
5907 : {
5908 119074 : gfc_gobble_whitespace ();
5909 119074 : switch (gfc_peek_ascii_char ())
5910 : {
5911 18462 : case 'a':
5912 18462 : gfc_next_ascii_char ();
5913 18462 : switch (gfc_next_ascii_char ())
5914 : {
5915 18396 : case 'l':
5916 18396 : if (match_string_p ("locatable"))
5917 : {
5918 : /* Matched "allocatable". */
5919 : d = DECL_ALLOCATABLE;
5920 : }
5921 : break;
5922 :
5923 25 : case 's':
5924 25 : if (match_string_p ("ynchronous"))
5925 : {
5926 : /* Matched "asynchronous". */
5927 : d = DECL_ASYNCHRONOUS;
5928 : }
5929 : break;
5930 :
5931 41 : case 'u':
5932 41 : if (match_string_p ("tomatic"))
5933 : {
5934 : /* Matched "automatic". */
5935 : d = DECL_AUTOMATIC;
5936 : }
5937 : break;
5938 : }
5939 : break;
5940 :
5941 163 : case 'b':
5942 : /* Try and match the bind(c). */
5943 163 : m = gfc_match_bind_c (NULL, true);
5944 163 : if (m == MATCH_YES)
5945 : d = DECL_IS_BIND_C;
5946 0 : else if (m == MATCH_ERROR)
5947 0 : goto cleanup;
5948 : break;
5949 :
5950 2164 : case 'c':
5951 2164 : gfc_next_ascii_char ();
5952 2164 : if ('o' != gfc_next_ascii_char ())
5953 : break;
5954 2163 : switch (gfc_next_ascii_char ())
5955 : {
5956 68 : case 'd':
5957 68 : if (match_string_p ("imension"))
5958 : {
5959 : d = DECL_CODIMENSION;
5960 : break;
5961 : }
5962 : /* FALLTHRU */
5963 2095 : case 'n':
5964 2095 : if (match_string_p ("tiguous"))
5965 : {
5966 : d = DECL_CONTIGUOUS;
5967 : break;
5968 : }
5969 : }
5970 : break;
5971 :
5972 19679 : case 'd':
5973 19679 : if (match_string_p ("dimension"))
5974 : d = DECL_DIMENSION;
5975 : break;
5976 :
5977 177 : case 'e':
5978 177 : if (match_string_p ("external"))
5979 : d = DECL_EXTERNAL;
5980 : break;
5981 :
5982 27941 : case 'i':
5983 27941 : if (match_string_p ("int"))
5984 : {
5985 27941 : ch = gfc_next_ascii_char ();
5986 27941 : if (ch == 'e')
5987 : {
5988 27935 : if (match_string_p ("nt"))
5989 : {
5990 : /* Matched "intent". */
5991 27934 : d = match_intent_spec ();
5992 27934 : if (d == INTENT_UNKNOWN)
5993 : {
5994 2 : m = MATCH_ERROR;
5995 2 : goto cleanup;
5996 : }
5997 : }
5998 : }
5999 6 : else if (ch == 'r')
6000 : {
6001 6 : if (match_string_p ("insic"))
6002 : {
6003 : /* Matched "intrinsic". */
6004 : d = DECL_INTRINSIC;
6005 : }
6006 : }
6007 : }
6008 : break;
6009 :
6010 293 : case 'k':
6011 293 : if (match_string_p ("kind"))
6012 : d = DECL_KIND;
6013 : break;
6014 :
6015 313 : case 'l':
6016 313 : if (match_string_p ("len"))
6017 : d = DECL_LEN;
6018 : break;
6019 :
6020 5060 : case 'o':
6021 5060 : if (match_string_p ("optional"))
6022 : d = DECL_OPTIONAL;
6023 : break;
6024 :
6025 27109 : case 'p':
6026 27109 : gfc_next_ascii_char ();
6027 27109 : switch (gfc_next_ascii_char ())
6028 : {
6029 14301 : case 'a':
6030 14301 : if (match_string_p ("rameter"))
6031 : {
6032 : /* Matched "parameter". */
6033 : d = DECL_PARAMETER;
6034 : }
6035 : break;
6036 :
6037 12289 : case 'o':
6038 12289 : if (match_string_p ("inter"))
6039 : {
6040 : /* Matched "pointer". */
6041 : d = DECL_POINTER;
6042 : }
6043 : break;
6044 :
6045 267 : case 'r':
6046 267 : ch = gfc_next_ascii_char ();
6047 267 : if (ch == 'i')
6048 : {
6049 216 : if (match_string_p ("vate"))
6050 : {
6051 : /* Matched "private". */
6052 : d = DECL_PRIVATE;
6053 : }
6054 : }
6055 51 : else if (ch == 'o')
6056 : {
6057 51 : if (match_string_p ("tected"))
6058 : {
6059 : /* Matched "protected". */
6060 : d = DECL_PROTECTED;
6061 : }
6062 : }
6063 : break;
6064 :
6065 252 : case 'u':
6066 252 : if (match_string_p ("blic"))
6067 : {
6068 : /* Matched "public". */
6069 : d = DECL_PUBLIC;
6070 : }
6071 : break;
6072 : }
6073 : break;
6074 :
6075 1216 : case 's':
6076 1216 : gfc_next_ascii_char ();
6077 1216 : switch (gfc_next_ascii_char ())
6078 : {
6079 1203 : case 'a':
6080 1203 : if (match_string_p ("ve"))
6081 : {
6082 : /* Matched "save". */
6083 : d = DECL_SAVE;
6084 : }
6085 : break;
6086 :
6087 13 : case 't':
6088 13 : if (match_string_p ("atic"))
6089 : {
6090 : /* Matched "static". */
6091 : d = DECL_STATIC;
6092 : }
6093 : break;
6094 : }
6095 : break;
6096 :
6097 5367 : case 't':
6098 5367 : if (match_string_p ("target"))
6099 : d = DECL_TARGET;
6100 : break;
6101 :
6102 11130 : case 'v':
6103 11130 : gfc_next_ascii_char ();
6104 11130 : ch = gfc_next_ascii_char ();
6105 11130 : if (ch == 'a')
6106 : {
6107 10621 : if (match_string_p ("lue"))
6108 : {
6109 : /* Matched "value". */
6110 : d = DECL_VALUE;
6111 : }
6112 : }
6113 509 : else if (ch == 'o')
6114 : {
6115 509 : if (match_string_p ("latile"))
6116 : {
6117 : /* Matched "volatile". */
6118 : d = DECL_VOLATILE;
6119 : }
6120 : }
6121 : break;
6122 : }
6123 : }
6124 :
6125 : /* No double colon and no recognizable decl_type, so assume that
6126 : we've been looking at something else the whole time. */
6127 : if (d == DECL_NONE)
6128 : {
6129 33823 : m = MATCH_NO;
6130 33823 : goto cleanup;
6131 : }
6132 :
6133 : /* Check to make sure any parens are paired up correctly. */
6134 119070 : if (gfc_match_parens () == MATCH_ERROR)
6135 : {
6136 1 : m = MATCH_ERROR;
6137 1 : goto cleanup;
6138 : }
6139 :
6140 119069 : seen[d]++;
6141 119069 : seen_at[d] = gfc_current_locus;
6142 :
6143 119069 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6144 : {
6145 19746 : gfc_array_spec *as = NULL;
6146 :
6147 19746 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6148 : d == DECL_CODIMENSION);
6149 :
6150 19746 : if (current_as == NULL)
6151 19721 : current_as = as;
6152 25 : else if (m == MATCH_YES)
6153 : {
6154 25 : if (!merge_array_spec (as, current_as, false))
6155 2 : m = MATCH_ERROR;
6156 25 : free (as);
6157 : }
6158 :
6159 19746 : if (m == MATCH_NO)
6160 : {
6161 0 : if (d == DECL_CODIMENSION)
6162 0 : gfc_error ("Missing codimension specification at %C");
6163 : else
6164 0 : gfc_error ("Missing dimension specification at %C");
6165 : m = MATCH_ERROR;
6166 : }
6167 :
6168 19746 : if (m == MATCH_ERROR)
6169 7 : goto cleanup;
6170 : }
6171 : }
6172 :
6173 : /* Since we've seen a double colon, we have to be looking at an
6174 : attr-spec. This means that we can now issue errors. */
6175 4960149 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6176 4776441 : if (seen[d] > 1)
6177 : {
6178 2 : switch (d)
6179 : {
6180 : case DECL_ALLOCATABLE:
6181 : attr = "ALLOCATABLE";
6182 : break;
6183 0 : case DECL_ASYNCHRONOUS:
6184 0 : attr = "ASYNCHRONOUS";
6185 0 : break;
6186 0 : case DECL_CODIMENSION:
6187 0 : attr = "CODIMENSION";
6188 0 : break;
6189 0 : case DECL_CONTIGUOUS:
6190 0 : attr = "CONTIGUOUS";
6191 0 : break;
6192 0 : case DECL_DIMENSION:
6193 0 : attr = "DIMENSION";
6194 0 : break;
6195 0 : case DECL_EXTERNAL:
6196 0 : attr = "EXTERNAL";
6197 0 : break;
6198 0 : case DECL_IN:
6199 0 : attr = "INTENT (IN)";
6200 0 : break;
6201 0 : case DECL_OUT:
6202 0 : attr = "INTENT (OUT)";
6203 0 : break;
6204 0 : case DECL_INOUT:
6205 0 : attr = "INTENT (IN OUT)";
6206 0 : break;
6207 0 : case DECL_INTRINSIC:
6208 0 : attr = "INTRINSIC";
6209 0 : break;
6210 0 : case DECL_OPTIONAL:
6211 0 : attr = "OPTIONAL";
6212 0 : break;
6213 0 : case DECL_KIND:
6214 0 : attr = "KIND";
6215 0 : break;
6216 0 : case DECL_LEN:
6217 0 : attr = "LEN";
6218 0 : break;
6219 0 : case DECL_PARAMETER:
6220 0 : attr = "PARAMETER";
6221 0 : break;
6222 0 : case DECL_POINTER:
6223 0 : attr = "POINTER";
6224 0 : break;
6225 0 : case DECL_PROTECTED:
6226 0 : attr = "PROTECTED";
6227 0 : break;
6228 0 : case DECL_PRIVATE:
6229 0 : attr = "PRIVATE";
6230 0 : break;
6231 0 : case DECL_PUBLIC:
6232 0 : attr = "PUBLIC";
6233 0 : break;
6234 0 : case DECL_SAVE:
6235 0 : attr = "SAVE";
6236 0 : break;
6237 0 : case DECL_STATIC:
6238 0 : attr = "STATIC";
6239 0 : break;
6240 1 : case DECL_AUTOMATIC:
6241 1 : attr = "AUTOMATIC";
6242 1 : break;
6243 0 : case DECL_TARGET:
6244 0 : attr = "TARGET";
6245 0 : break;
6246 0 : case DECL_IS_BIND_C:
6247 0 : attr = "IS_BIND_C";
6248 0 : break;
6249 0 : case DECL_VALUE:
6250 0 : attr = "VALUE";
6251 0 : break;
6252 1 : case DECL_VOLATILE:
6253 1 : attr = "VOLATILE";
6254 1 : break;
6255 0 : default:
6256 0 : attr = NULL; /* This shouldn't happen. */
6257 : }
6258 :
6259 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6260 2 : m = MATCH_ERROR;
6261 2 : goto cleanup;
6262 : }
6263 :
6264 : /* Now that we've dealt with duplicate attributes, add the attributes
6265 : to the current attribute. */
6266 4959329 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6267 : {
6268 4775694 : if (seen[d] == 0)
6269 4656641 : continue;
6270 : else
6271 119053 : attr_seen = 1;
6272 :
6273 119053 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6274 52 : && !flag_dec_static)
6275 : {
6276 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6277 : "%<-fdec-static%>",
6278 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6279 2 : m = MATCH_ERROR;
6280 2 : goto cleanup;
6281 : }
6282 : /* Allow SAVE with STATIC, but don't complain. */
6283 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6284 0 : continue;
6285 :
6286 119051 : if (gfc_comp_struct (gfc_current_state ())
6287 6881 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6288 5917 : && d != DECL_POINTER && d != DECL_PRIVATE
6289 4227 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6290 : {
6291 4170 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6292 4170 : if (d == DECL_ALLOCATABLE)
6293 : {
6294 3551 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6295 : ? G_("ALLOCATABLE attribute at %C in a "
6296 : "TYPE definition")
6297 : : G_("ALLOCATABLE attribute at %C in a "
6298 : "STRUCTURE definition")))
6299 : {
6300 2 : m = MATCH_ERROR;
6301 2 : goto cleanup;
6302 : }
6303 : }
6304 619 : else if (d == DECL_KIND)
6305 : {
6306 291 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6307 : ? G_("KIND attribute at %C in a "
6308 : "TYPE definition")
6309 : : G_("KIND attribute at %C in a "
6310 : "STRUCTURE definition")))
6311 : {
6312 1 : m = MATCH_ERROR;
6313 1 : goto cleanup;
6314 : }
6315 290 : if (current_ts.type != BT_INTEGER)
6316 : {
6317 2 : gfc_error ("Component with KIND attribute at %C must be "
6318 : "INTEGER");
6319 2 : m = MATCH_ERROR;
6320 2 : goto cleanup;
6321 : }
6322 : }
6323 328 : else if (d == DECL_LEN)
6324 : {
6325 312 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6326 : ? G_("LEN attribute at %C in a "
6327 : "TYPE definition")
6328 : : G_("LEN attribute at %C in a "
6329 : "STRUCTURE definition")))
6330 : {
6331 0 : m = MATCH_ERROR;
6332 0 : goto cleanup;
6333 : }
6334 312 : if (current_ts.type != BT_INTEGER)
6335 : {
6336 1 : gfc_error ("Component with LEN attribute at %C must be "
6337 : "INTEGER");
6338 1 : m = MATCH_ERROR;
6339 1 : goto cleanup;
6340 : }
6341 : }
6342 : else
6343 : {
6344 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6345 : "TYPE definition")
6346 : : G_("Attribute at %L is not allowed in a "
6347 : "STRUCTURE definition"), &seen_at[d]);
6348 16 : m = MATCH_ERROR;
6349 16 : goto cleanup;
6350 : }
6351 : }
6352 :
6353 119029 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6354 468 : && gfc_current_state () != COMP_MODULE)
6355 : {
6356 147 : if (d == DECL_PRIVATE)
6357 : attr = "PRIVATE";
6358 : else
6359 43 : attr = "PUBLIC";
6360 147 : if (gfc_current_state () == COMP_DERIVED
6361 141 : && gfc_state_stack->previous
6362 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6363 : {
6364 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6365 : "at %L in a TYPE definition", attr,
6366 : &seen_at[d]))
6367 : {
6368 2 : m = MATCH_ERROR;
6369 2 : goto cleanup;
6370 : }
6371 : }
6372 : else
6373 : {
6374 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6375 : "specification part of a module", attr, &seen_at[d]);
6376 9 : m = MATCH_ERROR;
6377 9 : goto cleanup;
6378 : }
6379 : }
6380 :
6381 119018 : if (gfc_current_state () != COMP_DERIVED
6382 112168 : && (d == DECL_KIND || d == DECL_LEN))
6383 : {
6384 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6385 : "definition", &seen_at[d]);
6386 3 : m = MATCH_ERROR;
6387 3 : goto cleanup;
6388 : }
6389 :
6390 119015 : switch (d)
6391 : {
6392 18394 : case DECL_ALLOCATABLE:
6393 18394 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6394 18394 : break;
6395 :
6396 24 : case DECL_ASYNCHRONOUS:
6397 24 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6398 : t = false;
6399 : else
6400 24 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6401 : break;
6402 :
6403 66 : case DECL_CODIMENSION:
6404 66 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6405 66 : break;
6406 :
6407 2095 : case DECL_CONTIGUOUS:
6408 2095 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6409 : t = false;
6410 : else
6411 2094 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6412 : break;
6413 :
6414 19671 : case DECL_DIMENSION:
6415 19671 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6416 19671 : break;
6417 :
6418 176 : case DECL_EXTERNAL:
6419 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6420 176 : break;
6421 :
6422 21087 : case DECL_IN:
6423 21087 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6424 21087 : break;
6425 :
6426 3683 : case DECL_OUT:
6427 3683 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6428 3683 : break;
6429 :
6430 3158 : case DECL_INOUT:
6431 3158 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6432 3158 : break;
6433 :
6434 5 : case DECL_INTRINSIC:
6435 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6436 5 : break;
6437 :
6438 5059 : case DECL_OPTIONAL:
6439 5059 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6440 5059 : break;
6441 :
6442 288 : case DECL_KIND:
6443 288 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6444 288 : break;
6445 :
6446 311 : case DECL_LEN:
6447 311 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6448 311 : break;
6449 :
6450 14300 : case DECL_PARAMETER:
6451 14300 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6452 14300 : break;
6453 :
6454 12288 : case DECL_POINTER:
6455 12288 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6456 12288 : break;
6457 :
6458 50 : case DECL_PROTECTED:
6459 50 : if (gfc_current_state () != COMP_MODULE
6460 48 : || (gfc_current_ns->proc_name
6461 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6462 : {
6463 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6464 : "part of a module");
6465 2 : t = false;
6466 2 : break;
6467 : }
6468 :
6469 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6470 : t = false;
6471 : else
6472 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6473 : break;
6474 :
6475 213 : case DECL_PRIVATE:
6476 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6477 : &seen_at[d]);
6478 213 : break;
6479 :
6480 244 : case DECL_PUBLIC:
6481 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6482 : &seen_at[d]);
6483 244 : break;
6484 :
6485 1213 : case DECL_STATIC:
6486 1213 : case DECL_SAVE:
6487 1213 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6488 1213 : break;
6489 :
6490 37 : case DECL_AUTOMATIC:
6491 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6492 37 : break;
6493 :
6494 5365 : case DECL_TARGET:
6495 5365 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6496 5365 : break;
6497 :
6498 162 : case DECL_IS_BIND_C:
6499 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6500 162 : break;
6501 :
6502 10620 : case DECL_VALUE:
6503 10620 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6504 : t = false;
6505 : else
6506 10620 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6507 : break;
6508 :
6509 506 : case DECL_VOLATILE:
6510 506 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6511 : t = false;
6512 : else
6513 505 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6514 : break;
6515 :
6516 0 : default:
6517 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6518 : }
6519 :
6520 119009 : if (!t)
6521 : {
6522 35 : m = MATCH_ERROR;
6523 35 : goto cleanup;
6524 : }
6525 : }
6526 :
6527 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6528 183635 : if ((gfc_current_state () == COMP_MODULE
6529 183635 : || gfc_current_state () == COMP_SUBMODULE)
6530 5787 : && !current_attr.save
6531 5605 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6532 5513 : current_attr.save = SAVE_IMPLICIT;
6533 :
6534 183635 : colon_seen = 1;
6535 183635 : return MATCH_YES;
6536 :
6537 33908 : cleanup:
6538 33908 : gfc_current_locus = start;
6539 33908 : gfc_free_array_spec (current_as);
6540 33908 : current_as = NULL;
6541 33908 : attr_seen = 0;
6542 33908 : return m;
6543 : }
6544 :
6545 :
6546 : /* Set the binding label, dest_label, either with the binding label
6547 : stored in the given gfc_typespec, ts, or if none was provided, it
6548 : will be the symbol name in all lower case, as required by the draft
6549 : (J3/04-007, section 15.4.1). If a binding label was given and
6550 : there is more than one argument (num_idents), it is an error. */
6551 :
6552 : static bool
6553 346 : set_binding_label (const char **dest_label, const char *sym_name,
6554 : int num_idents)
6555 : {
6556 346 : if (num_idents > 1 && has_name_equals)
6557 : {
6558 4 : gfc_error ("Multiple identifiers provided with "
6559 : "single NAME= specifier at %C");
6560 4 : return false;
6561 : }
6562 :
6563 342 : if (curr_binding_label)
6564 : /* Binding label given; store in temp holder till have sym. */
6565 107 : *dest_label = curr_binding_label;
6566 : else
6567 : {
6568 : /* No binding label given, and the NAME= specifier did not exist,
6569 : which means there was no NAME="". */
6570 235 : if (sym_name != NULL && has_name_equals == 0)
6571 205 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6572 : }
6573 :
6574 : return true;
6575 : }
6576 :
6577 :
6578 : /* Set the status of the given common block as being BIND(C) or not,
6579 : depending on the given parameter, is_bind_c. */
6580 :
6581 : static void
6582 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6583 : {
6584 76 : com_block->is_bind_c = is_bind_c;
6585 76 : return;
6586 : }
6587 :
6588 :
6589 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6590 :
6591 : bool
6592 21416 : gfc_verify_c_interop (gfc_typespec *ts)
6593 : {
6594 21416 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6595 4336 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6596 8629 : ? true : false;
6597 17096 : else if (ts->type == BT_CLASS)
6598 : return false;
6599 17088 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6600 3983 : return false;
6601 :
6602 : return true;
6603 : }
6604 :
6605 :
6606 : /* Verify that the variables of a given common block, which has been
6607 : defined with the attribute specifier bind(c), to be of a C
6608 : interoperable type. Errors will be reported here, if
6609 : encountered. */
6610 :
6611 : bool
6612 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6613 : {
6614 1 : gfc_symbol *curr_sym = NULL;
6615 1 : bool retval = true;
6616 :
6617 1 : curr_sym = com_block->head;
6618 :
6619 : /* Make sure we have at least one symbol. */
6620 1 : if (curr_sym == NULL)
6621 : return retval;
6622 :
6623 : /* Here we know we have a symbol, so we'll execute this loop
6624 : at least once. */
6625 1 : do
6626 : {
6627 : /* The second to last param, 1, says this is in a common block. */
6628 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6629 1 : curr_sym = curr_sym->common_next;
6630 1 : } while (curr_sym != NULL);
6631 :
6632 : return retval;
6633 : }
6634 :
6635 :
6636 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6637 : an appropriate error message is reported. */
6638 :
6639 : bool
6640 7395 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6641 : int is_in_common, gfc_common_head *com_block)
6642 : {
6643 7395 : bool bind_c_function = false;
6644 7395 : bool retval = true;
6645 :
6646 7395 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6647 7395 : bind_c_function = true;
6648 :
6649 7395 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6650 : {
6651 3149 : tmp_sym = tmp_sym->result;
6652 : /* Make sure it wasn't an implicitly typed result. */
6653 3149 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6654 : {
6655 1 : gfc_warning (OPT_Wc_binding_type,
6656 : "Implicitly declared BIND(C) function %qs at "
6657 : "%L may not be C interoperable", tmp_sym->name,
6658 : &tmp_sym->declared_at);
6659 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6660 : /* Mark it as C interoperable to prevent duplicate warnings. */
6661 1 : tmp_sym->ts.is_c_interop = 1;
6662 1 : tmp_sym->attr.is_c_interop = 1;
6663 : }
6664 : }
6665 :
6666 : /* Here, we know we have the bind(c) attribute, so if we have
6667 : enough type info, then verify that it's a C interop kind.
6668 : The info could be in the symbol already, or possibly still in
6669 : the given ts (current_ts), so look in both. */
6670 7395 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6671 : {
6672 3307 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6673 : {
6674 : /* See if we're dealing with a sym in a common block or not. */
6675 237 : if (is_in_common == 1 && warn_c_binding_type)
6676 : {
6677 0 : gfc_warning (OPT_Wc_binding_type,
6678 : "Variable %qs in common block %qs at %L "
6679 : "may not be a C interoperable "
6680 : "kind though common block %qs is BIND(C)",
6681 : tmp_sym->name, com_block->name,
6682 0 : &(tmp_sym->declared_at), com_block->name);
6683 : }
6684 : else
6685 : {
6686 237 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6687 235 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6688 : {
6689 3 : gfc_error ("Type declaration %qs at %L is not C "
6690 : "interoperable but it is BIND(C)",
6691 : tmp_sym->name, &(tmp_sym->declared_at));
6692 3 : retval = false;
6693 : }
6694 234 : else if (warn_c_binding_type)
6695 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6696 : "may not be a C interoperable "
6697 : "kind but it is BIND(C)",
6698 : tmp_sym->name, &(tmp_sym->declared_at));
6699 : }
6700 : }
6701 :
6702 : /* Variables declared w/in a common block can't be bind(c)
6703 : since there's no way for C to see these variables, so there's
6704 : semantically no reason for the attribute. */
6705 3307 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6706 : {
6707 1 : gfc_error ("Variable %qs in common block %qs at "
6708 : "%L cannot be declared with BIND(C) "
6709 : "since it is not a global",
6710 1 : tmp_sym->name, com_block->name,
6711 : &(tmp_sym->declared_at));
6712 1 : retval = false;
6713 : }
6714 :
6715 : /* Scalar variables that are bind(c) cannot have the pointer
6716 : or allocatable attributes. */
6717 3307 : if (tmp_sym->attr.is_bind_c == 1)
6718 : {
6719 2769 : if (tmp_sym->attr.pointer == 1)
6720 : {
6721 1 : gfc_error ("Variable %qs at %L cannot have both the "
6722 : "POINTER and BIND(C) attributes",
6723 : tmp_sym->name, &(tmp_sym->declared_at));
6724 1 : retval = false;
6725 : }
6726 :
6727 2769 : if (tmp_sym->attr.allocatable == 1)
6728 : {
6729 0 : gfc_error ("Variable %qs at %L cannot have both the "
6730 : "ALLOCATABLE and BIND(C) attributes",
6731 : tmp_sym->name, &(tmp_sym->declared_at));
6732 0 : retval = false;
6733 : }
6734 :
6735 : }
6736 :
6737 : /* If it is a BIND(C) function, make sure the return value is a
6738 : scalar value. The previous tests in this function made sure
6739 : the type is interoperable. */
6740 3307 : if (bind_c_function && tmp_sym->as != NULL)
6741 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6742 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6743 :
6744 : /* BIND(C) functions cannot return a character string. */
6745 3149 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6746 116 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6747 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6748 : "type at %L must have length 1", tmp_sym->name,
6749 : &(tmp_sym->declared_at));
6750 : }
6751 :
6752 : /* See if the symbol has been marked as private. If it has, warn if
6753 : there is a binding label with default binding name. */
6754 7395 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6755 11 : && tmp_sym->binding_label
6756 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6757 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6758 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6759 4 : gfc_warning (OPT_Wsurprising,
6760 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6761 : "via its default binding name %qs", tmp_sym->name,
6762 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6763 :
6764 7395 : return retval;
6765 : }
6766 :
6767 :
6768 : /* Set the appropriate fields for a symbol that's been declared as
6769 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6770 : the type is C interoperable. Errors are reported by the functions
6771 : used to set/test these fields. */
6772 :
6773 : static bool
6774 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6775 : {
6776 47 : bool retval = true;
6777 :
6778 : /* TODO: Do we need to make sure the vars aren't marked private? */
6779 :
6780 : /* Set the is_bind_c bit in symbol_attribute. */
6781 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6782 :
6783 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6784 : return false;
6785 :
6786 : return retval;
6787 : }
6788 :
6789 :
6790 : /* Set the fields marking the given common block as BIND(C), including
6791 : a binding label, and report any errors encountered. */
6792 :
6793 : static bool
6794 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6795 : {
6796 76 : bool retval = true;
6797 :
6798 : /* destLabel, common name, typespec (which may have binding label). */
6799 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6800 : num_idents))
6801 : return false;
6802 :
6803 : /* Set the given common block (com_block) to being bind(c) (1). */
6804 76 : set_com_block_bind_c (com_block, 1);
6805 :
6806 76 : return retval;
6807 : }
6808 :
6809 :
6810 : /* Retrieve the list of one or more identifiers that the given bind(c)
6811 : attribute applies to. */
6812 :
6813 : static bool
6814 102 : get_bind_c_idents (void)
6815 : {
6816 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6817 102 : int num_idents = 0;
6818 102 : gfc_symbol *tmp_sym = NULL;
6819 102 : match found_id;
6820 102 : gfc_common_head *com_block = NULL;
6821 :
6822 102 : if (gfc_match_name (name) == MATCH_YES)
6823 : {
6824 38 : found_id = MATCH_YES;
6825 38 : gfc_get_ha_symbol (name, &tmp_sym);
6826 : }
6827 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6828 : {
6829 64 : found_id = MATCH_YES;
6830 64 : com_block = gfc_get_common (name, 0);
6831 : }
6832 : else
6833 : {
6834 0 : gfc_error ("Need either entity or common block name for "
6835 : "attribute specification statement at %C");
6836 0 : return false;
6837 : }
6838 :
6839 : /* Save the current identifier and look for more. */
6840 123 : do
6841 : {
6842 : /* Increment the number of identifiers found for this spec stmt. */
6843 123 : num_idents++;
6844 :
6845 : /* Make sure we have a sym or com block, and verify that it can
6846 : be bind(c). Set the appropriate field(s) and look for more
6847 : identifiers. */
6848 123 : if (tmp_sym != NULL || com_block != NULL)
6849 : {
6850 123 : if (tmp_sym != NULL)
6851 : {
6852 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6853 : return false;
6854 : }
6855 : else
6856 : {
6857 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6858 : return false;
6859 : }
6860 :
6861 : /* Look to see if we have another identifier. */
6862 122 : tmp_sym = NULL;
6863 122 : if (gfc_match_eos () == MATCH_YES)
6864 : found_id = MATCH_NO;
6865 21 : else if (gfc_match_char (',') != MATCH_YES)
6866 : found_id = MATCH_NO;
6867 21 : else if (gfc_match_name (name) == MATCH_YES)
6868 : {
6869 9 : found_id = MATCH_YES;
6870 9 : gfc_get_ha_symbol (name, &tmp_sym);
6871 : }
6872 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6873 : {
6874 12 : found_id = MATCH_YES;
6875 12 : com_block = gfc_get_common (name, 0);
6876 : }
6877 : else
6878 : {
6879 0 : gfc_error ("Missing entity or common block name for "
6880 : "attribute specification statement at %C");
6881 0 : return false;
6882 : }
6883 : }
6884 : else
6885 : {
6886 0 : gfc_internal_error ("Missing symbol");
6887 : }
6888 122 : } while (found_id == MATCH_YES);
6889 :
6890 : /* if we get here we were successful */
6891 : return true;
6892 : }
6893 :
6894 :
6895 : /* Try and match a BIND(C) attribute specification statement. */
6896 :
6897 : match
6898 140 : gfc_match_bind_c_stmt (void)
6899 : {
6900 140 : match found_match = MATCH_NO;
6901 140 : gfc_typespec *ts;
6902 :
6903 140 : ts = ¤t_ts;
6904 :
6905 : /* This may not be necessary. */
6906 140 : gfc_clear_ts (ts);
6907 : /* Clear the temporary binding label holder. */
6908 140 : curr_binding_label = NULL;
6909 :
6910 : /* Look for the bind(c). */
6911 140 : found_match = gfc_match_bind_c (NULL, true);
6912 :
6913 140 : if (found_match == MATCH_YES)
6914 : {
6915 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6916 : return MATCH_ERROR;
6917 :
6918 : /* Look for the :: now, but it is not required. */
6919 102 : gfc_match (" :: ");
6920 :
6921 : /* Get the identifier(s) that needs to be updated. This may need to
6922 : change to hand the flag(s) for the attr specified so all identifiers
6923 : found can have all appropriate parts updated (assuming that the same
6924 : spec stmt can have multiple attrs, such as both bind(c) and
6925 : allocatable...). */
6926 102 : if (!get_bind_c_idents ())
6927 : /* Error message should have printed already. */
6928 : return MATCH_ERROR;
6929 : }
6930 :
6931 : return found_match;
6932 : }
6933 :
6934 :
6935 : /* Match a data declaration statement. */
6936 :
6937 : match
6938 1026263 : gfc_match_data_decl (void)
6939 : {
6940 1026263 : gfc_symbol *sym;
6941 1026263 : match m;
6942 1026263 : int elem;
6943 1026263 : gfc_component *comp_tail = NULL;
6944 :
6945 1026263 : type_param_spec_list = NULL;
6946 1026263 : decl_type_param_list = NULL;
6947 :
6948 1026263 : num_idents_on_line = 0;
6949 :
6950 : /* Record the last component before we start, so that we can roll back
6951 : any components added during this statement on error. PR106946.
6952 : Must be set before any 'goto cleanup' with m == MATCH_ERROR. */
6953 1026263 : if (gfc_comp_struct (gfc_current_state ()))
6954 : {
6955 31781 : gfc_symbol *block = gfc_current_block ();
6956 31781 : if (block)
6957 : {
6958 31781 : comp_tail = block->components;
6959 31781 : if (comp_tail)
6960 33059 : while (comp_tail->next)
6961 : comp_tail = comp_tail->next;
6962 : }
6963 : }
6964 :
6965 1026263 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6966 1026263 : if (m != MATCH_YES)
6967 : return m;
6968 :
6969 216376 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6970 35079 : && !gfc_comp_struct (gfc_current_state ()))
6971 : {
6972 31711 : sym = gfc_use_derived (current_ts.u.derived);
6973 :
6974 31711 : if (sym == NULL)
6975 : {
6976 22 : m = MATCH_ERROR;
6977 22 : goto cleanup;
6978 : }
6979 :
6980 31689 : current_ts.u.derived = sym;
6981 : }
6982 :
6983 216354 : m = match_attr_spec ();
6984 216354 : if (m == MATCH_ERROR)
6985 : {
6986 84 : m = MATCH_NO;
6987 84 : goto cleanup;
6988 : }
6989 :
6990 : /* F2018:C708. */
6991 216270 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6992 : {
6993 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6994 6 : m = MATCH_ERROR;
6995 6 : goto cleanup;
6996 : }
6997 :
6998 216264 : if (current_ts.type == BT_CLASS
6999 10912 : && current_ts.u.derived->attr.unlimited_polymorphic)
7000 1912 : goto ok;
7001 :
7002 214352 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
7003 33138 : && current_ts.u.derived->components == NULL
7004 2820 : && !current_ts.u.derived->attr.zero_comp)
7005 : {
7006 :
7007 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
7008 136 : goto ok;
7009 :
7010 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
7011 47 : goto ok;
7012 :
7013 27 : gfc_find_symbol (current_ts.u.derived->name,
7014 27 : current_ts.u.derived->ns, 1, &sym);
7015 :
7016 : /* Any symbol that we find had better be a type definition
7017 : which has its components defined, or be a structure definition
7018 : actively being parsed. */
7019 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
7020 26 : && (current_ts.u.derived->components != NULL
7021 26 : || current_ts.u.derived->attr.zero_comp
7022 26 : || current_ts.u.derived == gfc_new_block))
7023 26 : goto ok;
7024 :
7025 1 : gfc_error ("Derived type at %C has not been previously defined "
7026 : "and so cannot appear in a derived type definition");
7027 1 : m = MATCH_ERROR;
7028 1 : goto cleanup;
7029 : }
7030 :
7031 214142 : ok:
7032 : /* If we have an old-style character declaration, and no new-style
7033 : attribute specifications, then there a comma is optional between
7034 : the type specification and the variable list. */
7035 216263 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
7036 1407 : gfc_match_char (',');
7037 :
7038 : /* Give the types/attributes to symbols that follow. Give the element
7039 : a number so that repeat character length expressions can be copied. */
7040 : elem = 1;
7041 281472 : for (;;)
7042 : {
7043 281472 : num_idents_on_line++;
7044 281472 : m = variable_decl (elem++);
7045 281470 : if (m == MATCH_ERROR)
7046 415 : goto cleanup;
7047 281055 : if (m == MATCH_NO)
7048 : break;
7049 :
7050 281044 : if (gfc_match_eos () == MATCH_YES)
7051 215811 : goto cleanup;
7052 65233 : if (gfc_match_char (',') != MATCH_YES)
7053 : break;
7054 : }
7055 :
7056 35 : if (!gfc_error_flag_test ())
7057 : {
7058 : /* An anonymous structure declaration is unambiguous; if we matched one
7059 : according to gfc_match_structure_decl, we need to return MATCH_YES
7060 : here to avoid confusing the remaining matchers, even if there was an
7061 : error during variable_decl. We must flush any such errors. Note this
7062 : causes the parser to gracefully continue parsing the remaining input
7063 : as a structure body, which likely follows. */
7064 11 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
7065 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
7066 : {
7067 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
7068 : " at %C");
7069 : /* Skip the bad variable_decl and line up for the start of the
7070 : structure body. */
7071 1 : gfc_error_recovery ();
7072 1 : m = MATCH_YES;
7073 1 : goto cleanup;
7074 : }
7075 :
7076 10 : gfc_error ("Syntax error in data declaration at %C");
7077 : }
7078 :
7079 34 : m = MATCH_ERROR;
7080 :
7081 34 : gfc_free_data_all (gfc_current_ns);
7082 :
7083 216374 : cleanup:
7084 : /* If we failed inside a derived type definition, remove any CLASS
7085 : components that were added during this failed statement. For CLASS
7086 : components, gfc_build_class_symbol creates an extra container symbol in
7087 : the namespace outside the normal undo machinery. When reject_statement
7088 : later calls gfc_undo_symbols, the declaration state is rolled back but
7089 : that helper symbol survives and leaves the component dangling. Ordinary
7090 : components do not create that extra helper symbol, so leave them in
7091 : place for the usual follow-up diagnostics. PR106946.
7092 :
7093 : CLASS containers are shared between components of the same class type
7094 : and attributes (gfc_build_class_symbol reuses existing containers).
7095 : We must not free a container that is still referenced by a previously
7096 : committed component. Unlink and free the components first, then clean
7097 : up only orphaned containers. PR124482. */
7098 216374 : if (m == MATCH_ERROR && gfc_comp_struct (gfc_current_state ()))
7099 : {
7100 86 : gfc_symbol *block = gfc_current_block ();
7101 86 : if (block)
7102 : {
7103 86 : gfc_component **prev;
7104 86 : if (comp_tail)
7105 43 : prev = &comp_tail->next;
7106 : else
7107 43 : prev = &block->components;
7108 :
7109 : /* Record the CLASS container from the removed components.
7110 : Normally all components in one declaration share a single
7111 : container, but per-variable array specs can produce
7112 : additional ones; any beyond the first are harmlessly
7113 : leaked until namespace destruction. */
7114 86 : gfc_symbol *fclass_container = NULL;
7115 :
7116 120 : while (*prev)
7117 : {
7118 34 : gfc_component *c = *prev;
7119 34 : if (c->ts.type == BT_CLASS && c->ts.u.derived
7120 6 : && c->ts.u.derived->attr.is_class)
7121 : {
7122 3 : *prev = c->next;
7123 3 : if (!fclass_container)
7124 3 : fclass_container = c->ts.u.derived;
7125 3 : c->ts.u.derived = NULL;
7126 3 : gfc_free_component (c);
7127 : }
7128 : else
7129 31 : prev = &c->next;
7130 : }
7131 :
7132 : /* Free the container only if no remaining component still
7133 : references it. CLASS containers are shared between
7134 : components of the same class type and attributes
7135 : (gfc_build_class_symbol reuses existing ones). */
7136 86 : if (fclass_container)
7137 : {
7138 3 : bool shared = false;
7139 3 : for (gfc_component *q = block->components; q; q = q->next)
7140 1 : if (q->ts.type == BT_CLASS
7141 1 : && q->ts.u.derived == fclass_container)
7142 : {
7143 : shared = true;
7144 : break;
7145 : }
7146 3 : if (!shared)
7147 : {
7148 2 : if (gfc_find_symtree (fclass_container->ns->sym_root,
7149 : fclass_container->name))
7150 2 : gfc_delete_symtree (&fclass_container->ns->sym_root,
7151 : fclass_container->name);
7152 2 : gfc_release_symbol (fclass_container);
7153 : }
7154 : }
7155 : }
7156 : }
7157 :
7158 216374 : if (saved_kind_expr)
7159 180 : gfc_free_expr (saved_kind_expr);
7160 216374 : if (type_param_spec_list)
7161 985 : gfc_free_actual_arglist (type_param_spec_list);
7162 216374 : if (decl_type_param_list)
7163 942 : gfc_free_actual_arglist (decl_type_param_list);
7164 216374 : saved_kind_expr = NULL;
7165 216374 : gfc_free_array_spec (current_as);
7166 216374 : current_as = NULL;
7167 216374 : return m;
7168 : }
7169 :
7170 : static bool
7171 24543 : in_module_or_interface(void)
7172 : {
7173 24543 : if (gfc_current_state () == COMP_MODULE
7174 24543 : || gfc_current_state () == COMP_SUBMODULE
7175 24543 : || gfc_current_state () == COMP_INTERFACE)
7176 : return true;
7177 :
7178 20538 : if (gfc_state_stack->state == COMP_CONTAINS
7179 19658 : || gfc_state_stack->state == COMP_FUNCTION
7180 19552 : || gfc_state_stack->state == COMP_SUBROUTINE)
7181 : {
7182 986 : gfc_state_data *p;
7183 1030 : for (p = gfc_state_stack->previous; p ; p = p->previous)
7184 : {
7185 1026 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
7186 118 : || p->state == COMP_INTERFACE)
7187 : return true;
7188 : }
7189 : }
7190 : return false;
7191 : }
7192 :
7193 : /* Match a prefix associated with a function or subroutine
7194 : declaration. If the typespec pointer is nonnull, then a typespec
7195 : can be matched. Note that if nothing matches, MATCH_YES is
7196 : returned (the null string was matched). */
7197 :
7198 : match
7199 242901 : gfc_match_prefix (gfc_typespec *ts)
7200 : {
7201 242901 : bool seen_type;
7202 242901 : bool seen_impure;
7203 242901 : bool found_prefix;
7204 :
7205 242901 : gfc_clear_attr (¤t_attr);
7206 242901 : seen_type = false;
7207 242901 : seen_impure = false;
7208 :
7209 242901 : gcc_assert (!gfc_matching_prefix);
7210 242901 : gfc_matching_prefix = true;
7211 :
7212 252812 : do
7213 : {
7214 272668 : found_prefix = false;
7215 :
7216 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7217 : corresponding attribute seems natural and distinguishes these
7218 : procedures from procedure types of PROC_MODULE, which these are
7219 : as well. */
7220 272668 : if (gfc_match ("module% ") == MATCH_YES)
7221 : {
7222 24818 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7223 275 : goto error;
7224 :
7225 24543 : if (!in_module_or_interface ())
7226 : {
7227 19556 : gfc_error ("MODULE prefix at %C found outside of a module, "
7228 : "submodule, or interface");
7229 19556 : goto error;
7230 : }
7231 :
7232 4987 : current_attr.module_procedure = 1;
7233 4987 : found_prefix = true;
7234 : }
7235 :
7236 252837 : if (!seen_type && ts != NULL)
7237 : {
7238 136239 : match m;
7239 136239 : m = gfc_match_decl_type_spec (ts, 0);
7240 136239 : if (m == MATCH_ERROR)
7241 15 : goto error;
7242 136224 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7243 : {
7244 : seen_type = true;
7245 : found_prefix = true;
7246 : }
7247 : }
7248 :
7249 252822 : if (gfc_match ("elemental% ") == MATCH_YES)
7250 : {
7251 5377 : if (!gfc_add_elemental (¤t_attr, NULL))
7252 2 : goto error;
7253 :
7254 : found_prefix = true;
7255 : }
7256 :
7257 252820 : if (gfc_match ("pure% ") == MATCH_YES)
7258 : {
7259 2448 : if (!gfc_add_pure (¤t_attr, NULL))
7260 2 : goto error;
7261 :
7262 : found_prefix = true;
7263 : }
7264 :
7265 252818 : if (gfc_match ("recursive% ") == MATCH_YES)
7266 : {
7267 469 : if (!gfc_add_recursive (¤t_attr, NULL))
7268 2 : goto error;
7269 :
7270 : found_prefix = true;
7271 : }
7272 :
7273 : /* IMPURE is a somewhat special case, as it needs not set an actual
7274 : attribute but rather only prevents ELEMENTAL routines from being
7275 : automatically PURE. */
7276 252816 : if (gfc_match ("impure% ") == MATCH_YES)
7277 : {
7278 729 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7279 4 : goto error;
7280 :
7281 : seen_impure = true;
7282 : found_prefix = true;
7283 : }
7284 : }
7285 : while (found_prefix);
7286 :
7287 : /* IMPURE and PURE must not both appear, of course. */
7288 223045 : if (seen_impure && current_attr.pure)
7289 : {
7290 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7291 4 : goto error;
7292 : }
7293 :
7294 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7295 222320 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7296 : {
7297 4682 : if (!gfc_add_pure (¤t_attr, NULL))
7298 0 : goto error;
7299 : }
7300 :
7301 : /* At this point, the next item is not a prefix. */
7302 223041 : gcc_assert (gfc_matching_prefix);
7303 :
7304 223041 : gfc_matching_prefix = false;
7305 223041 : return MATCH_YES;
7306 :
7307 19860 : error:
7308 19860 : gcc_assert (gfc_matching_prefix);
7309 19860 : gfc_matching_prefix = false;
7310 19860 : return MATCH_ERROR;
7311 : }
7312 :
7313 :
7314 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7315 :
7316 : static bool
7317 63281 : copy_prefix (symbol_attribute *dest, locus *where)
7318 : {
7319 63281 : if (dest->module_procedure)
7320 : {
7321 730 : if (current_attr.elemental)
7322 13 : dest->elemental = 1;
7323 :
7324 730 : if (current_attr.pure)
7325 61 : dest->pure = 1;
7326 :
7327 730 : if (current_attr.recursive)
7328 8 : dest->recursive = 1;
7329 :
7330 : /* Module procedures are unusual in that the 'dest' is copied from
7331 : the interface declaration. However, this is an opportunity to
7332 : check that the submodule declaration is compliant with the
7333 : interface. */
7334 730 : if (dest->elemental && !current_attr.elemental)
7335 : {
7336 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7337 : "missing at %L", where);
7338 1 : return false;
7339 : }
7340 :
7341 729 : if (dest->pure && !current_attr.pure)
7342 : {
7343 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7344 : "missing at %L", where);
7345 1 : return false;
7346 : }
7347 :
7348 728 : if (dest->recursive && !current_attr.recursive)
7349 : {
7350 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7351 : "missing at %L", where);
7352 1 : return false;
7353 : }
7354 :
7355 : return true;
7356 : }
7357 :
7358 62551 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7359 : return false;
7360 :
7361 62549 : if (current_attr.pure && !gfc_add_pure (dest, where))
7362 : return false;
7363 :
7364 62549 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7365 : return false;
7366 :
7367 : return true;
7368 : }
7369 :
7370 :
7371 : /* Match a formal argument list or, if typeparam is true, a
7372 : type_param_name_list. */
7373 :
7374 : match
7375 488410 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7376 : int null_flag, bool typeparam)
7377 : {
7378 488410 : gfc_formal_arglist *head, *tail, *p, *q;
7379 488410 : char name[GFC_MAX_SYMBOL_LEN + 1];
7380 488410 : gfc_symbol *sym;
7381 488410 : match m;
7382 488410 : gfc_formal_arglist *formal = NULL;
7383 :
7384 488410 : head = tail = NULL;
7385 :
7386 : /* Keep the interface formal argument list and null it so that the
7387 : matching for the new declaration can be done. The numbers and
7388 : names of the arguments are checked here. The interface formal
7389 : arguments are retained in formal_arglist and the characteristics
7390 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7391 : in get_proc_name about the eventual need to copy the formal_arglist
7392 : and populate the formal namespace of the interface symbol. */
7393 488410 : if (progname->attr.module_procedure
7394 734 : && progname->attr.host_assoc)
7395 : {
7396 195 : formal = progname->formal;
7397 195 : progname->formal = NULL;
7398 : }
7399 :
7400 488410 : if (gfc_match_char ('(') != MATCH_YES)
7401 : {
7402 288623 : if (null_flag)
7403 6618 : goto ok;
7404 : return MATCH_NO;
7405 : }
7406 :
7407 199787 : if (gfc_match_char (')') == MATCH_YES)
7408 : {
7409 10454 : if (typeparam)
7410 : {
7411 1 : gfc_error_now ("A type parameter list is required at %C");
7412 1 : m = MATCH_ERROR;
7413 1 : goto cleanup;
7414 : }
7415 : else
7416 10453 : goto ok;
7417 : }
7418 :
7419 251634 : for (;;)
7420 : {
7421 251634 : gfc_gobble_whitespace ();
7422 251634 : if (gfc_match_char ('*') == MATCH_YES)
7423 : {
7424 10346 : sym = NULL;
7425 10346 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7426 : "Alternate-return argument at %C"))
7427 : {
7428 1 : m = MATCH_ERROR;
7429 1 : goto cleanup;
7430 : }
7431 10345 : else if (typeparam)
7432 2 : gfc_error_now ("A parameter name is required at %C");
7433 : }
7434 : else
7435 : {
7436 241288 : locus loc = gfc_current_locus;
7437 241288 : m = gfc_match_name (name);
7438 241288 : if (m != MATCH_YES)
7439 : {
7440 16607 : if(typeparam)
7441 1 : gfc_error_now ("A parameter name is required at %C");
7442 16623 : goto cleanup;
7443 : }
7444 224681 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7445 :
7446 224681 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7447 16 : goto cleanup;
7448 224665 : else if (typeparam
7449 224665 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7450 0 : goto cleanup;
7451 : }
7452 :
7453 235010 : p = gfc_get_formal_arglist ();
7454 :
7455 235010 : if (head == NULL)
7456 : head = tail = p;
7457 : else
7458 : {
7459 61598 : tail->next = p;
7460 61598 : tail = p;
7461 : }
7462 :
7463 235010 : tail->sym = sym;
7464 :
7465 : /* We don't add the VARIABLE flavor because the name could be a
7466 : dummy procedure. We don't apply these attributes to formal
7467 : arguments of statement functions. */
7468 224665 : if (sym != NULL && !st_flag
7469 336140 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7470 101130 : || !gfc_missing_attr (&sym->attr, NULL)))
7471 : {
7472 0 : m = MATCH_ERROR;
7473 0 : goto cleanup;
7474 : }
7475 :
7476 : /* The name of a program unit can be in a different namespace,
7477 : so check for it explicitly. After the statement is accepted,
7478 : the name is checked for especially in gfc_get_symbol(). */
7479 235010 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7480 99866 : && strcmp (sym->name, gfc_new_block->name) == 0)
7481 : {
7482 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7483 : sym->name);
7484 0 : m = MATCH_ERROR;
7485 0 : goto cleanup;
7486 : }
7487 :
7488 235010 : if (gfc_match_char (')') == MATCH_YES)
7489 124608 : goto ok;
7490 :
7491 110402 : m = gfc_match_char (',');
7492 110402 : if (m != MATCH_YES)
7493 : {
7494 48101 : if (typeparam)
7495 1 : gfc_error_now ("Expected parameter list in type declaration "
7496 : "at %C");
7497 : else
7498 48100 : gfc_error ("Unexpected junk in formal argument list at %C");
7499 48101 : goto cleanup;
7500 : }
7501 : }
7502 :
7503 141679 : ok:
7504 : /* Check for duplicate symbols in the formal argument list. */
7505 141679 : if (head != NULL)
7506 : {
7507 184584 : for (p = head; p->next; p = p->next)
7508 : {
7509 60024 : if (p->sym == NULL)
7510 337 : continue;
7511 :
7512 236755 : for (q = p->next; q; q = q->next)
7513 177116 : if (p->sym == q->sym)
7514 : {
7515 48 : if (typeparam)
7516 1 : gfc_error_now ("Duplicate name %qs in parameter "
7517 : "list at %C", p->sym->name);
7518 : else
7519 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7520 : "list at %C", p->sym->name);
7521 :
7522 48 : m = MATCH_ERROR;
7523 48 : goto cleanup;
7524 : }
7525 : }
7526 : }
7527 :
7528 141631 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7529 : {
7530 0 : m = MATCH_ERROR;
7531 0 : goto cleanup;
7532 : }
7533 :
7534 : /* gfc_error_now used in following and return with MATCH_YES because
7535 : doing otherwise results in a cascade of extraneous errors and in
7536 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7537 141631 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7538 : {
7539 194 : bool arg_count_mismatch = false;
7540 :
7541 194 : if (!formal && head)
7542 : arg_count_mismatch = true;
7543 :
7544 : /* Abbreviated module procedure declaration is not meant to have any
7545 : formal arguments! */
7546 194 : if (!progname->abr_modproc_decl && formal && !head)
7547 1 : arg_count_mismatch = true;
7548 :
7549 375 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7550 : {
7551 181 : if ((p->next != NULL && q->next == NULL)
7552 180 : || (p->next == NULL && q->next != NULL))
7553 : arg_count_mismatch = true;
7554 179 : else if ((p->sym == NULL && q->sym == NULL)
7555 179 : || (p->sym && q->sym
7556 177 : && strcmp (p->sym->name, q->sym->name) == 0))
7557 175 : continue;
7558 : else
7559 : {
7560 4 : if (q->sym == NULL)
7561 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7562 : "conflicts with alternate return at %C",
7563 : p->sym->name);
7564 3 : else if (p->sym == NULL)
7565 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7566 : "alternate return and conflicts with "
7567 : "%qs in the separate declaration at %C",
7568 : q->sym->name);
7569 : else
7570 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7571 : "argument names (%s/%s) at %C",
7572 : p->sym->name, q->sym->name);
7573 : }
7574 : }
7575 :
7576 194 : if (arg_count_mismatch)
7577 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7578 : "formal arguments at %C");
7579 : }
7580 :
7581 : return MATCH_YES;
7582 :
7583 64774 : cleanup:
7584 64774 : gfc_free_formal_arglist (head);
7585 64774 : return m;
7586 : }
7587 :
7588 :
7589 : /* Match a RESULT specification following a function declaration or
7590 : ENTRY statement. Also matches the end-of-statement. */
7591 :
7592 : static match
7593 8587 : match_result (gfc_symbol *function, gfc_symbol **result)
7594 : {
7595 8587 : char name[GFC_MAX_SYMBOL_LEN + 1];
7596 8587 : gfc_symbol *r;
7597 8587 : match m;
7598 :
7599 8587 : if (gfc_match (" result (") != MATCH_YES)
7600 : return MATCH_NO;
7601 :
7602 6032 : m = gfc_match_name (name);
7603 6032 : if (m != MATCH_YES)
7604 : return m;
7605 :
7606 : /* Get the right paren, and that's it because there could be the
7607 : bind(c) attribute after the result clause. */
7608 6032 : if (gfc_match_char (')') != MATCH_YES)
7609 : {
7610 : /* TODO: should report the missing right paren here. */
7611 : return MATCH_ERROR;
7612 : }
7613 :
7614 6032 : if (strcmp (function->name, name) == 0)
7615 : {
7616 1 : gfc_error ("RESULT variable at %C must be different than function name");
7617 1 : return MATCH_ERROR;
7618 : }
7619 :
7620 6031 : if (gfc_get_symbol (name, NULL, &r))
7621 : return MATCH_ERROR;
7622 :
7623 6031 : if (!gfc_add_result (&r->attr, r->name, NULL))
7624 : return MATCH_ERROR;
7625 :
7626 6031 : *result = r;
7627 :
7628 6031 : return MATCH_YES;
7629 : }
7630 :
7631 :
7632 : /* Match a function suffix, which could be a combination of a result
7633 : clause and BIND(C), either one, or neither. The draft does not
7634 : require them to come in a specific order. */
7635 :
7636 : static match
7637 8591 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7638 : {
7639 8591 : match is_bind_c; /* Found bind(c). */
7640 8591 : match is_result; /* Found result clause. */
7641 8591 : match found_match; /* Status of whether we've found a good match. */
7642 8591 : char peek_char; /* Character we're going to peek at. */
7643 8591 : bool allow_binding_name;
7644 :
7645 : /* Initialize to having found nothing. */
7646 8591 : found_match = MATCH_NO;
7647 8591 : is_bind_c = MATCH_NO;
7648 8591 : is_result = MATCH_NO;
7649 :
7650 : /* Get the next char to narrow between result and bind(c). */
7651 8591 : gfc_gobble_whitespace ();
7652 8591 : peek_char = gfc_peek_ascii_char ();
7653 :
7654 : /* C binding names are not allowed for internal procedures. */
7655 8591 : if (gfc_current_state () == COMP_CONTAINS
7656 4778 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7657 : allow_binding_name = false;
7658 : else
7659 6911 : allow_binding_name = true;
7660 :
7661 8591 : switch (peek_char)
7662 : {
7663 5661 : case 'r':
7664 : /* Look for result clause. */
7665 5661 : is_result = match_result (sym, result);
7666 5661 : if (is_result == MATCH_YES)
7667 : {
7668 : /* Now see if there is a bind(c) after it. */
7669 5660 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7670 : /* We've found the result clause and possibly bind(c). */
7671 5660 : found_match = MATCH_YES;
7672 : }
7673 : else
7674 : /* This should only be MATCH_ERROR. */
7675 : found_match = is_result;
7676 : break;
7677 2930 : case 'b':
7678 : /* Look for bind(c) first. */
7679 2930 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7680 2930 : if (is_bind_c == MATCH_YES)
7681 : {
7682 : /* Now see if a result clause followed it. */
7683 2926 : is_result = match_result (sym, result);
7684 2926 : found_match = MATCH_YES;
7685 : }
7686 : else
7687 : {
7688 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7689 : found_match = MATCH_ERROR;
7690 : }
7691 : break;
7692 0 : default:
7693 0 : gfc_error ("Unexpected junk after function declaration at %C");
7694 0 : found_match = MATCH_ERROR;
7695 0 : break;
7696 : }
7697 :
7698 8586 : if (is_bind_c == MATCH_YES)
7699 : {
7700 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7701 3093 : if (gfc_current_state () == COMP_CONTAINS
7702 423 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7703 3111 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7704 : "at %L may not be specified for an internal "
7705 : "procedure", &gfc_current_locus))
7706 : return MATCH_ERROR;
7707 :
7708 3090 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7709 : return MATCH_ERROR;
7710 : }
7711 :
7712 : return found_match;
7713 : }
7714 :
7715 :
7716 : /* Procedure pointer return value without RESULT statement:
7717 : Add "hidden" result variable named "ppr@". */
7718 :
7719 : static bool
7720 74953 : add_hidden_procptr_result (gfc_symbol *sym)
7721 : {
7722 74953 : bool case1,case2;
7723 :
7724 74953 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7725 : return false;
7726 :
7727 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7728 1538 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7729 1538 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7730 75351 : && sym->attr.external;
7731 : /* Second usage case: INTERFACE statements. */
7732 14858 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7733 14858 : && gfc_state_stack->previous->state == COMP_FUNCTION
7734 75000 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7735 :
7736 74769 : if (case1 || case2)
7737 : {
7738 124 : gfc_symtree *stree;
7739 124 : if (case1)
7740 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7741 : else
7742 : {
7743 30 : gfc_symtree *st2;
7744 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7745 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7746 30 : st2->n.sym = stree->n.sym;
7747 30 : stree->n.sym->refs++;
7748 : }
7749 124 : sym->result = stree->n.sym;
7750 :
7751 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7752 124 : sym->result->attr.pointer = sym->attr.pointer;
7753 124 : sym->result->attr.external = sym->attr.external;
7754 124 : sym->result->attr.referenced = sym->attr.referenced;
7755 124 : sym->result->ts = sym->ts;
7756 124 : sym->attr.proc_pointer = 0;
7757 124 : sym->attr.pointer = 0;
7758 124 : sym->attr.external = 0;
7759 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7760 : {
7761 4 : sym->result->attr.pointer = 0;
7762 4 : sym->result->attr.proc_pointer = 1;
7763 : }
7764 :
7765 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7766 : }
7767 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7768 74675 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7769 411 : && sym->result && sym->result != sym && sym->result->attr.external
7770 28 : && sym == gfc_current_ns->proc_name
7771 28 : && sym == sym->result->ns->proc_name
7772 28 : && strcmp ("ppr@", sym->result->name) == 0)
7773 : {
7774 28 : sym->result->attr.proc_pointer = 1;
7775 28 : sym->attr.pointer = 0;
7776 28 : return true;
7777 : }
7778 : else
7779 : return false;
7780 : }
7781 :
7782 :
7783 : /* Match the interface for a PROCEDURE declaration,
7784 : including brackets (R1212). */
7785 :
7786 : static match
7787 1622 : match_procedure_interface (gfc_symbol **proc_if)
7788 : {
7789 1622 : match m;
7790 1622 : gfc_symtree *st;
7791 1622 : locus old_loc, entry_loc;
7792 1622 : gfc_namespace *old_ns = gfc_current_ns;
7793 1622 : char name[GFC_MAX_SYMBOL_LEN + 1];
7794 :
7795 1622 : old_loc = entry_loc = gfc_current_locus;
7796 1622 : gfc_clear_ts (¤t_ts);
7797 :
7798 1622 : if (gfc_match (" (") != MATCH_YES)
7799 : {
7800 1 : gfc_current_locus = entry_loc;
7801 1 : return MATCH_NO;
7802 : }
7803 :
7804 : /* Get the type spec. for the procedure interface. */
7805 1621 : old_loc = gfc_current_locus;
7806 1621 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7807 1621 : gfc_gobble_whitespace ();
7808 1621 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7809 395 : goto got_ts;
7810 :
7811 1226 : if (m == MATCH_ERROR)
7812 : return m;
7813 :
7814 : /* Procedure interface is itself a procedure. */
7815 1226 : gfc_current_locus = old_loc;
7816 1226 : m = gfc_match_name (name);
7817 :
7818 : /* First look to see if it is already accessible in the current
7819 : namespace because it is use associated or contained. */
7820 1226 : st = NULL;
7821 1226 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7822 : return MATCH_ERROR;
7823 :
7824 : /* If it is still not found, then try the parent namespace, if it
7825 : exists and create the symbol there if it is still not found. */
7826 1226 : if (gfc_current_ns->parent)
7827 427 : gfc_current_ns = gfc_current_ns->parent;
7828 1226 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7829 : return MATCH_ERROR;
7830 :
7831 1226 : gfc_current_ns = old_ns;
7832 1226 : *proc_if = st->n.sym;
7833 :
7834 1226 : if (*proc_if)
7835 : {
7836 1226 : (*proc_if)->refs++;
7837 : /* Resolve interface if possible. That way, attr.procedure is only set
7838 : if it is declared by a later procedure-declaration-stmt, which is
7839 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7840 1226 : while ((*proc_if)->ts.interface
7841 1233 : && *proc_if != (*proc_if)->ts.interface)
7842 7 : *proc_if = (*proc_if)->ts.interface;
7843 :
7844 1226 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7845 389 : && (*proc_if)->ts.type == BT_UNKNOWN
7846 1615 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7847 : (*proc_if)->name, NULL))
7848 : return MATCH_ERROR;
7849 : }
7850 :
7851 0 : got_ts:
7852 1621 : if (gfc_match (" )") != MATCH_YES)
7853 : {
7854 0 : gfc_current_locus = entry_loc;
7855 0 : return MATCH_NO;
7856 : }
7857 :
7858 : return MATCH_YES;
7859 : }
7860 :
7861 :
7862 : /* Match a PROCEDURE declaration (R1211). */
7863 :
7864 : static match
7865 1189 : match_procedure_decl (void)
7866 : {
7867 1189 : match m;
7868 1189 : gfc_symbol *sym, *proc_if = NULL;
7869 1189 : int num;
7870 1189 : gfc_expr *initializer = NULL;
7871 :
7872 : /* Parse interface (with brackets). */
7873 1189 : m = match_procedure_interface (&proc_if);
7874 1189 : if (m != MATCH_YES)
7875 : return m;
7876 :
7877 : /* Parse attributes (with colons). */
7878 1189 : m = match_attr_spec();
7879 1189 : if (m == MATCH_ERROR)
7880 : return MATCH_ERROR;
7881 :
7882 1188 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7883 : {
7884 53 : current_attr.is_bind_c = 1;
7885 53 : has_name_equals = 0;
7886 53 : curr_binding_label = NULL;
7887 : }
7888 :
7889 : /* Get procedure symbols. */
7890 79 : for(num=1;;num++)
7891 : {
7892 1267 : m = gfc_match_symbol (&sym, 0);
7893 1267 : if (m == MATCH_NO)
7894 1 : goto syntax;
7895 1266 : else if (m == MATCH_ERROR)
7896 : return m;
7897 :
7898 : /* Add current_attr to the symbol attributes. */
7899 1266 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7900 : return MATCH_ERROR;
7901 :
7902 1264 : if (sym->attr.is_bind_c)
7903 : {
7904 : /* Check for C1218. */
7905 90 : if (!proc_if || !proc_if->attr.is_bind_c)
7906 : {
7907 1 : gfc_error ("BIND(C) attribute at %C requires "
7908 : "an interface with BIND(C)");
7909 1 : return MATCH_ERROR;
7910 : }
7911 : /* Check for C1217. */
7912 89 : if (has_name_equals && sym->attr.pointer)
7913 : {
7914 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7915 : "POINTER attribute at %C");
7916 1 : return MATCH_ERROR;
7917 : }
7918 88 : if (has_name_equals && sym->attr.dummy)
7919 : {
7920 1 : gfc_error ("Dummy procedure at %C may not have "
7921 : "BIND(C) attribute with NAME");
7922 1 : return MATCH_ERROR;
7923 : }
7924 : /* Set binding label for BIND(C). */
7925 87 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7926 : return MATCH_ERROR;
7927 : }
7928 :
7929 1260 : if (!gfc_add_external (&sym->attr, NULL))
7930 : return MATCH_ERROR;
7931 :
7932 1256 : if (add_hidden_procptr_result (sym))
7933 67 : sym = sym->result;
7934 :
7935 1256 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7936 : return MATCH_ERROR;
7937 :
7938 : /* Set interface. */
7939 1255 : if (proc_if != NULL)
7940 : {
7941 912 : if (sym->ts.type != BT_UNKNOWN)
7942 : {
7943 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7944 : sym->name, &gfc_current_locus,
7945 : gfc_basic_typename (sym->ts.type));
7946 1 : return MATCH_ERROR;
7947 : }
7948 911 : sym->ts.interface = proc_if;
7949 911 : sym->attr.untyped = 1;
7950 911 : sym->attr.if_source = IFSRC_IFBODY;
7951 : }
7952 343 : else if (current_ts.type != BT_UNKNOWN)
7953 : {
7954 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7955 : return MATCH_ERROR;
7956 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7957 198 : sym->ts.interface->ts = current_ts;
7958 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7959 198 : sym->ts.interface->attr.function = 1;
7960 198 : sym->attr.function = 1;
7961 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7962 : }
7963 :
7964 1253 : if (gfc_match (" =>") == MATCH_YES)
7965 : {
7966 110 : if (!current_attr.pointer)
7967 : {
7968 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7969 0 : m = MATCH_ERROR;
7970 0 : goto cleanup;
7971 : }
7972 :
7973 110 : m = match_pointer_init (&initializer, 1);
7974 110 : if (m != MATCH_YES)
7975 1 : goto cleanup;
7976 :
7977 109 : if (!add_init_expr_to_sym (sym->name, &initializer,
7978 : &gfc_current_locus,
7979 : gfc_current_ns->cl_list))
7980 0 : goto cleanup;
7981 :
7982 : }
7983 :
7984 1252 : if (gfc_match_eos () == MATCH_YES)
7985 : return MATCH_YES;
7986 79 : if (gfc_match_char (',') != MATCH_YES)
7987 0 : goto syntax;
7988 : }
7989 :
7990 1 : syntax:
7991 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7992 1 : return MATCH_ERROR;
7993 :
7994 1 : cleanup:
7995 : /* Free stuff up and return. */
7996 1 : gfc_free_expr (initializer);
7997 1 : return m;
7998 : }
7999 :
8000 :
8001 : static match
8002 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
8003 :
8004 :
8005 : /* Match a procedure pointer component declaration (R445). */
8006 :
8007 : static match
8008 433 : match_ppc_decl (void)
8009 : {
8010 433 : match m;
8011 433 : gfc_symbol *proc_if = NULL;
8012 433 : gfc_typespec ts;
8013 433 : int num;
8014 433 : gfc_component *c;
8015 433 : gfc_expr *initializer = NULL;
8016 433 : gfc_typebound_proc* tb;
8017 433 : char name[GFC_MAX_SYMBOL_LEN + 1];
8018 :
8019 : /* Parse interface (with brackets). */
8020 433 : m = match_procedure_interface (&proc_if);
8021 433 : if (m != MATCH_YES)
8022 1 : goto syntax;
8023 :
8024 : /* Parse attributes. */
8025 432 : tb = XCNEW (gfc_typebound_proc);
8026 432 : tb->where = gfc_current_locus;
8027 432 : m = match_binding_attributes (tb, false, true);
8028 432 : if (m == MATCH_ERROR)
8029 : return m;
8030 :
8031 429 : gfc_clear_attr (¤t_attr);
8032 429 : current_attr.procedure = 1;
8033 429 : current_attr.proc_pointer = 1;
8034 429 : current_attr.access = tb->access;
8035 429 : current_attr.flavor = FL_PROCEDURE;
8036 :
8037 : /* Match the colons (required). */
8038 429 : if (gfc_match (" ::") != MATCH_YES)
8039 : {
8040 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
8041 1 : return MATCH_ERROR;
8042 : }
8043 :
8044 : /* Check for C450. */
8045 428 : if (!tb->nopass && proc_if == NULL)
8046 : {
8047 2 : gfc_error("NOPASS or explicit interface required at %C");
8048 2 : return MATCH_ERROR;
8049 : }
8050 :
8051 426 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
8052 : return MATCH_ERROR;
8053 :
8054 : /* Match PPC names. */
8055 425 : ts = current_ts;
8056 425 : for(num=1;;num++)
8057 : {
8058 426 : m = gfc_match_name (name);
8059 426 : if (m == MATCH_NO)
8060 0 : goto syntax;
8061 426 : else if (m == MATCH_ERROR)
8062 : return m;
8063 :
8064 426 : if (!gfc_add_component (gfc_current_block(), name, &c))
8065 : return MATCH_ERROR;
8066 :
8067 : /* Add current_attr to the symbol attributes. */
8068 426 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
8069 : return MATCH_ERROR;
8070 :
8071 426 : if (!gfc_add_external (&c->attr, NULL))
8072 : return MATCH_ERROR;
8073 :
8074 426 : if (!gfc_add_proc (&c->attr, name, NULL))
8075 : return MATCH_ERROR;
8076 :
8077 426 : if (num == 1)
8078 425 : c->tb = tb;
8079 : else
8080 : {
8081 1 : c->tb = XCNEW (gfc_typebound_proc);
8082 1 : c->tb->where = gfc_current_locus;
8083 1 : *c->tb = *tb;
8084 : }
8085 :
8086 426 : if (saved_kind_expr)
8087 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
8088 :
8089 : /* Set interface. */
8090 426 : if (proc_if != NULL)
8091 : {
8092 359 : c->ts.interface = proc_if;
8093 359 : c->attr.untyped = 1;
8094 359 : c->attr.if_source = IFSRC_IFBODY;
8095 : }
8096 67 : else if (ts.type != BT_UNKNOWN)
8097 : {
8098 29 : c->ts = ts;
8099 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
8100 29 : c->ts.interface->result = c->ts.interface;
8101 29 : c->ts.interface->ts = ts;
8102 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
8103 29 : c->ts.interface->attr.function = 1;
8104 29 : c->attr.function = 1;
8105 29 : c->attr.if_source = IFSRC_UNKNOWN;
8106 : }
8107 :
8108 426 : if (gfc_match (" =>") == MATCH_YES)
8109 : {
8110 73 : m = match_pointer_init (&initializer, 1);
8111 73 : if (m != MATCH_YES)
8112 : {
8113 0 : gfc_free_expr (initializer);
8114 0 : return m;
8115 : }
8116 73 : c->initializer = initializer;
8117 : }
8118 :
8119 426 : if (gfc_match_eos () == MATCH_YES)
8120 : return MATCH_YES;
8121 1 : if (gfc_match_char (',') != MATCH_YES)
8122 0 : goto syntax;
8123 : }
8124 :
8125 1 : syntax:
8126 1 : gfc_error ("Syntax error in procedure pointer component at %C");
8127 1 : return MATCH_ERROR;
8128 : }
8129 :
8130 :
8131 : /* Match a PROCEDURE declaration inside an interface (R1206). */
8132 :
8133 : static match
8134 1561 : match_procedure_in_interface (void)
8135 : {
8136 1561 : match m;
8137 1561 : gfc_symbol *sym;
8138 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
8139 1561 : locus old_locus;
8140 :
8141 1561 : if (current_interface.type == INTERFACE_NAMELESS
8142 1561 : || current_interface.type == INTERFACE_ABSTRACT)
8143 : {
8144 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
8145 1 : return MATCH_ERROR;
8146 : }
8147 :
8148 : /* Check if the F2008 optional double colon appears. */
8149 1560 : gfc_gobble_whitespace ();
8150 1560 : old_locus = gfc_current_locus;
8151 1560 : if (gfc_match ("::") == MATCH_YES)
8152 : {
8153 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
8154 : "MODULE PROCEDURE statement at %L", &old_locus))
8155 : return MATCH_ERROR;
8156 : }
8157 : else
8158 685 : gfc_current_locus = old_locus;
8159 :
8160 2214 : for(;;)
8161 : {
8162 2214 : m = gfc_match_name (name);
8163 2214 : if (m == MATCH_NO)
8164 0 : goto syntax;
8165 2214 : else if (m == MATCH_ERROR)
8166 : return m;
8167 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
8168 : return MATCH_ERROR;
8169 :
8170 2214 : if (!gfc_add_interface (sym))
8171 : return MATCH_ERROR;
8172 :
8173 2213 : if (gfc_match_eos () == MATCH_YES)
8174 : break;
8175 655 : if (gfc_match_char (',') != MATCH_YES)
8176 0 : goto syntax;
8177 : }
8178 :
8179 : return MATCH_YES;
8180 :
8181 0 : syntax:
8182 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
8183 0 : return MATCH_ERROR;
8184 : }
8185 :
8186 :
8187 : /* General matcher for PROCEDURE declarations. */
8188 :
8189 : static match match_procedure_in_type (void);
8190 :
8191 : match
8192 6419 : gfc_match_procedure (void)
8193 : {
8194 6419 : match m;
8195 :
8196 6419 : switch (gfc_current_state ())
8197 : {
8198 1189 : case COMP_NONE:
8199 1189 : case COMP_PROGRAM:
8200 1189 : case COMP_MODULE:
8201 1189 : case COMP_SUBMODULE:
8202 1189 : case COMP_SUBROUTINE:
8203 1189 : case COMP_FUNCTION:
8204 1189 : case COMP_BLOCK:
8205 1189 : m = match_procedure_decl ();
8206 1189 : break;
8207 1561 : case COMP_INTERFACE:
8208 1561 : m = match_procedure_in_interface ();
8209 1561 : break;
8210 433 : case COMP_DERIVED:
8211 433 : m = match_ppc_decl ();
8212 433 : break;
8213 3236 : case COMP_DERIVED_CONTAINS:
8214 3236 : m = match_procedure_in_type ();
8215 3236 : break;
8216 : default:
8217 : return MATCH_NO;
8218 : }
8219 :
8220 6419 : if (m != MATCH_YES)
8221 : return m;
8222 :
8223 6363 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8224 4 : return MATCH_ERROR;
8225 :
8226 : return m;
8227 : }
8228 :
8229 :
8230 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8231 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8232 : parser-state-stack to find out whether we're in a module. */
8233 :
8234 : static void
8235 63278 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8236 : {
8237 63278 : bool in_module;
8238 :
8239 126556 : in_module = (gfc_state_stack->previous
8240 63278 : && (gfc_state_stack->previous->state == COMP_MODULE
8241 51612 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8242 :
8243 63278 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8244 63278 : }
8245 :
8246 :
8247 : /* Match a function declaration. */
8248 :
8249 : match
8250 129485 : gfc_match_function_decl (void)
8251 : {
8252 129485 : char name[GFC_MAX_SYMBOL_LEN + 1];
8253 129485 : gfc_symbol *sym, *result;
8254 129485 : locus old_loc;
8255 129485 : match m;
8256 129485 : match suffix_match;
8257 129485 : match found_match; /* Status returned by match func. */
8258 :
8259 129485 : if (gfc_current_state () != COMP_NONE
8260 81738 : && gfc_current_state () != COMP_INTERFACE
8261 52349 : && gfc_current_state () != COMP_CONTAINS)
8262 : return MATCH_NO;
8263 :
8264 129485 : gfc_clear_ts (¤t_ts);
8265 :
8266 129485 : old_loc = gfc_current_locus;
8267 :
8268 129485 : m = gfc_match_prefix (¤t_ts);
8269 129485 : if (m != MATCH_YES)
8270 : {
8271 9932 : gfc_current_locus = old_loc;
8272 9932 : return m;
8273 : }
8274 :
8275 119553 : if (gfc_match ("function% %n", name) != MATCH_YES)
8276 : {
8277 99453 : gfc_current_locus = old_loc;
8278 99453 : return MATCH_NO;
8279 : }
8280 :
8281 20100 : if (get_proc_name (name, &sym, false))
8282 : return MATCH_ERROR;
8283 :
8284 20095 : if (add_hidden_procptr_result (sym))
8285 20 : sym = sym->result;
8286 :
8287 20095 : if (current_attr.module_procedure)
8288 : {
8289 304 : sym->attr.module_procedure = 1;
8290 304 : if (gfc_current_state () == COMP_INTERFACE)
8291 215 : gfc_current_ns->has_import_set = 1;
8292 : }
8293 :
8294 20095 : gfc_new_block = sym;
8295 :
8296 20095 : m = gfc_match_formal_arglist (sym, 0, 0);
8297 20095 : if (m == MATCH_NO)
8298 : {
8299 6 : gfc_error ("Expected formal argument list in function "
8300 : "definition at %C");
8301 6 : m = MATCH_ERROR;
8302 6 : goto cleanup;
8303 : }
8304 20089 : else if (m == MATCH_ERROR)
8305 0 : goto cleanup;
8306 :
8307 20089 : result = NULL;
8308 :
8309 : /* According to the draft, the bind(c) and result clause can
8310 : come in either order after the formal_arg_list (i.e., either
8311 : can be first, both can exist together or by themselves or neither
8312 : one). Therefore, the match_result can't match the end of the
8313 : string, and check for the bind(c) or result clause in either order. */
8314 20089 : found_match = gfc_match_eos ();
8315 :
8316 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8317 : must have been marked BIND(C) with a BIND(C) attribute and that is
8318 : not allowed for procedures. */
8319 20089 : if (sym->attr.is_bind_c == 1)
8320 : {
8321 3 : sym->attr.is_bind_c = 0;
8322 :
8323 3 : if (gfc_state_stack->previous
8324 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8325 : {
8326 1 : locus loc;
8327 1 : loc = sym->old_symbol != NULL
8328 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8329 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8330 : "variables or common blocks", &loc);
8331 : }
8332 : }
8333 :
8334 20089 : if (found_match != MATCH_YES)
8335 : {
8336 : /* If we haven't found the end-of-statement, look for a suffix. */
8337 8342 : suffix_match = gfc_match_suffix (sym, &result);
8338 8342 : if (suffix_match == MATCH_YES)
8339 : /* Need to get the eos now. */
8340 8334 : found_match = gfc_match_eos ();
8341 : else
8342 : found_match = suffix_match;
8343 : }
8344 :
8345 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8346 : subprogram and a binding label is specified, it shall be the
8347 : same as the binding label specified in the corresponding module
8348 : procedure interface body. */
8349 20089 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8350 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8351 3 : && sym->binding_label && sym->old_symbol->binding_label
8352 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8353 : {
8354 1 : const char *null = "NULL", *s1, *s2;
8355 1 : s1 = sym->binding_label;
8356 1 : if (!s1) s1 = null;
8357 1 : s2 = sym->old_symbol->binding_label;
8358 1 : if (!s2) s2 = null;
8359 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8360 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8361 1 : return MATCH_ERROR;
8362 : }
8363 :
8364 20088 : if(found_match != MATCH_YES)
8365 : m = MATCH_ERROR;
8366 : else
8367 : {
8368 : /* Make changes to the symbol. */
8369 20080 : m = MATCH_ERROR;
8370 :
8371 20080 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8372 0 : goto cleanup;
8373 :
8374 20080 : if (!gfc_missing_attr (&sym->attr, NULL))
8375 0 : goto cleanup;
8376 :
8377 20080 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8378 : {
8379 1 : if(!sym->attr.module_procedure)
8380 1 : goto cleanup;
8381 : else
8382 0 : gfc_error_check ();
8383 : }
8384 :
8385 : /* Delay matching the function characteristics until after the
8386 : specification block by signalling kind=-1. */
8387 20079 : sym->declared_at = old_loc;
8388 20079 : if (current_ts.type != BT_UNKNOWN)
8389 6936 : current_ts.kind = -1;
8390 : else
8391 13143 : current_ts.kind = 0;
8392 :
8393 20079 : if (result == NULL)
8394 : {
8395 14260 : if (current_ts.type != BT_UNKNOWN
8396 14260 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8397 1 : goto cleanup;
8398 14259 : sym->result = sym;
8399 : }
8400 : else
8401 : {
8402 5819 : if (current_ts.type != BT_UNKNOWN
8403 5819 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8404 0 : goto cleanup;
8405 5819 : sym->result = result;
8406 : }
8407 :
8408 : /* Warn if this procedure has the same name as an intrinsic. */
8409 20078 : do_warn_intrinsic_shadow (sym, true);
8410 :
8411 20078 : return MATCH_YES;
8412 : }
8413 :
8414 16 : cleanup:
8415 16 : gfc_current_locus = old_loc;
8416 16 : return m;
8417 : }
8418 :
8419 :
8420 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8421 : pass the name of the entry, rather than the gfc_current_block name, and
8422 : to return false upon finding an existing global entry. */
8423 :
8424 : static bool
8425 539 : add_global_entry (const char *name, const char *binding_label, bool sub,
8426 : locus *where)
8427 : {
8428 539 : gfc_gsymbol *s;
8429 539 : enum gfc_symbol_type type;
8430 :
8431 539 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8432 :
8433 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8434 : name is a global identifier. */
8435 539 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8436 : {
8437 516 : s = gfc_get_gsymbol (name, false);
8438 :
8439 516 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8440 : {
8441 2 : gfc_global_used (s, where);
8442 2 : return false;
8443 : }
8444 : else
8445 : {
8446 514 : s->type = type;
8447 514 : s->sym_name = name;
8448 514 : s->where = *where;
8449 514 : s->defined = 1;
8450 514 : s->ns = gfc_current_ns;
8451 : }
8452 : }
8453 :
8454 : /* Don't add the symbol multiple times. */
8455 537 : if (binding_label
8456 537 : && (!gfc_notification_std (GFC_STD_F2008)
8457 0 : || strcmp (name, binding_label) != 0))
8458 : {
8459 23 : s = gfc_get_gsymbol (binding_label, true);
8460 :
8461 23 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8462 : {
8463 1 : gfc_global_used (s, where);
8464 1 : return false;
8465 : }
8466 : else
8467 : {
8468 22 : s->type = type;
8469 22 : s->sym_name = gfc_get_string ("%s", name);
8470 22 : s->binding_label = binding_label;
8471 22 : s->where = *where;
8472 22 : s->defined = 1;
8473 22 : s->ns = gfc_current_ns;
8474 : }
8475 : }
8476 :
8477 : return true;
8478 : }
8479 :
8480 :
8481 : /* Match an ENTRY statement. */
8482 :
8483 : match
8484 805 : gfc_match_entry (void)
8485 : {
8486 805 : gfc_symbol *proc;
8487 805 : gfc_symbol *result;
8488 805 : gfc_symbol *entry;
8489 805 : char name[GFC_MAX_SYMBOL_LEN + 1];
8490 805 : gfc_compile_state state;
8491 805 : match m;
8492 805 : gfc_entry_list *el;
8493 805 : locus old_loc;
8494 805 : bool module_procedure;
8495 805 : char peek_char;
8496 805 : match is_bind_c;
8497 :
8498 805 : m = gfc_match_name (name);
8499 805 : if (m != MATCH_YES)
8500 : return m;
8501 :
8502 805 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8503 : return MATCH_ERROR;
8504 :
8505 805 : state = gfc_current_state ();
8506 805 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8507 : {
8508 3 : switch (state)
8509 : {
8510 0 : case COMP_PROGRAM:
8511 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8512 0 : break;
8513 0 : case COMP_MODULE:
8514 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8515 0 : break;
8516 0 : case COMP_SUBMODULE:
8517 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8518 0 : break;
8519 0 : case COMP_BLOCK_DATA:
8520 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8521 : "a BLOCK DATA");
8522 0 : break;
8523 0 : case COMP_INTERFACE:
8524 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8525 : "an INTERFACE");
8526 0 : break;
8527 1 : case COMP_STRUCTURE:
8528 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8529 : "a STRUCTURE block");
8530 1 : break;
8531 0 : case COMP_DERIVED:
8532 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8533 : "a DERIVED TYPE block");
8534 0 : break;
8535 0 : case COMP_IF:
8536 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8537 : "an IF-THEN block");
8538 0 : break;
8539 0 : case COMP_DO:
8540 0 : case COMP_DO_CONCURRENT:
8541 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8542 : "a DO block");
8543 0 : break;
8544 0 : case COMP_SELECT:
8545 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8546 : "a SELECT block");
8547 0 : break;
8548 0 : case COMP_FORALL:
8549 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8550 : "a FORALL block");
8551 0 : break;
8552 0 : case COMP_WHERE:
8553 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8554 : "a WHERE block");
8555 0 : break;
8556 0 : case COMP_CONTAINS:
8557 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8558 : "a contained subprogram");
8559 0 : break;
8560 2 : default:
8561 2 : gfc_error ("Unexpected ENTRY statement at %C");
8562 : }
8563 3 : return MATCH_ERROR;
8564 : }
8565 :
8566 802 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8567 802 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8568 : {
8569 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8570 1 : return MATCH_ERROR;
8571 : }
8572 :
8573 1602 : module_procedure = gfc_current_ns->parent != NULL
8574 260 : && gfc_current_ns->parent->proc_name
8575 801 : && gfc_current_ns->parent->proc_name->attr.flavor
8576 260 : == FL_MODULE;
8577 :
8578 801 : if (gfc_current_ns->parent != NULL
8579 260 : && gfc_current_ns->parent->proc_name
8580 260 : && !module_procedure)
8581 : {
8582 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8583 : "contained procedure");
8584 0 : return MATCH_ERROR;
8585 : }
8586 :
8587 : /* Module function entries need special care in get_proc_name
8588 : because previous references within the function will have
8589 : created symbols attached to the current namespace. */
8590 801 : if (get_proc_name (name, &entry,
8591 : gfc_current_ns->parent != NULL
8592 801 : && module_procedure))
8593 : return MATCH_ERROR;
8594 :
8595 799 : proc = gfc_current_block ();
8596 :
8597 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8598 : must have been marked BIND(C) with a BIND(C) attribute and that is
8599 : not allowed for procedures. */
8600 799 : if (entry->attr.is_bind_c == 1)
8601 : {
8602 0 : locus loc;
8603 :
8604 0 : entry->attr.is_bind_c = 0;
8605 :
8606 0 : loc = entry->old_symbol != NULL
8607 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8608 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8609 : "variables or common blocks", &loc);
8610 : }
8611 :
8612 : /* Check what next non-whitespace character is so we can tell if there
8613 : is the required parens if we have a BIND(C). */
8614 799 : old_loc = gfc_current_locus;
8615 799 : gfc_gobble_whitespace ();
8616 799 : peek_char = gfc_peek_ascii_char ();
8617 :
8618 799 : if (state == COMP_SUBROUTINE)
8619 : {
8620 138 : m = gfc_match_formal_arglist (entry, 0, 1);
8621 138 : if (m != MATCH_YES)
8622 : return MATCH_ERROR;
8623 :
8624 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8625 : never be an internal procedure. */
8626 138 : is_bind_c = gfc_match_bind_c (entry, true);
8627 138 : if (is_bind_c == MATCH_ERROR)
8628 : return MATCH_ERROR;
8629 138 : if (is_bind_c == MATCH_YES)
8630 : {
8631 22 : if (peek_char != '(')
8632 : {
8633 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8634 0 : return MATCH_ERROR;
8635 : }
8636 :
8637 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8638 22 : &(entry->declared_at), 1))
8639 : return MATCH_ERROR;
8640 :
8641 : }
8642 :
8643 138 : if (!gfc_current_ns->parent
8644 138 : && !add_global_entry (name, entry->binding_label, true,
8645 : &old_loc))
8646 : return MATCH_ERROR;
8647 :
8648 : /* An entry in a subroutine. */
8649 135 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8650 135 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8651 3 : return MATCH_ERROR;
8652 : }
8653 : else
8654 : {
8655 : /* An entry in a function.
8656 : We need to take special care because writing
8657 : ENTRY f()
8658 : as
8659 : ENTRY f
8660 : is allowed, whereas
8661 : ENTRY f() RESULT (r)
8662 : can't be written as
8663 : ENTRY f RESULT (r). */
8664 661 : if (gfc_match_eos () == MATCH_YES)
8665 : {
8666 24 : gfc_current_locus = old_loc;
8667 : /* Match the empty argument list, and add the interface to
8668 : the symbol. */
8669 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8670 : }
8671 : else
8672 637 : m = gfc_match_formal_arglist (entry, 0, 0);
8673 :
8674 661 : if (m != MATCH_YES)
8675 : return MATCH_ERROR;
8676 :
8677 660 : result = NULL;
8678 :
8679 660 : if (gfc_match_eos () == MATCH_YES)
8680 : {
8681 411 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8682 411 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8683 2 : return MATCH_ERROR;
8684 :
8685 409 : entry->result = entry;
8686 : }
8687 : else
8688 : {
8689 249 : m = gfc_match_suffix (entry, &result);
8690 249 : if (m == MATCH_NO)
8691 0 : gfc_syntax_error (ST_ENTRY);
8692 249 : if (m != MATCH_YES)
8693 : return MATCH_ERROR;
8694 :
8695 249 : if (result)
8696 : {
8697 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8698 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8699 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8700 0 : return MATCH_ERROR;
8701 212 : entry->result = result;
8702 : }
8703 : else
8704 : {
8705 37 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8706 37 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8707 0 : return MATCH_ERROR;
8708 37 : entry->result = entry;
8709 : }
8710 : }
8711 :
8712 658 : if (!gfc_current_ns->parent
8713 658 : && !add_global_entry (name, entry->binding_label, false,
8714 : &old_loc))
8715 : return MATCH_ERROR;
8716 : }
8717 :
8718 790 : if (gfc_match_eos () != MATCH_YES)
8719 : {
8720 0 : gfc_syntax_error (ST_ENTRY);
8721 0 : return MATCH_ERROR;
8722 : }
8723 :
8724 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8725 790 : if (proc->attr.elemental && entry->attr.is_bind_c)
8726 : {
8727 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8728 : "elemental procedure", &entry->declared_at);
8729 2 : return MATCH_ERROR;
8730 : }
8731 :
8732 788 : entry->attr.recursive = proc->attr.recursive;
8733 788 : entry->attr.elemental = proc->attr.elemental;
8734 788 : entry->attr.pure = proc->attr.pure;
8735 :
8736 788 : el = gfc_get_entry_list ();
8737 788 : el->sym = entry;
8738 788 : el->next = gfc_current_ns->entries;
8739 788 : gfc_current_ns->entries = el;
8740 788 : if (el->next)
8741 85 : el->id = el->next->id + 1;
8742 : else
8743 703 : el->id = 1;
8744 :
8745 788 : new_st.op = EXEC_ENTRY;
8746 788 : new_st.ext.entry = el;
8747 :
8748 788 : return MATCH_YES;
8749 : }
8750 :
8751 :
8752 : /* Match a subroutine statement, including optional prefixes. */
8753 :
8754 : match
8755 808914 : gfc_match_subroutine (void)
8756 : {
8757 808914 : char name[GFC_MAX_SYMBOL_LEN + 1];
8758 808914 : gfc_symbol *sym;
8759 808914 : match m;
8760 808914 : match is_bind_c;
8761 808914 : char peek_char;
8762 808914 : bool allow_binding_name;
8763 808914 : locus loc;
8764 :
8765 808914 : if (gfc_current_state () != COMP_NONE
8766 767057 : && gfc_current_state () != COMP_INTERFACE
8767 744241 : && gfc_current_state () != COMP_CONTAINS)
8768 : return MATCH_NO;
8769 :
8770 106482 : m = gfc_match_prefix (NULL);
8771 106482 : if (m != MATCH_YES)
8772 : return m;
8773 :
8774 96560 : loc = gfc_current_locus;
8775 96560 : m = gfc_match ("subroutine% %n", name);
8776 96560 : if (m != MATCH_YES)
8777 : return m;
8778 :
8779 43236 : if (get_proc_name (name, &sym, false))
8780 : return MATCH_ERROR;
8781 :
8782 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8783 : the symbol existed before. */
8784 43225 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8785 : &gfc_current_locus);
8786 :
8787 43225 : if (current_attr.module_procedure)
8788 : {
8789 427 : sym->attr.module_procedure = 1;
8790 427 : if (gfc_current_state () == COMP_INTERFACE)
8791 301 : gfc_current_ns->has_import_set = 1;
8792 : }
8793 :
8794 43225 : if (add_hidden_procptr_result (sym))
8795 9 : sym = sym->result;
8796 :
8797 43225 : gfc_new_block = sym;
8798 :
8799 : /* Check what next non-whitespace character is so we can tell if there
8800 : is the required parens if we have a BIND(C). */
8801 43225 : gfc_gobble_whitespace ();
8802 43225 : peek_char = gfc_peek_ascii_char ();
8803 :
8804 43225 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8805 : return MATCH_ERROR;
8806 :
8807 43222 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8808 : return MATCH_ERROR;
8809 :
8810 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8811 : must have been marked BIND(C) with a BIND(C) attribute and that is
8812 : not allowed for procedures. */
8813 43222 : if (sym->attr.is_bind_c == 1)
8814 : {
8815 4 : sym->attr.is_bind_c = 0;
8816 :
8817 4 : if (gfc_state_stack->previous
8818 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8819 : {
8820 2 : locus loc;
8821 2 : loc = sym->old_symbol != NULL
8822 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8823 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8824 : "variables or common blocks", &loc);
8825 : }
8826 : }
8827 :
8828 : /* C binding names are not allowed for internal procedures. */
8829 43222 : if (gfc_current_state () == COMP_CONTAINS
8830 26241 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8831 : allow_binding_name = false;
8832 : else
8833 28231 : allow_binding_name = true;
8834 :
8835 : /* Here, we are just checking if it has the bind(c) attribute, and if
8836 : so, then we need to make sure it's all correct. If it doesn't,
8837 : we still need to continue matching the rest of the subroutine line. */
8838 43222 : gfc_gobble_whitespace ();
8839 43222 : loc = gfc_current_locus;
8840 43222 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8841 43222 : if (is_bind_c == MATCH_ERROR)
8842 : {
8843 : /* There was an attempt at the bind(c), but it was wrong. An
8844 : error message should have been printed w/in the gfc_match_bind_c
8845 : so here we'll just return the MATCH_ERROR. */
8846 : return MATCH_ERROR;
8847 : }
8848 :
8849 43209 : if (is_bind_c == MATCH_YES)
8850 : {
8851 4051 : gfc_formal_arglist *arg;
8852 :
8853 : /* The following is allowed in the Fortran 2008 draft. */
8854 4051 : if (gfc_current_state () == COMP_CONTAINS
8855 1297 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8856 4462 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8857 : "at %L may not be specified for an internal "
8858 : "procedure", &gfc_current_locus))
8859 : return MATCH_ERROR;
8860 :
8861 4048 : if (peek_char != '(')
8862 : {
8863 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8864 1 : return MATCH_ERROR;
8865 : }
8866 :
8867 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8868 : subprogram and a binding label is specified, it shall be the
8869 : same as the binding label specified in the corresponding module
8870 : procedure interface body. */
8871 4047 : if (sym->attr.module_procedure && sym->old_symbol
8872 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8873 3 : && sym->binding_label && sym->old_symbol->binding_label
8874 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8875 : {
8876 1 : const char *null = "NULL", *s1, *s2;
8877 1 : s1 = sym->binding_label;
8878 1 : if (!s1) s1 = null;
8879 1 : s2 = sym->old_symbol->binding_label;
8880 1 : if (!s2) s2 = null;
8881 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8882 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8883 1 : return MATCH_ERROR;
8884 : }
8885 :
8886 : /* Scan the dummy arguments for an alternate return. */
8887 12533 : for (arg = sym->formal; arg; arg = arg->next)
8888 8488 : if (!arg->sym)
8889 : {
8890 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8891 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8892 1 : return MATCH_ERROR;
8893 : }
8894 :
8895 4045 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8896 : return MATCH_ERROR;
8897 : }
8898 :
8899 43202 : if (gfc_match_eos () != MATCH_YES)
8900 : {
8901 1 : gfc_syntax_error (ST_SUBROUTINE);
8902 1 : return MATCH_ERROR;
8903 : }
8904 :
8905 43201 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8906 : {
8907 4 : if(!sym->attr.module_procedure)
8908 : return MATCH_ERROR;
8909 : else
8910 3 : gfc_error_check ();
8911 : }
8912 :
8913 : /* Warn if it has the same name as an intrinsic. */
8914 43200 : do_warn_intrinsic_shadow (sym, false);
8915 :
8916 43200 : return MATCH_YES;
8917 : }
8918 :
8919 :
8920 : /* Check that the NAME identifier in a BIND attribute or statement
8921 : is conform to C identifier rules. */
8922 :
8923 : match
8924 1185 : check_bind_name_identifier (char **name)
8925 : {
8926 1185 : char *n = *name, *p;
8927 :
8928 : /* Remove leading spaces. */
8929 1211 : while (*n == ' ')
8930 26 : n++;
8931 :
8932 : /* On an empty string, free memory and set name to NULL. */
8933 1185 : if (*n == '\0')
8934 : {
8935 42 : free (*name);
8936 42 : *name = NULL;
8937 42 : return MATCH_YES;
8938 : }
8939 :
8940 : /* Remove trailing spaces. */
8941 1143 : p = n + strlen(n) - 1;
8942 1159 : while (*p == ' ')
8943 16 : *(p--) = '\0';
8944 :
8945 : /* Insert the identifier into the symbol table. */
8946 1143 : p = xstrdup (n);
8947 1143 : free (*name);
8948 1143 : *name = p;
8949 :
8950 : /* Now check that identifier is valid under C rules. */
8951 1143 : if (ISDIGIT (*p))
8952 : {
8953 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8954 2 : return MATCH_ERROR;
8955 : }
8956 :
8957 12496 : for (; *p; p++)
8958 11358 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8959 : {
8960 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8961 3 : return MATCH_ERROR;
8962 : }
8963 :
8964 : return MATCH_YES;
8965 : }
8966 :
8967 :
8968 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8969 : given, and set the binding label in either the given symbol (if not
8970 : NULL), or in the current_ts. The symbol may be NULL because we may
8971 : encounter the BIND(C) before the declaration itself. Return
8972 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8973 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8974 : or MATCH_YES if the specifier was correct and the binding label and
8975 : bind(c) fields were set correctly for the given symbol or the
8976 : current_ts. If allow_binding_name is false, no binding name may be
8977 : given. */
8978 :
8979 : match
8980 52253 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8981 : {
8982 52253 : char *binding_label = NULL;
8983 52253 : gfc_expr *e = NULL;
8984 :
8985 : /* Initialize the flag that specifies whether we encountered a NAME=
8986 : specifier or not. */
8987 52253 : has_name_equals = 0;
8988 :
8989 : /* This much we have to be able to match, in this order, if
8990 : there is a bind(c) label. */
8991 52253 : if (gfc_match (" bind ( c ") != MATCH_YES)
8992 : return MATCH_NO;
8993 :
8994 : /* Now see if there is a binding label, or if we've reached the
8995 : end of the bind(c) attribute without one. */
8996 7454 : if (gfc_match_char (',') == MATCH_YES)
8997 : {
8998 1192 : if (gfc_match (" name = ") != MATCH_YES)
8999 : {
9000 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
9001 : "at %C");
9002 : /* should give an error message here */
9003 1 : return MATCH_ERROR;
9004 : }
9005 :
9006 1191 : has_name_equals = 1;
9007 :
9008 1191 : if (gfc_match_init_expr (&e) != MATCH_YES)
9009 : {
9010 2 : gfc_free_expr (e);
9011 2 : return MATCH_ERROR;
9012 : }
9013 :
9014 1189 : if (!gfc_simplify_expr(e, 0))
9015 : {
9016 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
9017 0 : gfc_free_expr (e);
9018 0 : return MATCH_ERROR;
9019 : }
9020 :
9021 1189 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
9022 1186 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
9023 : {
9024 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
9025 : "default character kind");
9026 4 : gfc_free_expr(e);
9027 4 : return MATCH_ERROR;
9028 : }
9029 :
9030 : // Get a C string from the Fortran string constant
9031 2370 : binding_label = gfc_widechar_to_char (e->value.character.string,
9032 1185 : e->value.character.length);
9033 1185 : gfc_free_expr(e);
9034 :
9035 : // Check that it is valid (old gfc_match_name_C)
9036 1185 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
9037 : return MATCH_ERROR;
9038 : }
9039 :
9040 : /* Get the required right paren. */
9041 7442 : if (gfc_match_char (')') != MATCH_YES)
9042 : {
9043 1 : gfc_error ("Missing closing paren for binding label at %C");
9044 1 : return MATCH_ERROR;
9045 : }
9046 :
9047 7441 : if (has_name_equals && !allow_binding_name)
9048 : {
9049 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
9050 6 : return MATCH_ERROR;
9051 : }
9052 :
9053 7435 : if (has_name_equals && sym != NULL && sym->attr.dummy)
9054 : {
9055 2 : gfc_error ("For dummy procedure %s, no binding name is "
9056 : "allowed in BIND(C) at %C", sym->name);
9057 2 : return MATCH_ERROR;
9058 : }
9059 :
9060 :
9061 : /* Save the binding label to the symbol. If sym is null, we're
9062 : probably matching the typespec attributes of a declaration and
9063 : haven't gotten the name yet, and therefore, no symbol yet. */
9064 7433 : if (binding_label)
9065 : {
9066 1131 : if (sym != NULL)
9067 1022 : sym->binding_label = binding_label;
9068 : else
9069 109 : curr_binding_label = binding_label;
9070 : }
9071 6302 : else if (allow_binding_name)
9072 : {
9073 : /* No binding label, but if symbol isn't null, we
9074 : can set the label for it here.
9075 : If name="" or allow_binding_name is false, no C binding name is
9076 : created. */
9077 5873 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
9078 5706 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
9079 : }
9080 :
9081 7433 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
9082 741 : && current_interface.type == INTERFACE_ABSTRACT)
9083 : {
9084 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
9085 1 : return MATCH_ERROR;
9086 : }
9087 :
9088 : return MATCH_YES;
9089 : }
9090 :
9091 :
9092 : /* Return nonzero if we're currently compiling a contained procedure. */
9093 :
9094 : static int
9095 63602 : contained_procedure (void)
9096 : {
9097 63602 : gfc_state_data *s = gfc_state_stack;
9098 :
9099 63602 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
9100 62680 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
9101 36702 : return 1;
9102 :
9103 : return 0;
9104 : }
9105 :
9106 : /* Set the kind of each enumerator. The kind is selected such that it is
9107 : interoperable with the corresponding C enumeration type, making
9108 : sure that -fshort-enums is honored. */
9109 :
9110 : static void
9111 158 : set_enum_kind(void)
9112 : {
9113 158 : enumerator_history *current_history = NULL;
9114 158 : int kind;
9115 158 : int i;
9116 :
9117 158 : if (max_enum == NULL || enum_history == NULL)
9118 : return;
9119 :
9120 150 : if (!flag_short_enums)
9121 : return;
9122 :
9123 : i = 0;
9124 48 : do
9125 : {
9126 48 : kind = gfc_integer_kinds[i++].kind;
9127 : }
9128 48 : while (kind < gfc_c_int_kind
9129 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
9130 : kind) != ARITH_OK);
9131 :
9132 24 : current_history = enum_history;
9133 96 : while (current_history != NULL)
9134 : {
9135 72 : current_history->sym->ts.kind = kind;
9136 72 : current_history = current_history->next;
9137 : }
9138 : }
9139 :
9140 :
9141 : /* Match any of the various end-block statements. Returns the type of
9142 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
9143 : and END BLOCK statements cannot be replaced by a single END statement. */
9144 :
9145 : match
9146 186544 : gfc_match_end (gfc_statement *st)
9147 : {
9148 186544 : char name[GFC_MAX_SYMBOL_LEN + 1];
9149 186544 : gfc_compile_state state;
9150 186544 : locus old_loc;
9151 186544 : const char *block_name;
9152 186544 : const char *target;
9153 186544 : int eos_ok;
9154 186544 : match m;
9155 186544 : gfc_namespace *parent_ns, *ns, *prev_ns;
9156 186544 : gfc_namespace **nsp;
9157 186544 : bool abbreviated_modproc_decl = false;
9158 186544 : bool got_matching_end = false;
9159 :
9160 186544 : old_loc = gfc_current_locus;
9161 186544 : if (gfc_match ("end") != MATCH_YES)
9162 : return MATCH_NO;
9163 :
9164 181398 : state = gfc_current_state ();
9165 99312 : block_name = gfc_current_block () == NULL
9166 181398 : ? NULL : gfc_current_block ()->name;
9167 :
9168 181398 : switch (state)
9169 : {
9170 3001 : case COMP_ASSOCIATE:
9171 3001 : case COMP_BLOCK:
9172 3001 : case COMP_CHANGE_TEAM:
9173 3001 : if (startswith (block_name, "block@"))
9174 : block_name = NULL;
9175 : break;
9176 :
9177 17595 : case COMP_CONTAINS:
9178 17595 : case COMP_DERIVED_CONTAINS:
9179 17595 : case COMP_OMP_BEGIN_METADIRECTIVE:
9180 17595 : state = gfc_state_stack->previous->state;
9181 16047 : block_name = gfc_state_stack->previous->sym == NULL
9182 17595 : ? NULL : gfc_state_stack->previous->sym->name;
9183 17595 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
9184 17595 : && gfc_state_stack->previous->sym->abr_modproc_decl;
9185 : break;
9186 :
9187 : case COMP_OMP_METADIRECTIVE:
9188 : {
9189 : /* Metadirectives can be nested, so we need to drill down to the
9190 : first state that is not COMP_OMP_METADIRECTIVE. */
9191 : gfc_state_data *state_data = gfc_state_stack;
9192 :
9193 85 : do
9194 : {
9195 85 : state_data = state_data->previous;
9196 85 : state = state_data->state;
9197 77 : block_name = (state_data->sym == NULL
9198 85 : ? NULL : state_data->sym->name);
9199 170 : abbreviated_modproc_decl = (state_data->sym
9200 85 : && state_data->sym->abr_modproc_decl);
9201 : }
9202 85 : while (state == COMP_OMP_METADIRECTIVE);
9203 :
9204 83 : if (block_name && startswith (block_name, "block@"))
9205 : block_name = NULL;
9206 : }
9207 : break;
9208 :
9209 : default:
9210 : break;
9211 : }
9212 :
9213 83 : if (!abbreviated_modproc_decl)
9214 181397 : abbreviated_modproc_decl = gfc_current_block ()
9215 181397 : && gfc_current_block ()->abr_modproc_decl;
9216 :
9217 181398 : switch (state)
9218 : {
9219 28023 : case COMP_NONE:
9220 28023 : case COMP_PROGRAM:
9221 28023 : *st = ST_END_PROGRAM;
9222 28023 : target = " program";
9223 28023 : eos_ok = 1;
9224 28023 : break;
9225 :
9226 43390 : case COMP_SUBROUTINE:
9227 43390 : *st = ST_END_SUBROUTINE;
9228 43390 : if (!abbreviated_modproc_decl)
9229 : target = " subroutine";
9230 : else
9231 148 : target = " procedure";
9232 43390 : eos_ok = !contained_procedure ();
9233 43390 : break;
9234 :
9235 20212 : case COMP_FUNCTION:
9236 20212 : *st = ST_END_FUNCTION;
9237 20212 : if (!abbreviated_modproc_decl)
9238 : target = " function";
9239 : else
9240 117 : target = " procedure";
9241 20212 : eos_ok = !contained_procedure ();
9242 20212 : break;
9243 :
9244 87 : case COMP_BLOCK_DATA:
9245 87 : *st = ST_END_BLOCK_DATA;
9246 87 : target = " block data";
9247 87 : eos_ok = 1;
9248 87 : break;
9249 :
9250 9914 : case COMP_MODULE:
9251 9914 : *st = ST_END_MODULE;
9252 9914 : target = " module";
9253 9914 : eos_ok = 1;
9254 9914 : break;
9255 :
9256 266 : case COMP_SUBMODULE:
9257 266 : *st = ST_END_SUBMODULE;
9258 266 : target = " submodule";
9259 266 : eos_ok = 1;
9260 266 : break;
9261 :
9262 11337 : case COMP_INTERFACE:
9263 11337 : *st = ST_END_INTERFACE;
9264 11337 : target = " interface";
9265 11337 : eos_ok = 0;
9266 11337 : break;
9267 :
9268 257 : case COMP_MAP:
9269 257 : *st = ST_END_MAP;
9270 257 : target = " map";
9271 257 : eos_ok = 0;
9272 257 : break;
9273 :
9274 132 : case COMP_UNION:
9275 132 : *st = ST_END_UNION;
9276 132 : target = " union";
9277 132 : eos_ok = 0;
9278 132 : break;
9279 :
9280 313 : case COMP_STRUCTURE:
9281 313 : *st = ST_END_STRUCTURE;
9282 313 : target = " structure";
9283 313 : eos_ok = 0;
9284 313 : break;
9285 :
9286 13056 : case COMP_DERIVED:
9287 13056 : case COMP_DERIVED_CONTAINS:
9288 13056 : *st = ST_END_TYPE;
9289 13056 : target = " type";
9290 13056 : eos_ok = 0;
9291 13056 : break;
9292 :
9293 1549 : case COMP_ASSOCIATE:
9294 1549 : *st = ST_END_ASSOCIATE;
9295 1549 : target = " associate";
9296 1549 : eos_ok = 0;
9297 1549 : break;
9298 :
9299 1408 : case COMP_BLOCK:
9300 1408 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9301 1408 : *st = ST_END_BLOCK;
9302 1408 : target = " block";
9303 1408 : eos_ok = 0;
9304 1408 : break;
9305 :
9306 14857 : case COMP_IF:
9307 14857 : *st = ST_ENDIF;
9308 14857 : target = " if";
9309 14857 : eos_ok = 0;
9310 14857 : break;
9311 :
9312 30767 : case COMP_DO:
9313 30767 : case COMP_DO_CONCURRENT:
9314 30767 : *st = ST_ENDDO;
9315 30767 : target = " do";
9316 30767 : eos_ok = 0;
9317 30767 : break;
9318 :
9319 54 : case COMP_CRITICAL:
9320 54 : *st = ST_END_CRITICAL;
9321 54 : target = " critical";
9322 54 : eos_ok = 0;
9323 54 : break;
9324 :
9325 4653 : case COMP_SELECT:
9326 4653 : case COMP_SELECT_TYPE:
9327 4653 : case COMP_SELECT_RANK:
9328 4653 : *st = ST_END_SELECT;
9329 4653 : target = " select";
9330 4653 : eos_ok = 0;
9331 4653 : break;
9332 :
9333 509 : case COMP_FORALL:
9334 509 : *st = ST_END_FORALL;
9335 509 : target = " forall";
9336 509 : eos_ok = 0;
9337 509 : break;
9338 :
9339 373 : case COMP_WHERE:
9340 373 : *st = ST_END_WHERE;
9341 373 : target = " where";
9342 373 : eos_ok = 0;
9343 373 : break;
9344 :
9345 158 : case COMP_ENUM:
9346 158 : *st = ST_END_ENUM;
9347 158 : target = " enum";
9348 158 : eos_ok = 0;
9349 158 : last_initializer = NULL;
9350 158 : set_enum_kind ();
9351 158 : gfc_free_enum_history ();
9352 158 : break;
9353 :
9354 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9355 0 : *st = ST_OMP_END_METADIRECTIVE;
9356 0 : target = " metadirective";
9357 0 : eos_ok = 0;
9358 0 : break;
9359 :
9360 74 : case COMP_CHANGE_TEAM:
9361 74 : *st = ST_END_TEAM;
9362 74 : target = " team";
9363 74 : eos_ok = 0;
9364 74 : break;
9365 :
9366 9 : default:
9367 9 : gfc_error ("Unexpected END statement at %C");
9368 9 : goto cleanup;
9369 : }
9370 :
9371 181389 : old_loc = gfc_current_locus;
9372 181389 : if (gfc_match_eos () == MATCH_YES)
9373 : {
9374 20719 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9375 : {
9376 8143 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9377 : "instead of %s statement at %L",
9378 : abbreviated_modproc_decl ? "END PROCEDURE"
9379 4059 : : gfc_ascii_statement(*st), &old_loc))
9380 4 : goto cleanup;
9381 : }
9382 9 : else if (!eos_ok)
9383 : {
9384 : /* We would have required END [something]. */
9385 9 : gfc_error ("%s statement expected at %L",
9386 : gfc_ascii_statement (*st), &old_loc);
9387 9 : goto cleanup;
9388 : }
9389 :
9390 20706 : return MATCH_YES;
9391 : }
9392 :
9393 : /* Verify that we've got the sort of end-block that we're expecting. */
9394 160670 : if (gfc_match (target) != MATCH_YES)
9395 : {
9396 331 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9397 165 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9398 166 : goto cleanup;
9399 : }
9400 : else
9401 160504 : got_matching_end = true;
9402 :
9403 160504 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9404 : /* Emit errors of stat and errmsg parsing now to finish the block and
9405 : continue analysis of compilation unit. */
9406 2 : gfc_error_check ();
9407 :
9408 160504 : old_loc = gfc_current_locus;
9409 : /* If we're at the end, make sure a block name wasn't required. */
9410 160504 : if (gfc_match_eos () == MATCH_YES)
9411 : {
9412 105993 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9413 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9414 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9415 : && *st != ST_END_TEAM)
9416 : return MATCH_YES;
9417 :
9418 53745 : if (!block_name)
9419 : return MATCH_YES;
9420 :
9421 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9422 : block_name, gfc_ascii_statement (*st), &old_loc);
9423 :
9424 8 : return MATCH_ERROR;
9425 : }
9426 :
9427 : /* END INTERFACE has a special handler for its several possible endings. */
9428 54511 : if (*st == ST_END_INTERFACE)
9429 696 : return gfc_match_end_interface ();
9430 :
9431 : /* We haven't hit the end of statement, so what is left must be an
9432 : end-name. */
9433 53815 : m = gfc_match_space ();
9434 53815 : if (m == MATCH_YES)
9435 53815 : m = gfc_match_name (name);
9436 :
9437 53815 : if (m == MATCH_NO)
9438 0 : gfc_error ("Expected terminating name at %C");
9439 53815 : if (m != MATCH_YES)
9440 0 : goto cleanup;
9441 :
9442 53815 : if (block_name == NULL)
9443 15 : goto syntax;
9444 :
9445 : /* We have to pick out the declared submodule name from the composite
9446 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9447 53800 : if (state == COMP_SUBMODULE)
9448 137 : block_name = strchr (block_name, '.') + 1;
9449 :
9450 53800 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9451 : {
9452 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9453 : gfc_ascii_statement (*st));
9454 8 : goto cleanup;
9455 : }
9456 : /* Procedure pointer as function result. */
9457 53792 : else if (strcmp (block_name, "ppr@") == 0
9458 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9459 : {
9460 0 : gfc_error ("Expected label %qs for %s statement at %C",
9461 0 : gfc_current_block ()->ns->proc_name->name,
9462 : gfc_ascii_statement (*st));
9463 0 : goto cleanup;
9464 : }
9465 :
9466 53792 : if (gfc_match_eos () == MATCH_YES)
9467 : return MATCH_YES;
9468 :
9469 0 : syntax:
9470 15 : gfc_syntax_error (*st);
9471 :
9472 211 : cleanup:
9473 211 : gfc_current_locus = old_loc;
9474 :
9475 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9476 : Remove it from the parent namespace's sibling list. */
9477 :
9478 211 : if (state == COMP_BLOCK && !got_matching_end)
9479 : {
9480 7 : parent_ns = gfc_current_ns->parent;
9481 :
9482 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9483 :
9484 7 : prev_ns = NULL;
9485 7 : ns = *nsp;
9486 14 : while (ns)
9487 : {
9488 7 : if (ns == gfc_current_ns)
9489 : {
9490 7 : if (prev_ns == NULL)
9491 7 : *nsp = NULL;
9492 : else
9493 0 : prev_ns->sibling = ns->sibling;
9494 : }
9495 7 : prev_ns = ns;
9496 7 : ns = ns->sibling;
9497 : }
9498 :
9499 : /* The namespace can still be referenced by parser state and code nodes;
9500 : let normal block unwinding/freeing own its lifetime. */
9501 7 : gfc_current_ns = parent_ns;
9502 7 : gfc_state_stack = gfc_state_stack->previous;
9503 7 : state = gfc_current_state ();
9504 : }
9505 :
9506 : return MATCH_ERROR;
9507 : }
9508 :
9509 :
9510 :
9511 : /***************** Attribute declaration statements ****************/
9512 :
9513 : /* Set the attribute of a single variable. */
9514 :
9515 : static match
9516 10427 : attr_decl1 (void)
9517 : {
9518 10427 : char name[GFC_MAX_SYMBOL_LEN + 1];
9519 10427 : gfc_array_spec *as;
9520 :
9521 : /* Workaround -Wmaybe-uninitialized false positive during
9522 : profiledbootstrap by initializing them. */
9523 10427 : gfc_symbol *sym = NULL;
9524 10427 : locus var_locus;
9525 10427 : match m;
9526 :
9527 10427 : as = NULL;
9528 :
9529 10427 : m = gfc_match_name (name);
9530 10427 : if (m != MATCH_YES)
9531 0 : goto cleanup;
9532 :
9533 10427 : if (find_special (name, &sym, false))
9534 : return MATCH_ERROR;
9535 :
9536 10427 : if (!check_function_name (name))
9537 : {
9538 7 : m = MATCH_ERROR;
9539 7 : goto cleanup;
9540 : }
9541 :
9542 10420 : var_locus = gfc_current_locus;
9543 :
9544 : /* Deal with possible array specification for certain attributes. */
9545 10420 : if (current_attr.dimension
9546 8841 : || current_attr.codimension
9547 8819 : || current_attr.allocatable
9548 8395 : || current_attr.pointer
9549 7672 : || current_attr.target)
9550 : {
9551 2974 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9552 : !current_attr.dimension
9553 1395 : && !current_attr.pointer
9554 3646 : && !current_attr.target);
9555 2974 : if (m == MATCH_ERROR)
9556 2 : goto cleanup;
9557 :
9558 2972 : if (current_attr.dimension && m == MATCH_NO)
9559 : {
9560 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9561 : "statement", &var_locus);
9562 0 : m = MATCH_ERROR;
9563 0 : goto cleanup;
9564 : }
9565 :
9566 2972 : if (current_attr.dimension && sym->value)
9567 : {
9568 1 : gfc_error ("Dimensions specified for %s at %L after its "
9569 : "initialization", sym->name, &var_locus);
9570 1 : m = MATCH_ERROR;
9571 1 : goto cleanup;
9572 : }
9573 :
9574 2971 : if (current_attr.codimension && m == MATCH_NO)
9575 : {
9576 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9577 : "statement", &var_locus);
9578 0 : m = MATCH_ERROR;
9579 0 : goto cleanup;
9580 : }
9581 :
9582 2971 : if ((current_attr.allocatable || current_attr.pointer)
9583 1147 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9584 : {
9585 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9586 0 : m = MATCH_ERROR;
9587 0 : goto cleanup;
9588 : }
9589 : }
9590 :
9591 10417 : if (sym->ts.type == BT_CLASS
9592 200 : && sym->ts.u.derived
9593 200 : && sym->ts.u.derived->attr.is_class)
9594 : {
9595 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9596 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9597 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9598 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9599 177 : if (CLASS_DATA (sym)->as)
9600 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9601 : }
9602 8840 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9603 19236 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9604 : {
9605 22 : m = MATCH_ERROR;
9606 22 : goto cleanup;
9607 : }
9608 10395 : if (!gfc_set_array_spec (sym, as, &var_locus))
9609 : {
9610 18 : m = MATCH_ERROR;
9611 18 : goto cleanup;
9612 : }
9613 :
9614 10377 : if (sym->attr.cray_pointee && sym->as != NULL)
9615 : {
9616 : /* Fix the array spec. */
9617 2 : m = gfc_mod_pointee_as (sym->as);
9618 2 : if (m == MATCH_ERROR)
9619 0 : goto cleanup;
9620 : }
9621 :
9622 10377 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9623 : {
9624 0 : m = MATCH_ERROR;
9625 0 : goto cleanup;
9626 : }
9627 :
9628 5740 : if ((current_attr.external || current_attr.intrinsic)
9629 6289 : && sym->attr.flavor != FL_PROCEDURE
9630 16634 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9631 : {
9632 0 : m = MATCH_ERROR;
9633 0 : goto cleanup;
9634 : }
9635 :
9636 10377 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9637 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9638 136 : && !current_attr.external)
9639 : {
9640 136 : sym->attr.pointer = 0;
9641 136 : sym->attr.allocatable = 0;
9642 136 : sym->attr.dimension = 0;
9643 136 : sym->attr.codimension = 0;
9644 136 : gfc_free_array_spec (sym->as);
9645 136 : sym->as = NULL;
9646 : }
9647 10241 : else if (sym->ts.type == BT_CLASS
9648 10241 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9649 : {
9650 0 : m = MATCH_ERROR;
9651 0 : goto cleanup;
9652 : }
9653 :
9654 10377 : add_hidden_procptr_result (sym);
9655 :
9656 10377 : return MATCH_YES;
9657 :
9658 50 : cleanup:
9659 50 : gfc_free_array_spec (as);
9660 50 : return m;
9661 : }
9662 :
9663 :
9664 : /* Generic attribute declaration subroutine. Used for attributes that
9665 : just have a list of names. */
9666 :
9667 : static match
9668 6712 : attr_decl (void)
9669 : {
9670 6712 : match m;
9671 :
9672 : /* Gobble the optional double colon, by simply ignoring the result
9673 : of gfc_match(). */
9674 6712 : gfc_match (" ::");
9675 :
9676 10427 : for (;;)
9677 : {
9678 10427 : m = attr_decl1 ();
9679 10427 : if (m != MATCH_YES)
9680 : break;
9681 :
9682 10377 : if (gfc_match_eos () == MATCH_YES)
9683 : {
9684 : m = MATCH_YES;
9685 : break;
9686 : }
9687 :
9688 3715 : if (gfc_match_char (',') != MATCH_YES)
9689 : {
9690 0 : gfc_error ("Unexpected character in variable list at %C");
9691 0 : m = MATCH_ERROR;
9692 0 : break;
9693 : }
9694 : }
9695 :
9696 6712 : return m;
9697 : }
9698 :
9699 :
9700 : /* This routine matches Cray Pointer declarations of the form:
9701 : pointer ( <pointer>, <pointee> )
9702 : or
9703 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9704 : The pointer, if already declared, should be an integer. Otherwise, we
9705 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9706 : be either a scalar, or an array declaration. No space is allocated for
9707 : the pointee. For the statement
9708 : pointer (ipt, ar(10))
9709 : any subsequent uses of ar will be translated (in C-notation) as
9710 : ar(i) => ((<type> *) ipt)(i)
9711 : After gimplification, pointee variable will disappear in the code. */
9712 :
9713 : static match
9714 334 : cray_pointer_decl (void)
9715 : {
9716 334 : match m;
9717 334 : gfc_array_spec *as = NULL;
9718 334 : gfc_symbol *cptr; /* Pointer symbol. */
9719 334 : gfc_symbol *cpte; /* Pointee symbol. */
9720 334 : locus var_locus;
9721 334 : bool done = false;
9722 :
9723 334 : while (!done)
9724 : {
9725 347 : if (gfc_match_char ('(') != MATCH_YES)
9726 : {
9727 1 : gfc_error ("Expected %<(%> at %C");
9728 1 : return MATCH_ERROR;
9729 : }
9730 :
9731 : /* Match pointer. */
9732 346 : var_locus = gfc_current_locus;
9733 346 : gfc_clear_attr (¤t_attr);
9734 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9735 346 : current_ts.type = BT_INTEGER;
9736 346 : current_ts.kind = gfc_index_integer_kind;
9737 :
9738 346 : m = gfc_match_symbol (&cptr, 0);
9739 346 : if (m != MATCH_YES)
9740 : {
9741 2 : gfc_error ("Expected variable name at %C");
9742 2 : return m;
9743 : }
9744 :
9745 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9746 : return MATCH_ERROR;
9747 :
9748 341 : gfc_set_sym_referenced (cptr);
9749 :
9750 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9751 : {
9752 327 : cptr->ts.type = BT_INTEGER;
9753 327 : cptr->ts.kind = gfc_index_integer_kind;
9754 : }
9755 14 : else if (cptr->ts.type != BT_INTEGER)
9756 : {
9757 1 : gfc_error ("Cray pointer at %C must be an integer");
9758 1 : return MATCH_ERROR;
9759 : }
9760 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9761 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9762 : " memory addresses require %d bytes",
9763 : cptr->ts.kind, gfc_index_integer_kind);
9764 :
9765 340 : if (gfc_match_char (',') != MATCH_YES)
9766 : {
9767 2 : gfc_error ("Expected \",\" at %C");
9768 2 : return MATCH_ERROR;
9769 : }
9770 :
9771 : /* Match Pointee. */
9772 338 : var_locus = gfc_current_locus;
9773 338 : gfc_clear_attr (¤t_attr);
9774 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9775 338 : current_ts.type = BT_UNKNOWN;
9776 338 : current_ts.kind = 0;
9777 :
9778 338 : m = gfc_match_symbol (&cpte, 0);
9779 338 : if (m != MATCH_YES)
9780 : {
9781 2 : gfc_error ("Expected variable name at %C");
9782 2 : return m;
9783 : }
9784 :
9785 : /* Check for an optional array spec. */
9786 336 : m = gfc_match_array_spec (&as, true, false);
9787 336 : if (m == MATCH_ERROR)
9788 : {
9789 0 : gfc_free_array_spec (as);
9790 0 : return m;
9791 : }
9792 336 : else if (m == MATCH_NO)
9793 : {
9794 226 : gfc_free_array_spec (as);
9795 226 : as = NULL;
9796 : }
9797 :
9798 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9799 : return MATCH_ERROR;
9800 :
9801 329 : gfc_set_sym_referenced (cpte);
9802 :
9803 329 : if (cpte->as == NULL)
9804 : {
9805 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9806 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9807 : }
9808 82 : else if (as != NULL)
9809 : {
9810 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9811 1 : gfc_free_array_spec (as);
9812 1 : return MATCH_ERROR;
9813 : }
9814 :
9815 328 : as = NULL;
9816 :
9817 328 : if (cpte->as != NULL)
9818 : {
9819 : /* Fix array spec. */
9820 190 : m = gfc_mod_pointee_as (cpte->as);
9821 190 : if (m == MATCH_ERROR)
9822 : return m;
9823 : }
9824 :
9825 : /* Point the Pointee at the Pointer. */
9826 328 : cpte->cp_pointer = cptr;
9827 :
9828 328 : if (gfc_match_char (')') != MATCH_YES)
9829 : {
9830 2 : gfc_error ("Expected \")\" at %C");
9831 2 : return MATCH_ERROR;
9832 : }
9833 326 : m = gfc_match_char (',');
9834 326 : if (m != MATCH_YES)
9835 313 : done = true; /* Stop searching for more declarations. */
9836 :
9837 : }
9838 :
9839 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9840 313 : || gfc_match_eos () != MATCH_YES)
9841 : {
9842 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9843 0 : return MATCH_ERROR;
9844 : }
9845 : return MATCH_YES;
9846 : }
9847 :
9848 :
9849 : match
9850 3215 : gfc_match_external (void)
9851 : {
9852 :
9853 3215 : gfc_clear_attr (¤t_attr);
9854 3215 : current_attr.external = 1;
9855 :
9856 3215 : return attr_decl ();
9857 : }
9858 :
9859 :
9860 : match
9861 208 : gfc_match_intent (void)
9862 : {
9863 208 : sym_intent intent;
9864 :
9865 : /* This is not allowed within a BLOCK construct! */
9866 208 : if (gfc_current_state () == COMP_BLOCK)
9867 : {
9868 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9869 2 : return MATCH_ERROR;
9870 : }
9871 :
9872 206 : intent = match_intent_spec ();
9873 206 : if (intent == INTENT_UNKNOWN)
9874 : return MATCH_ERROR;
9875 :
9876 206 : gfc_clear_attr (¤t_attr);
9877 206 : current_attr.intent = intent;
9878 :
9879 206 : return attr_decl ();
9880 : }
9881 :
9882 :
9883 : match
9884 1482 : gfc_match_intrinsic (void)
9885 : {
9886 :
9887 1482 : gfc_clear_attr (¤t_attr);
9888 1482 : current_attr.intrinsic = 1;
9889 :
9890 1482 : return attr_decl ();
9891 : }
9892 :
9893 :
9894 : match
9895 220 : gfc_match_optional (void)
9896 : {
9897 : /* This is not allowed within a BLOCK construct! */
9898 220 : if (gfc_current_state () == COMP_BLOCK)
9899 : {
9900 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9901 2 : return MATCH_ERROR;
9902 : }
9903 :
9904 218 : gfc_clear_attr (¤t_attr);
9905 218 : current_attr.optional = 1;
9906 :
9907 218 : return attr_decl ();
9908 : }
9909 :
9910 :
9911 : match
9912 915 : gfc_match_pointer (void)
9913 : {
9914 915 : gfc_gobble_whitespace ();
9915 915 : if (gfc_peek_ascii_char () == '(')
9916 : {
9917 335 : if (!flag_cray_pointer)
9918 : {
9919 1 : gfc_error ("Cray pointer declaration at %C requires "
9920 : "%<-fcray-pointer%> flag");
9921 1 : return MATCH_ERROR;
9922 : }
9923 334 : return cray_pointer_decl ();
9924 : }
9925 : else
9926 : {
9927 580 : gfc_clear_attr (¤t_attr);
9928 580 : current_attr.pointer = 1;
9929 :
9930 580 : return attr_decl ();
9931 : }
9932 : }
9933 :
9934 :
9935 : match
9936 162 : gfc_match_allocatable (void)
9937 : {
9938 162 : gfc_clear_attr (¤t_attr);
9939 162 : current_attr.allocatable = 1;
9940 :
9941 162 : return attr_decl ();
9942 : }
9943 :
9944 :
9945 : match
9946 23 : gfc_match_codimension (void)
9947 : {
9948 23 : gfc_clear_attr (¤t_attr);
9949 23 : current_attr.codimension = 1;
9950 :
9951 23 : return attr_decl ();
9952 : }
9953 :
9954 :
9955 : match
9956 80 : gfc_match_contiguous (void)
9957 : {
9958 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9959 : return MATCH_ERROR;
9960 :
9961 79 : gfc_clear_attr (¤t_attr);
9962 79 : current_attr.contiguous = 1;
9963 :
9964 79 : return attr_decl ();
9965 : }
9966 :
9967 :
9968 : match
9969 648 : gfc_match_dimension (void)
9970 : {
9971 648 : gfc_clear_attr (¤t_attr);
9972 648 : current_attr.dimension = 1;
9973 :
9974 648 : return attr_decl ();
9975 : }
9976 :
9977 :
9978 : match
9979 99 : gfc_match_target (void)
9980 : {
9981 99 : gfc_clear_attr (¤t_attr);
9982 99 : current_attr.target = 1;
9983 :
9984 99 : return attr_decl ();
9985 : }
9986 :
9987 :
9988 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9989 : statement. */
9990 :
9991 : static match
9992 1766 : access_attr_decl (gfc_statement st)
9993 : {
9994 1766 : char name[GFC_MAX_SYMBOL_LEN + 1];
9995 1766 : interface_type type;
9996 1766 : gfc_user_op *uop;
9997 1766 : gfc_symbol *sym, *dt_sym;
9998 1766 : gfc_intrinsic_op op;
9999 1766 : match m;
10000 1766 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
10001 :
10002 1766 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10003 0 : goto done;
10004 :
10005 2916 : for (;;)
10006 : {
10007 2916 : m = gfc_match_generic_spec (&type, name, &op);
10008 2916 : if (m == MATCH_NO)
10009 0 : goto syntax;
10010 2916 : if (m == MATCH_ERROR)
10011 0 : goto done;
10012 :
10013 2916 : switch (type)
10014 : {
10015 0 : case INTERFACE_NAMELESS:
10016 0 : case INTERFACE_ABSTRACT:
10017 0 : goto syntax;
10018 :
10019 2839 : case INTERFACE_GENERIC:
10020 2839 : case INTERFACE_DTIO:
10021 :
10022 2839 : if (gfc_get_symbol (name, NULL, &sym))
10023 0 : goto done;
10024 :
10025 2839 : if (type == INTERFACE_DTIO
10026 26 : && gfc_current_ns->proc_name
10027 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
10028 26 : && sym->attr.flavor == FL_UNKNOWN)
10029 2 : sym->attr.flavor = FL_PROCEDURE;
10030 :
10031 2839 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
10032 4 : goto done;
10033 :
10034 330 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
10035 2892 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
10036 0 : goto done;
10037 :
10038 : break;
10039 :
10040 72 : case INTERFACE_INTRINSIC_OP:
10041 72 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
10042 : {
10043 72 : gfc_intrinsic_op other_op;
10044 :
10045 72 : gfc_current_ns->operator_access[op] = access;
10046 :
10047 : /* Handle the case if there is another op with the same
10048 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
10049 72 : other_op = gfc_equivalent_op (op);
10050 :
10051 72 : if (other_op != INTRINSIC_NONE)
10052 21 : gfc_current_ns->operator_access[other_op] = access;
10053 : }
10054 : else
10055 : {
10056 0 : gfc_error ("Access specification of the %s operator at %C has "
10057 : "already been specified", gfc_op2string (op));
10058 0 : goto done;
10059 : }
10060 :
10061 : break;
10062 :
10063 5 : case INTERFACE_USER_OP:
10064 5 : uop = gfc_get_uop (name);
10065 :
10066 5 : if (uop->access == ACCESS_UNKNOWN)
10067 : {
10068 4 : uop->access = access;
10069 : }
10070 : else
10071 : {
10072 1 : gfc_error ("Access specification of the .%s. operator at %C "
10073 : "has already been specified", uop->name);
10074 1 : goto done;
10075 : }
10076 :
10077 4 : break;
10078 : }
10079 :
10080 2911 : if (gfc_match_char (',') == MATCH_NO)
10081 : break;
10082 : }
10083 :
10084 1761 : if (gfc_match_eos () != MATCH_YES)
10085 0 : goto syntax;
10086 : return MATCH_YES;
10087 :
10088 0 : syntax:
10089 0 : gfc_syntax_error (st);
10090 :
10091 : done:
10092 : return MATCH_ERROR;
10093 : }
10094 :
10095 :
10096 : match
10097 23 : gfc_match_protected (void)
10098 : {
10099 23 : gfc_symbol *sym;
10100 23 : match m;
10101 23 : char c;
10102 :
10103 : /* PROTECTED has already been seen, but must be followed by whitespace
10104 : or ::. */
10105 23 : c = gfc_peek_ascii_char ();
10106 23 : if (!gfc_is_whitespace (c) && c != ':')
10107 : return MATCH_NO;
10108 :
10109 22 : if (!gfc_current_ns->proc_name
10110 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
10111 : {
10112 3 : gfc_error ("PROTECTED at %C only allowed in specification "
10113 : "part of a module");
10114 3 : return MATCH_ERROR;
10115 :
10116 : }
10117 :
10118 19 : gfc_match (" ::");
10119 :
10120 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
10121 : return MATCH_ERROR;
10122 :
10123 : /* PROTECTED has an entity-list. */
10124 18 : if (gfc_match_eos () == MATCH_YES)
10125 0 : goto syntax;
10126 :
10127 26 : for(;;)
10128 : {
10129 26 : m = gfc_match_symbol (&sym, 0);
10130 26 : switch (m)
10131 : {
10132 26 : case MATCH_YES:
10133 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
10134 : return MATCH_ERROR;
10135 25 : goto next_item;
10136 :
10137 : case MATCH_NO:
10138 : break;
10139 :
10140 : case MATCH_ERROR:
10141 : return MATCH_ERROR;
10142 : }
10143 :
10144 25 : next_item:
10145 25 : if (gfc_match_eos () == MATCH_YES)
10146 : break;
10147 8 : if (gfc_match_char (',') != MATCH_YES)
10148 0 : goto syntax;
10149 : }
10150 :
10151 : return MATCH_YES;
10152 :
10153 0 : syntax:
10154 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
10155 0 : return MATCH_ERROR;
10156 : }
10157 :
10158 :
10159 : /* The PRIVATE statement is a bit weird in that it can be an attribute
10160 : declaration, but also works as a standalone statement inside of a
10161 : type declaration or a module. */
10162 :
10163 : match
10164 29199 : gfc_match_private (gfc_statement *st)
10165 : {
10166 29199 : gfc_state_data *prev;
10167 :
10168 29199 : if (gfc_match ("private") != MATCH_YES)
10169 : return MATCH_NO;
10170 :
10171 : /* Try matching PRIVATE without an access-list. */
10172 1634 : if (gfc_match_eos () == MATCH_YES)
10173 : {
10174 1347 : prev = gfc_state_stack->previous;
10175 1347 : if (gfc_current_state () != COMP_MODULE
10176 367 : && !(gfc_current_state () == COMP_DERIVED
10177 334 : && prev && prev->state == COMP_MODULE)
10178 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10179 32 : && prev->previous && prev->previous->state == COMP_MODULE))
10180 : {
10181 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10182 : "specification part of a module");
10183 2 : return MATCH_ERROR;
10184 : }
10185 :
10186 1345 : *st = ST_PRIVATE;
10187 1345 : return MATCH_YES;
10188 : }
10189 :
10190 : /* At this point in free-form source code, PRIVATE must be followed
10191 : by whitespace or ::. */
10192 287 : if (gfc_current_form == FORM_FREE)
10193 : {
10194 285 : char c = gfc_peek_ascii_char ();
10195 285 : if (!gfc_is_whitespace (c) && c != ':')
10196 : return MATCH_NO;
10197 : }
10198 :
10199 286 : prev = gfc_state_stack->previous;
10200 286 : if (gfc_current_state () != COMP_MODULE
10201 1 : && !(gfc_current_state () == COMP_DERIVED
10202 0 : && prev && prev->state == COMP_MODULE)
10203 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
10204 0 : && prev->previous && prev->previous->state == COMP_MODULE))
10205 : {
10206 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
10207 : "specification part of a module");
10208 1 : return MATCH_ERROR;
10209 : }
10210 :
10211 285 : *st = ST_ATTR_DECL;
10212 285 : return access_attr_decl (ST_PRIVATE);
10213 : }
10214 :
10215 :
10216 : match
10217 1879 : gfc_match_public (gfc_statement *st)
10218 : {
10219 1879 : if (gfc_match ("public") != MATCH_YES)
10220 : return MATCH_NO;
10221 :
10222 : /* Try matching PUBLIC without an access-list. */
10223 1528 : if (gfc_match_eos () == MATCH_YES)
10224 : {
10225 45 : if (gfc_current_state () != COMP_MODULE)
10226 : {
10227 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10228 : "specification part of a module");
10229 2 : return MATCH_ERROR;
10230 : }
10231 :
10232 43 : *st = ST_PUBLIC;
10233 43 : return MATCH_YES;
10234 : }
10235 :
10236 : /* At this point in free-form source code, PUBLIC must be followed
10237 : by whitespace or ::. */
10238 1483 : if (gfc_current_form == FORM_FREE)
10239 : {
10240 1481 : char c = gfc_peek_ascii_char ();
10241 1481 : if (!gfc_is_whitespace (c) && c != ':')
10242 : return MATCH_NO;
10243 : }
10244 :
10245 1482 : if (gfc_current_state () != COMP_MODULE)
10246 : {
10247 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10248 : "specification part of a module");
10249 1 : return MATCH_ERROR;
10250 : }
10251 :
10252 1481 : *st = ST_ATTR_DECL;
10253 1481 : return access_attr_decl (ST_PUBLIC);
10254 : }
10255 :
10256 :
10257 : /* Workhorse for gfc_match_parameter. */
10258 :
10259 : static match
10260 8533 : do_parm (void)
10261 : {
10262 8533 : gfc_symbol *sym;
10263 8533 : gfc_expr *init;
10264 8533 : gfc_charlen *saved_cl_list;
10265 8533 : match m;
10266 8533 : bool t;
10267 :
10268 8533 : saved_cl_list = gfc_current_ns->cl_list;
10269 :
10270 8533 : m = gfc_match_symbol (&sym, 0);
10271 8533 : if (m == MATCH_NO)
10272 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10273 :
10274 8533 : if (m != MATCH_YES)
10275 : return m;
10276 :
10277 8533 : if (gfc_match_char ('=') == MATCH_NO)
10278 : {
10279 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10280 0 : return MATCH_ERROR;
10281 : }
10282 :
10283 8533 : m = gfc_match_init_expr (&init);
10284 8533 : if (m == MATCH_NO)
10285 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10286 8533 : if (m != MATCH_YES)
10287 : return m;
10288 :
10289 8532 : if (sym->ts.type == BT_UNKNOWN
10290 8532 : && !gfc_set_default_type (sym, 1, NULL))
10291 : {
10292 1 : m = MATCH_ERROR;
10293 1 : goto cleanup;
10294 : }
10295 :
10296 8531 : if (!gfc_check_assign_symbol (sym, NULL, init)
10297 8531 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10298 : {
10299 1 : m = MATCH_ERROR;
10300 1 : goto cleanup;
10301 : }
10302 :
10303 8530 : if (sym->value)
10304 : {
10305 1 : gfc_error ("Initializing already initialized variable at %C");
10306 1 : m = MATCH_ERROR;
10307 1 : goto cleanup;
10308 : }
10309 :
10310 8529 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus,
10311 : saved_cl_list);
10312 8529 : return (t) ? MATCH_YES : MATCH_ERROR;
10313 :
10314 3 : cleanup:
10315 3 : gfc_free_expr (init);
10316 3 : return m;
10317 : }
10318 :
10319 :
10320 : /* Match a parameter statement, with the weird syntax that these have. */
10321 :
10322 : match
10323 7820 : gfc_match_parameter (void)
10324 : {
10325 7820 : const char *term = " )%t";
10326 7820 : match m;
10327 :
10328 7820 : if (gfc_match_char ('(') == MATCH_NO)
10329 : {
10330 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10331 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10332 : return MATCH_NO;
10333 7819 : term = " %t";
10334 : }
10335 :
10336 8533 : for (;;)
10337 : {
10338 8533 : m = do_parm ();
10339 8533 : if (m != MATCH_YES)
10340 : break;
10341 :
10342 8529 : if (gfc_match (term) == MATCH_YES)
10343 : break;
10344 :
10345 714 : if (gfc_match_char (',') != MATCH_YES)
10346 : {
10347 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10348 0 : m = MATCH_ERROR;
10349 0 : break;
10350 : }
10351 : }
10352 :
10353 : return m;
10354 : }
10355 :
10356 :
10357 : match
10358 8 : gfc_match_automatic (void)
10359 : {
10360 8 : gfc_symbol *sym;
10361 8 : match m;
10362 8 : bool seen_symbol = false;
10363 :
10364 8 : if (!flag_dec_static)
10365 : {
10366 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10367 : "%<-fdec-static%>",
10368 : "AUTOMATIC"
10369 : );
10370 2 : return MATCH_ERROR;
10371 : }
10372 :
10373 6 : gfc_match (" ::");
10374 :
10375 6 : for (;;)
10376 : {
10377 6 : m = gfc_match_symbol (&sym, 0);
10378 6 : switch (m)
10379 : {
10380 : case MATCH_NO:
10381 : break;
10382 :
10383 : case MATCH_ERROR:
10384 : return MATCH_ERROR;
10385 :
10386 4 : case MATCH_YES:
10387 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10388 : return MATCH_ERROR;
10389 : seen_symbol = true;
10390 : break;
10391 : }
10392 :
10393 4 : if (gfc_match_eos () == MATCH_YES)
10394 : break;
10395 0 : if (gfc_match_char (',') != MATCH_YES)
10396 0 : goto syntax;
10397 : }
10398 :
10399 4 : if (!seen_symbol)
10400 : {
10401 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10402 2 : return MATCH_ERROR;
10403 : }
10404 :
10405 : return MATCH_YES;
10406 :
10407 0 : syntax:
10408 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10409 0 : return MATCH_ERROR;
10410 : }
10411 :
10412 :
10413 : match
10414 7 : gfc_match_static (void)
10415 : {
10416 7 : gfc_symbol *sym;
10417 7 : match m;
10418 7 : bool seen_symbol = false;
10419 :
10420 7 : if (!flag_dec_static)
10421 : {
10422 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10423 : "%<-fdec-static%>",
10424 : "STATIC");
10425 2 : return MATCH_ERROR;
10426 : }
10427 :
10428 5 : gfc_match (" ::");
10429 :
10430 5 : for (;;)
10431 : {
10432 5 : m = gfc_match_symbol (&sym, 0);
10433 5 : switch (m)
10434 : {
10435 : case MATCH_NO:
10436 : break;
10437 :
10438 : case MATCH_ERROR:
10439 : return MATCH_ERROR;
10440 :
10441 3 : case MATCH_YES:
10442 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10443 : &gfc_current_locus))
10444 : return MATCH_ERROR;
10445 : seen_symbol = true;
10446 : break;
10447 : }
10448 :
10449 3 : if (gfc_match_eos () == MATCH_YES)
10450 : break;
10451 0 : if (gfc_match_char (',') != MATCH_YES)
10452 0 : goto syntax;
10453 : }
10454 :
10455 3 : if (!seen_symbol)
10456 : {
10457 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10458 2 : return MATCH_ERROR;
10459 : }
10460 :
10461 : return MATCH_YES;
10462 :
10463 0 : syntax:
10464 0 : gfc_error ("Syntax error in STATIC statement at %C");
10465 0 : return MATCH_ERROR;
10466 : }
10467 :
10468 :
10469 : /* Save statements have a special syntax. */
10470 :
10471 : match
10472 272 : gfc_match_save (void)
10473 : {
10474 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10475 272 : gfc_common_head *c;
10476 272 : gfc_symbol *sym;
10477 272 : match m;
10478 :
10479 272 : if (gfc_match_eos () == MATCH_YES)
10480 : {
10481 150 : if (gfc_current_ns->seen_save)
10482 : {
10483 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10484 : "follows previous SAVE statement"))
10485 : return MATCH_ERROR;
10486 : }
10487 :
10488 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10489 149 : return MATCH_YES;
10490 : }
10491 :
10492 122 : if (gfc_current_ns->save_all)
10493 : {
10494 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10495 : "blanket SAVE statement"))
10496 : return MATCH_ERROR;
10497 : }
10498 :
10499 121 : gfc_match (" ::");
10500 :
10501 183 : for (;;)
10502 : {
10503 183 : m = gfc_match_symbol (&sym, 0);
10504 183 : switch (m)
10505 : {
10506 181 : case MATCH_YES:
10507 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10508 : &gfc_current_locus))
10509 : return MATCH_ERROR;
10510 179 : goto next_item;
10511 :
10512 : case MATCH_NO:
10513 : break;
10514 :
10515 : case MATCH_ERROR:
10516 : return MATCH_ERROR;
10517 : }
10518 :
10519 2 : m = gfc_match (" / %n /", &n);
10520 2 : if (m == MATCH_ERROR)
10521 : return MATCH_ERROR;
10522 2 : if (m == MATCH_NO)
10523 0 : goto syntax;
10524 :
10525 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10526 : saved-entity-list that does not specify a common-block-name. */
10527 2 : if (gfc_current_state () == COMP_BLOCK)
10528 : {
10529 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10530 : "in a BLOCK construct", n);
10531 1 : return MATCH_ERROR;
10532 : }
10533 :
10534 1 : c = gfc_get_common (n, 0);
10535 1 : c->saved = 1;
10536 :
10537 1 : gfc_current_ns->seen_save = 1;
10538 :
10539 180 : next_item:
10540 180 : if (gfc_match_eos () == MATCH_YES)
10541 : break;
10542 62 : if (gfc_match_char (',') != MATCH_YES)
10543 0 : goto syntax;
10544 : }
10545 :
10546 : return MATCH_YES;
10547 :
10548 0 : syntax:
10549 0 : if (gfc_current_ns->seen_save)
10550 : {
10551 0 : gfc_error ("Syntax error in SAVE statement at %C");
10552 0 : return MATCH_ERROR;
10553 : }
10554 : else
10555 : return MATCH_NO;
10556 : }
10557 :
10558 :
10559 : match
10560 93 : gfc_match_value (void)
10561 : {
10562 93 : gfc_symbol *sym;
10563 93 : match m;
10564 :
10565 : /* This is not allowed within a BLOCK construct! */
10566 93 : if (gfc_current_state () == COMP_BLOCK)
10567 : {
10568 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10569 2 : return MATCH_ERROR;
10570 : }
10571 :
10572 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10573 : return MATCH_ERROR;
10574 :
10575 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10576 : {
10577 : return MATCH_ERROR;
10578 : }
10579 :
10580 90 : if (gfc_match_eos () == MATCH_YES)
10581 0 : goto syntax;
10582 :
10583 116 : for(;;)
10584 : {
10585 116 : m = gfc_match_symbol (&sym, 0);
10586 116 : switch (m)
10587 : {
10588 116 : case MATCH_YES:
10589 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10590 : return MATCH_ERROR;
10591 109 : goto next_item;
10592 :
10593 : case MATCH_NO:
10594 : break;
10595 :
10596 : case MATCH_ERROR:
10597 : return MATCH_ERROR;
10598 : }
10599 :
10600 109 : next_item:
10601 109 : if (gfc_match_eos () == MATCH_YES)
10602 : break;
10603 26 : if (gfc_match_char (',') != MATCH_YES)
10604 0 : goto syntax;
10605 : }
10606 :
10607 : return MATCH_YES;
10608 :
10609 0 : syntax:
10610 0 : gfc_error ("Syntax error in VALUE statement at %C");
10611 0 : return MATCH_ERROR;
10612 : }
10613 :
10614 :
10615 : match
10616 45 : gfc_match_volatile (void)
10617 : {
10618 45 : gfc_symbol *sym;
10619 45 : char *name;
10620 45 : match m;
10621 :
10622 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10623 : return MATCH_ERROR;
10624 :
10625 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10626 : {
10627 : return MATCH_ERROR;
10628 : }
10629 :
10630 44 : if (gfc_match_eos () == MATCH_YES)
10631 1 : goto syntax;
10632 :
10633 48 : for(;;)
10634 : {
10635 : /* VOLATILE is special because it can be added to host-associated
10636 : symbols locally. Except for coarrays. */
10637 48 : m = gfc_match_symbol (&sym, 1);
10638 48 : switch (m)
10639 : {
10640 48 : case MATCH_YES:
10641 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10642 48 : strcpy (name, sym->name);
10643 48 : if (!check_function_name (name))
10644 : return MATCH_ERROR;
10645 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10646 : for variable in a BLOCK which is defined outside of the BLOCK. */
10647 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10648 : {
10649 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10650 : "%C, which is use-/host-associated", sym->name);
10651 2 : return MATCH_ERROR;
10652 : }
10653 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10654 : return MATCH_ERROR;
10655 42 : goto next_item;
10656 :
10657 : case MATCH_NO:
10658 : break;
10659 :
10660 : case MATCH_ERROR:
10661 : return MATCH_ERROR;
10662 : }
10663 :
10664 42 : next_item:
10665 42 : if (gfc_match_eos () == MATCH_YES)
10666 : break;
10667 5 : if (gfc_match_char (',') != MATCH_YES)
10668 0 : goto syntax;
10669 : }
10670 :
10671 : return MATCH_YES;
10672 :
10673 1 : syntax:
10674 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10675 1 : return MATCH_ERROR;
10676 : }
10677 :
10678 :
10679 : match
10680 11 : gfc_match_asynchronous (void)
10681 : {
10682 11 : gfc_symbol *sym;
10683 11 : char *name;
10684 11 : match m;
10685 :
10686 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10687 : return MATCH_ERROR;
10688 :
10689 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10690 : {
10691 : return MATCH_ERROR;
10692 : }
10693 :
10694 10 : if (gfc_match_eos () == MATCH_YES)
10695 0 : goto syntax;
10696 :
10697 10 : for(;;)
10698 : {
10699 : /* ASYNCHRONOUS is special because it can be added to host-associated
10700 : symbols locally. */
10701 10 : m = gfc_match_symbol (&sym, 1);
10702 10 : switch (m)
10703 : {
10704 10 : case MATCH_YES:
10705 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10706 10 : strcpy (name, sym->name);
10707 10 : if (!check_function_name (name))
10708 : return MATCH_ERROR;
10709 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10710 : return MATCH_ERROR;
10711 7 : goto next_item;
10712 :
10713 : case MATCH_NO:
10714 : break;
10715 :
10716 : case MATCH_ERROR:
10717 : return MATCH_ERROR;
10718 : }
10719 :
10720 7 : next_item:
10721 7 : if (gfc_match_eos () == MATCH_YES)
10722 : break;
10723 0 : if (gfc_match_char (',') != MATCH_YES)
10724 0 : goto syntax;
10725 : }
10726 :
10727 : return MATCH_YES;
10728 :
10729 0 : syntax:
10730 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10731 0 : return MATCH_ERROR;
10732 : }
10733 :
10734 :
10735 : /* Match a module procedure statement in a submodule. */
10736 :
10737 : match
10738 765714 : gfc_match_submod_proc (void)
10739 : {
10740 765714 : char name[GFC_MAX_SYMBOL_LEN + 1];
10741 765714 : gfc_symbol *sym, *fsym;
10742 765714 : match m;
10743 765714 : gfc_formal_arglist *formal, *head, *tail;
10744 :
10745 765714 : if (gfc_current_state () != COMP_CONTAINS
10746 15583 : || !(gfc_state_stack->previous
10747 15583 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10748 15583 : || gfc_state_stack->previous->state == COMP_MODULE)))
10749 : return MATCH_NO;
10750 :
10751 7801 : m = gfc_match (" module% procedure% %n", name);
10752 7801 : if (m != MATCH_YES)
10753 : return m;
10754 :
10755 267 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10756 : "at %C"))
10757 : return MATCH_ERROR;
10758 :
10759 267 : if (get_proc_name (name, &sym, false))
10760 : return MATCH_ERROR;
10761 :
10762 : /* Make sure that the result field is appropriately filled. */
10763 267 : if (sym->tlink && sym->tlink->attr.function)
10764 : {
10765 117 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10766 : {
10767 67 : sym->result = sym->tlink->result;
10768 67 : if (!sym->result->attr.use_assoc)
10769 : {
10770 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10771 : sym->result->name);
10772 20 : st->n.sym = sym->result;
10773 20 : sym->result->refs++;
10774 : }
10775 : }
10776 : else
10777 50 : sym->result = sym;
10778 : }
10779 :
10780 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10781 : the symbol existed before. */
10782 267 : sym->declared_at = gfc_current_locus;
10783 :
10784 267 : if (!sym->attr.module_procedure)
10785 : return MATCH_ERROR;
10786 :
10787 : /* Signal match_end to expect "end procedure". */
10788 265 : sym->abr_modproc_decl = 1;
10789 :
10790 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10791 265 : sym->attr.if_source = IFSRC_DECL;
10792 :
10793 265 : gfc_new_block = sym;
10794 :
10795 : /* Make a new formal arglist with the symbols in the procedure
10796 : namespace. */
10797 265 : head = tail = NULL;
10798 600 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10799 : {
10800 335 : if (formal == sym->formal)
10801 238 : head = tail = gfc_get_formal_arglist ();
10802 : else
10803 : {
10804 97 : tail->next = gfc_get_formal_arglist ();
10805 97 : tail = tail->next;
10806 : }
10807 :
10808 335 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10809 0 : goto cleanup;
10810 :
10811 335 : tail->sym = fsym;
10812 335 : gfc_set_sym_referenced (fsym);
10813 : }
10814 :
10815 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10816 : interface declaration is cleared. This allows us to add the
10817 : explicit interface as is done for other type of procedure. */
10818 265 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10819 : &gfc_current_locus))
10820 : return MATCH_ERROR;
10821 :
10822 265 : if (gfc_match_eos () != MATCH_YES)
10823 : {
10824 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10825 : undone, such that the st->n.sym->formal points to the original symbol;
10826 : if now this namespace is finalized, the formal namespace is freed,
10827 : but it might be still needed in the parent namespace. */
10828 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10829 1 : st->n.sym = NULL;
10830 1 : gfc_free_symbol (sym->tlink);
10831 1 : sym->tlink = NULL;
10832 1 : sym->refs--;
10833 1 : gfc_syntax_error (ST_MODULE_PROC);
10834 1 : return MATCH_ERROR;
10835 : }
10836 :
10837 : return MATCH_YES;
10838 :
10839 0 : cleanup:
10840 0 : gfc_free_formal_arglist (head);
10841 0 : return MATCH_ERROR;
10842 : }
10843 :
10844 :
10845 : /* Match a module procedure statement. Note that we have to modify
10846 : symbols in the parent's namespace because the current one was there
10847 : to receive symbols that are in an interface's formal argument list. */
10848 :
10849 : match
10850 1620 : gfc_match_modproc (void)
10851 : {
10852 1620 : char name[GFC_MAX_SYMBOL_LEN + 1];
10853 1620 : gfc_symbol *sym;
10854 1620 : match m;
10855 1620 : locus old_locus;
10856 1620 : gfc_namespace *module_ns;
10857 1620 : gfc_interface *old_interface_head, *interface;
10858 :
10859 1620 : if (gfc_state_stack->previous == NULL
10860 1618 : || (gfc_state_stack->state != COMP_INTERFACE
10861 5 : && (gfc_state_stack->state != COMP_CONTAINS
10862 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10863 1613 : || current_interface.type == INTERFACE_NAMELESS
10864 1613 : || current_interface.type == INTERFACE_ABSTRACT)
10865 : {
10866 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10867 : "interface");
10868 8 : return MATCH_ERROR;
10869 : }
10870 :
10871 1612 : module_ns = gfc_current_ns->parent;
10872 1618 : for (; module_ns; module_ns = module_ns->parent)
10873 1618 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10874 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10875 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10876 12 : && !module_ns->proc_name->attr.contained))
10877 : break;
10878 :
10879 1612 : if (module_ns == NULL)
10880 : return MATCH_ERROR;
10881 :
10882 : /* Store the current state of the interface. We will need it if we
10883 : end up with a syntax error and need to recover. */
10884 1612 : old_interface_head = gfc_current_interface_head ();
10885 :
10886 : /* Check if the F2008 optional double colon appears. */
10887 1612 : gfc_gobble_whitespace ();
10888 1612 : old_locus = gfc_current_locus;
10889 1612 : if (gfc_match ("::") == MATCH_YES)
10890 : {
10891 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10892 : "MODULE PROCEDURE statement at %L", &old_locus))
10893 : return MATCH_ERROR;
10894 : }
10895 : else
10896 1587 : gfc_current_locus = old_locus;
10897 :
10898 1967 : for (;;)
10899 : {
10900 1967 : bool last = false;
10901 1967 : old_locus = gfc_current_locus;
10902 :
10903 1967 : m = gfc_match_name (name);
10904 1967 : if (m == MATCH_NO)
10905 1 : goto syntax;
10906 1966 : if (m != MATCH_YES)
10907 : return MATCH_ERROR;
10908 :
10909 : /* Check for syntax error before starting to add symbols to the
10910 : current namespace. */
10911 1966 : if (gfc_match_eos () == MATCH_YES)
10912 : last = true;
10913 :
10914 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10915 2 : goto syntax;
10916 :
10917 : /* Now we're sure the syntax is valid, we process this item
10918 : further. */
10919 1964 : if (gfc_get_symbol (name, module_ns, &sym))
10920 : return MATCH_ERROR;
10921 :
10922 1964 : if (sym->attr.intrinsic)
10923 : {
10924 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10925 : "PROCEDURE", &old_locus);
10926 1 : return MATCH_ERROR;
10927 : }
10928 :
10929 1963 : if (sym->attr.proc != PROC_MODULE
10930 1963 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10931 : return MATCH_ERROR;
10932 :
10933 1960 : if (!gfc_add_interface (sym))
10934 : return MATCH_ERROR;
10935 :
10936 1957 : sym->attr.mod_proc = 1;
10937 1957 : sym->declared_at = old_locus;
10938 :
10939 1957 : if (last)
10940 : break;
10941 : }
10942 :
10943 : return MATCH_YES;
10944 :
10945 3 : syntax:
10946 : /* Restore the previous state of the interface. */
10947 3 : interface = gfc_current_interface_head ();
10948 3 : gfc_set_current_interface_head (old_interface_head);
10949 :
10950 : /* Free the new interfaces. */
10951 10 : while (interface != old_interface_head)
10952 : {
10953 4 : gfc_interface *i = interface->next;
10954 4 : free (interface);
10955 4 : interface = i;
10956 : }
10957 :
10958 : /* And issue a syntax error. */
10959 3 : gfc_syntax_error (ST_MODULE_PROC);
10960 3 : return MATCH_ERROR;
10961 : }
10962 :
10963 :
10964 : /* Check a derived type that is being extended. */
10965 :
10966 : static gfc_symbol*
10967 1491 : check_extended_derived_type (char *name)
10968 : {
10969 1491 : gfc_symbol *extended;
10970 :
10971 1491 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10972 : {
10973 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10974 0 : return NULL;
10975 : }
10976 :
10977 1491 : extended = gfc_find_dt_in_generic (extended);
10978 :
10979 : /* F08:C428. */
10980 1491 : if (!extended)
10981 : {
10982 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10983 2 : return NULL;
10984 : }
10985 :
10986 1489 : if (extended->attr.flavor != FL_DERIVED)
10987 : {
10988 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10989 : "derived type", name);
10990 0 : return NULL;
10991 : }
10992 :
10993 1489 : if (extended->attr.is_bind_c)
10994 : {
10995 1 : gfc_error ("%qs cannot be extended at %C because it "
10996 : "is BIND(C)", extended->name);
10997 1 : return NULL;
10998 : }
10999 :
11000 1488 : if (extended->attr.sequence)
11001 : {
11002 1 : gfc_error ("%qs cannot be extended at %C because it "
11003 : "is a SEQUENCE type", extended->name);
11004 1 : return NULL;
11005 : }
11006 :
11007 : return extended;
11008 : }
11009 :
11010 :
11011 : /* Match the optional attribute specifiers for a type declaration.
11012 : Return MATCH_ERROR if an error is encountered in one of the handled
11013 : attributes (public, private, bind(c)), MATCH_NO if what's found is
11014 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
11015 : checking on attribute conflicts needs to be done. */
11016 :
11017 : static match
11018 19478 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
11019 : {
11020 : /* See if the derived type is marked as private. */
11021 19478 : if (gfc_match (" , private") == MATCH_YES)
11022 : {
11023 15 : if (gfc_current_state () != COMP_MODULE)
11024 : {
11025 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
11026 : "specification part of a module");
11027 1 : return MATCH_ERROR;
11028 : }
11029 :
11030 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
11031 : return MATCH_ERROR;
11032 : }
11033 19463 : else if (gfc_match (" , public") == MATCH_YES)
11034 : {
11035 546 : if (gfc_current_state () != COMP_MODULE)
11036 : {
11037 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
11038 : "specification part of a module");
11039 0 : return MATCH_ERROR;
11040 : }
11041 :
11042 546 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
11043 : return MATCH_ERROR;
11044 : }
11045 18917 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
11046 : {
11047 : /* If the type is defined to be bind(c) it then needs to make
11048 : sure that all fields are interoperable. This will
11049 : need to be a semantic check on the finished derived type.
11050 : See 15.2.3 (lines 9-12) of F2003 draft. */
11051 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
11052 : return MATCH_ERROR;
11053 :
11054 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
11055 : }
11056 18510 : else if (gfc_match (" , abstract") == MATCH_YES)
11057 : {
11058 337 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
11059 : return MATCH_ERROR;
11060 :
11061 336 : if (!gfc_add_abstract (attr, &gfc_current_locus))
11062 : return MATCH_ERROR;
11063 : }
11064 18173 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
11065 : {
11066 1492 : if (!gfc_add_extension (attr, &gfc_current_locus))
11067 : return MATCH_ERROR;
11068 : }
11069 : else
11070 16681 : return MATCH_NO;
11071 :
11072 : /* If we get here, something matched. */
11073 : return MATCH_YES;
11074 : }
11075 :
11076 :
11077 : /* Common function for type declaration blocks similar to derived types, such
11078 : as STRUCTURES and MAPs. Unlike derived types, a structure type
11079 : does NOT have a generic symbol matching the name given by the user.
11080 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
11081 : for the creation of an independent symbol.
11082 : Other parameters are a message to prefix errors with, the name of the new
11083 : type to be created, and the flavor to add to the resulting symbol. */
11084 :
11085 : static bool
11086 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
11087 : gfc_symbol **result)
11088 : {
11089 717 : gfc_symbol *sym;
11090 717 : locus where;
11091 :
11092 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
11093 :
11094 717 : if (decl)
11095 717 : where = *decl;
11096 : else
11097 0 : where = gfc_current_locus;
11098 :
11099 717 : if (gfc_get_symbol (name, NULL, &sym))
11100 : return false;
11101 :
11102 717 : if (!sym)
11103 : {
11104 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
11105 : return false;
11106 : }
11107 :
11108 717 : if (sym->components != NULL || sym->attr.zero_comp)
11109 : {
11110 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
11111 : sym->name, &sym->declared_at);
11112 3 : return false;
11113 : }
11114 :
11115 714 : sym->declared_at = where;
11116 :
11117 714 : if (sym->attr.flavor != fl
11118 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
11119 : return false;
11120 :
11121 714 : if (!sym->hash_value)
11122 : /* Set the hash for the compound name for this type. */
11123 713 : sym->hash_value = gfc_hash_value (sym);
11124 :
11125 : /* Normally the type is expected to have been completely parsed by the time
11126 : a field declaration with this type is seen. For unions, maps, and nested
11127 : structure declarations, we need to indicate that it is okay that we
11128 : haven't seen any components yet. This will be updated after the structure
11129 : is fully parsed. */
11130 714 : sym->attr.zero_comp = 0;
11131 :
11132 : /* Structures always act like derived-types with the SEQUENCE attribute */
11133 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
11134 :
11135 714 : if (result) *result = sym;
11136 :
11137 : return true;
11138 : }
11139 :
11140 :
11141 : /* Match the opening of a MAP block. Like a struct within a union in C;
11142 : behaves identical to STRUCTURE blocks. */
11143 :
11144 : match
11145 259 : gfc_match_map (void)
11146 : {
11147 : /* Counter used to give unique internal names to map structures. */
11148 259 : static unsigned int gfc_map_id = 0;
11149 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
11150 259 : gfc_symbol *sym;
11151 259 : locus old_loc;
11152 :
11153 259 : old_loc = gfc_current_locus;
11154 :
11155 259 : if (gfc_match_eos () != MATCH_YES)
11156 : {
11157 1 : gfc_error ("Junk after MAP statement at %C");
11158 1 : gfc_current_locus = old_loc;
11159 1 : return MATCH_ERROR;
11160 : }
11161 :
11162 : /* Map blocks are anonymous so we make up unique names for the symbol table
11163 : which are invalid Fortran identifiers. */
11164 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
11165 :
11166 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
11167 : return MATCH_ERROR;
11168 :
11169 258 : gfc_new_block = sym;
11170 :
11171 258 : return MATCH_YES;
11172 : }
11173 :
11174 :
11175 : /* Match the opening of a UNION block. */
11176 :
11177 : match
11178 133 : gfc_match_union (void)
11179 : {
11180 : /* Counter used to give unique internal names to union types. */
11181 133 : static unsigned int gfc_union_id = 0;
11182 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
11183 133 : gfc_symbol *sym;
11184 133 : locus old_loc;
11185 :
11186 133 : old_loc = gfc_current_locus;
11187 :
11188 133 : if (gfc_match_eos () != MATCH_YES)
11189 : {
11190 1 : gfc_error ("Junk after UNION statement at %C");
11191 1 : gfc_current_locus = old_loc;
11192 1 : return MATCH_ERROR;
11193 : }
11194 :
11195 : /* Unions are anonymous so we make up unique names for the symbol table
11196 : which are invalid Fortran identifiers. */
11197 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
11198 :
11199 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
11200 : return MATCH_ERROR;
11201 :
11202 132 : gfc_new_block = sym;
11203 :
11204 132 : return MATCH_YES;
11205 : }
11206 :
11207 :
11208 : /* Match the beginning of a STRUCTURE declaration. This is similar to
11209 : matching the beginning of a derived type declaration with a few
11210 : twists. The resulting type symbol has no access control or other
11211 : interesting attributes. */
11212 :
11213 : match
11214 336 : gfc_match_structure_decl (void)
11215 : {
11216 : /* Counter used to give unique internal names to anonymous structures. */
11217 336 : static unsigned int gfc_structure_id = 0;
11218 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
11219 336 : gfc_symbol *sym;
11220 336 : match m;
11221 336 : locus where;
11222 :
11223 336 : if (!flag_dec_structure)
11224 : {
11225 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11226 : "%<-fdec-structure%>",
11227 : "STRUCTURE");
11228 3 : return MATCH_ERROR;
11229 : }
11230 :
11231 333 : name[0] = '\0';
11232 :
11233 333 : m = gfc_match (" /%n/", name);
11234 333 : if (m != MATCH_YES)
11235 : {
11236 : /* Non-nested structure declarations require a structure name. */
11237 24 : if (!gfc_comp_struct (gfc_current_state ()))
11238 : {
11239 4 : gfc_error ("Structure name expected in non-nested structure "
11240 : "declaration at %C");
11241 4 : return MATCH_ERROR;
11242 : }
11243 : /* This is an anonymous structure; make up a unique name for it
11244 : (upper-case letters never make it to symbol names from the source).
11245 : The important thing is initializing the type variable
11246 : and setting gfc_new_symbol, which is immediately used by
11247 : parse_structure () and variable_decl () to add components of
11248 : this type. */
11249 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11250 : }
11251 :
11252 329 : where = gfc_current_locus;
11253 : /* No field list allowed after non-nested structure declaration. */
11254 329 : if (!gfc_comp_struct (gfc_current_state ())
11255 296 : && gfc_match_eos () != MATCH_YES)
11256 : {
11257 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11258 1 : return MATCH_ERROR;
11259 : }
11260 :
11261 : /* Make sure the name is not the name of an intrinsic type. */
11262 328 : if (gfc_is_intrinsic_typename (name))
11263 : {
11264 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11265 : " intrinsic type", name);
11266 1 : return MATCH_ERROR;
11267 : }
11268 :
11269 : /* Store the actual type symbol for the structure with an upper-case first
11270 : letter (an invalid Fortran identifier). */
11271 :
11272 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11273 : return MATCH_ERROR;
11274 :
11275 324 : gfc_new_block = sym;
11276 324 : return MATCH_YES;
11277 : }
11278 :
11279 :
11280 : /* This function does some work to determine which matcher should be used to
11281 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11282 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11283 : * and [parameterized] derived type declarations. */
11284 :
11285 : match
11286 531071 : gfc_match_type (gfc_statement *st)
11287 : {
11288 531071 : char name[GFC_MAX_SYMBOL_LEN + 1];
11289 531071 : match m;
11290 531071 : locus old_loc;
11291 :
11292 : /* Requires -fdec. */
11293 531071 : if (!flag_dec)
11294 : return MATCH_NO;
11295 :
11296 2483 : m = gfc_match ("type");
11297 2483 : if (m != MATCH_YES)
11298 : return m;
11299 : /* If we already have an error in the buffer, it is probably from failing to
11300 : * match a derived type data declaration. Let it happen. */
11301 20 : else if (gfc_error_flag_test ())
11302 : return MATCH_NO;
11303 :
11304 20 : old_loc = gfc_current_locus;
11305 20 : *st = ST_NONE;
11306 :
11307 : /* If we see an attribute list before anything else it's definitely a derived
11308 : * type declaration. */
11309 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11310 8 : goto derived;
11311 :
11312 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11313 : * be something like "TYPE *" or "TYPE <fmt>". */
11314 12 : m = gfc_match_name (name);
11315 12 : if (m != MATCH_YES)
11316 : {
11317 : /* Let print match if it can, otherwise throw an error from
11318 : * gfc_match_derived_decl. */
11319 7 : gfc_current_locus = old_loc;
11320 7 : if (gfc_match_print () == MATCH_YES)
11321 : {
11322 7 : *st = ST_WRITE;
11323 7 : return MATCH_YES;
11324 : }
11325 0 : goto derived;
11326 : }
11327 :
11328 : /* Check for EOS. */
11329 5 : if (gfc_match_eos () == MATCH_YES)
11330 : {
11331 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11332 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11333 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11334 : * symbol which can be printed. */
11335 3 : gfc_current_locus = old_loc;
11336 3 : m = gfc_match_derived_decl ();
11337 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11338 : {
11339 2 : *st = ST_DERIVED_DECL;
11340 2 : return m;
11341 : }
11342 : }
11343 : else
11344 : {
11345 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11346 : like <type name(parameter)>. */
11347 2 : gfc_gobble_whitespace ();
11348 2 : bool paren = gfc_peek_ascii_char () == '(';
11349 2 : if (paren)
11350 : {
11351 1 : if (strcmp ("is", name) == 0)
11352 1 : goto typeis;
11353 : else
11354 0 : goto derived;
11355 : }
11356 : }
11357 :
11358 : /* Treat TYPE... like PRINT... */
11359 2 : gfc_current_locus = old_loc;
11360 2 : *st = ST_WRITE;
11361 2 : return gfc_match_print ();
11362 :
11363 8 : derived:
11364 8 : gfc_current_locus = old_loc;
11365 8 : *st = ST_DERIVED_DECL;
11366 8 : return gfc_match_derived_decl ();
11367 :
11368 1 : typeis:
11369 1 : gfc_current_locus = old_loc;
11370 1 : *st = ST_TYPE_IS;
11371 1 : return gfc_match_type_is ();
11372 : }
11373 :
11374 :
11375 : /* Match the beginning of a derived type declaration. If a type name
11376 : was the result of a function, then it is possible to have a symbol
11377 : already to be known as a derived type yet have no components. */
11378 :
11379 : match
11380 16688 : gfc_match_derived_decl (void)
11381 : {
11382 16688 : char name[GFC_MAX_SYMBOL_LEN + 1];
11383 16688 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11384 16688 : symbol_attribute attr;
11385 16688 : gfc_symbol *sym, *gensym;
11386 16688 : gfc_symbol *extended;
11387 16688 : match m;
11388 16688 : match is_type_attr_spec = MATCH_NO;
11389 16688 : bool seen_attr = false;
11390 16688 : gfc_interface *intr = NULL, *head;
11391 16688 : bool parameterized_type = false;
11392 16688 : bool seen_colons = false;
11393 :
11394 16688 : if (gfc_comp_struct (gfc_current_state ()))
11395 : return MATCH_NO;
11396 :
11397 16684 : name[0] = '\0';
11398 16684 : parent[0] = '\0';
11399 16684 : gfc_clear_attr (&attr);
11400 16684 : extended = NULL;
11401 :
11402 19478 : do
11403 : {
11404 19478 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11405 19478 : if (is_type_attr_spec == MATCH_ERROR)
11406 : return MATCH_ERROR;
11407 19475 : if (is_type_attr_spec == MATCH_YES)
11408 2794 : seen_attr = true;
11409 19475 : } while (is_type_attr_spec == MATCH_YES);
11410 :
11411 : /* Deal with derived type extensions. The extension attribute has
11412 : been added to 'attr' but now the parent type must be found and
11413 : checked. */
11414 16681 : if (parent[0])
11415 1491 : extended = check_extended_derived_type (parent);
11416 :
11417 16681 : if (parent[0] && !extended)
11418 : return MATCH_ERROR;
11419 :
11420 16677 : m = gfc_match (" ::");
11421 16677 : if (m == MATCH_YES)
11422 : {
11423 : seen_colons = true;
11424 : }
11425 10508 : else if (seen_attr)
11426 : {
11427 5 : gfc_error ("Expected :: in TYPE definition at %C");
11428 5 : return MATCH_ERROR;
11429 : }
11430 :
11431 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11432 : But, we need to simply return for TYPE(. */
11433 10503 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11434 : {
11435 10454 : char c = gfc_peek_ascii_char ();
11436 10454 : if (c == '(')
11437 : return m;
11438 10373 : if (!gfc_is_whitespace (c))
11439 : {
11440 4 : gfc_error ("Mangled derived type definition at %C");
11441 4 : return MATCH_NO;
11442 : }
11443 : }
11444 :
11445 16587 : m = gfc_match (" %n ", name);
11446 16587 : if (m != MATCH_YES)
11447 : return m;
11448 :
11449 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11450 : derived type named 'is'.
11451 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11452 : and checking if this is a(n intrinsic) typename. This picks up
11453 : misplaced TYPE IS statements such as in select_type_1.f03. */
11454 16575 : if (gfc_peek_ascii_char () == '(')
11455 : {
11456 3941 : if (gfc_current_state () == COMP_SELECT_TYPE
11457 459 : || (!seen_colons && !strcmp (name, "is")))
11458 : return MATCH_NO;
11459 : parameterized_type = true;
11460 : }
11461 :
11462 13091 : m = gfc_match_eos ();
11463 13091 : if (m != MATCH_YES && !parameterized_type)
11464 : return m;
11465 :
11466 : /* Make sure the name is not the name of an intrinsic type. */
11467 13088 : if (gfc_is_intrinsic_typename (name))
11468 : {
11469 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11470 : "type", name);
11471 18 : return MATCH_ERROR;
11472 : }
11473 :
11474 13070 : if (gfc_get_symbol (name, NULL, &gensym))
11475 : return MATCH_ERROR;
11476 :
11477 13070 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11478 : {
11479 5 : if (gensym->ts.u.derived)
11480 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11481 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11482 : else
11483 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11484 : gensym->name);
11485 5 : return MATCH_ERROR;
11486 : }
11487 :
11488 13065 : if (!gensym->attr.generic
11489 13065 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11490 : return MATCH_ERROR;
11491 :
11492 13061 : if (!gensym->attr.function
11493 13061 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11494 : return MATCH_ERROR;
11495 :
11496 13060 : if (gensym->attr.dummy)
11497 : {
11498 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11499 : name, &gensym->declared_at);
11500 1 : return MATCH_ERROR;
11501 : }
11502 :
11503 13059 : sym = gfc_find_dt_in_generic (gensym);
11504 :
11505 13059 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11506 : {
11507 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11508 : "defined", sym->name);
11509 1 : return MATCH_ERROR;
11510 : }
11511 :
11512 13058 : if (!sym)
11513 : {
11514 : /* Use upper case to save the actual derived-type symbol. */
11515 12968 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11516 12968 : sym->name = gfc_get_string ("%s", gensym->name);
11517 12968 : head = gensym->generic;
11518 12968 : intr = gfc_get_interface ();
11519 12968 : intr->sym = sym;
11520 12968 : intr->where = gfc_current_locus;
11521 12968 : intr->sym->declared_at = gfc_current_locus;
11522 12968 : intr->next = head;
11523 12968 : gensym->generic = intr;
11524 12968 : gensym->attr.if_source = IFSRC_DECL;
11525 : }
11526 :
11527 : /* The symbol may already have the derived attribute without the
11528 : components. The ways this can happen is via a function
11529 : definition, an INTRINSIC statement or a subtype in another
11530 : derived type that is a pointer. The first part of the AND clause
11531 : is true if the symbol is not the return value of a function. */
11532 13058 : if (sym->attr.flavor != FL_DERIVED
11533 13058 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11534 : return MATCH_ERROR;
11535 :
11536 13058 : if (attr.access != ACCESS_UNKNOWN
11537 13058 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11538 : return MATCH_ERROR;
11539 13058 : else if (sym->attr.access == ACCESS_UNKNOWN
11540 12502 : && gensym->attr.access != ACCESS_UNKNOWN
11541 13406 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11542 : sym->name, NULL))
11543 : return MATCH_ERROR;
11544 :
11545 13058 : if (sym->attr.access != ACCESS_UNKNOWN
11546 904 : && gensym->attr.access == ACCESS_UNKNOWN)
11547 556 : gensym->attr.access = sym->attr.access;
11548 :
11549 : /* See if the derived type was labeled as bind(c). */
11550 13058 : if (attr.is_bind_c != 0)
11551 404 : sym->attr.is_bind_c = attr.is_bind_c;
11552 :
11553 : /* Construct the f2k_derived namespace if it is not yet there. */
11554 13058 : if (!sym->f2k_derived)
11555 13058 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11556 :
11557 13058 : if (parameterized_type)
11558 : {
11559 : /* Ignore error or mismatches by going to the end of the statement
11560 : in order to avoid the component declarations causing problems. */
11561 457 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11562 457 : if (m != MATCH_YES)
11563 4 : gfc_error_recovery ();
11564 : else
11565 453 : sym->attr.pdt_template = 1;
11566 457 : m = gfc_match_eos ();
11567 457 : if (m != MATCH_YES)
11568 : {
11569 1 : gfc_error_recovery ();
11570 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11571 : }
11572 : }
11573 :
11574 13058 : if (extended && !sym->components)
11575 : {
11576 1487 : gfc_component *p;
11577 1487 : gfc_formal_arglist *f, *g, *h;
11578 :
11579 : /* Add the extended derived type as the first component. */
11580 1487 : gfc_add_component (sym, parent, &p);
11581 1487 : extended->refs++;
11582 1487 : gfc_set_sym_referenced (extended);
11583 :
11584 1487 : p->ts.type = BT_DERIVED;
11585 1487 : p->ts.u.derived = extended;
11586 1487 : p->initializer = gfc_default_initializer (&p->ts);
11587 :
11588 : /* Set extension level. */
11589 1487 : if (extended->attr.extension == 255)
11590 : {
11591 : /* Since the extension field is 8 bit wide, we can only have
11592 : up to 255 extension levels. */
11593 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11594 : extended->name, &extended->declared_at);
11595 0 : return MATCH_ERROR;
11596 : }
11597 1487 : sym->attr.extension = extended->attr.extension + 1;
11598 :
11599 : /* Provide the links between the extended type and its extension. */
11600 1487 : if (!extended->f2k_derived)
11601 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11602 :
11603 : /* Copy the extended type-param-name-list from the extended type,
11604 : append those of the extension and add the whole lot to the
11605 : extension. */
11606 1487 : if (extended->attr.pdt_template)
11607 : {
11608 40 : g = h = NULL;
11609 40 : sym->attr.pdt_template = 1;
11610 111 : for (f = extended->formal; f; f = f->next)
11611 : {
11612 71 : if (f == extended->formal)
11613 : {
11614 40 : g = gfc_get_formal_arglist ();
11615 40 : h = g;
11616 : }
11617 : else
11618 : {
11619 31 : g->next = gfc_get_formal_arglist ();
11620 31 : g = g->next;
11621 : }
11622 71 : g->sym = f->sym;
11623 : }
11624 40 : g->next = sym->formal;
11625 40 : sym->formal = h;
11626 : }
11627 : }
11628 :
11629 13058 : if (!sym->hash_value)
11630 : /* Set the hash for the compound name for this type. */
11631 13058 : sym->hash_value = gfc_hash_value (sym);
11632 :
11633 : /* Take over the ABSTRACT attribute. */
11634 13058 : sym->attr.abstract = attr.abstract;
11635 :
11636 13058 : gfc_new_block = sym;
11637 :
11638 13058 : return MATCH_YES;
11639 : }
11640 :
11641 :
11642 : /* Cray Pointees can be declared as:
11643 : pointer (ipt, a (n,m,...,*)) */
11644 :
11645 : match
11646 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11647 : {
11648 240 : as->cray_pointee = true; /* This will be useful to know later. */
11649 240 : if (as->type == AS_ASSUMED_SIZE)
11650 72 : as->cp_was_assumed = true;
11651 168 : else if (as->type == AS_ASSUMED_SHAPE)
11652 : {
11653 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11654 0 : return MATCH_ERROR;
11655 : }
11656 : return MATCH_YES;
11657 : }
11658 :
11659 :
11660 : /* Match the enum definition statement, here we are trying to match
11661 : the first line of enum definition statement.
11662 : Returns MATCH_YES if match is found. */
11663 :
11664 : match
11665 158 : gfc_match_enum (void)
11666 : {
11667 158 : match m;
11668 :
11669 158 : m = gfc_match_eos ();
11670 158 : if (m != MATCH_YES)
11671 : return m;
11672 :
11673 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11674 0 : return MATCH_ERROR;
11675 :
11676 : return MATCH_YES;
11677 : }
11678 :
11679 :
11680 : /* Returns an initializer whose value is one higher than the value of the
11681 : LAST_INITIALIZER argument. If the argument is NULL, the
11682 : initializers value will be set to zero. The initializer's kind
11683 : will be set to gfc_c_int_kind.
11684 :
11685 : If -fshort-enums is given, the appropriate kind will be selected
11686 : later after all enumerators have been parsed. A warning is issued
11687 : here if an initializer exceeds gfc_c_int_kind. */
11688 :
11689 : static gfc_expr *
11690 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11691 : {
11692 377 : gfc_expr *result;
11693 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11694 :
11695 377 : mpz_init (result->value.integer);
11696 :
11697 377 : if (last_initializer != NULL)
11698 : {
11699 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11700 266 : result->where = last_initializer->where;
11701 :
11702 266 : if (gfc_check_integer_range (result->value.integer,
11703 : gfc_c_int_kind) != ARITH_OK)
11704 : {
11705 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11706 0 : return NULL;
11707 : }
11708 : }
11709 : else
11710 : {
11711 : /* Control comes here, if it's the very first enumerator and no
11712 : initializer has been given. It will be initialized to zero. */
11713 111 : mpz_set_si (result->value.integer, 0);
11714 : }
11715 :
11716 : return result;
11717 : }
11718 :
11719 :
11720 : /* Match a variable name with an optional initializer. When this
11721 : subroutine is called, a variable is expected to be parsed next.
11722 : Depending on what is happening at the moment, updates either the
11723 : symbol table or the current interface. */
11724 :
11725 : static match
11726 549 : enumerator_decl (void)
11727 : {
11728 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11729 549 : gfc_expr *initializer;
11730 549 : gfc_array_spec *as = NULL;
11731 549 : gfc_charlen *saved_cl_list;
11732 549 : gfc_symbol *sym;
11733 549 : locus var_locus;
11734 549 : match m;
11735 549 : bool t;
11736 549 : locus old_locus;
11737 :
11738 549 : initializer = NULL;
11739 549 : saved_cl_list = gfc_current_ns->cl_list;
11740 549 : old_locus = gfc_current_locus;
11741 :
11742 : /* When we get here, we've just matched a list of attributes and
11743 : maybe a type and a double colon. The next thing we expect to see
11744 : is the name of the symbol. */
11745 549 : m = gfc_match_name (name);
11746 549 : if (m != MATCH_YES)
11747 1 : goto cleanup;
11748 :
11749 548 : var_locus = gfc_current_locus;
11750 :
11751 : /* OK, we've successfully matched the declaration. Now put the
11752 : symbol in the current namespace. If we fail to create the symbol,
11753 : bail out. */
11754 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11755 : {
11756 1 : m = MATCH_ERROR;
11757 1 : goto cleanup;
11758 : }
11759 :
11760 : /* The double colon must be present in order to have initializers.
11761 : Otherwise the statement is ambiguous with an assignment statement. */
11762 547 : if (colon_seen)
11763 : {
11764 471 : if (gfc_match_char ('=') == MATCH_YES)
11765 : {
11766 170 : m = gfc_match_init_expr (&initializer);
11767 170 : if (m == MATCH_NO)
11768 : {
11769 0 : gfc_error ("Expected an initialization expression at %C");
11770 0 : m = MATCH_ERROR;
11771 : }
11772 :
11773 170 : if (m != MATCH_YES)
11774 2 : goto cleanup;
11775 : }
11776 : }
11777 :
11778 : /* If we do not have an initializer, the initialization value of the
11779 : previous enumerator (stored in last_initializer) is incremented
11780 : by 1 and is used to initialize the current enumerator. */
11781 545 : if (initializer == NULL)
11782 377 : initializer = enum_initializer (last_initializer, old_locus);
11783 :
11784 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11785 : {
11786 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11787 : &var_locus);
11788 2 : m = MATCH_ERROR;
11789 2 : goto cleanup;
11790 : }
11791 :
11792 : /* Store this current initializer, for the next enumerator variable
11793 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11794 : use last_initializer below. */
11795 543 : last_initializer = initializer;
11796 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus,
11797 : saved_cl_list);
11798 :
11799 : /* Maintain enumerator history. */
11800 543 : gfc_find_symbol (name, NULL, 0, &sym);
11801 543 : create_enum_history (sym, last_initializer);
11802 :
11803 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11804 :
11805 6 : cleanup:
11806 : /* Free stuff up and return. */
11807 6 : gfc_free_expr (initializer);
11808 :
11809 6 : return m;
11810 : }
11811 :
11812 :
11813 : /* Match the enumerator definition statement. */
11814 :
11815 : match
11816 810449 : gfc_match_enumerator_def (void)
11817 : {
11818 810449 : match m;
11819 810449 : bool t;
11820 :
11821 810449 : gfc_clear_ts (¤t_ts);
11822 :
11823 810449 : m = gfc_match (" enumerator");
11824 810449 : if (m != MATCH_YES)
11825 : return m;
11826 :
11827 269 : m = gfc_match (" :: ");
11828 269 : if (m == MATCH_ERROR)
11829 : return m;
11830 :
11831 269 : colon_seen = (m == MATCH_YES);
11832 :
11833 269 : if (gfc_current_state () != COMP_ENUM)
11834 : {
11835 4 : gfc_error ("ENUM definition statement expected before %C");
11836 4 : gfc_free_enum_history ();
11837 4 : return MATCH_ERROR;
11838 : }
11839 :
11840 265 : (¤t_ts)->type = BT_INTEGER;
11841 265 : (¤t_ts)->kind = gfc_c_int_kind;
11842 :
11843 265 : gfc_clear_attr (¤t_attr);
11844 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11845 265 : if (!t)
11846 : {
11847 0 : m = MATCH_ERROR;
11848 0 : goto cleanup;
11849 : }
11850 :
11851 549 : for (;;)
11852 : {
11853 549 : m = enumerator_decl ();
11854 549 : if (m == MATCH_ERROR)
11855 : {
11856 6 : gfc_free_enum_history ();
11857 6 : goto cleanup;
11858 : }
11859 543 : if (m == MATCH_NO)
11860 : break;
11861 :
11862 542 : if (gfc_match_eos () == MATCH_YES)
11863 256 : goto cleanup;
11864 286 : if (gfc_match_char (',') != MATCH_YES)
11865 : break;
11866 : }
11867 :
11868 3 : if (gfc_current_state () == COMP_ENUM)
11869 : {
11870 3 : gfc_free_enum_history ();
11871 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11872 3 : m = MATCH_ERROR;
11873 : }
11874 :
11875 0 : cleanup:
11876 265 : gfc_free_array_spec (current_as);
11877 265 : current_as = NULL;
11878 265 : return m;
11879 :
11880 : }
11881 :
11882 :
11883 : /* Match binding attributes. */
11884 :
11885 : static match
11886 4714 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11887 : {
11888 4714 : bool found_passing = false;
11889 4714 : bool seen_ptr = false;
11890 4714 : match m = MATCH_YES;
11891 :
11892 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11893 : this case the defaults are in there. */
11894 4714 : ba->access = ACCESS_UNKNOWN;
11895 4714 : ba->pass_arg = NULL;
11896 4714 : ba->pass_arg_num = 0;
11897 4714 : ba->nopass = 0;
11898 4714 : ba->non_overridable = 0;
11899 4714 : ba->deferred = 0;
11900 4714 : ba->ppc = ppc;
11901 :
11902 : /* If we find a comma, we believe there are binding attributes. */
11903 4714 : m = gfc_match_char (',');
11904 4714 : if (m == MATCH_NO)
11905 2470 : goto done;
11906 :
11907 2793 : do
11908 : {
11909 : /* Access specifier. */
11910 :
11911 2793 : m = gfc_match (" public");
11912 2793 : if (m == MATCH_ERROR)
11913 0 : goto error;
11914 2793 : if (m == MATCH_YES)
11915 : {
11916 250 : if (ba->access != ACCESS_UNKNOWN)
11917 : {
11918 0 : gfc_error ("Duplicate access-specifier at %C");
11919 0 : goto error;
11920 : }
11921 :
11922 250 : ba->access = ACCESS_PUBLIC;
11923 250 : continue;
11924 : }
11925 :
11926 2543 : m = gfc_match (" private");
11927 2543 : if (m == MATCH_ERROR)
11928 0 : goto error;
11929 2543 : if (m == MATCH_YES)
11930 : {
11931 181 : if (ba->access != ACCESS_UNKNOWN)
11932 : {
11933 1 : gfc_error ("Duplicate access-specifier at %C");
11934 1 : goto error;
11935 : }
11936 :
11937 180 : ba->access = ACCESS_PRIVATE;
11938 180 : continue;
11939 : }
11940 :
11941 : /* If inside GENERIC, the following is not allowed. */
11942 2362 : if (!generic)
11943 : {
11944 :
11945 : /* NOPASS flag. */
11946 2361 : m = gfc_match (" nopass");
11947 2361 : if (m == MATCH_ERROR)
11948 0 : goto error;
11949 2361 : if (m == MATCH_YES)
11950 : {
11951 707 : if (found_passing)
11952 : {
11953 1 : gfc_error ("Binding attributes already specify passing,"
11954 : " illegal NOPASS at %C");
11955 1 : goto error;
11956 : }
11957 :
11958 706 : found_passing = true;
11959 706 : ba->nopass = 1;
11960 706 : continue;
11961 : }
11962 :
11963 : /* PASS possibly including argument. */
11964 1654 : m = gfc_match (" pass");
11965 1654 : if (m == MATCH_ERROR)
11966 0 : goto error;
11967 1654 : if (m == MATCH_YES)
11968 : {
11969 901 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11970 :
11971 901 : if (found_passing)
11972 : {
11973 2 : gfc_error ("Binding attributes already specify passing,"
11974 : " illegal PASS at %C");
11975 2 : goto error;
11976 : }
11977 :
11978 899 : m = gfc_match (" ( %n )", arg);
11979 899 : if (m == MATCH_ERROR)
11980 0 : goto error;
11981 899 : if (m == MATCH_YES)
11982 490 : ba->pass_arg = gfc_get_string ("%s", arg);
11983 899 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11984 :
11985 899 : found_passing = true;
11986 899 : ba->nopass = 0;
11987 899 : continue;
11988 899 : }
11989 :
11990 753 : if (ppc)
11991 : {
11992 : /* POINTER flag. */
11993 431 : m = gfc_match (" pointer");
11994 431 : if (m == MATCH_ERROR)
11995 0 : goto error;
11996 431 : if (m == MATCH_YES)
11997 : {
11998 431 : if (seen_ptr)
11999 : {
12000 1 : gfc_error ("Duplicate POINTER attribute at %C");
12001 1 : goto error;
12002 : }
12003 :
12004 430 : seen_ptr = true;
12005 430 : continue;
12006 : }
12007 : }
12008 : else
12009 : {
12010 : /* NON_OVERRIDABLE flag. */
12011 322 : m = gfc_match (" non_overridable");
12012 322 : if (m == MATCH_ERROR)
12013 0 : goto error;
12014 322 : if (m == MATCH_YES)
12015 : {
12016 62 : if (ba->non_overridable)
12017 : {
12018 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
12019 1 : goto error;
12020 : }
12021 :
12022 61 : ba->non_overridable = 1;
12023 61 : continue;
12024 : }
12025 :
12026 : /* DEFERRED flag. */
12027 260 : m = gfc_match (" deferred");
12028 260 : if (m == MATCH_ERROR)
12029 0 : goto error;
12030 260 : if (m == MATCH_YES)
12031 : {
12032 260 : if (ba->deferred)
12033 : {
12034 1 : gfc_error ("Duplicate DEFERRED at %C");
12035 1 : goto error;
12036 : }
12037 :
12038 259 : ba->deferred = 1;
12039 259 : continue;
12040 : }
12041 : }
12042 :
12043 : }
12044 :
12045 : /* Nothing matching found. */
12046 1 : if (generic)
12047 1 : gfc_error ("Expected access-specifier at %C");
12048 : else
12049 0 : gfc_error ("Expected binding attribute at %C");
12050 1 : goto error;
12051 : }
12052 2785 : while (gfc_match_char (',') == MATCH_YES);
12053 :
12054 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
12055 2236 : if (ba->non_overridable && ba->deferred)
12056 : {
12057 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
12058 1 : goto error;
12059 : }
12060 :
12061 : m = MATCH_YES;
12062 :
12063 4705 : done:
12064 4705 : if (ba->access == ACCESS_UNKNOWN)
12065 4276 : ba->access = ppc ? gfc_current_block()->component_access
12066 : : gfc_typebound_default_access;
12067 :
12068 4705 : if (ppc && !seen_ptr)
12069 : {
12070 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
12071 : " at %C");
12072 2 : goto error;
12073 : }
12074 :
12075 : return m;
12076 :
12077 : error:
12078 : return MATCH_ERROR;
12079 : }
12080 :
12081 :
12082 : /* Match a PROCEDURE specific binding inside a derived type. */
12083 :
12084 : static match
12085 3236 : match_procedure_in_type (void)
12086 : {
12087 3236 : char name[GFC_MAX_SYMBOL_LEN + 1];
12088 3236 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
12089 3236 : char* target = NULL, *ifc = NULL;
12090 3236 : gfc_typebound_proc tb;
12091 3236 : bool seen_colons;
12092 3236 : bool seen_attrs;
12093 3236 : match m;
12094 3236 : gfc_symtree* stree;
12095 3236 : gfc_namespace* ns;
12096 3236 : gfc_symbol* block;
12097 3236 : int num;
12098 :
12099 : /* Check current state. */
12100 3236 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
12101 3236 : block = gfc_state_stack->previous->sym;
12102 3236 : gcc_assert (block);
12103 :
12104 : /* Try to match PROCEDURE(interface). */
12105 3236 : if (gfc_match (" (") == MATCH_YES)
12106 : {
12107 261 : m = gfc_match_name (target_buf);
12108 261 : if (m == MATCH_ERROR)
12109 : return m;
12110 261 : if (m != MATCH_YES)
12111 : {
12112 1 : gfc_error ("Interface-name expected after %<(%> at %C");
12113 1 : return MATCH_ERROR;
12114 : }
12115 :
12116 260 : if (gfc_match (" )") != MATCH_YES)
12117 : {
12118 1 : gfc_error ("%<)%> expected at %C");
12119 1 : return MATCH_ERROR;
12120 : }
12121 :
12122 : ifc = target_buf;
12123 : }
12124 :
12125 : /* Construct the data structure. */
12126 3234 : memset (&tb, 0, sizeof (tb));
12127 3234 : tb.where = gfc_current_locus;
12128 :
12129 : /* Match binding attributes. */
12130 3234 : m = match_binding_attributes (&tb, false, false);
12131 3234 : if (m == MATCH_ERROR)
12132 : return m;
12133 3227 : seen_attrs = (m == MATCH_YES);
12134 :
12135 : /* Check that attribute DEFERRED is given if an interface is specified. */
12136 3227 : if (tb.deferred && !ifc)
12137 : {
12138 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
12139 1 : return MATCH_ERROR;
12140 : }
12141 3226 : if (ifc && !tb.deferred)
12142 : {
12143 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
12144 1 : return MATCH_ERROR;
12145 : }
12146 :
12147 : /* Match the colons. */
12148 3225 : m = gfc_match (" ::");
12149 3225 : if (m == MATCH_ERROR)
12150 : return m;
12151 3225 : seen_colons = (m == MATCH_YES);
12152 3225 : if (seen_attrs && !seen_colons)
12153 : {
12154 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
12155 4 : return MATCH_ERROR;
12156 : }
12157 :
12158 : /* Match the binding names. */
12159 19 : for(num=1;;num++)
12160 : {
12161 3240 : m = gfc_match_name (name);
12162 3240 : if (m == MATCH_ERROR)
12163 : return m;
12164 3240 : if (m == MATCH_NO)
12165 : {
12166 5 : gfc_error ("Expected binding name at %C");
12167 5 : return MATCH_ERROR;
12168 : }
12169 :
12170 3235 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
12171 : return MATCH_ERROR;
12172 :
12173 : /* Try to match the '=> target', if it's there. */
12174 3234 : target = ifc;
12175 3234 : m = gfc_match (" =>");
12176 3234 : if (m == MATCH_ERROR)
12177 : return m;
12178 3234 : if (m == MATCH_YES)
12179 : {
12180 1250 : if (tb.deferred)
12181 : {
12182 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
12183 1 : return MATCH_ERROR;
12184 : }
12185 :
12186 1249 : if (!seen_colons)
12187 : {
12188 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
12189 : " at %C");
12190 1 : return MATCH_ERROR;
12191 : }
12192 :
12193 1248 : m = gfc_match_name (target_buf);
12194 1248 : if (m == MATCH_ERROR)
12195 : return m;
12196 1248 : if (m == MATCH_NO)
12197 : {
12198 2 : gfc_error ("Expected binding target after %<=>%> at %C");
12199 2 : return MATCH_ERROR;
12200 : }
12201 : target = target_buf;
12202 : }
12203 :
12204 : /* If no target was found, it has the same name as the binding. */
12205 1984 : if (!target)
12206 1729 : target = name;
12207 :
12208 : /* Get the namespace to insert the symbols into. */
12209 3230 : ns = block->f2k_derived;
12210 3230 : gcc_assert (ns);
12211 :
12212 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
12213 3230 : if (tb.deferred && !block->attr.abstract)
12214 : {
12215 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
12216 : "is not ABSTRACT", block->name);
12217 1 : return MATCH_ERROR;
12218 : }
12219 :
12220 : /* See if we already have a binding with this name in the symtree which
12221 : would be an error. If a GENERIC already targeted this binding, it may
12222 : be already there but then typebound is still NULL. */
12223 3229 : stree = gfc_find_symtree (ns->tb_sym_root, name);
12224 3229 : if (stree && stree->n.tb)
12225 : {
12226 2 : gfc_error ("There is already a procedure with binding name %qs for "
12227 : "the derived type %qs at %C", name, block->name);
12228 2 : return MATCH_ERROR;
12229 : }
12230 :
12231 : /* Insert it and set attributes. */
12232 :
12233 3108 : if (!stree)
12234 : {
12235 3108 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12236 3108 : gcc_assert (stree);
12237 : }
12238 3227 : stree->n.tb = gfc_get_typebound_proc (&tb);
12239 :
12240 3227 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12241 : false))
12242 : return MATCH_ERROR;
12243 3227 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12244 3227 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12245 3227 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12246 :
12247 3227 : if (gfc_match_eos () == MATCH_YES)
12248 : return MATCH_YES;
12249 20 : if (gfc_match_char (',') != MATCH_YES)
12250 1 : goto syntax;
12251 : }
12252 :
12253 1 : syntax:
12254 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12255 1 : return MATCH_ERROR;
12256 : }
12257 :
12258 :
12259 : /* Match a GENERIC statement.
12260 : F2018 15.4.3.3 GENERIC statement
12261 :
12262 : A GENERIC statement specifies a generic identifier for one or more specific
12263 : procedures, in the same way as a generic interface block that does not contain
12264 : interface bodies.
12265 :
12266 : R1510 generic-stmt is:
12267 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12268 :
12269 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12270 : procedure that was specified previously in any accessible interface with the
12271 : same generic identifier.
12272 :
12273 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12274 :
12275 : For GENERIC statements outside of a derived type, use is made of the existing,
12276 : typebound matching functions to obtain access-spec and generic-spec. After
12277 : this the standard INTERFACE machinery is used. */
12278 :
12279 : static match
12280 100 : match_generic_stmt (void)
12281 : {
12282 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12283 : /* Allow space for OPERATOR(...). */
12284 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12285 : /* Generics other than uops */
12286 100 : gfc_symbol* generic_spec = NULL;
12287 : /* Generic uops */
12288 100 : gfc_user_op *generic_uop = NULL;
12289 : /* For the matching calls */
12290 100 : gfc_typebound_proc tbattr;
12291 100 : gfc_namespace* ns = gfc_current_ns;
12292 100 : interface_type op_type;
12293 100 : gfc_intrinsic_op op;
12294 100 : match m;
12295 100 : gfc_symtree* st;
12296 : /* The specific-procedure-list */
12297 100 : gfc_interface *generic = NULL;
12298 : /* The head of the specific-procedure-list */
12299 100 : gfc_interface **generic_tail = NULL;
12300 :
12301 100 : memset (&tbattr, 0, sizeof (tbattr));
12302 100 : tbattr.where = gfc_current_locus;
12303 :
12304 : /* See if we get an access-specifier. */
12305 100 : m = match_binding_attributes (&tbattr, true, false);
12306 100 : tbattr.where = gfc_current_locus;
12307 100 : if (m == MATCH_ERROR)
12308 0 : goto error;
12309 :
12310 : /* Now the colons, those are required. */
12311 100 : if (gfc_match (" ::") != MATCH_YES)
12312 : {
12313 0 : gfc_error ("Expected %<::%> at %C");
12314 0 : goto error;
12315 : }
12316 :
12317 : /* Match the generic-spec name; depending on type (operator / generic) format
12318 : it for future error messages in 'generic_spec_name'. */
12319 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12320 100 : if (m == MATCH_ERROR)
12321 : return MATCH_ERROR;
12322 100 : if (m == MATCH_NO)
12323 : {
12324 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12325 0 : goto error;
12326 : }
12327 :
12328 100 : switch (op_type)
12329 : {
12330 63 : case INTERFACE_GENERIC:
12331 63 : case INTERFACE_DTIO:
12332 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12333 63 : break;
12334 :
12335 22 : case INTERFACE_USER_OP:
12336 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12337 22 : break;
12338 :
12339 13 : case INTERFACE_INTRINSIC_OP:
12340 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12341 : gfc_op2string (op));
12342 13 : break;
12343 :
12344 2 : case INTERFACE_NAMELESS:
12345 2 : gfc_error ("Malformed GENERIC statement at %C");
12346 2 : goto error;
12347 0 : break;
12348 :
12349 0 : default:
12350 0 : gcc_unreachable ();
12351 : }
12352 :
12353 : /* Match the required =>. */
12354 98 : if (gfc_match (" =>") != MATCH_YES)
12355 : {
12356 1 : gfc_error ("Expected %<=>%> at %C");
12357 1 : goto error;
12358 : }
12359 :
12360 :
12361 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12362 : {
12363 1 : gfc_error ("The access specification at %L not in a module",
12364 : &tbattr.where);
12365 1 : goto error;
12366 : }
12367 :
12368 : /* Try to find existing generic-spec with this name for this operator;
12369 : if there is something, check that it is another generic-spec and then
12370 : extend it rather than building a new symbol. Otherwise, create a new
12371 : one with the right attributes. */
12372 :
12373 96 : switch (op_type)
12374 : {
12375 61 : case INTERFACE_DTIO:
12376 61 : case INTERFACE_GENERIC:
12377 61 : st = gfc_find_symtree (ns->sym_root, name);
12378 61 : generic_spec = st ? st->n.sym : NULL;
12379 61 : if (generic_spec)
12380 : {
12381 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12382 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12383 : {
12384 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12385 : "name of an entity declared at %L that is not a "
12386 : "procedure", name, &generic_spec->declared_at);
12387 1 : goto error;
12388 : }
12389 :
12390 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12391 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12392 : {
12393 0 : gfc_error ("There's already a non-generic procedure with "
12394 : "name %qs at %C", generic_spec->name);
12395 0 : goto error;
12396 : }
12397 :
12398 24 : if (tbattr.access != ACCESS_UNKNOWN)
12399 : {
12400 2 : if (generic_spec->attr.access != tbattr.access)
12401 : {
12402 1 : gfc_error ("The access specification at %L conflicts with "
12403 : "that already given to %qs", &tbattr.where,
12404 : generic_spec->name);
12405 1 : goto error;
12406 : }
12407 : else
12408 : {
12409 1 : gfc_error ("The access specification at %L repeats that "
12410 : "already given to %qs", &tbattr.where,
12411 : generic_spec->name);
12412 1 : goto error;
12413 : }
12414 : }
12415 :
12416 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12417 : {
12418 1 : gfc_error ("The generic-spec in the generic statement at %C "
12419 : "has a type from the declaration at %L",
12420 : &generic_spec->declared_at);
12421 1 : goto error;
12422 : }
12423 : }
12424 :
12425 : /* Now create the generic_spec if it doesn't already exist and provide
12426 : is with the appropriate attributes. */
12427 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12428 : {
12429 45 : if (!generic_spec)
12430 : {
12431 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12432 36 : gfc_set_sym_referenced (generic_spec);
12433 36 : generic_spec->attr.access = tbattr.access;
12434 : }
12435 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12436 0 : generic_spec->attr.access = tbattr.access;
12437 45 : generic_spec->refs++;
12438 45 : generic_spec->attr.generic = 1;
12439 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12440 :
12441 45 : generic_spec->declared_at = gfc_current_locus;
12442 : }
12443 :
12444 : /* Prepare to add the specific procedures. */
12445 57 : generic = generic_spec->generic;
12446 57 : generic_tail = &generic_spec->generic;
12447 57 : break;
12448 :
12449 22 : case INTERFACE_USER_OP:
12450 22 : st = gfc_find_symtree (ns->uop_root, name);
12451 22 : generic_uop = st ? st->n.uop : NULL;
12452 2 : if (generic_uop)
12453 : {
12454 2 : if (generic_uop->access != ACCESS_UNKNOWN
12455 2 : && tbattr.access != ACCESS_UNKNOWN)
12456 : {
12457 2 : if (generic_uop->access != tbattr.access)
12458 : {
12459 1 : gfc_error ("The user operator at %L must have the same "
12460 : "access specification as already defined user "
12461 : "operator %qs", &tbattr.where, generic_spec_name);
12462 1 : goto error;
12463 : }
12464 : else
12465 : {
12466 1 : gfc_error ("The user operator at %L repeats the access "
12467 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12468 1 : goto error;
12469 : }
12470 : }
12471 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12472 0 : generic_uop->access = tbattr.access;
12473 : }
12474 : else
12475 : {
12476 20 : generic_uop = gfc_get_uop (name);
12477 20 : generic_uop->access = tbattr.access;
12478 : }
12479 :
12480 : /* Prepare to add the specific procedures. */
12481 20 : generic = generic_uop->op;
12482 20 : generic_tail = &generic_uop->op;
12483 20 : break;
12484 :
12485 13 : case INTERFACE_INTRINSIC_OP:
12486 13 : generic = ns->op[op];
12487 13 : generic_tail = &ns->op[op];
12488 13 : break;
12489 :
12490 0 : default:
12491 0 : gcc_unreachable ();
12492 : }
12493 :
12494 : /* Now, match all following names in the specific-procedure-list. */
12495 154 : do
12496 : {
12497 154 : m = gfc_match_name (name);
12498 154 : if (m == MATCH_ERROR)
12499 0 : goto error;
12500 154 : if (m == MATCH_NO)
12501 : {
12502 0 : gfc_error ("Expected specific procedure name at %C");
12503 0 : goto error;
12504 : }
12505 :
12506 154 : if (op_type == INTERFACE_GENERIC
12507 95 : && !strcmp (generic_spec->name, name))
12508 : {
12509 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12510 : "with that of the generic-spec", name);
12511 2 : goto error;
12512 : }
12513 :
12514 152 : generic = *generic_tail;
12515 242 : for (; generic; generic = generic->next)
12516 : {
12517 90 : if (!strcmp (generic->sym->name, name))
12518 : {
12519 0 : gfc_error ("%qs already defined as a specific procedure for the"
12520 : " generic %qs at %C", name, generic_spec->name);
12521 0 : goto error;
12522 : }
12523 : }
12524 :
12525 152 : gfc_find_sym_tree (name, ns, 1, &st);
12526 152 : if (!st)
12527 : {
12528 : /* This might be a procedure that has not yet been parsed. If
12529 : so gfc_fixup_sibling_symbols will replace this symbol with
12530 : that of the procedure. */
12531 75 : gfc_get_sym_tree (name, ns, &st, false);
12532 75 : st->n.sym->refs++;
12533 : }
12534 :
12535 152 : generic = gfc_get_interface();
12536 152 : generic->next = *generic_tail;
12537 152 : *generic_tail = generic;
12538 152 : generic->where = gfc_current_locus;
12539 152 : generic->sym = st->n.sym;
12540 : }
12541 152 : while (gfc_match (" ,") == MATCH_YES);
12542 :
12543 88 : if (gfc_match_eos () != MATCH_YES)
12544 : {
12545 0 : gfc_error ("Junk after GENERIC statement at %C");
12546 0 : goto error;
12547 : }
12548 :
12549 88 : gfc_commit_symbols ();
12550 88 : return MATCH_YES;
12551 :
12552 : error:
12553 : return MATCH_ERROR;
12554 : }
12555 :
12556 :
12557 : /* Match a GENERIC procedure binding inside a derived type. */
12558 :
12559 : static match
12560 948 : match_typebound_generic (void)
12561 : {
12562 948 : char name[GFC_MAX_SYMBOL_LEN + 1];
12563 948 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12564 948 : gfc_symbol* block;
12565 948 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12566 948 : gfc_typebound_proc* tb;
12567 948 : gfc_namespace* ns;
12568 948 : interface_type op_type;
12569 948 : gfc_intrinsic_op op;
12570 948 : match m;
12571 :
12572 : /* Check current state. */
12573 948 : if (gfc_current_state () == COMP_DERIVED)
12574 : {
12575 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12576 0 : return MATCH_ERROR;
12577 : }
12578 948 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12579 : return MATCH_NO;
12580 948 : block = gfc_state_stack->previous->sym;
12581 948 : ns = block->f2k_derived;
12582 948 : gcc_assert (block && ns);
12583 :
12584 948 : memset (&tbattr, 0, sizeof (tbattr));
12585 948 : tbattr.where = gfc_current_locus;
12586 :
12587 : /* See if we get an access-specifier. */
12588 948 : m = match_binding_attributes (&tbattr, true, false);
12589 948 : if (m == MATCH_ERROR)
12590 1 : goto error;
12591 :
12592 : /* Now the colons, those are required. */
12593 947 : if (gfc_match (" ::") != MATCH_YES)
12594 : {
12595 0 : gfc_error ("Expected %<::%> at %C");
12596 0 : goto error;
12597 : }
12598 :
12599 : /* Match the binding name; depending on type (operator / generic) format
12600 : it for future error messages into bind_name. */
12601 :
12602 947 : m = gfc_match_generic_spec (&op_type, name, &op);
12603 947 : if (m == MATCH_ERROR)
12604 : return MATCH_ERROR;
12605 947 : if (m == MATCH_NO)
12606 : {
12607 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12608 0 : goto error;
12609 : }
12610 :
12611 947 : switch (op_type)
12612 : {
12613 470 : case INTERFACE_GENERIC:
12614 470 : case INTERFACE_DTIO:
12615 470 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12616 470 : break;
12617 :
12618 47 : case INTERFACE_USER_OP:
12619 47 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12620 47 : break;
12621 :
12622 429 : case INTERFACE_INTRINSIC_OP:
12623 429 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12624 : gfc_op2string (op));
12625 429 : break;
12626 :
12627 1 : case INTERFACE_NAMELESS:
12628 1 : gfc_error ("Malformed GENERIC statement at %C");
12629 1 : goto error;
12630 0 : break;
12631 :
12632 0 : default:
12633 0 : gcc_unreachable ();
12634 : }
12635 :
12636 : /* Match the required =>. */
12637 946 : if (gfc_match (" =>") != MATCH_YES)
12638 : {
12639 0 : gfc_error ("Expected %<=>%> at %C");
12640 0 : goto error;
12641 : }
12642 :
12643 : /* Try to find existing GENERIC binding with this name / for this operator;
12644 : if there is something, check that it is another GENERIC and then extend
12645 : it rather than building a new node. Otherwise, create it and put it
12646 : at the right position. */
12647 :
12648 946 : switch (op_type)
12649 : {
12650 517 : case INTERFACE_DTIO:
12651 517 : case INTERFACE_USER_OP:
12652 517 : case INTERFACE_GENERIC:
12653 517 : {
12654 517 : const bool is_op = (op_type == INTERFACE_USER_OP);
12655 517 : gfc_symtree* st;
12656 :
12657 517 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12658 517 : tb = st ? st->n.tb : NULL;
12659 : break;
12660 : }
12661 :
12662 429 : case INTERFACE_INTRINSIC_OP:
12663 429 : tb = ns->tb_op[op];
12664 429 : break;
12665 :
12666 0 : default:
12667 0 : gcc_unreachable ();
12668 : }
12669 :
12670 440 : if (tb)
12671 : {
12672 9 : if (!tb->is_generic)
12673 : {
12674 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12675 1 : gfc_error ("There's already a non-generic procedure with binding name"
12676 : " %qs for the derived type %qs at %C",
12677 : bind_name, block->name);
12678 1 : goto error;
12679 : }
12680 :
12681 8 : if (tb->access != tbattr.access)
12682 : {
12683 2 : gfc_error ("Binding at %C must have the same access as already"
12684 : " defined binding %qs", bind_name);
12685 2 : goto error;
12686 : }
12687 : }
12688 : else
12689 : {
12690 937 : tb = gfc_get_typebound_proc (NULL);
12691 937 : tb->where = gfc_current_locus;
12692 937 : tb->access = tbattr.access;
12693 937 : tb->is_generic = 1;
12694 937 : tb->u.generic = NULL;
12695 :
12696 937 : switch (op_type)
12697 : {
12698 508 : case INTERFACE_DTIO:
12699 508 : case INTERFACE_GENERIC:
12700 508 : case INTERFACE_USER_OP:
12701 508 : {
12702 508 : const bool is_op = (op_type == INTERFACE_USER_OP);
12703 508 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12704 : &ns->tb_sym_root, name);
12705 508 : gcc_assert (st);
12706 508 : st->n.tb = tb;
12707 :
12708 508 : break;
12709 : }
12710 :
12711 429 : case INTERFACE_INTRINSIC_OP:
12712 429 : ns->tb_op[op] = tb;
12713 429 : break;
12714 :
12715 0 : default:
12716 0 : gcc_unreachable ();
12717 : }
12718 : }
12719 :
12720 : /* Now, match all following names as specific targets. */
12721 1100 : do
12722 : {
12723 1100 : gfc_symtree* target_st;
12724 1100 : gfc_tbp_generic* target;
12725 :
12726 1100 : m = gfc_match_name (name);
12727 1100 : if (m == MATCH_ERROR)
12728 0 : goto error;
12729 1100 : if (m == MATCH_NO)
12730 : {
12731 1 : gfc_error ("Expected specific binding name at %C");
12732 1 : goto error;
12733 : }
12734 :
12735 1099 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12736 :
12737 : /* See if this is a duplicate specification. */
12738 1334 : for (target = tb->u.generic; target; target = target->next)
12739 236 : if (target_st == target->specific_st)
12740 : {
12741 1 : gfc_error ("%qs already defined as specific binding for the"
12742 : " generic %qs at %C", name, bind_name);
12743 1 : goto error;
12744 : }
12745 :
12746 1098 : target = gfc_get_tbp_generic ();
12747 1098 : target->specific_st = target_st;
12748 1098 : target->specific = NULL;
12749 1098 : target->next = tb->u.generic;
12750 1098 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12751 1098 : || (op_type == INTERFACE_INTRINSIC_OP));
12752 1098 : tb->u.generic = target;
12753 : }
12754 1098 : while (gfc_match (" ,") == MATCH_YES);
12755 :
12756 : /* Here should be the end. */
12757 941 : if (gfc_match_eos () != MATCH_YES)
12758 : {
12759 1 : gfc_error ("Junk after GENERIC binding at %C");
12760 1 : goto error;
12761 : }
12762 :
12763 : return MATCH_YES;
12764 :
12765 : error:
12766 : return MATCH_ERROR;
12767 : }
12768 :
12769 :
12770 : match
12771 1048 : gfc_match_generic ()
12772 : {
12773 1048 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12774 1046 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12775 100 : return match_generic_stmt ();
12776 : else
12777 948 : return match_typebound_generic ();
12778 : }
12779 :
12780 :
12781 : /* Match a FINAL declaration inside a derived type. */
12782 :
12783 : match
12784 478 : gfc_match_final_decl (void)
12785 : {
12786 478 : char name[GFC_MAX_SYMBOL_LEN + 1];
12787 478 : gfc_symbol* sym;
12788 478 : match m;
12789 478 : gfc_namespace* module_ns;
12790 478 : bool first, last;
12791 478 : gfc_symbol* block;
12792 :
12793 478 : if (gfc_current_form == FORM_FREE)
12794 : {
12795 478 : char c = gfc_peek_ascii_char ();
12796 478 : if (!gfc_is_whitespace (c) && c != ':')
12797 : return MATCH_NO;
12798 : }
12799 :
12800 477 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12801 : {
12802 1 : if (gfc_current_form == FORM_FIXED)
12803 : return MATCH_NO;
12804 :
12805 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12806 : "CONTAINS section");
12807 1 : return MATCH_ERROR;
12808 : }
12809 :
12810 476 : block = gfc_state_stack->previous->sym;
12811 476 : gcc_assert (block);
12812 :
12813 476 : if (gfc_state_stack->previous->previous
12814 476 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12815 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12816 : {
12817 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12818 : " specification part of a MODULE");
12819 0 : return MATCH_ERROR;
12820 : }
12821 :
12822 476 : module_ns = gfc_current_ns;
12823 476 : gcc_assert (module_ns);
12824 476 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12825 :
12826 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12827 476 : if (gfc_match (" ::") == MATCH_ERROR)
12828 : return MATCH_ERROR;
12829 :
12830 : /* Match the sequence of procedure names. */
12831 : first = true;
12832 : last = false;
12833 568 : do
12834 : {
12835 568 : gfc_finalizer* f;
12836 :
12837 568 : if (first && gfc_match_eos () == MATCH_YES)
12838 : {
12839 2 : gfc_error ("Empty FINAL at %C");
12840 2 : return MATCH_ERROR;
12841 : }
12842 :
12843 566 : m = gfc_match_name (name);
12844 566 : if (m == MATCH_NO)
12845 : {
12846 1 : gfc_error ("Expected module procedure name at %C");
12847 1 : return MATCH_ERROR;
12848 : }
12849 565 : else if (m != MATCH_YES)
12850 : return MATCH_ERROR;
12851 :
12852 565 : if (gfc_match_eos () == MATCH_YES)
12853 : last = true;
12854 93 : if (!last && gfc_match_char (',') != MATCH_YES)
12855 : {
12856 1 : gfc_error ("Expected %<,%> at %C");
12857 1 : return MATCH_ERROR;
12858 : }
12859 :
12860 564 : if (gfc_get_symbol (name, module_ns, &sym))
12861 : {
12862 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12863 0 : return MATCH_ERROR;
12864 : }
12865 :
12866 : /* Mark the symbol as module procedure. */
12867 564 : if (sym->attr.proc != PROC_MODULE
12868 564 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12869 : return MATCH_ERROR;
12870 :
12871 : /* Check if we already have this symbol in the list, this is an error. */
12872 763 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12873 200 : if (f->proc_sym == sym)
12874 : {
12875 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12876 : name);
12877 1 : return MATCH_ERROR;
12878 : }
12879 :
12880 : /* Add this symbol to the list of finalizers. */
12881 563 : gcc_assert (block->f2k_derived);
12882 563 : sym->refs++;
12883 563 : f = XCNEW (gfc_finalizer);
12884 563 : f->proc_sym = sym;
12885 563 : f->proc_tree = NULL;
12886 563 : f->where = gfc_current_locus;
12887 563 : f->next = block->f2k_derived->finalizers;
12888 563 : block->f2k_derived->finalizers = f;
12889 :
12890 563 : first = false;
12891 : }
12892 563 : while (!last);
12893 :
12894 : return MATCH_YES;
12895 : }
12896 :
12897 :
12898 : const ext_attr_t ext_attr_list[] = {
12899 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12900 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12901 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12902 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12903 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12904 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12905 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12906 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12907 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12908 : { "weak", EXT_ATTR_WEAK, NULL },
12909 : { "inline", EXT_ATTR_INLINE, NULL },
12910 : { "always_inline",EXT_ATTR_ALWAYS_INLINE,NULL },
12911 : { NULL, EXT_ATTR_LAST, NULL }
12912 : };
12913 :
12914 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12915 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12916 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12917 :
12918 : TODO: We should support all GCC attributes using the same syntax for
12919 : the attribute list, i.e. the list in C
12920 : __attributes(( attribute-list ))
12921 : matches then
12922 : !GCC$ ATTRIBUTES attribute-list ::
12923 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12924 : saved into a TREE.
12925 :
12926 : As there is absolutely no risk of confusion, we should never return
12927 : MATCH_NO. */
12928 : match
12929 2984 : gfc_match_gcc_attributes (void)
12930 : {
12931 2984 : symbol_attribute attr;
12932 2984 : char name[GFC_MAX_SYMBOL_LEN + 1];
12933 2984 : unsigned id;
12934 2984 : gfc_symbol *sym;
12935 2984 : match m;
12936 :
12937 2984 : gfc_clear_attr (&attr);
12938 2988 : for(;;)
12939 : {
12940 2986 : char ch;
12941 :
12942 2986 : if (gfc_match_name (name) != MATCH_YES)
12943 : return MATCH_ERROR;
12944 :
12945 18042 : for (id = 0; id < EXT_ATTR_LAST; id++)
12946 18042 : if (strcmp (name, ext_attr_list[id].name) == 0)
12947 : break;
12948 :
12949 2986 : if (id == EXT_ATTR_LAST)
12950 : {
12951 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12952 0 : return MATCH_ERROR;
12953 : }
12954 :
12955 2986 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12956 : return MATCH_ERROR;
12957 :
12958 2986 : gfc_gobble_whitespace ();
12959 2986 : ch = gfc_next_ascii_char ();
12960 2986 : if (ch == ':')
12961 : {
12962 : /* This is the successful exit condition for the loop. */
12963 2984 : if (gfc_next_ascii_char () == ':')
12964 : break;
12965 : }
12966 :
12967 2 : if (ch == ',')
12968 2 : continue;
12969 :
12970 0 : goto syntax;
12971 2 : }
12972 :
12973 2984 : if (gfc_match_eos () == MATCH_YES)
12974 0 : goto syntax;
12975 :
12976 2999 : for(;;)
12977 : {
12978 2999 : m = gfc_match_name (name);
12979 2999 : if (m != MATCH_YES)
12980 : return m;
12981 :
12982 2999 : if (find_special (name, &sym, true))
12983 : return MATCH_ERROR;
12984 :
12985 2999 : sym->attr.ext_attr |= attr.ext_attr;
12986 :
12987 : /* INLINE and ALWAYS_INLINE are incompatible with NOINLINE. In the
12988 : middle-end the DECL_UNINLINABLE flag set by NOINLINE always wins, so
12989 : the inline request would be silently ignored. Warn and drop it. */
12990 2999 : if (sym->attr.ext_attr & (1 << EXT_ATTR_NOINLINE))
12991 : {
12992 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_ALWAYS_INLINE))
12993 : {
12994 2 : gfc_warning (0, "Attribute %<ALWAYS_INLINE%> at %C is "
12995 : "incompatible with %<NOINLINE%> for %qs and will "
12996 : "be ignored", sym->name);
12997 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_ALWAYS_INLINE);
12998 : }
12999 5 : if (sym->attr.ext_attr & (1 << EXT_ATTR_INLINE))
13000 : {
13001 2 : gfc_warning (0, "Attribute %<INLINE%> at %C is incompatible "
13002 : "with %<NOINLINE%> for %qs and will be ignored",
13003 : sym->name);
13004 2 : sym->attr.ext_attr &= ~(1 << EXT_ATTR_INLINE);
13005 : }
13006 : }
13007 :
13008 2999 : if (gfc_match_eos () == MATCH_YES)
13009 : break;
13010 :
13011 15 : if (gfc_match_char (',') != MATCH_YES)
13012 0 : goto syntax;
13013 : }
13014 :
13015 : return MATCH_YES;
13016 :
13017 0 : syntax:
13018 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
13019 0 : return MATCH_ERROR;
13020 : }
13021 :
13022 :
13023 : /* Match a !GCC$ UNROLL statement of the form:
13024 : !GCC$ UNROLL n
13025 :
13026 : The parameter n is the number of times we are supposed to unroll.
13027 :
13028 : When we come here, we have already matched the !GCC$ UNROLL string. */
13029 : match
13030 19 : gfc_match_gcc_unroll (void)
13031 : {
13032 19 : int value;
13033 :
13034 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
13035 19 : if (gfc_match_small_int (&value) == MATCH_YES)
13036 : {
13037 19 : if (value < 0 || value > USHRT_MAX)
13038 : {
13039 2 : gfc_error ("%<GCC unroll%> directive requires a"
13040 : " non-negative integral constant"
13041 : " less than or equal to %u at %C",
13042 : USHRT_MAX
13043 : );
13044 2 : return MATCH_ERROR;
13045 : }
13046 17 : if (gfc_match_eos () == MATCH_YES)
13047 : {
13048 17 : directive_unroll = value == 0 ? 1 : value;
13049 17 : return MATCH_YES;
13050 : }
13051 : }
13052 :
13053 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
13054 0 : return MATCH_ERROR;
13055 : }
13056 :
13057 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
13058 :
13059 : The parameter b is name of a middle-end built-in.
13060 : FLAGS is optional and must be one of:
13061 : - (inbranch)
13062 : - (notinbranch)
13063 :
13064 : IF('target') is optional and TARGET is a name of a multilib ABI.
13065 :
13066 : When we come here, we have already matched the !GCC$ builtin string. */
13067 :
13068 : match
13069 3440481 : gfc_match_gcc_builtin (void)
13070 : {
13071 3440481 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
13072 3440481 : char target[GFC_MAX_SYMBOL_LEN + 1];
13073 :
13074 3440481 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
13075 : return MATCH_ERROR;
13076 :
13077 3440481 : gfc_simd_clause clause = SIMD_NONE;
13078 3440481 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
13079 : clause = SIMD_NOTINBRANCH;
13080 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
13081 15 : clause = SIMD_INBRANCH;
13082 :
13083 3440481 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
13084 : {
13085 3440451 : if (strcmp (target, "fastmath") == 0)
13086 : {
13087 0 : if (!fast_math_flags_set_p (&global_options))
13088 : return MATCH_YES;
13089 : }
13090 : else
13091 : {
13092 3440451 : const char *abi = targetm.get_multilib_abi_name ();
13093 3440451 : if (abi == NULL || strcmp (abi, target) != 0)
13094 : return MATCH_YES;
13095 : }
13096 : }
13097 :
13098 1698170 : if (gfc_vectorized_builtins == NULL)
13099 31453 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
13100 :
13101 1698170 : char *r = XNEWVEC (char, strlen (builtin) + 32);
13102 1698170 : sprintf (r, "__builtin_%s", builtin);
13103 :
13104 1698170 : bool existed;
13105 1698170 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
13106 1698170 : value |= clause;
13107 1698170 : if (existed)
13108 23 : free (r);
13109 :
13110 : return MATCH_YES;
13111 : }
13112 :
13113 : /* Match an !GCC$ IVDEP statement.
13114 : When we come here, we have already matched the !GCC$ IVDEP string. */
13115 :
13116 : match
13117 3 : gfc_match_gcc_ivdep (void)
13118 : {
13119 3 : if (gfc_match_eos () == MATCH_YES)
13120 : {
13121 3 : directive_ivdep = true;
13122 3 : return MATCH_YES;
13123 : }
13124 :
13125 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
13126 0 : return MATCH_ERROR;
13127 : }
13128 :
13129 : /* Match an !GCC$ VECTOR statement.
13130 : When we come here, we have already matched the !GCC$ VECTOR string. */
13131 :
13132 : match
13133 3 : gfc_match_gcc_vector (void)
13134 : {
13135 3 : if (gfc_match_eos () == MATCH_YES)
13136 : {
13137 3 : directive_vector = true;
13138 3 : directive_novector = false;
13139 3 : return MATCH_YES;
13140 : }
13141 :
13142 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
13143 0 : return MATCH_ERROR;
13144 : }
13145 :
13146 : /* Match an !GCC$ NOVECTOR statement.
13147 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
13148 :
13149 : match
13150 3 : gfc_match_gcc_novector (void)
13151 : {
13152 3 : if (gfc_match_eos () == MATCH_YES)
13153 : {
13154 3 : directive_novector = true;
13155 3 : directive_vector = false;
13156 3 : return MATCH_YES;
13157 : }
13158 :
13159 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
13160 0 : return MATCH_ERROR;
13161 : }
|
