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 : /********************* DATA statement subroutines *********************/
121 :
122 : static bool in_match_data = false;
123 :
124 : bool
125 9064 : gfc_in_match_data (void)
126 : {
127 9064 : return in_match_data;
128 : }
129 :
130 : static void
131 4840 : set_in_match_data (bool set_value)
132 : {
133 4840 : in_match_data = set_value;
134 2420 : }
135 :
136 : /* Free a gfc_data_variable structure and everything beneath it. */
137 :
138 : static void
139 5663 : free_variable (gfc_data_variable *p)
140 : {
141 5663 : gfc_data_variable *q;
142 :
143 8752 : for (; p; p = q)
144 : {
145 3089 : q = p->next;
146 3089 : gfc_free_expr (p->expr);
147 3089 : gfc_free_iterator (&p->iter, 0);
148 3089 : free_variable (p->list);
149 3089 : free (p);
150 : }
151 5663 : }
152 :
153 :
154 : /* Free a gfc_data_value structure and everything beneath it. */
155 :
156 : static void
157 2574 : free_value (gfc_data_value *p)
158 : {
159 2574 : gfc_data_value *q;
160 :
161 10886 : for (; p; p = q)
162 : {
163 8312 : q = p->next;
164 8312 : mpz_clear (p->repeat);
165 8312 : gfc_free_expr (p->expr);
166 8312 : free (p);
167 : }
168 2574 : }
169 :
170 :
171 : /* Free a list of gfc_data structures. */
172 :
173 : void
174 515820 : gfc_free_data (gfc_data *p)
175 : {
176 515820 : gfc_data *q;
177 :
178 518394 : for (; p; p = q)
179 : {
180 2574 : q = p->next;
181 2574 : free_variable (p->var);
182 2574 : free_value (p->value);
183 2574 : free (p);
184 : }
185 515820 : }
186 :
187 :
188 : /* Free all data in a namespace. */
189 :
190 : static void
191 38 : gfc_free_data_all (gfc_namespace *ns)
192 : {
193 38 : gfc_data *d;
194 :
195 44 : for (;ns->data;)
196 : {
197 6 : d = ns->data->next;
198 6 : free (ns->data);
199 6 : ns->data = d;
200 : }
201 38 : }
202 :
203 : /* Reject data parsed since the last restore point was marked. */
204 :
205 : void
206 8916381 : gfc_reject_data (gfc_namespace *ns)
207 : {
208 8916381 : gfc_data *d;
209 :
210 8916383 : while (ns->data && ns->data != ns->old_data)
211 : {
212 2 : d = ns->data->next;
213 2 : free (ns->data);
214 2 : ns->data = d;
215 : }
216 8916381 : }
217 :
218 : static match var_element (gfc_data_variable *);
219 :
220 : /* Match a list of variables terminated by an iterator and a right
221 : parenthesis. */
222 :
223 : static match
224 154 : var_list (gfc_data_variable *parent)
225 : {
226 154 : gfc_data_variable *tail, var;
227 154 : match m;
228 :
229 154 : m = var_element (&var);
230 154 : if (m == MATCH_ERROR)
231 : return MATCH_ERROR;
232 154 : if (m == MATCH_NO)
233 0 : goto syntax;
234 :
235 154 : tail = gfc_get_data_variable ();
236 154 : *tail = var;
237 :
238 154 : parent->list = tail;
239 :
240 156 : for (;;)
241 : {
242 155 : if (gfc_match_char (',') != MATCH_YES)
243 0 : goto syntax;
244 :
245 155 : m = gfc_match_iterator (&parent->iter, 1);
246 155 : if (m == MATCH_YES)
247 : break;
248 1 : if (m == MATCH_ERROR)
249 : return MATCH_ERROR;
250 :
251 1 : m = var_element (&var);
252 1 : if (m == MATCH_ERROR)
253 : return MATCH_ERROR;
254 1 : if (m == MATCH_NO)
255 0 : goto syntax;
256 :
257 1 : tail->next = gfc_get_data_variable ();
258 1 : tail = tail->next;
259 :
260 1 : *tail = var;
261 : }
262 :
263 154 : if (gfc_match_char (')') != MATCH_YES)
264 0 : goto syntax;
265 : return MATCH_YES;
266 :
267 0 : syntax:
268 0 : gfc_syntax_error (ST_DATA);
269 0 : return MATCH_ERROR;
270 : }
271 :
272 :
273 : /* Match a single element in a data variable list, which can be a
274 : variable-iterator list. */
275 :
276 : static match
277 3047 : var_element (gfc_data_variable *new_var)
278 : {
279 3047 : match m;
280 3047 : gfc_symbol *sym;
281 :
282 3047 : memset (new_var, 0, sizeof (gfc_data_variable));
283 :
284 3047 : if (gfc_match_char ('(') == MATCH_YES)
285 154 : return var_list (new_var);
286 :
287 2893 : m = gfc_match_variable (&new_var->expr, 0);
288 2893 : if (m != MATCH_YES)
289 : return m;
290 :
291 2889 : if (new_var->expr->expr_type == EXPR_CONSTANT
292 2 : && new_var->expr->symtree == NULL)
293 : {
294 2 : gfc_error ("Inquiry parameter cannot appear in a "
295 : "data-stmt-object-list at %C");
296 2 : return MATCH_ERROR;
297 : }
298 :
299 2887 : sym = new_var->expr->symtree->n.sym;
300 :
301 : /* Symbol should already have an associated type. */
302 2887 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
303 : return MATCH_ERROR;
304 :
305 2886 : if (!sym->attr.function && gfc_current_ns->parent
306 148 : && gfc_current_ns->parent == sym->ns)
307 : {
308 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
309 : "statement at %C", sym->name);
310 1 : return MATCH_ERROR;
311 : }
312 :
313 2885 : if (gfc_current_state () != COMP_BLOCK_DATA
314 2732 : && sym->attr.in_common
315 2914 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
316 : "common block variable %qs in DATA statement at %C",
317 : sym->name))
318 : return MATCH_ERROR;
319 :
320 2883 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
321 : return MATCH_ERROR;
322 :
323 : return MATCH_YES;
324 : }
325 :
326 :
327 : /* Match the top-level list of data variables. */
328 :
329 : static match
330 2517 : top_var_list (gfc_data *d)
331 : {
332 2517 : gfc_data_variable var, *tail, *new_var;
333 2517 : match m;
334 :
335 2517 : tail = NULL;
336 :
337 2892 : for (;;)
338 : {
339 2892 : m = var_element (&var);
340 2892 : if (m == MATCH_NO)
341 0 : goto syntax;
342 2892 : if (m == MATCH_ERROR)
343 : return MATCH_ERROR;
344 :
345 2877 : new_var = gfc_get_data_variable ();
346 2877 : *new_var = var;
347 2877 : if (new_var->expr)
348 2751 : new_var->expr->where = gfc_current_locus;
349 :
350 2877 : if (tail == NULL)
351 2502 : d->var = new_var;
352 : else
353 375 : tail->next = new_var;
354 :
355 2877 : tail = new_var;
356 :
357 2877 : if (gfc_match_char ('/') == MATCH_YES)
358 : break;
359 378 : if (gfc_match_char (',') != MATCH_YES)
360 3 : goto syntax;
361 : }
362 :
363 : return MATCH_YES;
364 :
365 3 : syntax:
366 3 : gfc_syntax_error (ST_DATA);
367 3 : gfc_free_data_all (gfc_current_ns);
368 3 : return MATCH_ERROR;
369 : }
370 :
371 :
372 : static match
373 8713 : match_data_constant (gfc_expr **result)
374 : {
375 8713 : char name[GFC_MAX_SYMBOL_LEN + 1];
376 8713 : gfc_symbol *sym, *dt_sym = NULL;
377 8713 : gfc_expr *expr;
378 8713 : match m;
379 8713 : locus old_loc;
380 8713 : gfc_symtree *symtree;
381 :
382 8713 : m = gfc_match_literal_constant (&expr, 1);
383 8713 : if (m == MATCH_YES)
384 : {
385 8368 : *result = expr;
386 8368 : return MATCH_YES;
387 : }
388 :
389 345 : if (m == MATCH_ERROR)
390 : return MATCH_ERROR;
391 :
392 337 : m = gfc_match_null (result);
393 337 : if (m != MATCH_NO)
394 : return m;
395 :
396 329 : old_loc = gfc_current_locus;
397 :
398 : /* Should this be a structure component, try to match it
399 : before matching a name. */
400 329 : m = gfc_match_rvalue (result);
401 329 : if (m == MATCH_ERROR)
402 : return m;
403 :
404 329 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
405 : {
406 4 : if (!gfc_simplify_expr (*result, 0))
407 0 : m = MATCH_ERROR;
408 4 : return m;
409 : }
410 319 : else if (m == MATCH_YES)
411 : {
412 : /* If a parameter inquiry ends up here, symtree is NULL but **result
413 : contains the right constant expression. Check here. */
414 319 : if ((*result)->symtree == NULL
415 37 : && (*result)->expr_type == EXPR_CONSTANT
416 37 : && ((*result)->ts.type == BT_INTEGER
417 1 : || (*result)->ts.type == BT_REAL))
418 : return m;
419 :
420 : /* F2018:R845 data-stmt-constant is initial-data-target.
421 : A data-stmt-constant shall be ... initial-data-target if and
422 : only if the corresponding data-stmt-object has the POINTER
423 : attribute. ... If data-stmt-constant is initial-data-target
424 : the corresponding data statement object shall be
425 : data-pointer-initialization compatible (7.5.4.6) with the initial
426 : data target; the data statement object is initially associated
427 : with the target. */
428 283 : if ((*result)->symtree
429 282 : && (*result)->symtree->n.sym->attr.save
430 218 : && (*result)->symtree->n.sym->attr.target)
431 : return m;
432 250 : gfc_free_expr (*result);
433 : }
434 :
435 256 : gfc_current_locus = old_loc;
436 :
437 256 : m = gfc_match_name (name);
438 256 : if (m != MATCH_YES)
439 : return m;
440 :
441 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
442 : return MATCH_ERROR;
443 :
444 250 : sym = symtree->n.sym;
445 :
446 250 : if (sym && sym->attr.generic)
447 60 : dt_sym = gfc_find_dt_in_generic (sym);
448 :
449 60 : if (sym == NULL
450 250 : || (sym->attr.flavor != FL_PARAMETER
451 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
452 : {
453 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
454 : name);
455 5 : *result = NULL;
456 5 : return MATCH_ERROR;
457 : }
458 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
459 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
460 :
461 : /* Check to see if the value is an initialization array expression. */
462 185 : if (sym->value->expr_type == EXPR_ARRAY)
463 : {
464 67 : gfc_current_locus = old_loc;
465 :
466 67 : m = gfc_match_init_expr (result);
467 67 : if (m == MATCH_ERROR)
468 : return m;
469 :
470 66 : if (m == MATCH_YES)
471 : {
472 66 : if (!gfc_simplify_expr (*result, 0))
473 0 : m = MATCH_ERROR;
474 :
475 66 : if ((*result)->expr_type == EXPR_CONSTANT)
476 : return m;
477 : else
478 : {
479 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
480 2 : return MATCH_ERROR;
481 : }
482 : }
483 : }
484 :
485 118 : *result = gfc_copy_expr (sym->value);
486 118 : return MATCH_YES;
487 : }
488 :
489 :
490 : /* Match a list of values in a DATA statement. The leading '/' has
491 : already been seen at this point. */
492 :
493 : static match
494 2560 : top_val_list (gfc_data *data)
495 : {
496 2560 : gfc_data_value *new_val, *tail;
497 2560 : gfc_expr *expr;
498 2560 : match m;
499 :
500 2560 : tail = NULL;
501 :
502 8349 : for (;;)
503 : {
504 8349 : m = match_data_constant (&expr);
505 8349 : if (m == MATCH_NO)
506 3 : goto syntax;
507 8346 : if (m == MATCH_ERROR)
508 : return MATCH_ERROR;
509 :
510 8324 : new_val = gfc_get_data_value ();
511 8324 : mpz_init (new_val->repeat);
512 :
513 8324 : if (tail == NULL)
514 2535 : data->value = new_val;
515 : else
516 5789 : tail->next = new_val;
517 :
518 8324 : tail = new_val;
519 :
520 8324 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
521 : {
522 8119 : tail->expr = expr;
523 8119 : mpz_set_ui (tail->repeat, 1);
524 : }
525 : else
526 : {
527 205 : mpz_set (tail->repeat, expr->value.integer);
528 205 : gfc_free_expr (expr);
529 :
530 205 : m = match_data_constant (&tail->expr);
531 205 : if (m == MATCH_NO)
532 0 : goto syntax;
533 205 : if (m == MATCH_ERROR)
534 : return MATCH_ERROR;
535 : }
536 :
537 8320 : if (gfc_match_char ('/') == MATCH_YES)
538 : break;
539 5790 : if (gfc_match_char (',') == MATCH_NO)
540 1 : goto syntax;
541 : }
542 :
543 : return MATCH_YES;
544 :
545 4 : syntax:
546 4 : gfc_syntax_error (ST_DATA);
547 4 : gfc_free_data_all (gfc_current_ns);
548 4 : return MATCH_ERROR;
549 : }
550 :
551 :
552 : /* Matches an old style initialization. */
553 :
554 : static match
555 70 : match_old_style_init (const char *name)
556 : {
557 70 : match m;
558 70 : gfc_symtree *st;
559 70 : gfc_symbol *sym;
560 70 : gfc_data *newdata, *nd;
561 :
562 : /* Set up data structure to hold initializers. */
563 70 : gfc_find_sym_tree (name, NULL, 0, &st);
564 70 : sym = st->n.sym;
565 :
566 70 : newdata = gfc_get_data ();
567 70 : newdata->var = gfc_get_data_variable ();
568 70 : newdata->var->expr = gfc_get_variable_expr (st);
569 70 : newdata->var->expr->where = sym->declared_at;
570 70 : newdata->where = gfc_current_locus;
571 :
572 : /* Match initial value list. This also eats the terminal '/'. */
573 70 : m = top_val_list (newdata);
574 70 : if (m != MATCH_YES)
575 : {
576 1 : free (newdata);
577 1 : return m;
578 : }
579 :
580 : /* Check that a BOZ did not creep into an old-style initialization. */
581 137 : for (nd = newdata; nd; nd = nd->next)
582 : {
583 69 : if (nd->value->expr->ts.type == BT_BOZ
584 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
585 : "initialization"), &nd->value->expr->where))
586 : return MATCH_ERROR;
587 :
588 68 : if (nd->var->expr->ts.type != BT_INTEGER
589 27 : && nd->var->expr->ts.type != BT_REAL
590 21 : && nd->value->expr->ts.type == BT_BOZ)
591 : {
592 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
593 : "a %qs variable in an old-style initialization"),
594 0 : &nd->value->expr->where,
595 : gfc_typename (&nd->value->expr->ts));
596 0 : return MATCH_ERROR;
597 : }
598 : }
599 :
600 68 : if (gfc_pure (NULL))
601 : {
602 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
603 1 : free (newdata);
604 1 : return MATCH_ERROR;
605 : }
606 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
607 :
608 : /* Mark the variable as having appeared in a data statement. */
609 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
610 : {
611 2 : free (newdata);
612 2 : return MATCH_ERROR;
613 : }
614 :
615 : /* Chain in namespace list of DATA initializers. */
616 65 : newdata->next = gfc_current_ns->data;
617 65 : gfc_current_ns->data = newdata;
618 :
619 65 : return m;
620 : }
621 :
622 :
623 : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
624 : we are matching a DATA statement and are therefore issuing an error
625 : if we encounter something unexpected, if not, we're trying to match
626 : an old-style initialization expression of the form INTEGER I /2/. */
627 :
628 : match
629 2422 : gfc_match_data (void)
630 : {
631 2422 : gfc_data *new_data;
632 2422 : gfc_expr *e;
633 2422 : gfc_ref *ref;
634 2422 : match m;
635 2422 : char c;
636 :
637 : /* DATA has been matched. In free form source code, the next character
638 : needs to be whitespace or '(' from an implied do-loop. Check that
639 : here. */
640 2422 : c = gfc_peek_ascii_char ();
641 2422 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
642 : return MATCH_NO;
643 :
644 : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
645 2421 : if ((gfc_current_state () == COMP_FUNCTION
646 2421 : || gfc_current_state () == COMP_SUBROUTINE)
647 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
648 : {
649 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
650 1 : return MATCH_ERROR;
651 : }
652 :
653 2420 : set_in_match_data (true);
654 :
655 2614 : for (;;)
656 : {
657 2517 : new_data = gfc_get_data ();
658 2517 : new_data->where = gfc_current_locus;
659 :
660 2517 : m = top_var_list (new_data);
661 2517 : if (m != MATCH_YES)
662 18 : goto cleanup;
663 :
664 2499 : if (new_data->var->iter.var
665 117 : && new_data->var->iter.var->ts.type == BT_INTEGER
666 74 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
667 68 : && new_data->var->list
668 68 : && new_data->var->list->expr
669 55 : && new_data->var->list->expr->ts.type == BT_CHARACTER
670 3 : && new_data->var->list->expr->ref
671 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
672 : {
673 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
674 : "statement", &new_data->var->list->expr->where);
675 1 : goto cleanup;
676 : }
677 :
678 : /* Check for an entity with an allocatable component, which is not
679 : allowed. */
680 2498 : e = new_data->var->expr;
681 2498 : if (e)
682 : {
683 2382 : bool invalid;
684 :
685 2382 : invalid = false;
686 3606 : for (ref = e->ref; ref; ref = ref->next)
687 1224 : if ((ref->type == REF_COMPONENT
688 140 : && ref->u.c.component->attr.allocatable)
689 1222 : || (ref->type == REF_ARRAY
690 1034 : && e->symtree->n.sym->attr.pointer != 1
691 1031 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
692 1224 : invalid = true;
693 :
694 2382 : if (invalid)
695 : {
696 2 : gfc_error ("Allocatable component or deferred-shaped array "
697 : "near %C in DATA statement");
698 2 : goto cleanup;
699 : }
700 :
701 : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
702 : as a data-stmt-object shall not be an object designator in which
703 : a pointer appears other than as the entire rightmost part-ref. */
704 2380 : if (!e->ref && e->ts.type == BT_DERIVED
705 43 : && e->symtree->n.sym->attr.pointer)
706 4 : goto partref;
707 :
708 2376 : ref = e->ref;
709 2376 : if (e->symtree->n.sym->ts.type == BT_DERIVED
710 125 : && e->symtree->n.sym->attr.pointer
711 1 : && ref->type == REF_COMPONENT)
712 1 : goto partref;
713 :
714 3591 : for (; ref; ref = ref->next)
715 1217 : if (ref->type == REF_COMPONENT
716 135 : && ref->u.c.component->attr.pointer
717 27 : && ref->next)
718 1 : goto partref;
719 : }
720 :
721 2490 : m = top_val_list (new_data);
722 2490 : if (m != MATCH_YES)
723 29 : goto cleanup;
724 :
725 2461 : new_data->next = gfc_current_ns->data;
726 2461 : gfc_current_ns->data = new_data;
727 :
728 : /* A BOZ literal constant cannot appear in a structure constructor.
729 : Check for that here for a data statement value. */
730 2461 : if (new_data->value->expr->ts.type == BT_DERIVED
731 37 : && new_data->value->expr->value.constructor)
732 : {
733 35 : gfc_constructor *c;
734 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
735 106 : for (; c; c = gfc_constructor_next (c))
736 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
737 : {
738 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
739 : "structure constructor", &c->expr->where);
740 0 : return MATCH_ERROR;
741 : }
742 : }
743 :
744 2461 : if (gfc_match_eos () == MATCH_YES)
745 : break;
746 :
747 97 : gfc_match_char (','); /* Optional comma */
748 97 : }
749 :
750 2364 : set_in_match_data (false);
751 :
752 2364 : if (gfc_pure (NULL))
753 : {
754 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
755 0 : return MATCH_ERROR;
756 : }
757 2364 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
758 :
759 2364 : return MATCH_YES;
760 :
761 6 : partref:
762 :
763 6 : gfc_error ("part-ref with pointer attribute near %L is not "
764 : "rightmost part-ref of data-stmt-object",
765 : &e->where);
766 :
767 56 : cleanup:
768 56 : set_in_match_data (false);
769 56 : gfc_free_data (new_data);
770 56 : return MATCH_ERROR;
771 : }
772 :
773 :
774 : /************************ Declaration statements *********************/
775 :
776 :
777 : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
778 : list). The difference here is the expression is a list of constants
779 : and is surrounded by '/'.
780 : The typespec ts must match the typespec of the variable which the
781 : clist is initializing.
782 : The arrayspec tells whether this should match a list of constants
783 : corresponding to array elements or a scalar (as == NULL). */
784 :
785 : static match
786 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
787 : {
788 74 : gfc_constructor_base array_head = NULL;
789 74 : gfc_expr *expr = NULL;
790 74 : match m = MATCH_ERROR;
791 74 : locus where;
792 74 : mpz_t repeat, cons_size, as_size;
793 74 : bool scalar;
794 74 : int cmp;
795 :
796 74 : gcc_assert (ts);
797 :
798 : /* We have already matched '/' - now look for a constant list, as with
799 : top_val_list from decl.cc, but append the result to an array. */
800 74 : if (gfc_match ("/") == MATCH_YES)
801 : {
802 1 : gfc_error ("Empty old style initializer list at %C");
803 1 : return MATCH_ERROR;
804 : }
805 :
806 73 : where = gfc_current_locus;
807 73 : scalar = !as || !as->rank;
808 :
809 42 : if (!scalar && !spec_size (as, &as_size))
810 : {
811 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
812 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
813 : /* Nothing to cleanup yet. */
814 1 : return MATCH_ERROR;
815 : }
816 :
817 72 : mpz_init_set_ui (repeat, 0);
818 :
819 143 : for (;;)
820 : {
821 143 : m = match_data_constant (&expr);
822 143 : if (m != MATCH_YES)
823 3 : expr = NULL; /* match_data_constant may set expr to garbage */
824 3 : if (m == MATCH_NO)
825 2 : goto syntax;
826 141 : if (m == MATCH_ERROR)
827 1 : goto cleanup;
828 :
829 : /* Found r in repeat spec r*c; look for the constant to repeat. */
830 140 : if ( gfc_match_char ('*') == MATCH_YES)
831 : {
832 18 : if (scalar)
833 : {
834 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
835 1 : goto cleanup;
836 : }
837 17 : if (expr->ts.type != BT_INTEGER)
838 : {
839 1 : gfc_error ("Repeat spec must be an integer at %C");
840 1 : goto cleanup;
841 : }
842 16 : mpz_set (repeat, expr->value.integer);
843 16 : gfc_free_expr (expr);
844 16 : expr = NULL;
845 :
846 16 : m = match_data_constant (&expr);
847 16 : if (m == MATCH_NO)
848 : {
849 1 : m = MATCH_ERROR;
850 1 : gfc_error ("Expected data constant after repeat spec at %C");
851 : }
852 16 : if (m != MATCH_YES)
853 1 : goto cleanup;
854 : }
855 : /* No repeat spec, we matched the data constant itself. */
856 : else
857 122 : mpz_set_ui (repeat, 1);
858 :
859 137 : if (!scalar)
860 : {
861 : /* Add the constant initializer as many times as repeated. */
862 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
863 : {
864 : /* Make sure types of elements match */
865 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
866 12 : && !gfc_convert_type (expr, ts, 1))
867 0 : goto cleanup;
868 :
869 144 : gfc_constructor_append_expr (&array_head,
870 : gfc_copy_expr (expr), &gfc_current_locus);
871 : }
872 :
873 107 : gfc_free_expr (expr);
874 107 : expr = NULL;
875 : }
876 :
877 : /* For scalar initializers quit after one element. */
878 : else
879 : {
880 30 : if(gfc_match_char ('/') != MATCH_YES)
881 : {
882 1 : gfc_error ("End of scalar initializer expected at %C");
883 1 : goto cleanup;
884 : }
885 : break;
886 : }
887 :
888 107 : if (gfc_match_char ('/') == MATCH_YES)
889 : break;
890 72 : if (gfc_match_char (',') == MATCH_NO)
891 1 : goto syntax;
892 : }
893 :
894 : /* If we break early from here out, we encountered an error. */
895 64 : m = MATCH_ERROR;
896 :
897 : /* Set up expr as an array constructor. */
898 64 : if (!scalar)
899 : {
900 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
901 35 : expr->ts = *ts;
902 35 : expr->value.constructor = array_head;
903 :
904 : /* Validate sizes. We built expr ourselves, so cons_size will be
905 : constant (we fail above for non-constant expressions).
906 : We still need to verify that the sizes match. */
907 35 : gcc_assert (gfc_array_size (expr, &cons_size));
908 35 : cmp = mpz_cmp (cons_size, as_size);
909 35 : if (cmp < 0)
910 2 : gfc_error ("Not enough elements in array initializer at %C");
911 33 : else if (cmp > 0)
912 3 : gfc_error ("Too many elements in array initializer at %C");
913 35 : mpz_clear (cons_size);
914 35 : if (cmp)
915 5 : goto cleanup;
916 :
917 : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
918 30 : expr->rank = as->rank;
919 30 : expr->corank = as->corank;
920 30 : expr->shape = gfc_get_shape (as->rank);
921 66 : for (int i = 0; i < as->rank; ++i)
922 36 : spec_dimen_size (as, i, &expr->shape[i]);
923 : }
924 :
925 : /* Make sure scalar types match. */
926 29 : else if (!gfc_compare_types (&expr->ts, ts)
927 29 : && !gfc_convert_type (expr, ts, 1))
928 2 : goto cleanup;
929 :
930 57 : if (expr->ts.u.cl)
931 1 : expr->ts.u.cl->length_from_typespec = 1;
932 :
933 57 : *result = expr;
934 57 : m = MATCH_YES;
935 57 : goto done;
936 :
937 3 : syntax:
938 3 : m = MATCH_ERROR;
939 3 : gfc_error ("Syntax error in old style initializer list at %C");
940 :
941 15 : cleanup:
942 15 : if (expr)
943 10 : expr->value.constructor = NULL;
944 15 : gfc_free_expr (expr);
945 15 : gfc_constructor_free (array_head);
946 :
947 72 : done:
948 72 : mpz_clear (repeat);
949 72 : if (!scalar)
950 41 : mpz_clear (as_size);
951 : return m;
952 : }
953 :
954 :
955 : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
956 :
957 : static bool
958 113 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
959 : {
960 113 : if ((from->type == AS_ASSUMED_RANK && to->corank)
961 111 : || (to->type == AS_ASSUMED_RANK && from->corank))
962 : {
963 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
964 5 : return false;
965 : }
966 :
967 108 : if (to->rank == 0 && from->rank > 0)
968 : {
969 48 : to->rank = from->rank;
970 48 : to->type = from->type;
971 48 : to->cray_pointee = from->cray_pointee;
972 48 : to->cp_was_assumed = from->cp_was_assumed;
973 :
974 152 : for (int i = to->corank - 1; i >= 0; i--)
975 : {
976 : /* Do not exceed the limits on lower[] and upper[]. gfortran
977 : cleans up elsewhere. */
978 104 : int j = from->rank + i;
979 104 : if (j >= GFC_MAX_DIMENSIONS)
980 : break;
981 :
982 104 : to->lower[j] = to->lower[i];
983 104 : to->upper[j] = to->upper[i];
984 : }
985 115 : for (int i = 0; i < from->rank; i++)
986 : {
987 67 : if (copy)
988 : {
989 43 : to->lower[i] = gfc_copy_expr (from->lower[i]);
990 43 : to->upper[i] = gfc_copy_expr (from->upper[i]);
991 : }
992 : else
993 : {
994 24 : to->lower[i] = from->lower[i];
995 24 : to->upper[i] = from->upper[i];
996 : }
997 : }
998 : }
999 60 : else if (to->corank == 0 && from->corank > 0)
1000 : {
1001 33 : to->corank = from->corank;
1002 33 : to->cotype = from->cotype;
1003 :
1004 102 : for (int i = 0; i < from->corank; i++)
1005 : {
1006 : /* Do not exceed the limits on lower[] and upper[]. gfortran
1007 : cleans up elsewhere. */
1008 70 : int k = from->rank + i;
1009 70 : int j = to->rank + i;
1010 70 : if (j >= GFC_MAX_DIMENSIONS)
1011 : break;
1012 :
1013 69 : if (copy)
1014 : {
1015 37 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1016 37 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1017 : }
1018 : else
1019 : {
1020 32 : to->lower[j] = from->lower[k];
1021 32 : to->upper[j] = from->upper[k];
1022 : }
1023 : }
1024 : }
1025 :
1026 108 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1027 : {
1028 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1029 : "allowed dimensions of %d",
1030 : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1031 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1032 1 : return false;
1033 : }
1034 : return true;
1035 : }
1036 :
1037 :
1038 : /* Match an intent specification. Since this can only happen after an
1039 : INTENT word, a legal intent-spec must follow. */
1040 :
1041 : static sym_intent
1042 26856 : match_intent_spec (void)
1043 : {
1044 :
1045 26856 : if (gfc_match (" ( in out )") == MATCH_YES)
1046 : return INTENT_INOUT;
1047 23853 : if (gfc_match (" ( in )") == MATCH_YES)
1048 : return INTENT_IN;
1049 3576 : if (gfc_match (" ( out )") == MATCH_YES)
1050 : return INTENT_OUT;
1051 :
1052 2 : gfc_error ("Bad INTENT specification at %C");
1053 2 : return INTENT_UNKNOWN;
1054 : }
1055 :
1056 :
1057 : /* Matches a character length specification, which is either a
1058 : specification expression, '*', or ':'. */
1059 :
1060 : static match
1061 27391 : char_len_param_value (gfc_expr **expr, bool *deferred)
1062 : {
1063 27391 : match m;
1064 27391 : gfc_expr *p;
1065 :
1066 27391 : *expr = NULL;
1067 27391 : *deferred = false;
1068 :
1069 27391 : if (gfc_match_char ('*') == MATCH_YES)
1070 : return MATCH_YES;
1071 :
1072 20910 : if (gfc_match_char (':') == MATCH_YES)
1073 : {
1074 3287 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1075 : return MATCH_ERROR;
1076 :
1077 3285 : *deferred = true;
1078 :
1079 3285 : return MATCH_YES;
1080 : }
1081 :
1082 17623 : m = gfc_match_expr (expr);
1083 :
1084 17623 : if (m == MATCH_NO || m == MATCH_ERROR)
1085 : return m;
1086 :
1087 17618 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1088 : return MATCH_ERROR;
1089 :
1090 : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1091 17612 : p = gfc_copy_expr (*expr);
1092 17612 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1093 14583 : gfc_replace_expr (*expr, p);
1094 : else
1095 3029 : gfc_free_expr (p);
1096 :
1097 17612 : if ((*expr)->expr_type == EXPR_FUNCTION)
1098 : {
1099 1014 : if ((*expr)->ts.type == BT_INTEGER
1100 1013 : || ((*expr)->ts.type == BT_UNKNOWN
1101 1013 : && strcmp((*expr)->symtree->name, "null") != 0))
1102 : return MATCH_YES;
1103 :
1104 2 : goto syntax;
1105 : }
1106 16598 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1107 : {
1108 : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1109 : processor dependent and its value is greater than or equal to zero.
1110 : F2008, 4.4.3.2: If the character length parameter value evaluates
1111 : to a negative value, the length of character entities declared
1112 : is zero. */
1113 :
1114 14513 : if ((*expr)->ts.type == BT_INTEGER)
1115 : {
1116 14495 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1117 4 : mpz_set_si ((*expr)->value.integer, 0);
1118 : }
1119 : else
1120 18 : goto syntax;
1121 : }
1122 2085 : else if ((*expr)->expr_type == EXPR_ARRAY)
1123 8 : goto syntax;
1124 2077 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1125 : {
1126 1511 : bool t;
1127 1511 : gfc_expr *e;
1128 :
1129 1511 : e = gfc_copy_expr (*expr);
1130 :
1131 : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1132 : which causes an ICE if gfc_reduce_init_expr() is called. */
1133 1511 : if (e->ref && e->ref->type == REF_ARRAY
1134 8 : && e->ref->u.ar.type == AR_UNKNOWN
1135 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1136 2 : goto syntax;
1137 :
1138 1509 : t = gfc_reduce_init_expr (e);
1139 :
1140 1509 : if (!t && e->ts.type == BT_UNKNOWN
1141 7 : && e->symtree->n.sym->attr.untyped == 1
1142 7 : && (flag_implicit_none
1143 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1144 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1145 : {
1146 7 : gfc_free_expr (e);
1147 7 : goto syntax;
1148 : }
1149 :
1150 1502 : if ((e->ref && e->ref->type == REF_ARRAY
1151 4 : && e->ref->u.ar.type != AR_ELEMENT)
1152 1501 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1153 : {
1154 2 : gfc_free_expr (e);
1155 2 : goto syntax;
1156 : }
1157 :
1158 1500 : gfc_free_expr (e);
1159 : }
1160 :
1161 16561 : if (gfc_seen_div0)
1162 52 : m = MATCH_ERROR;
1163 :
1164 : return m;
1165 :
1166 39 : syntax:
1167 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1168 39 : return MATCH_ERROR;
1169 : }
1170 :
1171 :
1172 : /* A character length is a '*' followed by a literal integer or a
1173 : char_len_param_value in parenthesis. */
1174 :
1175 : static match
1176 61996 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1177 : {
1178 61996 : int length;
1179 61996 : match m;
1180 :
1181 61996 : *deferred = false;
1182 61996 : m = gfc_match_char ('*');
1183 61996 : if (m != MATCH_YES)
1184 : return m;
1185 :
1186 2641 : m = gfc_match_small_literal_int (&length, NULL);
1187 2641 : if (m == MATCH_ERROR)
1188 : return m;
1189 :
1190 2641 : if (m == MATCH_YES)
1191 : {
1192 2137 : if (obsolescent_check
1193 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1194 : return MATCH_ERROR;
1195 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1196 2137 : return m;
1197 : }
1198 :
1199 504 : if (gfc_match_char ('(') == MATCH_NO)
1200 0 : goto syntax;
1201 :
1202 504 : m = char_len_param_value (expr, deferred);
1203 504 : if (m != MATCH_YES && gfc_matching_function)
1204 : {
1205 0 : gfc_undo_symbols ();
1206 0 : m = MATCH_YES;
1207 : }
1208 :
1209 1 : if (m == MATCH_ERROR)
1210 : return m;
1211 503 : if (m == MATCH_NO)
1212 0 : goto syntax;
1213 :
1214 503 : if (gfc_match_char (')') == MATCH_NO)
1215 : {
1216 0 : gfc_free_expr (*expr);
1217 0 : *expr = NULL;
1218 0 : goto syntax;
1219 : }
1220 :
1221 503 : if (obsolescent_check
1222 503 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1223 : return MATCH_ERROR;
1224 :
1225 : return MATCH_YES;
1226 :
1227 0 : syntax:
1228 0 : gfc_error ("Syntax error in character length specification at %C");
1229 0 : return MATCH_ERROR;
1230 : }
1231 :
1232 :
1233 : /* Special subroutine for finding a symbol. Check if the name is found
1234 : in the current name space. If not, and we're compiling a function or
1235 : subroutine and the parent compilation unit is an interface, then check
1236 : to see if the name we've been given is the name of the interface
1237 : (located in another namespace). */
1238 :
1239 : static int
1240 277672 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1241 : {
1242 277672 : gfc_state_data *s;
1243 277672 : gfc_symtree *st;
1244 277672 : int i;
1245 :
1246 277672 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1247 277672 : if (i == 0)
1248 : {
1249 277672 : *result = st ? st->n.sym : NULL;
1250 277672 : goto end;
1251 : }
1252 :
1253 0 : if (gfc_current_state () != COMP_SUBROUTINE
1254 0 : && gfc_current_state () != COMP_FUNCTION)
1255 0 : goto end;
1256 :
1257 0 : s = gfc_state_stack->previous;
1258 0 : if (s == NULL)
1259 0 : goto end;
1260 :
1261 0 : if (s->state != COMP_INTERFACE)
1262 0 : goto end;
1263 0 : if (s->sym == NULL)
1264 0 : goto end; /* Nameless interface. */
1265 :
1266 0 : if (strcmp (name, s->sym->name) == 0)
1267 : {
1268 0 : *result = s->sym;
1269 0 : return 0;
1270 : }
1271 :
1272 0 : end:
1273 : return i;
1274 : }
1275 :
1276 :
1277 : /* Special subroutine for getting a symbol node associated with a
1278 : procedure name, used in SUBROUTINE and FUNCTION statements. The
1279 : symbol is created in the parent using with symtree node in the
1280 : child unit pointing to the symbol. If the current namespace has no
1281 : parent, then the symbol is just created in the current unit. */
1282 :
1283 : static int
1284 62375 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1285 : {
1286 62375 : gfc_symtree *st;
1287 62375 : gfc_symbol *sym;
1288 62375 : int rc = 0;
1289 :
1290 : /* Module functions have to be left in their own namespace because
1291 : they have potentially (almost certainly!) already been referenced.
1292 : In this sense, they are rather like external functions. This is
1293 : fixed up in resolve.cc(resolve_entries), where the symbol name-
1294 : space is set to point to the master function, so that the fake
1295 : result mechanism can work. */
1296 62375 : if (module_fcn_entry)
1297 : {
1298 : /* Present if entry is declared to be a module procedure. */
1299 259 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1300 :
1301 259 : if (*result == NULL)
1302 216 : rc = gfc_get_symbol (name, NULL, result);
1303 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1304 43 : && (*result)->ts.type == BT_UNKNOWN
1305 86 : && sym->attr.flavor == FL_UNKNOWN)
1306 : /* Pick up the typespec for the entry, if declared in the function
1307 : body. Note that this symbol is FL_UNKNOWN because it will
1308 : only have appeared in a type declaration. The local symtree
1309 : is set to point to the module symbol and a unique symtree
1310 : to the local version. This latter ensures a correct clearing
1311 : of the symbols. */
1312 : {
1313 : /* If the ENTRY proceeds its specification, we need to ensure
1314 : that this does not raise a "has no IMPLICIT type" error. */
1315 43 : if (sym->ts.type == BT_UNKNOWN)
1316 23 : sym->attr.untyped = 1;
1317 :
1318 43 : (*result)->ts = sym->ts;
1319 :
1320 : /* Put the symbol in the procedure namespace so that, should
1321 : the ENTRY precede its specification, the specification
1322 : can be applied. */
1323 43 : (*result)->ns = gfc_current_ns;
1324 :
1325 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1326 43 : st->n.sym = *result;
1327 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1328 43 : sym->refs++;
1329 43 : st->n.sym = sym;
1330 : }
1331 : }
1332 : else
1333 62116 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1334 :
1335 62375 : if (rc)
1336 : return rc;
1337 :
1338 62374 : sym = *result;
1339 62374 : if (sym->attr.proc == PROC_ST_FUNCTION)
1340 : return rc;
1341 :
1342 62373 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1343 : {
1344 : /* Create a partially populated interface symbol to carry the
1345 : characteristics of the procedure and the result. */
1346 436 : sym->tlink = gfc_new_symbol (name, sym->ns);
1347 436 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1348 436 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1349 436 : if (sym->attr.dimension)
1350 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1351 :
1352 : /* Ideally, at this point, a copy would be made of the formal
1353 : arguments and their namespace. However, this does not appear
1354 : to be necessary, albeit at the expense of not being able to
1355 : use gfc_compare_interfaces directly. */
1356 :
1357 436 : if (sym->result && sym->result != sym)
1358 : {
1359 104 : sym->tlink->result = sym->result;
1360 104 : sym->result = NULL;
1361 : }
1362 332 : else if (sym->result)
1363 : {
1364 84 : sym->tlink->result = sym->tlink;
1365 : }
1366 : }
1367 61937 : else if (sym && !sym->gfc_new
1368 23823 : && gfc_current_state () != COMP_INTERFACE)
1369 : {
1370 : /* Trap another encompassed procedure with the same name. All
1371 : these conditions are necessary to avoid picking up an entry
1372 : whose name clashes with that of the encompassing procedure;
1373 : this is handled using gsymbols to register unique, globally
1374 : accessible names. */
1375 22822 : if (sym->attr.flavor != 0
1376 20798 : && sym->attr.proc != 0
1377 2307 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1378 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1379 : {
1380 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1381 : name, &sym->declared_at);
1382 7 : return true;
1383 : }
1384 22815 : if (sym->attr.flavor != 0
1385 20791 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1386 : {
1387 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1388 : name, &sym->declared_at);
1389 1 : return true;
1390 : }
1391 :
1392 22814 : if (sym->attr.external && sym->attr.procedure
1393 2 : && gfc_current_state () == COMP_CONTAINS)
1394 : {
1395 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1396 : "procedure defined at %L",
1397 : name, &sym->declared_at);
1398 1 : return true;
1399 : }
1400 :
1401 : /* Trap a procedure with a name the same as interface in the
1402 : encompassing scope. */
1403 22813 : if (sym->attr.generic != 0
1404 60 : && (sym->attr.subroutine || sym->attr.function)
1405 1 : && !sym->attr.mod_proc)
1406 : {
1407 1 : gfc_error_now ("Name %qs at %C is already defined"
1408 : " as a generic interface at %L",
1409 : name, &sym->declared_at);
1410 1 : return true;
1411 : }
1412 :
1413 : /* Trap declarations of attributes in encompassing scope. The
1414 : signature for this is that ts.kind is nonzero for no-CLASS
1415 : entity. For a CLASS entity, ts.kind is zero. */
1416 22812 : if ((sym->ts.kind != 0
1417 22471 : || sym->ts.type == BT_CLASS
1418 22470 : || sym->ts.type == BT_DERIVED)
1419 365 : && !sym->attr.implicit_type
1420 364 : && sym->attr.proc == 0
1421 346 : && gfc_current_ns->parent != NULL
1422 137 : && sym->attr.access == 0
1423 135 : && !module_fcn_entry)
1424 : {
1425 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1426 : "from a previous declaration", name);
1427 5 : return true;
1428 : }
1429 : }
1430 :
1431 : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1432 : subroutine-stmt of a module subprogram or of a nonabstract interface
1433 : body that is declared in the scoping unit of a module or submodule. */
1434 62358 : if (sym->attr.external
1435 92 : && (sym->attr.subroutine || sym->attr.function)
1436 91 : && sym->attr.if_source == IFSRC_IFBODY
1437 91 : && !current_attr.module_procedure
1438 3 : && sym->attr.proc == PROC_MODULE
1439 3 : && gfc_state_stack->state == COMP_CONTAINS)
1440 : {
1441 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1442 : "clashes with internal procedure defined at %C",
1443 : name, &sym->declared_at);
1444 1 : return true;
1445 : }
1446 :
1447 62357 : if (sym && !sym->gfc_new
1448 24243 : && sym->attr.flavor != FL_UNKNOWN
1449 21840 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1450 217 : && gfc_state_stack->state == COMP_CONTAINS
1451 212 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1452 : {
1453 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1454 : name, &sym->declared_at);
1455 1 : return true;
1456 : }
1457 :
1458 62356 : if (gfc_current_ns->parent == NULL || *result == NULL)
1459 : return rc;
1460 :
1461 : /* Module function entries will already have a symtree in
1462 : the current namespace but will need one at module level. */
1463 50437 : if (module_fcn_entry)
1464 : {
1465 : /* Present if entry is declared to be a module procedure. */
1466 257 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1467 257 : if (st == NULL)
1468 216 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1469 : }
1470 : else
1471 50180 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1472 :
1473 50437 : st->n.sym = sym;
1474 50437 : sym->refs++;
1475 :
1476 : /* See if the procedure should be a module procedure. */
1477 :
1478 50437 : if (((sym->ns->proc_name != NULL
1479 50437 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1480 20564 : && sym->attr.proc != PROC_MODULE)
1481 50437 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1482 68288 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1483 : rc = 2;
1484 :
1485 : return rc;
1486 : }
1487 :
1488 :
1489 : /* Verify that the given symbol representing a parameter is C
1490 : interoperable, by checking to see if it was marked as such after
1491 : its declaration. If the given symbol is not interoperable, a
1492 : warning is reported, thus removing the need to return the status to
1493 : the calling function. The standard does not require the user use
1494 : one of the iso_c_binding named constants to declare an
1495 : interoperable parameter, but we can't be sure if the param is C
1496 : interop or not if the user doesn't. For example, integer(4) may be
1497 : legal Fortran, but doesn't have meaning in C. It may interop with
1498 : a number of the C types, which causes a problem because the
1499 : compiler can't know which one. This code is almost certainly not
1500 : portable, and the user will get what they deserve if the C type
1501 : across platforms isn't always interoperable with integer(4). If
1502 : the user had used something like integer(c_int) or integer(c_long),
1503 : the compiler could have automatically handled the varying sizes
1504 : across platforms. */
1505 :
1506 : bool
1507 16361 : gfc_verify_c_interop_param (gfc_symbol *sym)
1508 : {
1509 16361 : int is_c_interop = 0;
1510 16361 : bool retval = true;
1511 :
1512 : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1513 : Don't repeat the checks here. */
1514 16361 : if (sym->attr.implicit_type)
1515 : return true;
1516 :
1517 : /* For subroutines or functions that are passed to a BIND(C) procedure,
1518 : they're interoperable if they're BIND(C) and their params are all
1519 : interoperable. */
1520 16361 : if (sym->attr.flavor == FL_PROCEDURE)
1521 : {
1522 4 : if (sym->attr.is_bind_c == 0)
1523 : {
1524 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1525 : "attribute to be C interoperable", sym->name,
1526 : &(sym->declared_at));
1527 0 : return false;
1528 : }
1529 : else
1530 : {
1531 4 : if (sym->attr.is_c_interop == 1)
1532 : /* We've already checked this procedure; don't check it again. */
1533 : return true;
1534 : else
1535 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1536 4 : sym->common_block);
1537 : }
1538 : }
1539 :
1540 : /* See if we've stored a reference to a procedure that owns sym. */
1541 16357 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1542 : {
1543 16357 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1544 : {
1545 16318 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1546 16318 : bool f2018_added = false;
1547 :
1548 16318 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1549 :
1550 : /* F2018:18.3.6 has the following text:
1551 : "(5) any dummy argument without the VALUE attribute corresponds to
1552 : a formal parameter of the prototype that is of a pointer type, and
1553 : either
1554 : • the dummy argument is interoperable with an entity of the
1555 : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1556 : the formal parameter (this is equivalent to the F2008 text),
1557 : • the dummy argument is a nonallocatable nonpointer variable of
1558 : type CHARACTER with assumed character length and the formal
1559 : parameter is a pointer to CFI_cdesc_t,
1560 : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1561 : or a pointer without the CONTIGUOUS attribute, and the formal
1562 : parameter is a pointer to CFI_cdesc_t, or
1563 : • the dummy argument is assumed-type and not allocatable,
1564 : assumed-shape, assumed-rank, or a pointer, and the formal
1565 : parameter is a pointer to void," */
1566 3720 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1567 : {
1568 2354 : bool as_ar = (sym->as
1569 2354 : && (sym->as->type == AS_ASSUMED_SHAPE
1570 2109 : || sym->as->type == AS_ASSUMED_RANK));
1571 4708 : bool cond1 = (sym->ts.type == BT_CHARACTER
1572 1564 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1573 904 : && !sym->attr.allocatable
1574 3240 : && !sym->attr.pointer);
1575 4708 : bool cond2 = (sym->attr.allocatable
1576 2257 : || as_ar
1577 3370 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1578 4708 : bool cond3 = (sym->ts.type == BT_ASSUMED
1579 0 : && !sym->attr.allocatable
1580 0 : && !sym->attr.pointer
1581 2354 : && !as_ar);
1582 2354 : f2018_added = cond1 || cond2 || cond3;
1583 : }
1584 :
1585 16318 : if (is_c_interop != 1 && !f2018_added)
1586 : {
1587 : /* Make personalized messages to give better feedback. */
1588 1828 : if (sym->ts.type == BT_DERIVED)
1589 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1590 : "BIND(C) procedure %qs but is not C interoperable "
1591 : "because derived type %qs is not C interoperable",
1592 : sym->name, &(sym->declared_at),
1593 1 : sym->ns->proc_name->name,
1594 1 : sym->ts.u.derived->name);
1595 1827 : else if (sym->ts.type == BT_CLASS)
1596 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1597 : "BIND(C) procedure %qs but is not C interoperable "
1598 : "because it is polymorphic",
1599 : sym->name, &(sym->declared_at),
1600 6 : sym->ns->proc_name->name);
1601 1821 : else if (warn_c_binding_type)
1602 39 : gfc_warning (OPT_Wc_binding_type,
1603 : "Variable %qs at %L is a dummy argument of the "
1604 : "BIND(C) procedure %qs but may not be C "
1605 : "interoperable",
1606 : sym->name, &(sym->declared_at),
1607 39 : sym->ns->proc_name->name);
1608 : }
1609 :
1610 : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1611 16318 : if (sym->attr.pointer && sym->attr.contiguous)
1612 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1613 : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1614 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1615 :
1616 : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1617 : procedure that are default-initialized are not permitted. */
1618 15680 : if ((sym->attr.pointer || sym->attr.allocatable)
1619 1037 : && sym->ts.type == BT_DERIVED
1620 16696 : && gfc_has_default_initializer (sym->ts.u.derived))
1621 : {
1622 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1623 : "attribute at %L is not permitted in BIND(C) "
1624 : "procedure %qs", sym->name,
1625 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1626 4 : &sym->declared_at, sym->ns->proc_name->name);
1627 4 : retval = false;
1628 : }
1629 :
1630 : /* Character strings are only C interoperable if they have a
1631 : length of 1. However, as an argument they are also interoperable
1632 : when passed as descriptor (which requires len=: or len=*). */
1633 16318 : if (sym->ts.type == BT_CHARACTER)
1634 : {
1635 2338 : gfc_charlen *cl = sym->ts.u.cl;
1636 :
1637 2338 : if (sym->attr.allocatable || sym->attr.pointer)
1638 : {
1639 : /* F2018, 18.3.6 (6). */
1640 193 : if (!sym->ts.deferred)
1641 : {
1642 64 : if (sym->attr.allocatable)
1643 32 : gfc_error ("Allocatable character dummy argument %qs "
1644 : "at %L must have deferred length as "
1645 : "procedure %qs is BIND(C)", sym->name,
1646 32 : &sym->declared_at, sym->ns->proc_name->name);
1647 : else
1648 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1649 : "must have deferred length as procedure %qs "
1650 : "is BIND(C)", sym->name, &sym->declared_at,
1651 32 : sym->ns->proc_name->name);
1652 : retval = false;
1653 : }
1654 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1655 : "Deferred-length character dummy "
1656 : "argument %qs at %L of procedure "
1657 : "%qs with BIND(C) attribute",
1658 : sym->name, &sym->declared_at,
1659 129 : sym->ns->proc_name->name))
1660 102 : retval = false;
1661 : }
1662 2145 : else if (sym->attr.value
1663 354 : && (!cl || !cl->length
1664 354 : || cl->length->expr_type != EXPR_CONSTANT
1665 354 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1666 : {
1667 1 : gfc_error ("Character dummy argument %qs at %L must be "
1668 : "of length 1 as it has the VALUE attribute",
1669 : sym->name, &sym->declared_at);
1670 1 : retval = false;
1671 : }
1672 2144 : else if (!cl || !cl->length)
1673 : {
1674 : /* Assumed length; F2018, 18.3.6 (5)(2).
1675 : Uses the CFI array descriptor - also for scalars and
1676 : explicit-size/assumed-size arrays. */
1677 957 : if (!gfc_notify_std (GFC_STD_F2018,
1678 : "Assumed-length character dummy argument "
1679 : "%qs at %L of procedure %qs with BIND(C) "
1680 : "attribute", sym->name, &sym->declared_at,
1681 957 : sym->ns->proc_name->name))
1682 102 : retval = false;
1683 : }
1684 1187 : else if (cl->length->expr_type != EXPR_CONSTANT
1685 873 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1686 : {
1687 : /* F2018, 18.3.6, (5), item 4. */
1688 653 : if (!sym->attr.dimension
1689 645 : || sym->as->type == AS_ASSUMED_SIZE
1690 639 : || sym->as->type == AS_EXPLICIT)
1691 : {
1692 20 : gfc_error ("Character dummy argument %qs at %L must be "
1693 : "of constant length of one or assumed length, "
1694 : "unless it has assumed shape or assumed rank, "
1695 : "as procedure %qs has the BIND(C) attribute",
1696 : sym->name, &sym->declared_at,
1697 20 : sym->ns->proc_name->name);
1698 20 : retval = false;
1699 : }
1700 : /* else: valid only since F2018 - and an assumed-shape/rank
1701 : array; however, gfc_notify_std is already called when
1702 : those array types are used. Thus, silently accept F200x. */
1703 : }
1704 : }
1705 :
1706 : /* We have to make sure that any param to a bind(c) routine does
1707 : not have the allocatable, pointer, or optional attributes,
1708 : according to J3/04-007, section 5.1. */
1709 16318 : if (sym->attr.allocatable == 1
1710 16717 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1711 : "ALLOCATABLE attribute in procedure %qs "
1712 : "with BIND(C)", sym->name,
1713 : &(sym->declared_at),
1714 399 : sym->ns->proc_name->name))
1715 : retval = false;
1716 :
1717 16318 : if (sym->attr.pointer == 1
1718 16956 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1719 : "POINTER attribute in procedure %qs "
1720 : "with BIND(C)", sym->name,
1721 : &(sym->declared_at),
1722 638 : sym->ns->proc_name->name))
1723 : retval = false;
1724 :
1725 16318 : if (sym->attr.optional == 1 && sym->attr.value)
1726 : {
1727 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1728 : "and the VALUE attribute because procedure %qs "
1729 : "is BIND(C)", sym->name, &(sym->declared_at),
1730 9 : sym->ns->proc_name->name);
1731 9 : retval = false;
1732 : }
1733 16309 : else if (sym->attr.optional == 1
1734 17253 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1735 : "at %L with OPTIONAL attribute in "
1736 : "procedure %qs which is BIND(C)",
1737 : sym->name, &(sym->declared_at),
1738 944 : sym->ns->proc_name->name))
1739 : retval = false;
1740 :
1741 : /* Make sure that if it has the dimension attribute, that it is
1742 : either assumed size or explicit shape. Deferred shape is already
1743 : covered by the pointer/allocatable attribute. */
1744 5399 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1745 17648 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1746 : "at %L as dummy argument to the BIND(C) "
1747 : "procedure %qs at %L", sym->name,
1748 : &(sym->declared_at),
1749 : sym->ns->proc_name->name,
1750 1330 : &(sym->ns->proc_name->declared_at)))
1751 : retval = false;
1752 : }
1753 : }
1754 :
1755 : return retval;
1756 : }
1757 :
1758 :
1759 :
1760 : /* Function called by variable_decl() that adds a name to the symbol table. */
1761 :
1762 : static bool
1763 256983 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1764 : gfc_array_spec **as, locus *var_locus)
1765 : {
1766 256983 : symbol_attribute attr;
1767 256983 : gfc_symbol *sym;
1768 256983 : int upper;
1769 256983 : gfc_symtree *st, *host_st = NULL;
1770 :
1771 : /* Symbols in a submodule are host associated from the parent module or
1772 : submodules. Therefore, they can be overridden by declarations in the
1773 : submodule scope. Deal with this by attaching the existing symbol to
1774 : a new symtree and recycling the old symtree with a new symbol... */
1775 256983 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1776 256983 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1777 3 : && gfc_current_ns->parent)
1778 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1779 :
1780 256983 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1781 12 : && st->n.sym != NULL
1782 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1783 : {
1784 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1785 12 : s->n.sym = st->n.sym;
1786 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1787 :
1788 12 : st->n.sym = sym;
1789 12 : sym->refs++;
1790 12 : gfc_set_sym_referenced (sym);
1791 12 : }
1792 : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1793 : current scope are not violated by local redeclarations. Note that there is
1794 : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1795 : only set for these standards. */
1796 256971 : else if (host_st && host_st->n.sym
1797 2 : && host_st->n.sym != gfc_current_ns->proc_name
1798 2 : && !(st && st->n.sym
1799 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1800 : {
1801 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1802 : "statement and must not be re-declared", name, var_locus,
1803 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1804 2 : return false;
1805 : }
1806 : /* ...Otherwise generate a new symtree and new symbol. */
1807 256969 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1808 : return false;
1809 :
1810 : /* Check if the name has already been defined as a type. The
1811 : first letter of the symtree will be in upper case then. Of
1812 : course, this is only necessary if the upper case letter is
1813 : actually different. */
1814 :
1815 256981 : upper = TOUPPER(name[0]);
1816 256981 : if (upper != name[0])
1817 : {
1818 256343 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1819 256343 : gfc_symtree *st;
1820 :
1821 256343 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1822 256343 : strcpy (u_name, name);
1823 256343 : u_name[0] = upper;
1824 :
1825 256343 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1826 :
1827 : /* STRUCTURE types can alias symbol names */
1828 256343 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1829 : {
1830 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1831 : &st->n.sym->declared_at);
1832 1 : return false;
1833 : }
1834 : }
1835 :
1836 : /* Start updating the symbol table. Add basic type attribute if present. */
1837 256980 : if (current_ts.type != BT_UNKNOWN
1838 256980 : && (sym->attr.implicit_type == 0
1839 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1840 513778 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1841 : return false;
1842 :
1843 256954 : if (sym->ts.type == BT_CHARACTER)
1844 : {
1845 28568 : if (elem > 1)
1846 4080 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1847 : else
1848 24488 : sym->ts.u.cl = cl;
1849 28568 : sym->ts.deferred = cl_deferred;
1850 : }
1851 :
1852 : /* Add dimension attribute if present. */
1853 256954 : if (!gfc_set_array_spec (sym, *as, var_locus))
1854 : return false;
1855 256952 : *as = NULL;
1856 :
1857 : /* Add attribute to symbol. The copy is so that we can reset the
1858 : dimension attribute. */
1859 256952 : attr = current_attr;
1860 256952 : attr.dimension = 0;
1861 256952 : attr.codimension = 0;
1862 :
1863 256952 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1864 : return false;
1865 :
1866 : /* Finish any work that may need to be done for the binding label,
1867 : if it's a bind(c). The bind(c) attr is found before the symbol
1868 : is made, and before the symbol name (for data decls), so the
1869 : current_ts is holding the binding label, or nothing if the
1870 : name= attr wasn't given. Therefore, test here if we're dealing
1871 : with a bind(c) and make sure the binding label is set correctly. */
1872 256938 : if (sym->attr.is_bind_c == 1)
1873 : {
1874 1300 : if (!sym->binding_label)
1875 : {
1876 : /* Set the binding label and verify that if a NAME= was specified
1877 : then only one identifier was in the entity-decl-list. */
1878 136 : if (!set_binding_label (&sym->binding_label, sym->name,
1879 : num_idents_on_line))
1880 : return false;
1881 : }
1882 : }
1883 :
1884 : /* See if we know we're in a common block, and if it's a bind(c)
1885 : common then we need to make sure we're an interoperable type. */
1886 256936 : if (sym->attr.in_common == 1)
1887 : {
1888 : /* Test the common block object. */
1889 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1890 6 : && sym->ts.is_c_interop != 1)
1891 : {
1892 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1893 : "must be declared with a C interoperable "
1894 : "kind since common block %qs is BIND(C)",
1895 : sym->name, sym->common_block->name,
1896 0 : sym->common_block->name);
1897 0 : gfc_clear_error ();
1898 : }
1899 : }
1900 :
1901 256936 : sym->attr.implied_index = 0;
1902 :
1903 : /* Use the parameter expressions for a parameterized derived type. */
1904 256936 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1905 36002 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1906 990 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1907 :
1908 256936 : if (sym->ts.type == BT_CLASS)
1909 10803 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1910 :
1911 : return true;
1912 : }
1913 :
1914 :
1915 : /* Set character constant to the given length. The constant will be padded or
1916 : truncated. If we're inside an array constructor without a typespec, we
1917 : additionally check that all elements have the same length; check_len -1
1918 : means no checking. */
1919 :
1920 : void
1921 14019 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1922 : gfc_charlen_t check_len)
1923 : {
1924 14019 : gfc_char_t *s;
1925 14019 : gfc_charlen_t slen;
1926 :
1927 14019 : if (expr->ts.type != BT_CHARACTER)
1928 : return;
1929 :
1930 14017 : if (expr->expr_type != EXPR_CONSTANT)
1931 : {
1932 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1933 1 : return;
1934 : }
1935 :
1936 14016 : slen = expr->value.character.length;
1937 14016 : if (len != slen)
1938 : {
1939 2141 : s = gfc_get_wide_string (len + 1);
1940 2141 : memcpy (s, expr->value.character.string,
1941 2141 : MIN (len, slen) * sizeof (gfc_char_t));
1942 2141 : if (len > slen)
1943 1850 : gfc_wide_memset (&s[slen], ' ', len - slen);
1944 :
1945 2141 : if (warn_character_truncation && slen > len)
1946 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1947 : "CHARACTER expression at %L is being truncated "
1948 : "(%ld/%ld)", &expr->where,
1949 : (long) slen, (long) len);
1950 :
1951 : /* Apply the standard by 'hand' otherwise it gets cleared for
1952 : initializers. */
1953 2141 : if (check_len != -1 && slen != check_len)
1954 : {
1955 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
1956 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
1957 : "at %L must have the same length (%ld/%ld)",
1958 : &expr->where, (long) slen,
1959 : (long) check_len);
1960 : else
1961 3 : gfc_notify_std (GFC_STD_LEGACY,
1962 : "The CHARACTER elements of the array constructor "
1963 : "at %L must have the same length (%ld/%ld)",
1964 : &expr->where, (long) slen,
1965 : (long) check_len);
1966 : }
1967 :
1968 2141 : s[len] = '\0';
1969 2141 : free (expr->value.character.string);
1970 2141 : expr->value.character.string = s;
1971 2141 : expr->value.character.length = len;
1972 : /* If explicit representation was given, clear it
1973 : as it is no longer needed after padding. */
1974 2141 : if (expr->representation.length)
1975 : {
1976 45 : expr->representation.length = 0;
1977 45 : free (expr->representation.string);
1978 45 : expr->representation.string = NULL;
1979 : }
1980 : }
1981 : }
1982 :
1983 :
1984 : /* Function to create and update the enumerator history
1985 : using the information passed as arguments.
1986 : Pointer "max_enum" is also updated, to point to
1987 : enum history node containing largest initializer.
1988 :
1989 : SYM points to the symbol node of enumerator.
1990 : INIT points to its enumerator value. */
1991 :
1992 : static void
1993 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
1994 : {
1995 543 : enumerator_history *new_enum_history;
1996 543 : gcc_assert (sym != NULL && init != NULL);
1997 :
1998 543 : new_enum_history = XCNEW (enumerator_history);
1999 :
2000 543 : new_enum_history->sym = sym;
2001 543 : new_enum_history->initializer = init;
2002 543 : new_enum_history->next = NULL;
2003 :
2004 543 : if (enum_history == NULL)
2005 : {
2006 160 : enum_history = new_enum_history;
2007 160 : max_enum = enum_history;
2008 : }
2009 : else
2010 : {
2011 383 : new_enum_history->next = enum_history;
2012 383 : enum_history = new_enum_history;
2013 :
2014 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2015 383 : new_enum_history->initializer->value.integer) < 0)
2016 381 : max_enum = new_enum_history;
2017 : }
2018 543 : }
2019 :
2020 :
2021 : /* Function to free enum kind history. */
2022 :
2023 : void
2024 175 : gfc_free_enum_history (void)
2025 : {
2026 175 : enumerator_history *current = enum_history;
2027 175 : enumerator_history *next;
2028 :
2029 718 : while (current != NULL)
2030 : {
2031 543 : next = current->next;
2032 543 : free (current);
2033 543 : current = next;
2034 : }
2035 175 : max_enum = NULL;
2036 175 : enum_history = NULL;
2037 175 : }
2038 :
2039 :
2040 : /* Function to fix initializer character length if the length of the
2041 : symbol or component is constant. */
2042 :
2043 : static bool
2044 2722 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2045 : {
2046 2722 : if (!gfc_specification_expr (ts->u.cl->length))
2047 : return false;
2048 :
2049 2722 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2050 :
2051 : /* resolve_charlen will complain later on if the length
2052 : is too large. Just skip the initialization in that case. */
2053 2722 : if (mpz_cmp (ts->u.cl->length->value.integer,
2054 2722 : gfc_integer_kinds[k].huge) <= 0)
2055 : {
2056 2721 : HOST_WIDE_INT len
2057 2721 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2058 :
2059 2721 : if (init->expr_type == EXPR_CONSTANT)
2060 1987 : gfc_set_constant_character_len (len, init, -1);
2061 734 : else if (init->expr_type == EXPR_ARRAY)
2062 : {
2063 733 : gfc_constructor *cons;
2064 :
2065 : /* Build a new charlen to prevent simplification from
2066 : deleting the length before it is resolved. */
2067 733 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2068 733 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2069 733 : cons = gfc_constructor_first (init->value.constructor);
2070 4971 : for (; cons; cons = gfc_constructor_next (cons))
2071 3505 : gfc_set_constant_character_len (len, cons->expr, -1);
2072 : }
2073 : }
2074 :
2075 : return true;
2076 : }
2077 :
2078 :
2079 : /* Function called by variable_decl() that adds an initialization
2080 : expression to a symbol. */
2081 :
2082 : static bool
2083 264423 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
2084 : {
2085 264423 : symbol_attribute attr;
2086 264423 : gfc_symbol *sym;
2087 264423 : gfc_expr *init;
2088 :
2089 264423 : init = *initp;
2090 264423 : if (find_special (name, &sym, false))
2091 : return false;
2092 :
2093 264423 : attr = sym->attr;
2094 :
2095 : /* If this symbol is confirming an implicit parameter type,
2096 : then an initialization expression is not allowed. */
2097 264423 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2098 : {
2099 1 : if (*initp != NULL)
2100 : {
2101 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2102 : sym->name);
2103 0 : return false;
2104 : }
2105 : else
2106 : return true;
2107 : }
2108 :
2109 264422 : if (init == NULL)
2110 : {
2111 : /* An initializer is required for PARAMETER declarations. */
2112 232470 : if (attr.flavor == FL_PARAMETER)
2113 : {
2114 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2115 1 : return false;
2116 : }
2117 : }
2118 : else
2119 : {
2120 : /* If a variable appears in a DATA block, it cannot have an
2121 : initializer. */
2122 31952 : if (sym->attr.data)
2123 : {
2124 0 : gfc_error ("Variable %qs at %C with an initializer already "
2125 : "appears in a DATA statement", sym->name);
2126 0 : return false;
2127 : }
2128 :
2129 : /* Check if the assignment can happen. This has to be put off
2130 : until later for derived type variables and procedure pointers. */
2131 30812 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2132 30789 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2133 30739 : && !sym->attr.proc_pointer
2134 62605 : && !gfc_check_assign_symbol (sym, NULL, init))
2135 : return false;
2136 :
2137 31921 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2138 3408 : && init->ts.type == BT_CHARACTER)
2139 : {
2140 : /* Update symbol character length according initializer. */
2141 3244 : if (!gfc_check_assign_symbol (sym, NULL, init))
2142 : return false;
2143 :
2144 3244 : if (sym->ts.u.cl->length == NULL)
2145 : {
2146 838 : gfc_charlen_t clen;
2147 : /* If there are multiple CHARACTER variables declared on the
2148 : same line, we don't want them to share the same length. */
2149 838 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2150 :
2151 838 : if (sym->attr.flavor == FL_PARAMETER)
2152 : {
2153 829 : if (init->expr_type == EXPR_CONSTANT)
2154 : {
2155 546 : clen = init->value.character.length;
2156 546 : sym->ts.u.cl->length
2157 546 : = gfc_get_int_expr (gfc_charlen_int_kind,
2158 : NULL, clen);
2159 : }
2160 283 : else if (init->expr_type == EXPR_ARRAY)
2161 : {
2162 283 : if (init->ts.u.cl && init->ts.u.cl->length)
2163 : {
2164 271 : const gfc_expr *length = init->ts.u.cl->length;
2165 271 : if (length->expr_type != EXPR_CONSTANT)
2166 : {
2167 1 : gfc_error ("Cannot initialize parameter array "
2168 : "at %L "
2169 : "with variable length elements",
2170 : &sym->declared_at);
2171 1 : return false;
2172 : }
2173 270 : clen = mpz_get_si (length->value.integer);
2174 270 : }
2175 12 : else if (init->value.constructor)
2176 : {
2177 12 : gfc_constructor *c;
2178 12 : c = gfc_constructor_first (init->value.constructor);
2179 12 : clen = c->expr->value.character.length;
2180 : }
2181 : else
2182 0 : gcc_unreachable ();
2183 282 : sym->ts.u.cl->length
2184 282 : = gfc_get_int_expr (gfc_charlen_int_kind,
2185 : NULL, clen);
2186 : }
2187 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2188 0 : sym->ts.u.cl->length =
2189 0 : gfc_copy_expr (init->ts.u.cl->length);
2190 : }
2191 : }
2192 : /* Update initializer character length according to symbol. */
2193 2406 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2194 2406 : && !fix_initializer_charlen (&sym->ts, init))
2195 : return false;
2196 : }
2197 :
2198 31920 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2199 3766 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2200 : {
2201 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2202 : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2203 3 : return false;
2204 : }
2205 :
2206 : /* If sym is implied-shape, set its upper bounds from init. */
2207 31917 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2208 3763 : && sym->as->type == AS_IMPLIED_SHAPE)
2209 : {
2210 1038 : int dim;
2211 :
2212 1038 : if (init->rank == 0)
2213 : {
2214 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2215 : " with scalar", &sym->declared_at);
2216 1 : return false;
2217 : }
2218 :
2219 : /* The shape may be NULL for EXPR_ARRAY, set it. */
2220 1037 : if (init->shape == NULL)
2221 : {
2222 5 : if (init->expr_type != EXPR_ARRAY)
2223 : {
2224 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2225 2 : return false;
2226 : }
2227 :
2228 3 : init->shape = gfc_get_shape (1);
2229 3 : if (!gfc_array_size (init, &init->shape[0]))
2230 : {
2231 1 : gfc_error ("Cannot determine shape of initializer at %L",
2232 : &init->where);
2233 1 : free (init->shape);
2234 1 : init->shape = NULL;
2235 1 : return false;
2236 : }
2237 : }
2238 :
2239 2169 : for (dim = 0; dim < sym->as->rank; ++dim)
2240 : {
2241 1136 : int k;
2242 1136 : gfc_expr *e, *lower;
2243 :
2244 1136 : lower = sym->as->lower[dim];
2245 :
2246 : /* If the lower bound is an array element from another
2247 : parameterized array, then it is marked with EXPR_VARIABLE and
2248 : is an initialization expression. Try to reduce it. */
2249 1136 : if (lower->expr_type == EXPR_VARIABLE)
2250 7 : gfc_reduce_init_expr (lower);
2251 :
2252 1136 : if (lower->expr_type == EXPR_CONSTANT)
2253 : {
2254 : /* All dimensions must be without upper bound. */
2255 1135 : gcc_assert (!sym->as->upper[dim]);
2256 :
2257 1135 : k = lower->ts.kind;
2258 1135 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2259 1135 : mpz_add (e->value.integer, lower->value.integer,
2260 1135 : init->shape[dim]);
2261 1135 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2262 1135 : sym->as->upper[dim] = e;
2263 : }
2264 : else
2265 : {
2266 1 : gfc_error ("Non-constant lower bound in implied-shape"
2267 : " declaration at %L", &lower->where);
2268 1 : return false;
2269 : }
2270 : }
2271 :
2272 1033 : sym->as->type = AS_EXPLICIT;
2273 : }
2274 :
2275 : /* Ensure that explicit bounds are simplified. */
2276 31912 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2277 3758 : && sym->as->type == AS_EXPLICIT)
2278 : {
2279 8348 : for (int dim = 0; dim < sym->as->rank; ++dim)
2280 : {
2281 4602 : gfc_expr *e;
2282 :
2283 4602 : e = sym->as->lower[dim];
2284 4602 : if (e->expr_type != EXPR_CONSTANT)
2285 12 : gfc_reduce_init_expr (e);
2286 :
2287 4602 : e = sym->as->upper[dim];
2288 4602 : if (e->expr_type != EXPR_CONSTANT)
2289 106 : gfc_reduce_init_expr (e);
2290 : }
2291 : }
2292 :
2293 : /* Need to check if the expression we initialized this
2294 : to was one of the iso_c_binding named constants. If so,
2295 : and we're a parameter (constant), let it be iso_c.
2296 : For example:
2297 : integer(c_int), parameter :: my_int = c_int
2298 : integer(my_int) :: my_int_2
2299 : If we mark my_int as iso_c (since we can see it's value
2300 : is equal to one of the named constants), then my_int_2
2301 : will be considered C interoperable. */
2302 31912 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2303 : {
2304 27368 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2305 27368 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2306 : /* attr bits needed for module files. */
2307 27368 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2308 27368 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2309 27368 : if (init->ts.is_iso_c)
2310 113 : sym->ts.f90_type = init->ts.f90_type;
2311 : }
2312 :
2313 : /* Catch the case: type(t), parameter :: x = z'1'. */
2314 31912 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2315 : {
2316 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2317 : "literal constant", name, &sym->declared_at);
2318 1 : return false;
2319 : }
2320 :
2321 : /* Add initializer. Make sure we keep the ranks sane. */
2322 31911 : if (sym->attr.dimension && init->rank == 0)
2323 : {
2324 1238 : mpz_t size;
2325 1238 : gfc_expr *array;
2326 1238 : int n;
2327 1238 : if (sym->attr.flavor == FL_PARAMETER
2328 438 : && gfc_is_constant_expr (init)
2329 438 : && (init->expr_type == EXPR_CONSTANT
2330 31 : || init->expr_type == EXPR_STRUCTURE)
2331 1676 : && spec_size (sym->as, &size))
2332 : {
2333 434 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2334 : &init->where);
2335 434 : if (init->ts.type == BT_DERIVED)
2336 31 : array->ts.u.derived = init->ts.u.derived;
2337 67549 : for (n = 0; n < (int)mpz_get_si (size); n++)
2338 133937 : gfc_constructor_append_expr (&array->value.constructor,
2339 : n == 0
2340 : ? init
2341 66822 : : gfc_copy_expr (init),
2342 : &init->where);
2343 :
2344 434 : array->shape = gfc_get_shape (sym->as->rank);
2345 994 : for (n = 0; n < sym->as->rank; n++)
2346 560 : spec_dimen_size (sym->as, n, &array->shape[n]);
2347 :
2348 434 : init = array;
2349 434 : mpz_clear (size);
2350 : }
2351 1238 : init->rank = sym->as->rank;
2352 1238 : init->corank = sym->as->corank;
2353 : }
2354 :
2355 31911 : sym->value = init;
2356 31911 : if (sym->attr.save == SAVE_NONE)
2357 27468 : sym->attr.save = SAVE_IMPLICIT;
2358 31911 : *initp = NULL;
2359 : }
2360 :
2361 : return true;
2362 : }
2363 :
2364 :
2365 : /* Function called by variable_decl() that adds a name to a structure
2366 : being built. */
2367 :
2368 : static bool
2369 17677 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2370 : gfc_array_spec **as)
2371 : {
2372 17677 : gfc_state_data *s;
2373 17677 : gfc_component *c;
2374 :
2375 : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2376 : constructing, it must have the pointer attribute. */
2377 17677 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2378 3333 : && current_ts.u.derived == gfc_current_block ()
2379 267 : && current_attr.pointer == 0)
2380 : {
2381 106 : if (current_attr.allocatable
2382 106 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2383 : "must have the POINTER attribute"))
2384 : {
2385 : return false;
2386 : }
2387 105 : else if (current_attr.allocatable == 0)
2388 : {
2389 0 : gfc_error ("Component at %C must have the POINTER attribute");
2390 0 : return false;
2391 : }
2392 : }
2393 :
2394 : /* F03:C437. */
2395 17676 : if (current_ts.type == BT_CLASS
2396 812 : && !(current_attr.pointer || current_attr.allocatable))
2397 : {
2398 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2399 : "or pointer", name);
2400 5 : return false;
2401 : }
2402 :
2403 17671 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2404 : {
2405 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2406 : {
2407 0 : gfc_error ("Array component of structure at %C must have explicit "
2408 : "or deferred shape");
2409 0 : return false;
2410 : }
2411 : }
2412 :
2413 : /* If we are in a nested union/map definition, gfc_add_component will not
2414 : properly find repeated components because:
2415 : (i) gfc_add_component does a flat search, where components of unions
2416 : and maps are implicity chained so nested components may conflict.
2417 : (ii) Unions and maps are not linked as components of their parent
2418 : structures until after they are parsed.
2419 : For (i) we use gfc_find_component which searches recursively, and for (ii)
2420 : we search each block directly from the parse stack until we find the top
2421 : level structure. */
2422 :
2423 17671 : s = gfc_state_stack;
2424 17671 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2425 : {
2426 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2427 : {
2428 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2429 1434 : if (c != NULL)
2430 : {
2431 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2432 : name, &c->loc);
2433 0 : return false;
2434 : }
2435 : /* Break after we've searched the entire chain. */
2436 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2437 : break;
2438 1000 : s = s->previous;
2439 : }
2440 : }
2441 :
2442 17671 : if (!gfc_add_component (gfc_current_block(), name, &c))
2443 : return false;
2444 :
2445 17665 : c->ts = current_ts;
2446 17665 : if (c->ts.type == BT_CHARACTER)
2447 1920 : c->ts.u.cl = cl;
2448 :
2449 17665 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2450 14338 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2451 2094 : && saved_kind_expr != NULL)
2452 188 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2453 :
2454 17665 : c->attr = current_attr;
2455 :
2456 17665 : c->initializer = *init;
2457 17665 : *init = NULL;
2458 :
2459 : /* Update initializer character length according to component. */
2460 1920 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2461 1521 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2462 1458 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2463 17984 : && !fix_initializer_charlen (&c->ts, c->initializer))
2464 : return false;
2465 :
2466 17665 : c->as = *as;
2467 17665 : if (c->as != NULL)
2468 : {
2469 4629 : if (c->as->corank)
2470 107 : c->attr.codimension = 1;
2471 4629 : if (c->as->rank)
2472 4554 : c->attr.dimension = 1;
2473 : }
2474 17665 : *as = NULL;
2475 :
2476 17665 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2477 :
2478 : /* Check array components. */
2479 17665 : if (!c->attr.dimension)
2480 13111 : goto scalar;
2481 :
2482 4554 : if (c->attr.pointer)
2483 : {
2484 682 : if (c->as->type != AS_DEFERRED)
2485 : {
2486 5 : gfc_error ("Pointer array component of structure at %C must have a "
2487 : "deferred shape");
2488 5 : return false;
2489 : }
2490 : }
2491 3872 : else if (c->attr.allocatable)
2492 : {
2493 2287 : const char *err = G_("Allocatable component of structure at %C must have "
2494 : "a deferred shape");
2495 2287 : if (c->as->type != AS_DEFERRED)
2496 : {
2497 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2498 : {
2499 : /* Issue an immediate error and allow this component to pass for
2500 : the sake of clean error recovery. Set the error flag for the
2501 : containing derived type so that finalizers are not built. */
2502 4 : gfc_error_now (err);
2503 4 : s->sym->error = 1;
2504 4 : c->as->type = AS_DEFERRED;
2505 : }
2506 : else
2507 : {
2508 10 : gfc_error (err);
2509 10 : return false;
2510 : }
2511 : }
2512 : }
2513 : else
2514 : {
2515 1585 : if (c->as->type != AS_EXPLICIT)
2516 : {
2517 7 : gfc_error ("Array component of structure at %C must have an "
2518 : "explicit shape");
2519 7 : return false;
2520 : }
2521 : }
2522 :
2523 1578 : scalar:
2524 17643 : if (c->ts.type == BT_CLASS)
2525 804 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2526 :
2527 16839 : if (c->attr.pdt_kind || c->attr.pdt_len)
2528 : {
2529 562 : gfc_symbol *sym;
2530 562 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2531 : 0, &sym);
2532 562 : if (sym == NULL)
2533 : {
2534 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2535 : "in the type parameter name list at %L",
2536 0 : c->name, &gfc_current_block ()->declared_at);
2537 0 : return false;
2538 : }
2539 562 : sym->ts = c->ts;
2540 562 : sym->attr.pdt_kind = c->attr.pdt_kind;
2541 562 : sym->attr.pdt_len = c->attr.pdt_len;
2542 562 : if (c->initializer)
2543 217 : sym->value = gfc_copy_expr (c->initializer);
2544 562 : sym->attr.flavor = FL_VARIABLE;
2545 : }
2546 :
2547 16839 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2548 2520 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2549 116 : && decl_type_param_list)
2550 116 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2551 :
2552 : return true;
2553 : }
2554 :
2555 :
2556 : /* Match a 'NULL()', and possibly take care of some side effects. */
2557 :
2558 : match
2559 1680 : gfc_match_null (gfc_expr **result)
2560 : {
2561 1680 : gfc_symbol *sym;
2562 1680 : match m, m2 = MATCH_NO;
2563 :
2564 1680 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2565 : return MATCH_ERROR;
2566 :
2567 1680 : if (m == MATCH_NO)
2568 : {
2569 505 : locus old_loc;
2570 505 : char name[GFC_MAX_SYMBOL_LEN + 1];
2571 :
2572 505 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2573 499 : return m2;
2574 :
2575 6 : old_loc = gfc_current_locus;
2576 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2577 : return MATCH_ERROR;
2578 6 : if (m2 != MATCH_YES
2579 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2580 : return MATCH_ERROR;
2581 6 : if (m2 == MATCH_NO)
2582 : {
2583 0 : gfc_current_locus = old_loc;
2584 0 : return MATCH_NO;
2585 : }
2586 : }
2587 :
2588 : /* The NULL symbol now has to be/become an intrinsic function. */
2589 1181 : if (gfc_get_symbol ("null", NULL, &sym))
2590 : {
2591 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2592 0 : return MATCH_ERROR;
2593 : }
2594 :
2595 1181 : gfc_intrinsic_symbol (sym);
2596 :
2597 1181 : if (sym->attr.proc != PROC_INTRINSIC
2598 829 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2599 2009 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2600 828 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2601 0 : return MATCH_ERROR;
2602 :
2603 1181 : *result = gfc_get_null_expr (&gfc_current_locus);
2604 :
2605 : /* Invalid per F2008, C512. */
2606 1181 : if (m2 == MATCH_YES)
2607 : {
2608 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2609 6 : return MATCH_ERROR;
2610 : }
2611 :
2612 : return MATCH_YES;
2613 : }
2614 :
2615 :
2616 : /* Match the initialization expr for a data pointer or procedure pointer. */
2617 :
2618 : static match
2619 1344 : match_pointer_init (gfc_expr **init, int procptr)
2620 : {
2621 1344 : match m;
2622 :
2623 1344 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2624 : {
2625 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2626 : "a PURE procedure");
2627 1 : return MATCH_ERROR;
2628 : }
2629 1343 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2630 :
2631 : /* Match NULL() initialization. */
2632 1343 : m = gfc_match_null (init);
2633 1343 : if (m != MATCH_NO)
2634 : return m;
2635 :
2636 : /* Match non-NULL initialization. */
2637 170 : gfc_matching_ptr_assignment = !procptr;
2638 170 : gfc_matching_procptr_assignment = procptr;
2639 170 : m = gfc_match_rvalue (init);
2640 170 : gfc_matching_ptr_assignment = 0;
2641 170 : gfc_matching_procptr_assignment = 0;
2642 170 : if (m == MATCH_ERROR)
2643 : return MATCH_ERROR;
2644 169 : else if (m == MATCH_NO)
2645 : {
2646 2 : gfc_error ("Error in pointer initialization at %C");
2647 2 : return MATCH_ERROR;
2648 : }
2649 :
2650 167 : if (!procptr && !gfc_resolve_expr (*init))
2651 : return MATCH_ERROR;
2652 :
2653 166 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2654 : "initialization at %C"))
2655 : return MATCH_ERROR;
2656 :
2657 : return MATCH_YES;
2658 : }
2659 :
2660 :
2661 : static bool
2662 284410 : check_function_name (char *name)
2663 : {
2664 : /* In functions that have a RESULT variable defined, the function name always
2665 : refers to function calls. Therefore, the name is not allowed to appear in
2666 : specification statements. When checking this, be careful about
2667 : 'hidden' procedure pointer results ('ppr@'). */
2668 :
2669 284410 : if (gfc_current_state () == COMP_FUNCTION)
2670 : {
2671 45340 : gfc_symbol *block = gfc_current_block ();
2672 45340 : if (block && block->result && block->result != block
2673 14998 : && strcmp (block->result->name, "ppr@") != 0
2674 14939 : && strcmp (block->name, name) == 0)
2675 : {
2676 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2677 : "from appearing in a specification statement",
2678 : block->result->name, &block->result->declared_at, name);
2679 9 : return false;
2680 : }
2681 : }
2682 :
2683 : return true;
2684 : }
2685 :
2686 :
2687 : /* Match a variable name with an optional initializer. When this
2688 : subroutine is called, a variable is expected to be parsed next.
2689 : Depending on what is happening at the moment, updates either the
2690 : symbol table or the current interface. */
2691 :
2692 : static match
2693 274342 : variable_decl (int elem)
2694 : {
2695 274342 : char name[GFC_MAX_SYMBOL_LEN + 1];
2696 274342 : static unsigned int fill_id = 0;
2697 274342 : gfc_expr *initializer, *char_len;
2698 274342 : gfc_array_spec *as;
2699 274342 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2700 274342 : gfc_charlen *cl;
2701 274342 : bool cl_deferred;
2702 274342 : locus var_locus;
2703 274342 : match m;
2704 274342 : bool t;
2705 274342 : gfc_symbol *sym;
2706 274342 : char c;
2707 :
2708 274342 : initializer = NULL;
2709 274342 : as = NULL;
2710 274342 : cp_as = NULL;
2711 :
2712 : /* When we get here, we've just matched a list of attributes and
2713 : maybe a type and a double colon. The next thing we expect to see
2714 : is the name of the symbol. */
2715 :
2716 : /* If we are parsing a structure with legacy support, we allow the symbol
2717 : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2718 274342 : m = MATCH_NO;
2719 274342 : gfc_gobble_whitespace ();
2720 274342 : var_locus = gfc_current_locus;
2721 274342 : c = gfc_peek_ascii_char ();
2722 274342 : if (c == '%')
2723 : {
2724 12 : gfc_next_ascii_char (); /* Burn % character. */
2725 12 : m = gfc_match ("fill");
2726 12 : if (m == MATCH_YES)
2727 : {
2728 11 : if (gfc_current_state () != COMP_STRUCTURE)
2729 : {
2730 2 : if (flag_dec_structure)
2731 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2732 : else
2733 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2734 : "%<-fdec-structure%>", "%FILL");
2735 2 : m = MATCH_ERROR;
2736 2 : goto cleanup;
2737 : }
2738 :
2739 9 : if (attr_seen)
2740 : {
2741 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2742 1 : m = MATCH_ERROR;
2743 1 : goto cleanup;
2744 : }
2745 :
2746 : /* %FILL components are given invalid fortran names. */
2747 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2748 : }
2749 : else
2750 : {
2751 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2752 1 : return MATCH_ERROR;
2753 : }
2754 : }
2755 : else
2756 : {
2757 274330 : m = gfc_match_name (name);
2758 274329 : if (m != MATCH_YES)
2759 10 : goto cleanup;
2760 : }
2761 :
2762 : /* Now we could see the optional array spec. or character length. */
2763 274327 : m = gfc_match_array_spec (&as, true, true);
2764 274326 : if (m == MATCH_ERROR)
2765 56 : goto cleanup;
2766 :
2767 274270 : if (m == MATCH_NO)
2768 214273 : as = gfc_copy_array_spec (current_as);
2769 59997 : else if (current_as
2770 59997 : && !merge_array_spec (current_as, as, true))
2771 : {
2772 4 : m = MATCH_ERROR;
2773 4 : goto cleanup;
2774 : }
2775 :
2776 274266 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2777 : &gfc_current_locus);
2778 274266 : if (flag_cray_pointer)
2779 3063 : cp_as = gfc_copy_array_spec (as);
2780 :
2781 : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2782 : determine (and check) whether it can be implied-shape. If it
2783 : was parsed as assumed-size, change it because PARAMETERs cannot
2784 : be assumed-size.
2785 :
2786 : An explicit-shape-array cannot appear under several conditions.
2787 : That check is done here as well. */
2788 274266 : if (as)
2789 : {
2790 82503 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2791 : {
2792 2 : m = MATCH_ERROR;
2793 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2794 : name, &var_locus);
2795 2 : goto cleanup;
2796 : }
2797 :
2798 82501 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2799 6459 : && current_attr.flavor == FL_PARAMETER)
2800 990 : as->type = AS_IMPLIED_SHAPE;
2801 :
2802 82501 : if (as->type == AS_IMPLIED_SHAPE
2803 82501 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2804 : &var_locus))
2805 : {
2806 1 : m = MATCH_ERROR;
2807 1 : goto cleanup;
2808 : }
2809 :
2810 82500 : gfc_seen_div0 = false;
2811 :
2812 : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2813 : constant expressions shall appear only in a subprogram, derived
2814 : type definition, BLOCK construct, or interface body. */
2815 82500 : if (as->type == AS_EXPLICIT
2816 41322 : && gfc_current_state () != COMP_BLOCK
2817 : && gfc_current_state () != COMP_DERIVED
2818 : && gfc_current_state () != COMP_FUNCTION
2819 : && gfc_current_state () != COMP_INTERFACE
2820 : && gfc_current_state () != COMP_SUBROUTINE)
2821 : {
2822 : gfc_expr *e;
2823 49333 : bool not_constant = false;
2824 :
2825 49333 : for (int i = 0; i < as->rank; i++)
2826 : {
2827 28111 : e = gfc_copy_expr (as->lower[i]);
2828 28111 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2829 : {
2830 0 : m = MATCH_ERROR;
2831 0 : goto cleanup;
2832 : }
2833 :
2834 28111 : gfc_simplify_expr (e, 0);
2835 28111 : if (e && (e->expr_type != EXPR_CONSTANT))
2836 : {
2837 : not_constant = true;
2838 : break;
2839 : }
2840 28111 : gfc_free_expr (e);
2841 :
2842 28111 : e = gfc_copy_expr (as->upper[i]);
2843 28111 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2844 : {
2845 4 : m = MATCH_ERROR;
2846 4 : goto cleanup;
2847 : }
2848 :
2849 28107 : gfc_simplify_expr (e, 0);
2850 28107 : if (e && (e->expr_type != EXPR_CONSTANT))
2851 : {
2852 : not_constant = true;
2853 : break;
2854 : }
2855 28094 : gfc_free_expr (e);
2856 : }
2857 :
2858 21235 : if (not_constant && e->ts.type != BT_INTEGER)
2859 : {
2860 4 : gfc_error ("Explicit array shape at %C must be constant of "
2861 : "INTEGER type and not %s type",
2862 : gfc_basic_typename (e->ts.type));
2863 4 : m = MATCH_ERROR;
2864 4 : goto cleanup;
2865 : }
2866 9 : if (not_constant)
2867 : {
2868 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2869 9 : m = MATCH_ERROR;
2870 9 : goto cleanup;
2871 : }
2872 : }
2873 82483 : if (as->type == AS_EXPLICIT)
2874 : {
2875 99031 : for (int i = 0; i < as->rank; i++)
2876 : {
2877 57726 : gfc_expr *e, *n;
2878 57726 : e = as->lower[i];
2879 57726 : if (e->expr_type != EXPR_CONSTANT)
2880 : {
2881 452 : n = gfc_copy_expr (e);
2882 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2883 : {
2884 0 : m = MATCH_ERROR;
2885 0 : goto cleanup;
2886 : }
2887 :
2888 452 : if (n->expr_type == EXPR_CONSTANT)
2889 22 : gfc_replace_expr (e, n);
2890 : else
2891 430 : gfc_free_expr (n);
2892 : }
2893 57726 : e = as->upper[i];
2894 57726 : if (e->expr_type != EXPR_CONSTANT)
2895 : {
2896 6588 : n = gfc_copy_expr (e);
2897 6588 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2898 : {
2899 0 : m = MATCH_ERROR;
2900 0 : goto cleanup;
2901 : }
2902 :
2903 6588 : if (n->expr_type == EXPR_CONSTANT)
2904 45 : gfc_replace_expr (e, n);
2905 : else
2906 6543 : gfc_free_expr (n);
2907 : }
2908 : /* For an explicit-shape spec with constant bounds, ensure
2909 : that the effective upper bound is not lower than the
2910 : respective lower bound minus one. Otherwise adjust it so
2911 : that the extent is trivially derived to be zero. */
2912 57726 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2913 57296 : && as->upper[i]->expr_type == EXPR_CONSTANT
2914 51177 : && as->lower[i]->ts.type == BT_INTEGER
2915 51177 : && as->upper[i]->ts.type == BT_INTEGER
2916 51172 : && mpz_cmp (as->upper[i]->value.integer,
2917 51172 : as->lower[i]->value.integer) < 0)
2918 1212 : mpz_sub_ui (as->upper[i]->value.integer,
2919 : as->lower[i]->value.integer, 1);
2920 : }
2921 : }
2922 : }
2923 :
2924 274246 : char_len = NULL;
2925 274246 : cl = NULL;
2926 274246 : cl_deferred = false;
2927 :
2928 274246 : if (current_ts.type == BT_CHARACTER)
2929 : {
2930 30528 : switch (match_char_length (&char_len, &cl_deferred, false))
2931 : {
2932 435 : case MATCH_YES:
2933 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2934 :
2935 435 : cl->length = char_len;
2936 435 : break;
2937 :
2938 : /* Non-constant lengths need to be copied after the first
2939 : element. Also copy assumed lengths. */
2940 30092 : case MATCH_NO:
2941 30092 : if (elem > 1
2942 3849 : && (current_ts.u.cl->length == NULL
2943 2656 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2944 : {
2945 1248 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2946 1248 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
2947 : }
2948 : else
2949 28844 : cl = current_ts.u.cl;
2950 :
2951 30092 : cl_deferred = current_ts.deferred;
2952 :
2953 30092 : break;
2954 :
2955 1 : case MATCH_ERROR:
2956 1 : goto cleanup;
2957 : }
2958 : }
2959 :
2960 : /* The dummy arguments and result of the abbreviated form of MODULE
2961 : PROCEDUREs, used in SUBMODULES should not be redefined. */
2962 274245 : if (gfc_current_ns->proc_name
2963 269758 : && gfc_current_ns->proc_name->abr_modproc_decl)
2964 : {
2965 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2966 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2967 : {
2968 2 : m = MATCH_ERROR;
2969 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
2970 : "in the corresponding interface for MODULE "
2971 : "PROCEDURE %qs", sym->name, &var_locus,
2972 2 : gfc_current_ns->proc_name->name);
2973 2 : goto cleanup;
2974 : }
2975 : }
2976 :
2977 : /* %FILL components may not have initializers. */
2978 274243 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
2979 : {
2980 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
2981 : &var_locus);
2982 1 : m = MATCH_ERROR;
2983 1 : goto cleanup;
2984 : }
2985 :
2986 : /* If this symbol has already shown up in a Cray Pointer declaration,
2987 : and this is not a component declaration,
2988 : then we want to set the type & bail out. */
2989 274242 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2990 : {
2991 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2992 2959 : if (sym != NULL && sym->attr.cray_pointee)
2993 : {
2994 101 : m = MATCH_YES;
2995 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
2996 : {
2997 1 : m = MATCH_ERROR;
2998 1 : goto cleanup;
2999 : }
3000 :
3001 : /* Check to see if we have an array specification. */
3002 100 : if (cp_as != NULL)
3003 : {
3004 49 : if (sym->as != NULL)
3005 : {
3006 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3007 1 : gfc_free_array_spec (cp_as);
3008 1 : m = MATCH_ERROR;
3009 1 : goto cleanup;
3010 : }
3011 : else
3012 : {
3013 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3014 0 : gfc_internal_error ("Cannot set pointee array spec.");
3015 :
3016 : /* Fix the array spec. */
3017 48 : m = gfc_mod_pointee_as (sym->as);
3018 48 : if (m == MATCH_ERROR)
3019 0 : goto cleanup;
3020 : }
3021 : }
3022 99 : goto cleanup;
3023 : }
3024 : else
3025 : {
3026 2858 : gfc_free_array_spec (cp_as);
3027 : }
3028 : }
3029 :
3030 : /* Procedure pointer as function result. */
3031 274141 : if (gfc_current_state () == COMP_FUNCTION
3032 43980 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3033 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3034 7 : strcpy (name, "ppr@");
3035 :
3036 274141 : if (gfc_current_state () == COMP_FUNCTION
3037 43980 : && strcmp (name, gfc_current_block ()->name) == 0
3038 7493 : && gfc_current_block ()->result
3039 7493 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3040 16 : strcpy (name, "ppr@");
3041 :
3042 : /* OK, we've successfully matched the declaration. Now put the
3043 : symbol in the current namespace, because it might be used in the
3044 : optional initialization expression for this symbol, e.g. this is
3045 : perfectly legal:
3046 :
3047 : integer, parameter :: i = huge(i)
3048 :
3049 : This is only true for parameters or variables of a basic type.
3050 : For components of derived types, it is not true, so we don't
3051 : create a symbol for those yet. If we fail to create the symbol,
3052 : bail out. */
3053 274141 : if (!gfc_comp_struct (gfc_current_state ())
3054 256435 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3055 : {
3056 47 : m = MATCH_ERROR;
3057 47 : goto cleanup;
3058 : }
3059 :
3060 274094 : if (!check_function_name (name))
3061 : {
3062 0 : m = MATCH_ERROR;
3063 0 : goto cleanup;
3064 : }
3065 :
3066 : /* We allow old-style initializations of the form
3067 : integer i /2/, j(4) /3*3, 1/
3068 : (if no colon has been seen). These are different from data
3069 : statements in that initializers are only allowed to apply to the
3070 : variable immediately preceding, i.e.
3071 : integer i, j /1, 2/
3072 : is not allowed. Therefore we have to do some work manually, that
3073 : could otherwise be left to the matchers for DATA statements. */
3074 :
3075 274094 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3076 : {
3077 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3078 : "initialization at %C"))
3079 : return MATCH_ERROR;
3080 :
3081 : /* Allow old style initializations for components of STRUCTUREs and MAPs
3082 : but not components of derived types. */
3083 146 : else if (gfc_current_state () == COMP_DERIVED)
3084 : {
3085 2 : gfc_error ("Invalid old style initialization for derived type "
3086 : "component at %C");
3087 2 : m = MATCH_ERROR;
3088 2 : goto cleanup;
3089 : }
3090 :
3091 : /* For structure components, read the initializer as a special
3092 : expression and let the rest of this function apply the initializer
3093 : as usual. */
3094 144 : else if (gfc_comp_struct (gfc_current_state ()))
3095 : {
3096 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3097 74 : if (m == MATCH_NO)
3098 : gfc_error ("Syntax error in old style initialization of %s at %C",
3099 : name);
3100 74 : if (m != MATCH_YES)
3101 14 : goto cleanup;
3102 : }
3103 :
3104 : /* Otherwise we treat the old style initialization just like a
3105 : DATA declaration for the current variable. */
3106 : else
3107 70 : return match_old_style_init (name);
3108 : }
3109 :
3110 : /* The double colon must be present in order to have initializers.
3111 : Otherwise the statement is ambiguous with an assignment statement. */
3112 274008 : if (colon_seen)
3113 : {
3114 229056 : if (gfc_match (" =>") == MATCH_YES)
3115 : {
3116 1191 : if (!current_attr.pointer)
3117 : {
3118 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3119 0 : m = MATCH_ERROR;
3120 0 : goto cleanup;
3121 : }
3122 :
3123 1191 : m = match_pointer_init (&initializer, 0);
3124 1191 : if (m != MATCH_YES)
3125 10 : goto cleanup;
3126 :
3127 : /* The target of a pointer initialization must have the SAVE
3128 : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3129 : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3130 1181 : if (initializer->expr_type == EXPR_VARIABLE
3131 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3132 25 : && (gfc_current_state () == COMP_PROGRAM
3133 : || gfc_current_state () == COMP_MODULE
3134 25 : || gfc_current_state () == COMP_SUBMODULE))
3135 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3136 : }
3137 227865 : else if (gfc_match_char ('=') == MATCH_YES)
3138 : {
3139 25657 : if (current_attr.pointer)
3140 : {
3141 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3142 : "not %<=%>");
3143 0 : m = MATCH_ERROR;
3144 0 : goto cleanup;
3145 : }
3146 :
3147 25657 : if (gfc_comp_struct (gfc_current_state ())
3148 2402 : && gfc_current_block ()->attr.pdt_template)
3149 : {
3150 240 : m = gfc_match_expr (&initializer);
3151 240 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3152 102 : initializer->ts = current_ts;
3153 : }
3154 : else
3155 25417 : m = gfc_match_init_expr (&initializer);
3156 :
3157 25657 : if (m == MATCH_NO)
3158 : {
3159 1 : gfc_error ("Expected an initialization expression at %C");
3160 1 : m = MATCH_ERROR;
3161 : }
3162 :
3163 9837 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3164 25659 : && !gfc_comp_struct (gfc_state_stack->state))
3165 : {
3166 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3167 : "a PURE procedure");
3168 1 : m = MATCH_ERROR;
3169 : }
3170 :
3171 25657 : if (current_attr.flavor != FL_PARAMETER
3172 9837 : && !gfc_comp_struct (gfc_state_stack->state))
3173 7435 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3174 :
3175 25657 : if (m != MATCH_YES)
3176 157 : goto cleanup;
3177 : }
3178 : }
3179 :
3180 273841 : if (initializer != NULL && current_attr.allocatable
3181 3 : && gfc_comp_struct (gfc_current_state ()))
3182 : {
3183 2 : gfc_error ("Initialization of allocatable component at %C is not "
3184 : "allowed");
3185 2 : m = MATCH_ERROR;
3186 2 : goto cleanup;
3187 : }
3188 :
3189 273839 : if (gfc_current_state () == COMP_DERIVED
3190 16664 : && initializer && initializer->ts.type == BT_HOLLERITH)
3191 : {
3192 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3193 : "constant at %L is not allowed", &initializer->where);
3194 1 : m = MATCH_ERROR;
3195 1 : goto cleanup;
3196 : }
3197 :
3198 273838 : if (gfc_current_state () == COMP_DERIVED
3199 16663 : && gfc_current_block ()->attr.pdt_template)
3200 : {
3201 1052 : gfc_symbol *param;
3202 1052 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3203 : 0, ¶m);
3204 1052 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3205 : {
3206 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3207 : "not appear in the type parameter list at %L",
3208 1 : &gfc_current_block ()->declared_at);
3209 1 : m = MATCH_ERROR;
3210 4 : goto cleanup;
3211 : }
3212 1051 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3213 : {
3214 1 : gfc_error ("The component at %C that appears in the type parameter "
3215 : "list at %L has neither the KIND nor LEN attribute",
3216 1 : &gfc_current_block ()->declared_at);
3217 1 : m = MATCH_ERROR;
3218 1 : goto cleanup;
3219 : }
3220 1050 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3221 : {
3222 1 : gfc_error ("The component at %C which is a type parameter must be "
3223 : "a scalar");
3224 1 : m = MATCH_ERROR;
3225 1 : goto cleanup;
3226 : }
3227 1049 : else if (param && initializer)
3228 : {
3229 218 : if (initializer->ts.type == BT_BOZ)
3230 : {
3231 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3232 : "initializer", &initializer->where);
3233 1 : m = MATCH_ERROR;
3234 1 : goto cleanup;
3235 : }
3236 217 : param->value = gfc_copy_expr (initializer);
3237 : }
3238 : }
3239 :
3240 : /* Before adding a possible initializer, do a simple check for compatibility
3241 : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3242 : good thing. */
3243 27699 : if (current_ts.type == BT_DERIVED && initializer
3244 275231 : && (gfc_numeric_ts (&initializer->ts)
3245 1395 : || initializer->ts.type == BT_LOGICAL
3246 1395 : || initializer->ts.type == BT_CHARACTER))
3247 : {
3248 2 : gfc_error ("Incompatible initialization between a derived type "
3249 : "entity and an entity with %qs type at %C",
3250 : gfc_typename (initializer));
3251 2 : m = MATCH_ERROR;
3252 2 : goto cleanup;
3253 : }
3254 :
3255 :
3256 : /* Add the initializer. Note that it is fine if initializer is
3257 : NULL here, because we sometimes also need to check if a
3258 : declaration *must* have an initialization expression. */
3259 273832 : if (!gfc_comp_struct (gfc_current_state ()))
3260 256155 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
3261 : else
3262 : {
3263 17677 : if (current_ts.type == BT_DERIVED
3264 2520 : && !current_attr.pointer && !initializer)
3265 1975 : initializer = gfc_default_initializer (¤t_ts);
3266 17677 : t = build_struct (name, cl, &initializer, &as);
3267 :
3268 : /* If we match a nested structure definition we expect to see the
3269 : * body even if the variable declarations blow up, so we need to keep
3270 : * the structure declaration around. */
3271 17677 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3272 34 : gfc_commit_symbol (gfc_new_block);
3273 : }
3274 :
3275 273978 : m = (t) ? MATCH_YES : MATCH_ERROR;
3276 :
3277 274269 : cleanup:
3278 : /* Free stuff up and return. */
3279 274269 : gfc_seen_div0 = false;
3280 274269 : gfc_free_expr (initializer);
3281 274269 : gfc_free_array_spec (as);
3282 :
3283 274269 : return m;
3284 : }
3285 :
3286 :
3287 : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3288 : This assumes that the byte size is equal to the kind number for
3289 : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3290 :
3291 : static match
3292 105894 : gfc_match_old_kind_spec (gfc_typespec *ts)
3293 : {
3294 105894 : match m;
3295 105894 : int original_kind;
3296 :
3297 105894 : if (gfc_match_char ('*') != MATCH_YES)
3298 : return MATCH_NO;
3299 :
3300 1150 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3301 1150 : if (m != MATCH_YES)
3302 : return MATCH_ERROR;
3303 :
3304 1150 : original_kind = ts->kind;
3305 :
3306 : /* Massage the kind numbers for complex types. */
3307 1150 : if (ts->type == BT_COMPLEX)
3308 : {
3309 79 : if (ts->kind % 2)
3310 : {
3311 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3312 : gfc_basic_typename (ts->type), original_kind);
3313 0 : return MATCH_ERROR;
3314 : }
3315 79 : ts->kind /= 2;
3316 :
3317 : }
3318 :
3319 1150 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3320 0 : ts->kind = 8;
3321 :
3322 1150 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3323 : {
3324 858 : if (ts->kind == 4)
3325 : {
3326 224 : if (flag_real4_kind == 8)
3327 24 : ts->kind = 8;
3328 224 : if (flag_real4_kind == 10)
3329 24 : ts->kind = 10;
3330 224 : if (flag_real4_kind == 16)
3331 24 : ts->kind = 16;
3332 : }
3333 634 : else if (ts->kind == 8)
3334 : {
3335 629 : if (flag_real8_kind == 4)
3336 24 : ts->kind = 4;
3337 629 : if (flag_real8_kind == 10)
3338 24 : ts->kind = 10;
3339 629 : if (flag_real8_kind == 16)
3340 24 : ts->kind = 16;
3341 : }
3342 : }
3343 :
3344 1150 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3345 : {
3346 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3347 : gfc_basic_typename (ts->type), original_kind);
3348 8 : return MATCH_ERROR;
3349 : }
3350 :
3351 1142 : if (!gfc_notify_std (GFC_STD_GNU,
3352 : "Nonstandard type declaration %s*%d at %C",
3353 : gfc_basic_typename(ts->type), original_kind))
3354 : return MATCH_ERROR;
3355 :
3356 : return MATCH_YES;
3357 : }
3358 :
3359 :
3360 : /* Match a kind specification. Since kinds are generally optional, we
3361 : usually return MATCH_NO if something goes wrong. If a "kind="
3362 : string is found, then we know we have an error. */
3363 :
3364 : match
3365 155496 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3366 : {
3367 155496 : locus where, loc;
3368 155496 : gfc_expr *e;
3369 155496 : match m, n;
3370 155496 : char c;
3371 :
3372 155496 : m = MATCH_NO;
3373 155496 : n = MATCH_YES;
3374 155496 : e = NULL;
3375 155496 : saved_kind_expr = NULL;
3376 :
3377 155496 : where = loc = gfc_current_locus;
3378 :
3379 155496 : if (kind_expr_only)
3380 0 : goto kind_expr;
3381 :
3382 155496 : if (gfc_match_char ('(') == MATCH_NO)
3383 : return MATCH_NO;
3384 :
3385 : /* Also gobbles optional text. */
3386 48164 : if (gfc_match (" kind = ") == MATCH_YES)
3387 48164 : m = MATCH_ERROR;
3388 :
3389 48164 : loc = gfc_current_locus;
3390 :
3391 48164 : kind_expr:
3392 :
3393 48164 : n = gfc_match_init_expr (&e);
3394 :
3395 48164 : if (gfc_derived_parameter_expr (e))
3396 : {
3397 154 : ts->kind = 0;
3398 154 : saved_kind_expr = gfc_copy_expr (e);
3399 154 : goto close_brackets;
3400 : }
3401 :
3402 48010 : if (n != MATCH_YES)
3403 : {
3404 345 : if (gfc_matching_function)
3405 : {
3406 : /* The function kind expression might include use associated or
3407 : imported parameters and try again after the specification
3408 : expressions..... */
3409 317 : if (gfc_match_char (')') != MATCH_YES)
3410 : {
3411 1 : gfc_error ("Missing right parenthesis at %C");
3412 1 : m = MATCH_ERROR;
3413 1 : goto no_match;
3414 : }
3415 :
3416 316 : gfc_free_expr (e);
3417 316 : gfc_undo_symbols ();
3418 316 : return MATCH_YES;
3419 : }
3420 : else
3421 : {
3422 : /* ....or else, the match is real. */
3423 28 : if (n == MATCH_NO)
3424 0 : gfc_error ("Expected initialization expression at %C");
3425 28 : if (n != MATCH_YES)
3426 28 : return MATCH_ERROR;
3427 : }
3428 : }
3429 :
3430 47665 : if (e->rank != 0)
3431 : {
3432 0 : gfc_error ("Expected scalar initialization expression at %C");
3433 0 : m = MATCH_ERROR;
3434 0 : goto no_match;
3435 : }
3436 :
3437 47665 : if (gfc_extract_int (e, &ts->kind, 1))
3438 : {
3439 0 : m = MATCH_ERROR;
3440 0 : goto no_match;
3441 : }
3442 :
3443 : /* Before throwing away the expression, let's see if we had a
3444 : C interoperable kind (and store the fact). */
3445 47665 : if (e->ts.is_c_interop == 1)
3446 : {
3447 : /* Mark this as C interoperable if being declared with one
3448 : of the named constants from iso_c_binding. */
3449 17646 : ts->is_c_interop = e->ts.is_iso_c;
3450 17646 : ts->f90_type = e->ts.f90_type;
3451 17646 : if (e->symtree)
3452 17645 : ts->interop_kind = e->symtree->n.sym;
3453 : }
3454 :
3455 47665 : gfc_free_expr (e);
3456 47665 : e = NULL;
3457 :
3458 : /* Ignore errors to this point, if we've gotten here. This means
3459 : we ignore the m=MATCH_ERROR from above. */
3460 47665 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3461 : {
3462 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3463 : gfc_basic_typename (ts->type));
3464 7 : gfc_current_locus = where;
3465 7 : return MATCH_ERROR;
3466 : }
3467 :
3468 : /* Warn if, e.g., c_int is used for a REAL variable, but not
3469 : if, e.g., c_double is used for COMPLEX as the standard
3470 : explicitly says that the kind type parameter for complex and real
3471 : variable is the same, i.e. c_float == c_float_complex. */
3472 47658 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3473 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3474 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3475 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3476 : "is %s", gfc_basic_typename (ts->f90_type), &where,
3477 : gfc_basic_typename (ts->type));
3478 :
3479 47645 : close_brackets:
3480 :
3481 47812 : gfc_gobble_whitespace ();
3482 47812 : if ((c = gfc_next_ascii_char ()) != ')'
3483 47812 : && (ts->type != BT_CHARACTER || c != ','))
3484 : {
3485 0 : if (ts->type == BT_CHARACTER)
3486 0 : gfc_error ("Missing right parenthesis or comma at %C");
3487 : else
3488 0 : gfc_error ("Missing right parenthesis at %C");
3489 0 : m = MATCH_ERROR;
3490 0 : goto no_match;
3491 : }
3492 : else
3493 : /* All tests passed. */
3494 47812 : m = MATCH_YES;
3495 :
3496 47812 : if(m == MATCH_ERROR)
3497 : gfc_current_locus = where;
3498 :
3499 47812 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3500 0 : ts->kind = 8;
3501 :
3502 47812 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3503 : {
3504 13814 : if (ts->kind == 4)
3505 : {
3506 4442 : if (flag_real4_kind == 8)
3507 54 : ts->kind = 8;
3508 4442 : if (flag_real4_kind == 10)
3509 54 : ts->kind = 10;
3510 4442 : if (flag_real4_kind == 16)
3511 54 : ts->kind = 16;
3512 : }
3513 9372 : else if (ts->kind == 8)
3514 : {
3515 6401 : if (flag_real8_kind == 4)
3516 48 : ts->kind = 4;
3517 6401 : if (flag_real8_kind == 10)
3518 48 : ts->kind = 10;
3519 6401 : if (flag_real8_kind == 16)
3520 48 : ts->kind = 16;
3521 : }
3522 : }
3523 :
3524 : /* Return what we know from the test(s). */
3525 : return m;
3526 :
3527 1 : no_match:
3528 1 : gfc_free_expr (e);
3529 1 : gfc_current_locus = where;
3530 1 : return m;
3531 : }
3532 :
3533 :
3534 : static match
3535 4685 : match_char_kind (int * kind, int * is_iso_c)
3536 : {
3537 4685 : locus where;
3538 4685 : gfc_expr *e;
3539 4685 : match m, n;
3540 4685 : bool fail;
3541 :
3542 4685 : m = MATCH_NO;
3543 4685 : e = NULL;
3544 4685 : where = gfc_current_locus;
3545 :
3546 4685 : n = gfc_match_init_expr (&e);
3547 :
3548 4685 : if (n != MATCH_YES && gfc_matching_function)
3549 : {
3550 : /* The expression might include use-associated or imported
3551 : parameters and try again after the specification
3552 : expressions. */
3553 7 : gfc_free_expr (e);
3554 7 : gfc_undo_symbols ();
3555 7 : return MATCH_YES;
3556 : }
3557 :
3558 7 : if (n == MATCH_NO)
3559 2 : gfc_error ("Expected initialization expression at %C");
3560 4678 : if (n != MATCH_YES)
3561 : return MATCH_ERROR;
3562 :
3563 4671 : if (e->rank != 0)
3564 : {
3565 0 : gfc_error ("Expected scalar initialization expression at %C");
3566 0 : m = MATCH_ERROR;
3567 0 : goto no_match;
3568 : }
3569 :
3570 4671 : if (gfc_derived_parameter_expr (e))
3571 : {
3572 14 : saved_kind_expr = e;
3573 14 : *kind = 0;
3574 14 : return MATCH_YES;
3575 : }
3576 :
3577 4657 : fail = gfc_extract_int (e, kind, 1);
3578 4657 : *is_iso_c = e->ts.is_iso_c;
3579 4657 : if (fail)
3580 : {
3581 0 : m = MATCH_ERROR;
3582 0 : goto no_match;
3583 : }
3584 :
3585 4657 : gfc_free_expr (e);
3586 :
3587 : /* Ignore errors to this point, if we've gotten here. This means
3588 : we ignore the m=MATCH_ERROR from above. */
3589 4657 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3590 : {
3591 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3592 14 : m = MATCH_ERROR;
3593 : }
3594 : else
3595 : /* All tests passed. */
3596 : m = MATCH_YES;
3597 :
3598 14 : if (m == MATCH_ERROR)
3599 14 : gfc_current_locus = where;
3600 :
3601 : /* Return what we know from the test(s). */
3602 : return m;
3603 :
3604 0 : no_match:
3605 0 : gfc_free_expr (e);
3606 0 : gfc_current_locus = where;
3607 0 : return m;
3608 : }
3609 :
3610 :
3611 : /* Match the various kind/length specifications in a CHARACTER
3612 : declaration. We don't return MATCH_NO. */
3613 :
3614 : match
3615 31468 : gfc_match_char_spec (gfc_typespec *ts)
3616 : {
3617 31468 : int kind, seen_length, is_iso_c;
3618 31468 : gfc_charlen *cl;
3619 31468 : gfc_expr *len;
3620 31468 : match m;
3621 31468 : bool deferred;
3622 :
3623 31468 : len = NULL;
3624 31468 : seen_length = 0;
3625 31468 : kind = 0;
3626 31468 : is_iso_c = 0;
3627 31468 : deferred = false;
3628 :
3629 : /* Try the old-style specification first. */
3630 31468 : old_char_selector = 0;
3631 :
3632 31468 : m = match_char_length (&len, &deferred, true);
3633 31468 : if (m != MATCH_NO)
3634 : {
3635 2205 : if (m == MATCH_YES)
3636 2205 : old_char_selector = 1;
3637 2205 : seen_length = 1;
3638 2205 : goto done;
3639 : }
3640 :
3641 29263 : m = gfc_match_char ('(');
3642 29263 : if (m != MATCH_YES)
3643 : {
3644 1844 : m = MATCH_YES; /* Character without length is a single char. */
3645 1844 : goto done;
3646 : }
3647 :
3648 : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3649 27419 : if (gfc_match (" kind =") == MATCH_YES)
3650 : {
3651 3264 : m = match_char_kind (&kind, &is_iso_c);
3652 :
3653 3264 : if (m == MATCH_ERROR)
3654 16 : goto done;
3655 3248 : if (m == MATCH_NO)
3656 : goto syntax;
3657 :
3658 3248 : if (gfc_match (" , len =") == MATCH_NO)
3659 516 : goto rparen;
3660 :
3661 2732 : m = char_len_param_value (&len, &deferred);
3662 2732 : if (m == MATCH_NO)
3663 0 : goto syntax;
3664 2732 : if (m == MATCH_ERROR)
3665 2 : goto done;
3666 2730 : seen_length = 1;
3667 :
3668 2730 : goto rparen;
3669 : }
3670 :
3671 : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3672 24155 : if (gfc_match (" len =") == MATCH_YES)
3673 : {
3674 13823 : m = char_len_param_value (&len, &deferred);
3675 13823 : if (m == MATCH_NO)
3676 2 : goto syntax;
3677 13821 : if (m == MATCH_ERROR)
3678 8 : goto done;
3679 13813 : seen_length = 1;
3680 :
3681 13813 : if (gfc_match_char (')') == MATCH_YES)
3682 12534 : goto done;
3683 :
3684 1279 : if (gfc_match (" , kind =") != MATCH_YES)
3685 0 : goto syntax;
3686 :
3687 1279 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3688 2 : goto done;
3689 :
3690 1277 : goto rparen;
3691 : }
3692 :
3693 : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3694 10332 : m = char_len_param_value (&len, &deferred);
3695 10332 : if (m == MATCH_NO)
3696 0 : goto syntax;
3697 10332 : if (m == MATCH_ERROR)
3698 44 : goto done;
3699 10288 : seen_length = 1;
3700 :
3701 10288 : m = gfc_match_char (')');
3702 10288 : if (m == MATCH_YES)
3703 10144 : goto done;
3704 :
3705 144 : if (gfc_match_char (',') != MATCH_YES)
3706 2 : goto syntax;
3707 :
3708 142 : gfc_match (" kind ="); /* Gobble optional text. */
3709 :
3710 142 : m = match_char_kind (&kind, &is_iso_c);
3711 142 : if (m == MATCH_ERROR)
3712 3 : goto done;
3713 : if (m == MATCH_NO)
3714 : goto syntax;
3715 :
3716 4662 : rparen:
3717 : /* Require a right-paren at this point. */
3718 4662 : m = gfc_match_char (')');
3719 4662 : if (m == MATCH_YES)
3720 4662 : goto done;
3721 :
3722 0 : syntax:
3723 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3724 4 : m = MATCH_ERROR;
3725 4 : gfc_free_expr (len);
3726 4 : return m;
3727 :
3728 31464 : done:
3729 : /* Deal with character functions after USE and IMPORT statements. */
3730 31464 : if (gfc_matching_function)
3731 : {
3732 1417 : gfc_free_expr (len);
3733 1417 : gfc_undo_symbols ();
3734 1417 : return MATCH_YES;
3735 : }
3736 :
3737 30047 : if (m != MATCH_YES)
3738 : {
3739 65 : gfc_free_expr (len);
3740 65 : return m;
3741 : }
3742 :
3743 : /* Do some final massaging of the length values. */
3744 29982 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3745 :
3746 29982 : if (seen_length == 0)
3747 2308 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3748 : else
3749 : {
3750 : /* If gfortran ends up here, then len may be reducible to a constant.
3751 : Try to do that here. If it does not reduce, simply assign len to
3752 : charlen. A complication occurs with user-defined generic functions,
3753 : which are not resolved. Use a private namespace to deal with
3754 : generic functions. */
3755 :
3756 27674 : if (len && len->expr_type != EXPR_CONSTANT)
3757 : {
3758 3040 : gfc_namespace *old_ns;
3759 3040 : gfc_expr *e;
3760 :
3761 3040 : old_ns = gfc_current_ns;
3762 3040 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3763 :
3764 3040 : e = gfc_copy_expr (len);
3765 3040 : gfc_push_suppress_errors ();
3766 3040 : gfc_reduce_init_expr (e);
3767 3040 : gfc_pop_suppress_errors ();
3768 3040 : if (e->expr_type == EXPR_CONSTANT)
3769 : {
3770 294 : gfc_replace_expr (len, e);
3771 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3772 7 : mpz_set_ui (len->value.integer, 0);
3773 : }
3774 : else
3775 2746 : gfc_free_expr (e);
3776 :
3777 3040 : gfc_free_namespace (gfc_current_ns);
3778 3040 : gfc_current_ns = old_ns;
3779 : }
3780 :
3781 27674 : cl->length = len;
3782 : }
3783 :
3784 29982 : ts->u.cl = cl;
3785 29982 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3786 29982 : ts->deferred = deferred;
3787 :
3788 : /* We have to know if it was a C interoperable kind so we can
3789 : do accurate type checking of bind(c) procs, etc. */
3790 29982 : if (kind != 0)
3791 : /* Mark this as C interoperable if being declared with one
3792 : of the named constants from iso_c_binding. */
3793 4568 : ts->is_c_interop = is_iso_c;
3794 25414 : else if (len != NULL)
3795 : /* Here, we might have parsed something such as: character(c_char)
3796 : In this case, the parsing code above grabs the c_char when
3797 : looking for the length (line 1690, roughly). it's the last
3798 : testcase for parsing the kind params of a character variable.
3799 : However, it's not actually the length. this seems like it
3800 : could be an error.
3801 : To see if the user used a C interop kind, test the expr
3802 : of the so called length, and see if it's C interoperable. */
3803 16397 : ts->is_c_interop = len->ts.is_iso_c;
3804 :
3805 : return MATCH_YES;
3806 : }
3807 :
3808 :
3809 : /* Matches a RECORD declaration. */
3810 :
3811 : static match
3812 944709 : match_record_decl (char *name)
3813 : {
3814 944709 : locus old_loc;
3815 944709 : old_loc = gfc_current_locus;
3816 944709 : match m;
3817 :
3818 944709 : m = gfc_match (" record /");
3819 944709 : if (m == MATCH_YES)
3820 : {
3821 353 : if (!flag_dec_structure)
3822 : {
3823 6 : gfc_current_locus = old_loc;
3824 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3825 : "%<-fdec-structure%>");
3826 6 : return MATCH_ERROR;
3827 : }
3828 347 : m = gfc_match (" %n/", name);
3829 347 : if (m == MATCH_YES)
3830 : return MATCH_YES;
3831 : }
3832 :
3833 944359 : gfc_current_locus = old_loc;
3834 944359 : if (flag_dec_structure
3835 944359 : && (gfc_match (" record% ") == MATCH_YES
3836 8026 : || gfc_match (" record%t") == MATCH_YES))
3837 6 : gfc_error ("Structure name expected after RECORD at %C");
3838 944359 : if (m == MATCH_NO)
3839 : return MATCH_NO;
3840 :
3841 : return MATCH_ERROR;
3842 : }
3843 :
3844 :
3845 : /* In parsing a PDT, it is possible that one of the type parameters has the
3846 : same name as a previously declared symbol that is not a type parameter.
3847 : Intercept this now by looking for the symtree in f2k_derived. */
3848 :
3849 : static bool
3850 815 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3851 : {
3852 815 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3853 : return false;
3854 :
3855 659 : if (!(e->symtree->n.sym->attr.pdt_len
3856 100 : || e->symtree->n.sym->attr.pdt_kind))
3857 : {
3858 36 : gfc_symtree *st;
3859 36 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3860 : e->symtree->n.sym->name);
3861 36 : if (st && st->n.sym
3862 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3863 : {
3864 30 : gfc_expr *new_expr;
3865 30 : gfc_set_sym_referenced (st->n.sym);
3866 30 : new_expr = gfc_get_expr ();
3867 30 : new_expr->ts = st->n.sym->ts;
3868 30 : new_expr->expr_type = EXPR_VARIABLE;
3869 30 : new_expr->symtree = st;
3870 30 : new_expr->where = e->where;
3871 30 : gfc_replace_expr (e, new_expr);
3872 : }
3873 : }
3874 :
3875 : return false;
3876 : }
3877 :
3878 :
3879 : void
3880 609 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3881 : {
3882 609 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3883 : return;
3884 579 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3885 : }
3886 :
3887 : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3888 : of expressions to substitute into the possibly parameterized expression
3889 : 'e'. Using a list is inefficient but should not be too bad since the
3890 : number of type parameters is not likely to be large. */
3891 : static bool
3892 3037 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3893 : int* f)
3894 : {
3895 3037 : gfc_actual_arglist *param;
3896 3037 : gfc_expr *copy;
3897 :
3898 3037 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
3899 : return false;
3900 :
3901 1336 : gcc_assert (e->symtree);
3902 1336 : if (e->symtree->n.sym->attr.pdt_kind
3903 989 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
3904 483 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
3905 : {
3906 1326 : for (param = type_param_spec_list; param; param = param->next)
3907 1287 : if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3908 : break;
3909 :
3910 892 : if (param && param->expr)
3911 : {
3912 853 : copy = gfc_copy_expr (param->expr);
3913 853 : *e = *copy;
3914 853 : free (copy);
3915 : /* Catch variables declared without a value expression. */
3916 853 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
3917 13 : e->ts = e->symtree->n.sym->ts;
3918 : }
3919 : }
3920 :
3921 : return false;
3922 : }
3923 :
3924 :
3925 : static bool
3926 907 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3927 : {
3928 907 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3929 : }
3930 :
3931 :
3932 : bool
3933 1708 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3934 : {
3935 1708 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3936 1708 : type_param_spec_list = param_list;
3937 1708 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3938 1708 : type_param_spec_list = old_param_spec_list;
3939 1708 : return res;
3940 : }
3941 :
3942 : /* Determines the instance of a parameterized derived type to be used by
3943 : matching determining the values of the kind parameters and using them
3944 : in the name of the instance. If the instance exists, it is used, otherwise
3945 : a new derived type is created. */
3946 : match
3947 2532 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3948 : gfc_actual_arglist **ext_param_list)
3949 : {
3950 : /* The PDT template symbol. */
3951 2532 : gfc_symbol *pdt = *sym;
3952 : /* The symbol for the parameter in the template f2k_namespace. */
3953 2532 : gfc_symbol *param;
3954 : /* The hoped for instance of the PDT. */
3955 2532 : gfc_symbol *instance = NULL;
3956 : /* The list of parameters appearing in the PDT declaration. */
3957 2532 : gfc_formal_arglist *type_param_name_list;
3958 : /* Used to store the parameter specification list during recursive calls. */
3959 2532 : gfc_actual_arglist *old_param_spec_list;
3960 : /* Pointers to the parameter specification being used. */
3961 2532 : gfc_actual_arglist *actual_param;
3962 2532 : gfc_actual_arglist *tail = NULL;
3963 : /* Used to build up the name of the PDT instance. */
3964 2532 : char *name;
3965 2532 : bool name_seen = (param_list == NULL);
3966 2532 : bool assumed_seen = false;
3967 2532 : bool deferred_seen = false;
3968 2532 : bool spec_error = false;
3969 2532 : bool alloc_seen = false;
3970 2532 : bool ptr_seen = false;
3971 2532 : int i;
3972 2532 : gfc_expr *kind_expr;
3973 2532 : gfc_component *c1, *c2;
3974 2532 : match m;
3975 2532 : gfc_symtree *s = NULL;
3976 :
3977 2532 : type_param_spec_list = NULL;
3978 :
3979 2532 : type_param_name_list = pdt->formal;
3980 2532 : actual_param = param_list;
3981 :
3982 : /* Prevent a PDT component of the same type as the template from being
3983 : converted into an instance. Doing this results in the component being
3984 : lost. */
3985 2532 : if (gfc_current_state () == COMP_DERIVED
3986 94 : && !(gfc_state_stack->previous
3987 94 : && gfc_state_stack->previous->state == COMP_DERIVED)
3988 94 : && gfc_current_block ()->attr.pdt_template)
3989 : {
3990 93 : if (ext_param_list)
3991 93 : *ext_param_list = gfc_copy_actual_arglist (param_list);
3992 93 : return MATCH_YES;
3993 : }
3994 :
3995 2439 : name = xasprintf ("%s%s", PDT_PREFIX, pdt->name);
3996 :
3997 : /* Run through the parameter name list and pick up the actual
3998 : parameter values or use the default values in the PDT declaration. */
3999 5711 : for (; type_param_name_list;
4000 3272 : type_param_name_list = type_param_name_list->next)
4001 : {
4002 3334 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
4003 : {
4004 2991 : if (actual_param->spec_type == SPEC_ASSUMED)
4005 : spec_error = deferred_seen;
4006 : else
4007 2991 : spec_error = assumed_seen;
4008 :
4009 2991 : if (spec_error)
4010 : {
4011 : gfc_error ("The type parameter spec list at %C cannot contain "
4012 : "both ASSUMED and DEFERRED parameters");
4013 : goto error_return;
4014 : }
4015 : }
4016 :
4017 2991 : if (actual_param && actual_param->name)
4018 3334 : name_seen = true;
4019 3334 : param = type_param_name_list->sym;
4020 :
4021 3334 : if (!param || !param->name)
4022 2 : continue;
4023 :
4024 3332 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4025 : /* An error should already have been thrown in resolve.cc
4026 : (resolve_fl_derived0). */
4027 3332 : if (!pdt->attr.use_assoc && !c1)
4028 8 : goto error_return;
4029 :
4030 : /* Resolution PDT class components of derived types are handled here.
4031 : They can arrive without a parameter list and no KIND parameters. */
4032 3324 : if (!param_list && (!c1->attr.pdt_kind && !c1->initializer))
4033 14 : continue;
4034 :
4035 3310 : kind_expr = NULL;
4036 3310 : if (!name_seen)
4037 : {
4038 1963 : if (!actual_param && !(c1 && c1->initializer))
4039 : {
4040 2 : gfc_error ("The type parameter spec list at %C does not contain "
4041 : "enough parameter expressions");
4042 2 : goto error_return;
4043 : }
4044 1961 : else if (!actual_param && c1 && c1->initializer)
4045 5 : kind_expr = gfc_copy_expr (c1->initializer);
4046 1956 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4047 1765 : kind_expr = gfc_copy_expr (actual_param->expr);
4048 : }
4049 : else
4050 : {
4051 : actual_param = param_list;
4052 1776 : for (;actual_param; actual_param = actual_param->next)
4053 1446 : if (actual_param->name
4054 1430 : && strcmp (actual_param->name, param->name) == 0)
4055 : break;
4056 1347 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4057 863 : kind_expr = gfc_copy_expr (actual_param->expr);
4058 : else
4059 : {
4060 484 : if (c1->initializer)
4061 426 : kind_expr = gfc_copy_expr (c1->initializer);
4062 58 : else if (!(actual_param && param->attr.pdt_len))
4063 : {
4064 9 : gfc_error ("The derived parameter %qs at %C does not "
4065 : "have a default value", param->name);
4066 9 : goto error_return;
4067 : }
4068 : }
4069 : }
4070 :
4071 3059 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4072 241 : && kind_expr->ts.type != BT_INTEGER
4073 116 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4074 : {
4075 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4076 : "type and not %s", &kind_expr->where,
4077 : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4078 12 : goto error_return;
4079 : }
4080 :
4081 : /* Store the current parameter expressions in a temporary actual
4082 : arglist 'list' so that they can be substituted in the corresponding
4083 : expressions in the PDT instance. */
4084 3287 : if (type_param_spec_list == NULL)
4085 : {
4086 2402 : type_param_spec_list = gfc_get_actual_arglist ();
4087 2402 : tail = type_param_spec_list;
4088 : }
4089 : else
4090 : {
4091 885 : tail->next = gfc_get_actual_arglist ();
4092 885 : tail = tail->next;
4093 : }
4094 3287 : tail->name = param->name;
4095 :
4096 3287 : if (kind_expr)
4097 : {
4098 : /* Try simplification even for LEN expressions. */
4099 3047 : bool ok;
4100 3047 : gfc_resolve_expr (kind_expr);
4101 :
4102 3047 : if (c1->attr.pdt_kind
4103 1537 : && kind_expr->expr_type != EXPR_CONSTANT
4104 22 : && type_param_spec_list)
4105 22 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4106 :
4107 3047 : ok = gfc_simplify_expr (kind_expr, 1);
4108 : /* Variable expressions default to BT_PROCEDURE in the absence of an
4109 : initializer so allow for this. */
4110 3047 : if (kind_expr->ts.type != BT_INTEGER
4111 127 : && kind_expr->ts.type != BT_PROCEDURE)
4112 : {
4113 23 : gfc_error ("The parameter expression at %C must be of "
4114 : "INTEGER type and not %s type",
4115 : gfc_basic_typename (kind_expr->ts.type));
4116 23 : goto error_return;
4117 : }
4118 3024 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4119 : {
4120 4 : gfc_error ("The parameter expression at %C does not "
4121 : "simplify to an INTEGER constant");
4122 4 : goto error_return;
4123 : }
4124 :
4125 3020 : tail->expr = gfc_copy_expr (kind_expr);
4126 : }
4127 :
4128 3260 : if (actual_param)
4129 2932 : tail->spec_type = actual_param->spec_type;
4130 :
4131 3260 : if (!param->attr.pdt_kind)
4132 : {
4133 1742 : if (!name_seen && actual_param)
4134 1059 : actual_param = actual_param->next;
4135 1742 : if (kind_expr)
4136 : {
4137 1504 : gfc_free_expr (kind_expr);
4138 1504 : kind_expr = NULL;
4139 : }
4140 1742 : continue;
4141 : }
4142 :
4143 1518 : if (actual_param
4144 1227 : && (actual_param->spec_type == SPEC_ASSUMED
4145 1227 : || actual_param->spec_type == SPEC_DEFERRED))
4146 : {
4147 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4148 : "ASSUMED or DEFERRED", param->name);
4149 2 : goto error_return;
4150 : }
4151 :
4152 1516 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4153 : {
4154 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4155 : "reduce to a constant expression", param->name);
4156 2 : goto error_return;
4157 : }
4158 :
4159 : /* This can come about during the parsing of nested pdt_templates. An
4160 : error arises because the KIND parameter expression has not been
4161 : provided. Use the template instead of an incorrect instance. */
4162 1514 : if (kind_expr->expr_type != EXPR_CONSTANT
4163 1514 : || kind_expr->ts.type != BT_INTEGER)
4164 : {
4165 0 : gfc_free_actual_arglist (type_param_spec_list);
4166 0 : free (name);
4167 0 : return MATCH_YES;
4168 : }
4169 :
4170 1514 : char *kind_value = mpz_get_str (NULL, 10, kind_expr->value.integer);
4171 1514 : char *old_name = name;
4172 1514 : name = xasprintf ("%s_%s", old_name, kind_value);
4173 1514 : free (old_name);
4174 1514 : free (kind_value);
4175 :
4176 1514 : if (!name_seen && actual_param)
4177 854 : actual_param = actual_param->next;
4178 1514 : gfc_free_expr (kind_expr);
4179 : }
4180 :
4181 2377 : if (!name_seen && actual_param)
4182 : {
4183 2 : gfc_error ("The type parameter spec list at %C contains too many "
4184 : "parameter expressions");
4185 2 : goto error_return;
4186 : }
4187 :
4188 : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4189 : build it, using 'pdt' as a template. */
4190 2375 : if (gfc_get_symbol (name, pdt->ns, &instance))
4191 : {
4192 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4193 0 : goto error_return;
4194 : }
4195 :
4196 : /* If we are in an interface body, the instance will not have been imported.
4197 : Make sure that it is imported implicitly. */
4198 2375 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4199 2375 : if (gfc_current_ns->proc_name
4200 2346 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4201 80 : && s && s->import_only && pdt->attr.imported)
4202 : {
4203 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4204 2 : if (!s)
4205 : {
4206 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4207 : &gfc_current_locus);
4208 1 : s->n.sym = instance;
4209 : }
4210 2 : s->n.sym->attr.imported = 1;
4211 2 : s->import_only = 1;
4212 : }
4213 :
4214 2375 : m = MATCH_YES;
4215 :
4216 2375 : if (instance->attr.flavor == FL_DERIVED
4217 1887 : && instance->attr.pdt_type
4218 1887 : && instance->components)
4219 : {
4220 1887 : instance->refs++;
4221 1887 : if (ext_param_list)
4222 895 : *ext_param_list = type_param_spec_list;
4223 1887 : *sym = instance;
4224 1887 : gfc_commit_symbols ();
4225 1887 : free (name);
4226 1887 : return m;
4227 : }
4228 :
4229 : /* Start building the new instance of the parameterized type. */
4230 488 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4231 488 : if (pdt->attr.use_assoc)
4232 41 : instance->module = pdt->module;
4233 488 : instance->attr.pdt_template = 0;
4234 488 : instance->attr.pdt_type = 1;
4235 488 : instance->declared_at = gfc_current_locus;
4236 :
4237 : /* In resolution, the finalizers are copied, according to the type of the
4238 : argument, to the instance finalizers. However, they are retained by the
4239 : template and procedures are freed there. */
4240 488 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4241 : {
4242 12 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4243 12 : instance->template_sym = pdt;
4244 12 : *instance->f2k_derived = *pdt->f2k_derived;
4245 : }
4246 :
4247 : /* Add the components, replacing the parameters in all expressions
4248 : with the expressions for their values in 'type_param_spec_list'. */
4249 488 : c1 = pdt->components;
4250 488 : tail = type_param_spec_list;
4251 1811 : for (; c1; c1 = c1->next)
4252 : {
4253 1325 : gfc_add_component (instance, c1->name, &c2);
4254 :
4255 1325 : c2->ts = c1->ts;
4256 1325 : c2->attr = c1->attr;
4257 1325 : if (c1->tb)
4258 : {
4259 6 : c2->tb = gfc_get_tbp ();
4260 6 : *c2->tb = *c1->tb;
4261 : }
4262 :
4263 : /* The order of declaration of the type_specs might not be the
4264 : same as that of the components. */
4265 1325 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4266 : {
4267 951 : for (tail = type_param_spec_list; tail; tail = tail->next)
4268 941 : if (strcmp (c1->name, tail->name) == 0)
4269 : break;
4270 : }
4271 :
4272 : /* Deal with type extension by recursively calling this function
4273 : to obtain the instance of the extended type. */
4274 1325 : if (gfc_current_state () != COMP_DERIVED
4275 1323 : && c1 == pdt->components
4276 487 : && c1->ts.type == BT_DERIVED
4277 42 : && c1->ts.u.derived
4278 1367 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4279 : {
4280 42 : if (c1->ts.u.derived->attr.pdt_template)
4281 : {
4282 35 : gfc_formal_arglist *f;
4283 :
4284 35 : old_param_spec_list = type_param_spec_list;
4285 :
4286 : /* Obtain a spec list appropriate to the extended type..*/
4287 35 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4288 35 : type_param_spec_list = actual_param;
4289 67 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4290 32 : actual_param = actual_param->next;
4291 35 : if (actual_param)
4292 : {
4293 35 : gfc_free_actual_arglist (actual_param->next);
4294 35 : actual_param->next = NULL;
4295 : }
4296 :
4297 : /* Now obtain the PDT instance for the extended type. */
4298 35 : c2->param_list = type_param_spec_list;
4299 35 : m = gfc_get_pdt_instance (type_param_spec_list,
4300 : &c2->ts.u.derived,
4301 : &c2->param_list);
4302 35 : type_param_spec_list = old_param_spec_list;
4303 : }
4304 : else
4305 7 : c2->ts = c1->ts;
4306 :
4307 42 : c2->ts.u.derived->refs++;
4308 42 : gfc_set_sym_referenced (c2->ts.u.derived);
4309 :
4310 : /* If the component is allocatable or the parent has allocatable
4311 : components, make sure that the new instance also is marked as
4312 : having allocatable components. */
4313 42 : if (c2->attr.allocatable || c2->ts.u.derived->attr.alloc_comp)
4314 6 : instance->attr.alloc_comp = 1;
4315 :
4316 : /* Set extension level. */
4317 42 : if (c2->ts.u.derived->attr.extension == 255)
4318 : {
4319 : /* Since the extension field is 8 bit wide, we can only have
4320 : up to 255 extension levels. */
4321 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4322 : c2->ts.u.derived->name,
4323 : &c2->ts.u.derived->declared_at);
4324 0 : goto error_return;
4325 : }
4326 42 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4327 :
4328 42 : continue;
4329 42 : }
4330 :
4331 : /* Addressing PR82943, this will fix the issue where a function or
4332 : subroutine is declared as not a member of the PDT instance.
4333 : The reason for this is because the PDT instance did not have access
4334 : to its template's f2k_derived namespace in order to find the
4335 : typebound procedures.
4336 :
4337 : The number of references to the PDT template's f2k_derived will
4338 : ensure that f2k_derived is properly freed later on. */
4339 :
4340 1283 : if (!instance->f2k_derived && pdt->f2k_derived)
4341 : {
4342 469 : instance->f2k_derived = pdt->f2k_derived;
4343 469 : instance->f2k_derived->refs++;
4344 : }
4345 :
4346 : /* Set the component kind using the parameterized expression. */
4347 1283 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4348 440 : && c1->kind_expr != NULL)
4349 : {
4350 266 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4351 266 : gfc_insert_kind_parameter_exprs (e);
4352 266 : gfc_simplify_expr (e, 1);
4353 266 : gfc_extract_int (e, &c2->ts.kind);
4354 266 : gfc_free_expr (e);
4355 266 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4356 : {
4357 2 : gfc_error ("Kind %d not supported for type %s at %C",
4358 : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4359 2 : goto error_return;
4360 : }
4361 264 : if (c2->attr.proc_pointer && c2->attr.function
4362 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4363 : {
4364 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4365 0 : c2->ts.interface->result = c2->ts.interface;
4366 0 : c2->ts.interface->ts = c2->ts;
4367 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4368 0 : c2->ts.interface->attr.function = 1;
4369 0 : c2->attr.function = 1;
4370 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4371 : }
4372 : }
4373 :
4374 : /* Set up either the KIND/LEN initializer, if constant,
4375 : or the parameterized expression. Use the template
4376 : initializer if one is not already set in this instance. */
4377 1281 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4378 : {
4379 667 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4380 555 : c2->initializer = gfc_copy_expr (tail->expr);
4381 112 : else if (tail && tail->expr)
4382 : {
4383 10 : c2->param_list = gfc_get_actual_arglist ();
4384 10 : c2->param_list->name = tail->name;
4385 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4386 10 : c2->param_list->next = NULL;
4387 : }
4388 :
4389 667 : if (!c2->initializer && c1->initializer)
4390 23 : c2->initializer = gfc_copy_expr (c1->initializer);
4391 :
4392 667 : if (c2->initializer)
4393 578 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4394 : }
4395 :
4396 : /* Copy the array spec. */
4397 1281 : c2->as = gfc_copy_array_spec (c1->as);
4398 1281 : if (c1->ts.type == BT_CLASS)
4399 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4400 :
4401 1281 : if (c1->attr.allocatable)
4402 57 : alloc_seen = true;
4403 :
4404 1281 : if (c1->attr.pointer)
4405 19 : ptr_seen = true;
4406 :
4407 : /* Determine if an array spec is parameterized. If so, substitute
4408 : in the parameter expressions for the bounds and set the pdt_array
4409 : attribute. Notice that this attribute must be unconditionally set
4410 : if this is an array of parameterized character length. */
4411 1281 : if (c1->as && c1->as->type == AS_EXPLICIT)
4412 : {
4413 : bool pdt_array = false;
4414 :
4415 : /* Are the bounds of the array parameterized? */
4416 485 : for (i = 0; i < c1->as->rank; i++)
4417 : {
4418 290 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4419 6 : pdt_array = true;
4420 290 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4421 276 : pdt_array = true;
4422 : }
4423 :
4424 : /* If they are, free the expressions for the bounds and
4425 : replace them with the template expressions with substitute
4426 : values. */
4427 471 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4428 : {
4429 276 : gfc_expr *e;
4430 276 : e = gfc_copy_expr (c1->as->lower[i]);
4431 276 : gfc_insert_kind_parameter_exprs (e);
4432 276 : gfc_simplify_expr (e, 1);
4433 276 : gfc_free_expr (c2->as->lower[i]);
4434 276 : c2->as->lower[i] = e;
4435 276 : e = gfc_copy_expr (c1->as->upper[i]);
4436 276 : gfc_insert_kind_parameter_exprs (e);
4437 276 : gfc_simplify_expr (e, 1);
4438 276 : gfc_free_expr (c2->as->upper[i]);
4439 276 : c2->as->upper[i] = e;
4440 : }
4441 :
4442 195 : c2->attr.pdt_array = 1;
4443 195 : if (c1->initializer)
4444 : {
4445 6 : c2->initializer = gfc_copy_expr (c1->initializer);
4446 6 : gfc_insert_kind_parameter_exprs (c2->initializer);
4447 6 : gfc_simplify_expr (c2->initializer, 1);
4448 : }
4449 : }
4450 :
4451 : /* Similarly, set the string length if parameterized. */
4452 1281 : if (c1->ts.type == BT_CHARACTER
4453 83 : && c1->ts.u.cl->length
4454 1364 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4455 : {
4456 83 : gfc_expr *e;
4457 83 : e = gfc_copy_expr (c1->ts.u.cl->length);
4458 83 : gfc_insert_kind_parameter_exprs (e);
4459 83 : gfc_simplify_expr (e, 1);
4460 83 : gfc_free_expr (c2->ts.u.cl->length);
4461 83 : c2->ts.u.cl->length = e;
4462 83 : c2->attr.pdt_string = 1;
4463 : }
4464 :
4465 : /* Recurse into this function for PDT components. */
4466 1281 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4467 116 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4468 : {
4469 109 : gfc_actual_arglist *params;
4470 : /* The component in the template has a list of specification
4471 : expressions derived from its declaration. */
4472 109 : params = gfc_copy_actual_arglist (c1->param_list);
4473 109 : actual_param = params;
4474 : /* Substitute the template parameters with the expressions
4475 : from the specification list. */
4476 340 : for (;actual_param; actual_param = actual_param->next)
4477 : {
4478 122 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4479 122 : gfc_insert_parameter_exprs (actual_param->expr,
4480 : type_param_spec_list);
4481 : }
4482 :
4483 : /* Now obtain the PDT instance for the component. */
4484 109 : old_param_spec_list = type_param_spec_list;
4485 218 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4486 109 : &c2->param_list);
4487 109 : type_param_spec_list = old_param_spec_list;
4488 :
4489 109 : if (!(c2->attr.pointer || c2->attr.allocatable))
4490 : {
4491 70 : if (!c1->initializer
4492 45 : || c1->initializer->expr_type != EXPR_FUNCTION)
4493 69 : c2->initializer = gfc_default_initializer (&c2->ts);
4494 : else
4495 : {
4496 1 : gfc_symtree *s;
4497 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4498 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4499 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4500 1 : if (s)
4501 0 : c2->initializer->symtree = s;
4502 1 : c2->initializer->ts = c2->ts;
4503 1 : if (!s)
4504 1 : gfc_insert_parameter_exprs (c2->initializer,
4505 : type_param_spec_list);
4506 1 : gfc_simplify_expr (params->expr, 1);
4507 : }
4508 : }
4509 :
4510 109 : if (c2->attr.allocatable)
4511 32 : instance->attr.alloc_comp = 1;
4512 : }
4513 1172 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4514 422 : || c2->attr.pdt_array) && c1->initializer)
4515 : {
4516 30 : c2->initializer = gfc_copy_expr (c1->initializer);
4517 30 : if (c2->initializer->ts.type == BT_UNKNOWN)
4518 12 : c2->initializer->ts = c2->ts;
4519 30 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4520 : /* The template initializers are parsed using gfc_match_expr rather
4521 : than gfc_match_init_expr. Apply the missing reduction to the
4522 : PDT instance initializers. */
4523 30 : if (!gfc_reduce_init_expr (c2->initializer))
4524 : {
4525 0 : gfc_free_expr (c2->initializer);
4526 0 : goto error_return;
4527 : }
4528 30 : gfc_simplify_expr (c2->initializer, 1);
4529 : }
4530 : }
4531 :
4532 486 : if (alloc_seen)
4533 54 : instance->attr.alloc_comp = 1;
4534 486 : if (ptr_seen)
4535 19 : instance->attr.pointer_comp = 1;
4536 :
4537 :
4538 486 : gfc_commit_symbol (instance);
4539 486 : if (ext_param_list)
4540 319 : *ext_param_list = type_param_spec_list;
4541 486 : *sym = instance;
4542 486 : free (name);
4543 486 : return m;
4544 :
4545 66 : error_return:
4546 66 : gfc_free_actual_arglist (type_param_spec_list);
4547 66 : free (name);
4548 66 : return MATCH_ERROR;
4549 : }
4550 :
4551 :
4552 : /* Match a legacy nonstandard BYTE type-spec. */
4553 :
4554 : static match
4555 1160887 : match_byte_typespec (gfc_typespec *ts)
4556 : {
4557 1160887 : if (gfc_match (" byte") == MATCH_YES)
4558 : {
4559 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4560 : return MATCH_ERROR;
4561 :
4562 31 : if (gfc_current_form == FORM_FREE)
4563 : {
4564 19 : char c = gfc_peek_ascii_char ();
4565 19 : if (!gfc_is_whitespace (c) && c != ',')
4566 : return MATCH_NO;
4567 : }
4568 :
4569 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4570 : {
4571 0 : gfc_error ("BYTE type used at %C "
4572 : "is not available on the target machine");
4573 0 : return MATCH_ERROR;
4574 : }
4575 :
4576 29 : ts->type = BT_INTEGER;
4577 29 : ts->kind = 1;
4578 29 : return MATCH_YES;
4579 : }
4580 : return MATCH_NO;
4581 : }
4582 :
4583 :
4584 : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4585 : structure to the matched specification. This is necessary for FUNCTION and
4586 : IMPLICIT statements.
4587 :
4588 : If implicit_flag is nonzero, then we don't check for the optional
4589 : kind specification. Not doing so is needed for matching an IMPLICIT
4590 : statement correctly. */
4591 :
4592 : match
4593 1160887 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4594 : {
4595 : /* Provide sufficient space to hold "pdtsymbol". */
4596 1160887 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4597 1160887 : gfc_symbol *sym, *dt_sym;
4598 1160887 : match m;
4599 1160887 : char c;
4600 1160887 : bool seen_deferred_kind, matched_type;
4601 1160887 : const char *dt_name;
4602 :
4603 1160887 : decl_type_param_list = NULL;
4604 :
4605 : /* A belt and braces check that the typespec is correctly being treated
4606 : as a deferred characteristic association. */
4607 2321774 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4608 80250 : && (gfc_current_block ()->result->ts.kind == -1)
4609 1172529 : && (ts->kind == -1);
4610 1160887 : gfc_clear_ts (ts);
4611 1160887 : if (seen_deferred_kind)
4612 9455 : ts->kind = -1;
4613 :
4614 : /* Clear the current binding label, in case one is given. */
4615 1160887 : curr_binding_label = NULL;
4616 :
4617 : /* Match BYTE type-spec. */
4618 1160887 : m = match_byte_typespec (ts);
4619 1160887 : if (m != MATCH_NO)
4620 : return m;
4621 :
4622 1160856 : m = gfc_match (" type (");
4623 1160856 : matched_type = (m == MATCH_YES);
4624 1160856 : if (matched_type)
4625 : {
4626 30776 : gfc_gobble_whitespace ();
4627 30776 : if (gfc_peek_ascii_char () == '*')
4628 : {
4629 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4630 : return m;
4631 5617 : if (gfc_comp_struct (gfc_current_state ()))
4632 : {
4633 2 : gfc_error ("Assumed type at %C is not allowed for components");
4634 2 : return MATCH_ERROR;
4635 : }
4636 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4637 : return MATCH_ERROR;
4638 5613 : ts->type = BT_ASSUMED;
4639 5613 : return MATCH_YES;
4640 : }
4641 :
4642 25159 : m = gfc_match ("%n", name);
4643 25159 : matched_type = (m == MATCH_YES);
4644 : }
4645 :
4646 25159 : if ((matched_type && strcmp ("integer", name) == 0)
4647 1155239 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4648 : {
4649 108179 : ts->type = BT_INTEGER;
4650 108179 : ts->kind = gfc_default_integer_kind;
4651 108179 : goto get_kind;
4652 : }
4653 :
4654 1047060 : if (flag_unsigned)
4655 : {
4656 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4657 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4658 : {
4659 1036 : ts->type = BT_UNSIGNED;
4660 1036 : ts->kind = gfc_default_integer_kind;
4661 1036 : goto get_kind;
4662 : }
4663 : }
4664 :
4665 25153 : if ((matched_type && strcmp ("character", name) == 0)
4666 1046024 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4667 : {
4668 28542 : if (matched_type
4669 28542 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4670 : "intrinsic-type-spec at %C"))
4671 : return MATCH_ERROR;
4672 :
4673 28541 : ts->type = BT_CHARACTER;
4674 28541 : if (implicit_flag == 0)
4675 28435 : m = gfc_match_char_spec (ts);
4676 : else
4677 : m = MATCH_YES;
4678 :
4679 28541 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4680 : {
4681 1 : gfc_error ("Malformed type-spec at %C");
4682 1 : return MATCH_ERROR;
4683 : }
4684 :
4685 28540 : return m;
4686 : }
4687 :
4688 25149 : if ((matched_type && strcmp ("real", name) == 0)
4689 1017482 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4690 : {
4691 29499 : ts->type = BT_REAL;
4692 29499 : ts->kind = gfc_default_real_kind;
4693 29499 : goto get_kind;
4694 : }
4695 :
4696 987983 : if ((matched_type
4697 25146 : && (strcmp ("doubleprecision", name) == 0
4698 25145 : || (strcmp ("double", name) == 0
4699 5 : && gfc_match (" precision") == MATCH_YES)))
4700 987983 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4701 : {
4702 2551 : if (matched_type
4703 2551 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4704 : "intrinsic-type-spec at %C"))
4705 : return MATCH_ERROR;
4706 :
4707 2550 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4708 : {
4709 2 : gfc_error ("Malformed type-spec at %C");
4710 2 : return MATCH_ERROR;
4711 : }
4712 :
4713 2548 : ts->type = BT_REAL;
4714 2548 : ts->kind = gfc_default_double_kind;
4715 2548 : return MATCH_YES;
4716 : }
4717 :
4718 25142 : if ((matched_type && strcmp ("complex", name) == 0)
4719 985432 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4720 : {
4721 4009 : ts->type = BT_COMPLEX;
4722 4009 : ts->kind = gfc_default_complex_kind;
4723 4009 : goto get_kind;
4724 : }
4725 :
4726 981423 : if ((matched_type
4727 25142 : && (strcmp ("doublecomplex", name) == 0
4728 25141 : || (strcmp ("double", name) == 0
4729 2 : && gfc_match (" complex") == MATCH_YES)))
4730 981423 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4731 : {
4732 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4733 : return MATCH_ERROR;
4734 :
4735 203 : if (matched_type
4736 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4737 : "intrinsic-type-spec at %C"))
4738 : return MATCH_ERROR;
4739 :
4740 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4741 : {
4742 2 : gfc_error ("Malformed type-spec at %C");
4743 2 : return MATCH_ERROR;
4744 : }
4745 :
4746 201 : ts->type = BT_COMPLEX;
4747 201 : ts->kind = gfc_default_double_kind;
4748 201 : return MATCH_YES;
4749 : }
4750 :
4751 25139 : if ((matched_type && strcmp ("logical", name) == 0)
4752 981219 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4753 : {
4754 11374 : ts->type = BT_LOGICAL;
4755 11374 : ts->kind = gfc_default_logical_kind;
4756 11374 : goto get_kind;
4757 : }
4758 :
4759 969845 : if (matched_type)
4760 : {
4761 25136 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4762 25136 : if (m == MATCH_ERROR)
4763 : return m;
4764 :
4765 25136 : gfc_gobble_whitespace ();
4766 25136 : if (gfc_peek_ascii_char () != ')')
4767 : {
4768 1 : gfc_error ("Malformed type-spec at %C");
4769 1 : return MATCH_ERROR;
4770 : }
4771 25135 : m = gfc_match_char (')'); /* Burn closing ')'. */
4772 : }
4773 :
4774 969844 : if (m != MATCH_YES)
4775 944709 : m = match_record_decl (name);
4776 :
4777 969844 : if (matched_type || m == MATCH_YES)
4778 : {
4779 25479 : ts->type = BT_DERIVED;
4780 : /* We accept record/s/ or type(s) where s is a structure, but we
4781 : * don't need all the extra derived-type stuff for structures. */
4782 25479 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4783 : {
4784 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4785 1 : return MATCH_ERROR;
4786 : }
4787 :
4788 25478 : if (sym && sym->attr.flavor == FL_DERIVED
4789 24720 : && sym->attr.pdt_template
4790 926 : && gfc_current_state () != COMP_DERIVED)
4791 : {
4792 819 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4793 819 : if (m != MATCH_YES)
4794 : return m;
4795 804 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4796 804 : ts->u.derived = sym;
4797 804 : const char* lower = gfc_dt_lower_string (sym->name);
4798 804 : size_t len = strlen (lower);
4799 : /* Reallocate with sufficient size. */
4800 804 : if (len > GFC_MAX_SYMBOL_LEN)
4801 2 : name = XALLOCAVEC (char, len + 1);
4802 804 : memcpy (name, lower, len);
4803 804 : name[len] = '\0';
4804 : }
4805 :
4806 25463 : if (sym && sym->attr.flavor == FL_STRUCT)
4807 : {
4808 361 : ts->u.derived = sym;
4809 361 : return MATCH_YES;
4810 : }
4811 : /* Actually a derived type. */
4812 : }
4813 :
4814 : else
4815 : {
4816 : /* Match nested STRUCTURE declarations; only valid within another
4817 : structure declaration. */
4818 944365 : if (flag_dec_structure
4819 8032 : && (gfc_current_state () == COMP_STRUCTURE
4820 7570 : || gfc_current_state () == COMP_MAP))
4821 : {
4822 732 : m = gfc_match (" structure");
4823 732 : if (m == MATCH_YES)
4824 : {
4825 27 : m = gfc_match_structure_decl ();
4826 27 : if (m == MATCH_YES)
4827 : {
4828 : /* gfc_new_block is updated by match_structure_decl. */
4829 26 : ts->type = BT_DERIVED;
4830 26 : ts->u.derived = gfc_new_block;
4831 26 : return MATCH_YES;
4832 : }
4833 : }
4834 706 : if (m == MATCH_ERROR)
4835 : return MATCH_ERROR;
4836 : }
4837 :
4838 : /* Match CLASS declarations. */
4839 944338 : m = gfc_match (" class ( * )");
4840 944338 : if (m == MATCH_ERROR)
4841 : return MATCH_ERROR;
4842 944338 : else if (m == MATCH_YES)
4843 : {
4844 1903 : gfc_symbol *upe;
4845 1903 : gfc_symtree *st;
4846 1903 : ts->type = BT_CLASS;
4847 1903 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4848 1903 : if (upe == NULL)
4849 : {
4850 1164 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4851 1164 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4852 1164 : st->n.sym = upe;
4853 1164 : gfc_set_sym_referenced (upe);
4854 1164 : upe->refs++;
4855 1164 : upe->ts.type = BT_VOID;
4856 1164 : upe->attr.unlimited_polymorphic = 1;
4857 : /* This is essential to force the construction of
4858 : unlimited polymorphic component class containers. */
4859 1164 : upe->attr.zero_comp = 1;
4860 1164 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4861 : &gfc_current_locus))
4862 : return MATCH_ERROR;
4863 : }
4864 : else
4865 : {
4866 739 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4867 739 : st->n.sym = upe;
4868 739 : upe->refs++;
4869 : }
4870 1903 : ts->u.derived = upe;
4871 1903 : return m;
4872 : }
4873 :
4874 942435 : m = gfc_match (" class (");
4875 :
4876 942435 : if (m == MATCH_YES)
4877 8732 : m = gfc_match ("%n", name);
4878 : else
4879 : return m;
4880 :
4881 8732 : if (m != MATCH_YES)
4882 : return m;
4883 8732 : ts->type = BT_CLASS;
4884 :
4885 8732 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4886 : return MATCH_ERROR;
4887 :
4888 8731 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4889 8731 : if (m == MATCH_ERROR)
4890 : return m;
4891 :
4892 8731 : m = gfc_match_char (')');
4893 8731 : if (m != MATCH_YES)
4894 : return m;
4895 : }
4896 :
4897 : /* This picks up function declarations with a PDT typespec. Since a
4898 : pdt_type has been generated, there is no more to do. Within the
4899 : function body, this type must be used for the typespec so that
4900 : the "being used before it is defined warning" does not arise. */
4901 33833 : if (ts->type == BT_DERIVED
4902 25102 : && sym && sym->attr.pdt_type
4903 34637 : && (gfc_current_state () == COMP_CONTAINS
4904 788 : || (gfc_current_state () == COMP_FUNCTION
4905 250 : && gfc_current_block ()->ts.type == BT_DERIVED
4906 48 : && gfc_current_block ()->ts.u.derived == sym
4907 24 : && !gfc_find_symtree (gfc_current_ns->sym_root,
4908 : sym->name))))
4909 : {
4910 36 : if (gfc_current_state () == COMP_FUNCTION)
4911 : {
4912 20 : gfc_symtree *pdt_st;
4913 20 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
4914 : sym->name);
4915 20 : pdt_st->n.sym = sym;
4916 20 : sym->refs++;
4917 : }
4918 36 : ts->u.derived = sym;
4919 36 : return MATCH_YES;
4920 : }
4921 :
4922 : /* Defer association of the derived type until the end of the
4923 : specification block. However, if the derived type can be
4924 : found, add it to the typespec. */
4925 33797 : if (gfc_matching_function)
4926 : {
4927 1029 : ts->u.derived = NULL;
4928 1029 : if (gfc_current_state () != COMP_INTERFACE
4929 1029 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4930 : {
4931 512 : sym = gfc_find_dt_in_generic (sym);
4932 512 : ts->u.derived = sym;
4933 : }
4934 1029 : return MATCH_YES;
4935 : }
4936 :
4937 : /* Search for the name but allow the components to be defined later. If
4938 : type = -1, this typespec has been seen in a function declaration but
4939 : the type could not be accessed at that point. The actual derived type is
4940 : stored in a symtree with the first letter of the name capitalized; the
4941 : symtree with the all lower-case name contains the associated
4942 : generic function. */
4943 32768 : dt_name = gfc_dt_upper_string (name);
4944 32768 : sym = NULL;
4945 32768 : dt_sym = NULL;
4946 32768 : if (ts->kind != -1)
4947 : {
4948 31564 : gfc_get_ha_symbol (name, &sym);
4949 31564 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4950 : {
4951 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4952 0 : return MATCH_ERROR;
4953 : }
4954 31564 : if (sym->generic && !dt_sym)
4955 12932 : dt_sym = gfc_find_dt_in_generic (sym);
4956 :
4957 : /* Host associated PDTs can get confused with their constructors
4958 : because they are instantiated in the template's namespace. */
4959 31564 : if (!dt_sym)
4960 : {
4961 878 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4962 : {
4963 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4964 0 : return MATCH_ERROR;
4965 : }
4966 878 : if (dt_sym && !dt_sym->attr.pdt_type)
4967 0 : dt_sym = NULL;
4968 : }
4969 : }
4970 1204 : else if (ts->kind == -1)
4971 : {
4972 2408 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4973 1204 : || gfc_current_ns->has_import_set;
4974 1204 : gfc_find_symbol (name, NULL, iface, &sym);
4975 1204 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4976 : {
4977 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4978 0 : return MATCH_ERROR;
4979 : }
4980 1204 : if (sym && sym->generic && !dt_sym)
4981 0 : dt_sym = gfc_find_dt_in_generic (sym);
4982 :
4983 1204 : ts->kind = 0;
4984 1204 : if (sym == NULL)
4985 : return MATCH_NO;
4986 : }
4987 :
4988 32751 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4989 32076 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4990 32749 : || sym->attr.subroutine)
4991 : {
4992 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
4993 : "entity at %L, which has the same name", name,
4994 : &sym->declared_at);
4995 2 : return MATCH_ERROR;
4996 : }
4997 :
4998 32749 : if (dt_sym && decl_type_param_list
4999 861 : && dt_sym->attr.flavor == FL_DERIVED
5000 861 : && !dt_sym->attr.pdt_type
5001 224 : && !dt_sym->attr.pdt_template)
5002 : {
5003 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
5004 : "list at %C may not appear", dt_sym->name);
5005 1 : return MATCH_ERROR;
5006 : }
5007 :
5008 32748 : if (sym && sym->attr.flavor == FL_DERIVED
5009 : && sym->attr.pdt_template
5010 : && gfc_current_state () != COMP_DERIVED)
5011 : {
5012 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
5013 : if (m != MATCH_YES)
5014 : return m;
5015 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
5016 : ts->u.derived = sym;
5017 : strcpy (name, gfc_dt_lower_string (sym->name));
5018 : }
5019 :
5020 32748 : gfc_save_symbol_data (sym);
5021 32748 : gfc_set_sym_referenced (sym);
5022 32748 : if (!sym->attr.generic
5023 32748 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5024 : return MATCH_ERROR;
5025 :
5026 32748 : if (!sym->attr.function
5027 32748 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5028 : return MATCH_ERROR;
5029 :
5030 32748 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5031 32616 : && dt_sym->attr.pdt_template
5032 234 : && gfc_current_state () != COMP_DERIVED)
5033 : {
5034 121 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5035 121 : if (m != MATCH_YES)
5036 : return m;
5037 121 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5038 : }
5039 :
5040 32748 : if (!dt_sym)
5041 : {
5042 132 : gfc_interface *intr, *head;
5043 :
5044 : /* Use upper case to save the actual derived-type symbol. */
5045 132 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5046 132 : dt_sym->name = gfc_get_string ("%s", sym->name);
5047 132 : head = sym->generic;
5048 132 : intr = gfc_get_interface ();
5049 132 : intr->sym = dt_sym;
5050 132 : intr->where = gfc_current_locus;
5051 132 : intr->next = head;
5052 132 : sym->generic = intr;
5053 132 : sym->attr.if_source = IFSRC_DECL;
5054 : }
5055 : else
5056 32616 : gfc_save_symbol_data (dt_sym);
5057 :
5058 32748 : gfc_set_sym_referenced (dt_sym);
5059 :
5060 132 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5061 32880 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5062 : return MATCH_ERROR;
5063 :
5064 32748 : ts->u.derived = dt_sym;
5065 :
5066 32748 : return MATCH_YES;
5067 :
5068 154097 : get_kind:
5069 154097 : if (matched_type
5070 154097 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5071 : "intrinsic-type-spec at %C"))
5072 : return MATCH_ERROR;
5073 :
5074 : /* For all types except double, derived and character, look for an
5075 : optional kind specifier. MATCH_NO is actually OK at this point. */
5076 154094 : if (implicit_flag == 1)
5077 : {
5078 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5079 : return MATCH_ERROR;
5080 :
5081 223 : return MATCH_YES;
5082 : }
5083 :
5084 153871 : if (gfc_current_form == FORM_FREE)
5085 : {
5086 140120 : c = gfc_peek_ascii_char ();
5087 140120 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5088 69685 : && c != ':' && c != ',')
5089 : {
5090 167 : if (matched_type && c == ')')
5091 : {
5092 3 : gfc_next_ascii_char ();
5093 3 : return MATCH_YES;
5094 : }
5095 164 : gfc_error ("Malformed type-spec at %C");
5096 164 : return MATCH_NO;
5097 : }
5098 : }
5099 :
5100 153704 : m = gfc_match_kind_spec (ts, false);
5101 153704 : if (m == MATCH_ERROR)
5102 : return MATCH_ERROR;
5103 :
5104 153668 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5105 : {
5106 105854 : m = gfc_match_old_kind_spec (ts);
5107 105854 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5108 : return MATCH_ERROR;
5109 : }
5110 :
5111 153660 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5112 : {
5113 0 : gfc_error ("Malformed type-spec at %C");
5114 0 : return MATCH_ERROR;
5115 : }
5116 :
5117 : /* Defer association of the KIND expression of function results
5118 : until after USE and IMPORT statements. */
5119 4445 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5120 158078 : || gfc_matching_function)
5121 7061 : return MATCH_YES;
5122 :
5123 146599 : if (m == MATCH_NO)
5124 149131 : m = MATCH_YES; /* No kind specifier found. */
5125 :
5126 : return m;
5127 : }
5128 :
5129 :
5130 : /* Match an IMPLICIT NONE statement. Actually, this statement is
5131 : already matched in parse.cc, or we would not end up here in the
5132 : first place. So the only thing we need to check, is if there is
5133 : trailing garbage. If not, the match is successful. */
5134 :
5135 : match
5136 23320 : gfc_match_implicit_none (void)
5137 : {
5138 23320 : char c;
5139 23320 : match m;
5140 23320 : char name[GFC_MAX_SYMBOL_LEN + 1];
5141 23320 : bool type = false;
5142 23320 : bool external = false;
5143 23320 : locus cur_loc = gfc_current_locus;
5144 :
5145 23320 : if (gfc_current_ns->seen_implicit_none
5146 23318 : || gfc_current_ns->has_implicit_none_export)
5147 : {
5148 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5149 4 : return MATCH_ERROR;
5150 : }
5151 :
5152 23316 : gfc_gobble_whitespace ();
5153 23316 : c = gfc_peek_ascii_char ();
5154 23316 : if (c == '(')
5155 : {
5156 1064 : (void) gfc_next_ascii_char ();
5157 1064 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5158 : return MATCH_ERROR;
5159 :
5160 1063 : gfc_gobble_whitespace ();
5161 1063 : if (gfc_peek_ascii_char () == ')')
5162 : {
5163 1 : (void) gfc_next_ascii_char ();
5164 1 : type = true;
5165 : }
5166 : else
5167 3162 : for(;;)
5168 : {
5169 2112 : m = gfc_match (" %n", name);
5170 2112 : if (m != MATCH_YES)
5171 : return MATCH_ERROR;
5172 :
5173 2112 : if (strcmp (name, "type") == 0)
5174 : type = true;
5175 1062 : else if (strcmp (name, "external") == 0)
5176 : external = true;
5177 : else
5178 : return MATCH_ERROR;
5179 :
5180 2112 : gfc_gobble_whitespace ();
5181 2112 : c = gfc_next_ascii_char ();
5182 2112 : if (c == ',')
5183 1050 : continue;
5184 1062 : if (c == ')')
5185 : break;
5186 : return MATCH_ERROR;
5187 : }
5188 : }
5189 : else
5190 : type = true;
5191 :
5192 23315 : if (gfc_match_eos () != MATCH_YES)
5193 : return MATCH_ERROR;
5194 :
5195 23315 : gfc_set_implicit_none (type, external, &cur_loc);
5196 :
5197 23315 : return MATCH_YES;
5198 : }
5199 :
5200 :
5201 : /* Match the letter range(s) of an IMPLICIT statement. */
5202 :
5203 : static match
5204 600 : match_implicit_range (void)
5205 : {
5206 600 : char c, c1, c2;
5207 600 : int inner;
5208 600 : locus cur_loc;
5209 :
5210 600 : cur_loc = gfc_current_locus;
5211 :
5212 600 : gfc_gobble_whitespace ();
5213 600 : c = gfc_next_ascii_char ();
5214 600 : if (c != '(')
5215 : {
5216 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5217 59 : goto bad;
5218 : }
5219 :
5220 : inner = 1;
5221 1195 : while (inner)
5222 : {
5223 722 : gfc_gobble_whitespace ();
5224 722 : c1 = gfc_next_ascii_char ();
5225 722 : if (!ISALPHA (c1))
5226 33 : goto bad;
5227 :
5228 689 : gfc_gobble_whitespace ();
5229 689 : c = gfc_next_ascii_char ();
5230 :
5231 689 : switch (c)
5232 : {
5233 201 : case ')':
5234 201 : inner = 0; /* Fall through. */
5235 :
5236 : case ',':
5237 : c2 = c1;
5238 : break;
5239 :
5240 439 : case '-':
5241 439 : gfc_gobble_whitespace ();
5242 439 : c2 = gfc_next_ascii_char ();
5243 439 : if (!ISALPHA (c2))
5244 0 : goto bad;
5245 :
5246 439 : gfc_gobble_whitespace ();
5247 439 : c = gfc_next_ascii_char ();
5248 :
5249 439 : if ((c != ',') && (c != ')'))
5250 0 : goto bad;
5251 439 : if (c == ')')
5252 272 : inner = 0;
5253 :
5254 : break;
5255 :
5256 35 : default:
5257 35 : goto bad;
5258 : }
5259 :
5260 654 : if (c1 > c2)
5261 : {
5262 0 : gfc_error ("Letters must be in alphabetic order in "
5263 : "IMPLICIT statement at %C");
5264 0 : goto bad;
5265 : }
5266 :
5267 : /* See if we can add the newly matched range to the pending
5268 : implicits from this IMPLICIT statement. We do not check for
5269 : conflicts with whatever earlier IMPLICIT statements may have
5270 : set. This is done when we've successfully finished matching
5271 : the current one. */
5272 654 : if (!gfc_add_new_implicit_range (c1, c2))
5273 0 : goto bad;
5274 : }
5275 :
5276 : return MATCH_YES;
5277 :
5278 127 : bad:
5279 127 : gfc_syntax_error (ST_IMPLICIT);
5280 :
5281 127 : gfc_current_locus = cur_loc;
5282 127 : return MATCH_ERROR;
5283 : }
5284 :
5285 :
5286 : /* Match an IMPLICIT statement, storing the types for
5287 : gfc_set_implicit() if the statement is accepted by the parser.
5288 : There is a strange looking, but legal syntactic construction
5289 : possible. It looks like:
5290 :
5291 : IMPLICIT INTEGER (a-b) (c-d)
5292 :
5293 : This is legal if "a-b" is a constant expression that happens to
5294 : equal one of the legal kinds for integers. The real problem
5295 : happens with an implicit specification that looks like:
5296 :
5297 : IMPLICIT INTEGER (a-b)
5298 :
5299 : In this case, a typespec matcher that is "greedy" (as most of the
5300 : matchers are) gobbles the character range as a kindspec, leaving
5301 : nothing left. We therefore have to go a bit more slowly in the
5302 : matching process by inhibiting the kindspec checking during
5303 : typespec matching and checking for a kind later. */
5304 :
5305 : match
5306 23746 : gfc_match_implicit (void)
5307 : {
5308 23746 : gfc_typespec ts;
5309 23746 : locus cur_loc;
5310 23746 : char c;
5311 23746 : match m;
5312 :
5313 23746 : if (gfc_current_ns->seen_implicit_none)
5314 : {
5315 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5316 : "statement");
5317 4 : return MATCH_ERROR;
5318 : }
5319 :
5320 23742 : gfc_clear_ts (&ts);
5321 :
5322 : /* We don't allow empty implicit statements. */
5323 23742 : if (gfc_match_eos () == MATCH_YES)
5324 : {
5325 0 : gfc_error ("Empty IMPLICIT statement at %C");
5326 0 : return MATCH_ERROR;
5327 : }
5328 :
5329 23771 : do
5330 : {
5331 : /* First cleanup. */
5332 23771 : gfc_clear_new_implicit ();
5333 :
5334 : /* A basic type is mandatory here. */
5335 23771 : m = gfc_match_decl_type_spec (&ts, 1);
5336 23771 : if (m == MATCH_ERROR)
5337 0 : goto error;
5338 23771 : if (m == MATCH_NO)
5339 23318 : goto syntax;
5340 :
5341 453 : cur_loc = gfc_current_locus;
5342 453 : m = match_implicit_range ();
5343 :
5344 453 : if (m == MATCH_YES)
5345 : {
5346 : /* We may have <TYPE> (<RANGE>). */
5347 326 : gfc_gobble_whitespace ();
5348 326 : c = gfc_peek_ascii_char ();
5349 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5350 : {
5351 : /* Check for CHARACTER with no length parameter. */
5352 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5353 : {
5354 32 : ts.kind = gfc_default_character_kind;
5355 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5356 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5357 : NULL, 1);
5358 : }
5359 :
5360 : /* Record the Successful match. */
5361 299 : if (!gfc_merge_new_implicit (&ts))
5362 : return MATCH_ERROR;
5363 297 : if (c == ',')
5364 28 : c = gfc_next_ascii_char ();
5365 269 : else if (gfc_match_eos () == MATCH_ERROR)
5366 0 : goto error;
5367 297 : continue;
5368 : }
5369 :
5370 27 : gfc_current_locus = cur_loc;
5371 : }
5372 :
5373 : /* Discard the (incorrectly) matched range. */
5374 154 : gfc_clear_new_implicit ();
5375 :
5376 : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5377 154 : if (ts.type == BT_CHARACTER)
5378 74 : m = gfc_match_char_spec (&ts);
5379 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5380 : {
5381 76 : m = gfc_match_kind_spec (&ts, false);
5382 76 : if (m == MATCH_NO)
5383 : {
5384 40 : m = gfc_match_old_kind_spec (&ts);
5385 40 : if (m == MATCH_ERROR)
5386 0 : goto error;
5387 40 : if (m == MATCH_NO)
5388 0 : goto syntax;
5389 : }
5390 : }
5391 154 : if (m == MATCH_ERROR)
5392 7 : goto error;
5393 :
5394 147 : m = match_implicit_range ();
5395 147 : if (m == MATCH_ERROR)
5396 0 : goto error;
5397 147 : if (m == MATCH_NO)
5398 : goto syntax;
5399 :
5400 147 : gfc_gobble_whitespace ();
5401 147 : c = gfc_next_ascii_char ();
5402 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5403 0 : goto syntax;
5404 :
5405 147 : if (!gfc_merge_new_implicit (&ts))
5406 : return MATCH_ERROR;
5407 : }
5408 444 : while (c == ',');
5409 :
5410 : return MATCH_YES;
5411 :
5412 23318 : syntax:
5413 23318 : gfc_syntax_error (ST_IMPLICIT);
5414 :
5415 : error:
5416 : return MATCH_ERROR;
5417 : }
5418 :
5419 :
5420 : /* Match the IMPORT statement. IMPORT was added to F2003 as
5421 :
5422 : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5423 :
5424 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5425 :
5426 : C1211 (R1209) Each import-name shall be the name of an entity in the
5427 : host scoping unit.
5428 :
5429 : under the description of an interface block. Under F2008, IMPORT was
5430 : split out of the interface block description to 12.4.3.3 and C1210
5431 : became
5432 :
5433 : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5434 : that is not a module procedure interface body.
5435 :
5436 : Finally, F2018, section 8.8, has changed the IMPORT statement to
5437 :
5438 : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5439 : or IMPORT, ONLY : import-name-list
5440 : or IMPORT, NONE
5441 : or IMPORT, ALL
5442 :
5443 : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5444 : a main-program, external-subprogram, module, or block-data.
5445 :
5446 : C897 (R867) Each import-name shall be the name of an entity in the host
5447 : scoping unit.
5448 :
5449 : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5450 : all IMPORT statements in that scoping unit shall have an ONLY
5451 : specifier.
5452 :
5453 : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5454 :
5455 : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5456 : unit, no other IMPORT statement shall appear in that scoping unit.
5457 :
5458 : C8101 Within an interface body, an entity that is accessed by host
5459 : association shall be accessible by host or use association within
5460 : the host scoping unit, or explicitly declared prior to the interface
5461 : body.
5462 :
5463 : C8102 An entity whose name appears as an import-name or which is made
5464 : accessible by an IMPORT, ALL statement shall not appear in any
5465 : context described in 19.5.1.4 that would cause the host entity
5466 : of that name to be inaccessible. */
5467 :
5468 : match
5469 3905 : gfc_match_import (void)
5470 : {
5471 3905 : char name[GFC_MAX_SYMBOL_LEN + 1];
5472 3905 : match m;
5473 3905 : gfc_symbol *sym;
5474 3905 : gfc_symtree *st;
5475 3905 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5476 3905 : importstate current_import_state = gfc_current_ns->import_state;
5477 :
5478 3905 : if (!f2018_allowed
5479 13 : && (gfc_current_ns->proc_name == NULL
5480 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5481 : {
5482 3 : gfc_error ("IMPORT statement at %C only permitted in "
5483 : "an INTERFACE body");
5484 3 : return MATCH_ERROR;
5485 : }
5486 : else if (f2018_allowed
5487 3892 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5488 4 : goto C897;
5489 :
5490 3888 : if (f2018_allowed
5491 3888 : && (current_import_state == IMPORT_ALL
5492 3888 : || current_import_state == IMPORT_NONE))
5493 2 : goto C8100;
5494 :
5495 3896 : if (gfc_current_ns->proc_name
5496 3895 : && gfc_current_ns->proc_name->attr.module_procedure)
5497 : {
5498 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5499 : "in a module procedure interface body");
5500 1 : return MATCH_ERROR;
5501 : }
5502 :
5503 3895 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5504 : return MATCH_ERROR;
5505 :
5506 3891 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5507 3891 : if (f2018_allowed)
5508 : {
5509 3885 : if (gfc_match (" , none") == MATCH_YES)
5510 : {
5511 8 : if (current_import_state == IMPORT_ONLY)
5512 0 : goto C898;
5513 8 : if (gfc_current_state () == COMP_SUBMODULE)
5514 0 : goto C899;
5515 8 : gfc_current_ns->import_state = IMPORT_NONE;
5516 : }
5517 3877 : else if (gfc_match (" , only :") == MATCH_YES)
5518 : {
5519 19 : if (current_import_state != IMPORT_NOT_SET
5520 19 : && current_import_state != IMPORT_ONLY)
5521 0 : goto C898;
5522 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5523 : }
5524 3858 : else if (gfc_match (" , all") == MATCH_YES)
5525 : {
5526 1 : if (current_import_state == IMPORT_ONLY)
5527 0 : goto C898;
5528 1 : gfc_current_ns->import_state = IMPORT_ALL;
5529 : }
5530 :
5531 3885 : if (current_import_state != IMPORT_NOT_SET
5532 6 : && (gfc_current_ns->import_state == IMPORT_NONE
5533 6 : || gfc_current_ns->import_state == IMPORT_ALL))
5534 0 : goto C8100;
5535 : }
5536 :
5537 : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5538 3891 : if (gfc_match_eos () == MATCH_YES)
5539 : {
5540 : /* This is the F2008 variant. */
5541 225 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5542 : {
5543 216 : if (current_import_state == IMPORT_ONLY)
5544 0 : goto C898;
5545 216 : gfc_current_ns->import_state = IMPORT_F2008;
5546 : }
5547 :
5548 : /* Host variables should be imported. */
5549 225 : if (gfc_current_ns->import_state != IMPORT_NONE)
5550 217 : gfc_current_ns->has_import_set = 1;
5551 225 : return MATCH_YES;
5552 : }
5553 :
5554 3666 : if (gfc_match (" ::") == MATCH_YES
5555 3666 : && gfc_current_ns->import_state != IMPORT_ONLY)
5556 : {
5557 1158 : if (gfc_match_eos () == MATCH_YES)
5558 1 : goto expecting_list;
5559 1157 : gfc_current_ns->import_state = IMPORT_F2008;
5560 : }
5561 2508 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5562 : {
5563 19 : if (gfc_match_eos () == MATCH_YES)
5564 0 : goto expecting_list;
5565 : }
5566 :
5567 4349 : for(;;)
5568 : {
5569 4349 : sym = NULL;
5570 4349 : m = gfc_match (" %n", name);
5571 4349 : switch (m)
5572 : {
5573 4349 : case MATCH_YES:
5574 : /* Before checking if the symbol is available from host
5575 : association into a SUBROUTINE or FUNCTION within an
5576 : INTERFACE, check if it is already in local scope. */
5577 4349 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
5578 4349 : if (sym
5579 25 : && gfc_state_stack->previous
5580 25 : && gfc_state_stack->previous->state == COMP_INTERFACE)
5581 : {
5582 2 : gfc_error ("import-name %qs at %C is in the "
5583 : "local scope", name);
5584 2 : return MATCH_ERROR;
5585 : }
5586 :
5587 4347 : if (gfc_current_ns->parent != NULL
5588 4347 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5589 : {
5590 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5591 0 : return MATCH_ERROR;
5592 : }
5593 4347 : else if (!sym
5594 5 : && gfc_current_ns->proc_name
5595 4 : && gfc_current_ns->proc_name->ns->parent
5596 4348 : && gfc_find_symbol (name,
5597 : gfc_current_ns->proc_name->ns->parent,
5598 : 1, &sym))
5599 : {
5600 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5601 0 : return MATCH_ERROR;
5602 : }
5603 :
5604 4347 : if (sym == NULL)
5605 : {
5606 5 : if (gfc_current_ns->proc_name
5607 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5608 : {
5609 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5610 : "at %C - does not exist.", name);
5611 1 : return MATCH_ERROR;
5612 : }
5613 : else
5614 : {
5615 : /* This might be a procedure that has not yet been parsed. If
5616 : so gfc_fixup_sibling_symbols will replace this symbol with
5617 : that of the procedure. */
5618 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5619 : &gfc_current_locus);
5620 4 : st->n.sym->refs++;
5621 4 : st->n.sym->attr.imported = 1;
5622 4 : st->import_only = 1;
5623 4 : goto next_item;
5624 : }
5625 : }
5626 :
5627 4342 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5628 4342 : if (st && st->n.sym && st->n.sym->attr.imported)
5629 : {
5630 0 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5631 : "at %C", name);
5632 0 : goto next_item;
5633 : }
5634 :
5635 4342 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5636 4342 : st->n.sym = sym;
5637 4342 : sym->refs++;
5638 4342 : sym->attr.imported = 1;
5639 4342 : st->import_only = 1;
5640 :
5641 4342 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5642 : {
5643 : /* The actual derived type is stored in a symtree with the first
5644 : letter of the name capitalized; the symtree with the all
5645 : lower-case name contains the associated generic function. */
5646 596 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5647 : gfc_dt_upper_string (name));
5648 596 : st->n.sym = sym;
5649 596 : sym->refs++;
5650 596 : sym->attr.imported = 1;
5651 596 : st->import_only = 1;
5652 : }
5653 :
5654 4342 : goto next_item;
5655 :
5656 : case MATCH_NO:
5657 : break;
5658 :
5659 : case MATCH_ERROR:
5660 : return MATCH_ERROR;
5661 : }
5662 :
5663 4346 : next_item:
5664 4346 : if (gfc_match_eos () == MATCH_YES)
5665 : break;
5666 684 : if (gfc_match_char (',') != MATCH_YES)
5667 0 : goto syntax;
5668 : }
5669 :
5670 : return MATCH_YES;
5671 :
5672 0 : syntax:
5673 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5674 0 : return MATCH_ERROR;
5675 :
5676 4 : C897:
5677 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5678 : "program, an external subprogram, a module or block data");
5679 4 : return MATCH_ERROR;
5680 :
5681 0 : C898:
5682 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5683 : "a scoping unit has an ONLY specifier, can only have IMPORT "
5684 : "with an ONLY specifier");
5685 0 : return MATCH_ERROR;
5686 :
5687 0 : C899:
5688 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5689 : " of a submodule as at %C");
5690 0 : return MATCH_ERROR;
5691 :
5692 2 : C8100:
5693 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5694 : "%s has already been declared, which must be unique in the "
5695 : "scoping unit",
5696 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5697 : "IMPORT, NONE");
5698 2 : return MATCH_ERROR;
5699 :
5700 1 : expecting_list:
5701 1 : gfc_error ("Expecting list of named entities at %C");
5702 1 : return MATCH_ERROR;
5703 : }
5704 :
5705 :
5706 : /* A minimal implementation of gfc_match without whitespace, escape
5707 : characters or variable arguments. Returns true if the next
5708 : characters match the TARGET template exactly. */
5709 :
5710 : static bool
5711 142483 : match_string_p (const char *target)
5712 : {
5713 142483 : const char *p;
5714 :
5715 900983 : for (p = target; *p; p++)
5716 758501 : if ((char) gfc_next_ascii_char () != *p)
5717 : return false;
5718 : return true;
5719 : }
5720 :
5721 : /* Matches an attribute specification including array specs. If
5722 : successful, leaves the variables current_attr and current_as
5723 : holding the specification. Also sets the colon_seen variable for
5724 : later use by matchers associated with initializations.
5725 :
5726 : This subroutine is a little tricky in the sense that we don't know
5727 : if we really have an attr-spec until we hit the double colon.
5728 : Until that time, we can only return MATCH_NO. This forces us to
5729 : check for duplicate specification at this level. */
5730 :
5731 : static match
5732 211150 : match_attr_spec (void)
5733 : {
5734 : /* Modifiers that can exist in a type statement. */
5735 211150 : enum
5736 : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5737 : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5738 : DECL_DIMENSION, DECL_EXTERNAL,
5739 : DECL_INTRINSIC, DECL_OPTIONAL,
5740 : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5741 : DECL_STATIC, DECL_AUTOMATIC,
5742 : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5743 : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5744 : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5745 : };
5746 :
5747 : /* GFC_DECL_END is the sentinel, index starts at 0. */
5748 : #define NUM_DECL GFC_DECL_END
5749 :
5750 : /* Make sure that values from sym_intent are safe to be used here. */
5751 211150 : gcc_assert (INTENT_IN > 0);
5752 :
5753 211150 : locus start, seen_at[NUM_DECL];
5754 211150 : int seen[NUM_DECL];
5755 211150 : unsigned int d;
5756 211150 : const char *attr;
5757 211150 : match m;
5758 211150 : bool t;
5759 :
5760 211150 : gfc_clear_attr (¤t_attr);
5761 211150 : start = gfc_current_locus;
5762 :
5763 211150 : current_as = NULL;
5764 211150 : colon_seen = 0;
5765 211150 : attr_seen = 0;
5766 :
5767 : /* See if we get all of the keywords up to the final double colon. */
5768 5701050 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5769 5489900 : seen[d] = 0;
5770 :
5771 327128 : for (;;)
5772 : {
5773 327128 : char ch;
5774 :
5775 327128 : d = DECL_NONE;
5776 327128 : gfc_gobble_whitespace ();
5777 :
5778 327128 : ch = gfc_next_ascii_char ();
5779 327128 : if (ch == ':')
5780 : {
5781 : /* This is the successful exit condition for the loop. */
5782 178535 : if (gfc_next_ascii_char () == ':')
5783 : break;
5784 : }
5785 148593 : else if (ch == ',')
5786 : {
5787 115990 : gfc_gobble_whitespace ();
5788 115990 : switch (gfc_peek_ascii_char ())
5789 : {
5790 18032 : case 'a':
5791 18032 : gfc_next_ascii_char ();
5792 18032 : switch (gfc_next_ascii_char ())
5793 : {
5794 17967 : case 'l':
5795 17967 : if (match_string_p ("locatable"))
5796 : {
5797 : /* Matched "allocatable". */
5798 : d = DECL_ALLOCATABLE;
5799 : }
5800 : break;
5801 :
5802 24 : case 's':
5803 24 : if (match_string_p ("ynchronous"))
5804 : {
5805 : /* Matched "asynchronous". */
5806 : d = DECL_ASYNCHRONOUS;
5807 : }
5808 : break;
5809 :
5810 41 : case 'u':
5811 41 : if (match_string_p ("tomatic"))
5812 : {
5813 : /* Matched "automatic". */
5814 : d = DECL_AUTOMATIC;
5815 : }
5816 : break;
5817 : }
5818 : break;
5819 :
5820 163 : case 'b':
5821 : /* Try and match the bind(c). */
5822 163 : m = gfc_match_bind_c (NULL, true);
5823 163 : if (m == MATCH_YES)
5824 : d = DECL_IS_BIND_C;
5825 0 : else if (m == MATCH_ERROR)
5826 0 : goto cleanup;
5827 : break;
5828 :
5829 2108 : case 'c':
5830 2108 : gfc_next_ascii_char ();
5831 2108 : if ('o' != gfc_next_ascii_char ())
5832 : break;
5833 2107 : switch (gfc_next_ascii_char ())
5834 : {
5835 67 : case 'd':
5836 67 : if (match_string_p ("imension"))
5837 : {
5838 : d = DECL_CODIMENSION;
5839 : break;
5840 : }
5841 : /* FALLTHRU */
5842 2040 : case 'n':
5843 2040 : if (match_string_p ("tiguous"))
5844 : {
5845 : d = DECL_CONTIGUOUS;
5846 : break;
5847 : }
5848 : }
5849 : break;
5850 :
5851 19573 : case 'd':
5852 19573 : if (match_string_p ("dimension"))
5853 : d = DECL_DIMENSION;
5854 : break;
5855 :
5856 177 : case 'e':
5857 177 : if (match_string_p ("external"))
5858 : d = DECL_EXTERNAL;
5859 : break;
5860 :
5861 26657 : case 'i':
5862 26657 : if (match_string_p ("int"))
5863 : {
5864 26657 : ch = gfc_next_ascii_char ();
5865 26657 : if (ch == 'e')
5866 : {
5867 26651 : if (match_string_p ("nt"))
5868 : {
5869 : /* Matched "intent". */
5870 26650 : d = match_intent_spec ();
5871 26650 : if (d == INTENT_UNKNOWN)
5872 : {
5873 2 : m = MATCH_ERROR;
5874 2 : goto cleanup;
5875 : }
5876 : }
5877 : }
5878 6 : else if (ch == 'r')
5879 : {
5880 6 : if (match_string_p ("insic"))
5881 : {
5882 : /* Matched "intrinsic". */
5883 : d = DECL_INTRINSIC;
5884 : }
5885 : }
5886 : }
5887 : break;
5888 :
5889 271 : case 'k':
5890 271 : if (match_string_p ("kind"))
5891 : d = DECL_KIND;
5892 : break;
5893 :
5894 295 : case 'l':
5895 295 : if (match_string_p ("len"))
5896 : d = DECL_LEN;
5897 : break;
5898 :
5899 5040 : case 'o':
5900 5040 : if (match_string_p ("optional"))
5901 : d = DECL_OPTIONAL;
5902 : break;
5903 :
5904 26684 : case 'p':
5905 26684 : gfc_next_ascii_char ();
5906 26684 : switch (gfc_next_ascii_char ())
5907 : {
5908 14088 : case 'a':
5909 14088 : if (match_string_p ("rameter"))
5910 : {
5911 : /* Matched "parameter". */
5912 : d = DECL_PARAMETER;
5913 : }
5914 : break;
5915 :
5916 12077 : case 'o':
5917 12077 : if (match_string_p ("inter"))
5918 : {
5919 : /* Matched "pointer". */
5920 : d = DECL_POINTER;
5921 : }
5922 : break;
5923 :
5924 267 : case 'r':
5925 267 : ch = gfc_next_ascii_char ();
5926 267 : if (ch == 'i')
5927 : {
5928 216 : if (match_string_p ("vate"))
5929 : {
5930 : /* Matched "private". */
5931 : d = DECL_PRIVATE;
5932 : }
5933 : }
5934 51 : else if (ch == 'o')
5935 : {
5936 51 : if (match_string_p ("tected"))
5937 : {
5938 : /* Matched "protected". */
5939 : d = DECL_PROTECTED;
5940 : }
5941 : }
5942 : break;
5943 :
5944 252 : case 'u':
5945 252 : if (match_string_p ("blic"))
5946 : {
5947 : /* Matched "public". */
5948 : d = DECL_PUBLIC;
5949 : }
5950 : break;
5951 : }
5952 : break;
5953 :
5954 1210 : case 's':
5955 1210 : gfc_next_ascii_char ();
5956 1210 : switch (gfc_next_ascii_char ())
5957 : {
5958 1197 : case 'a':
5959 1197 : if (match_string_p ("ve"))
5960 : {
5961 : /* Matched "save". */
5962 : d = DECL_SAVE;
5963 : }
5964 : break;
5965 :
5966 13 : case 't':
5967 13 : if (match_string_p ("atic"))
5968 : {
5969 : /* Matched "static". */
5970 : d = DECL_STATIC;
5971 : }
5972 : break;
5973 : }
5974 : break;
5975 :
5976 5268 : case 't':
5977 5268 : if (match_string_p ("target"))
5978 : d = DECL_TARGET;
5979 : break;
5980 :
5981 10512 : case 'v':
5982 10512 : gfc_next_ascii_char ();
5983 10512 : ch = gfc_next_ascii_char ();
5984 10512 : if (ch == 'a')
5985 : {
5986 10005 : if (match_string_p ("lue"))
5987 : {
5988 : /* Matched "value". */
5989 : d = DECL_VALUE;
5990 : }
5991 : }
5992 507 : else if (ch == 'o')
5993 : {
5994 507 : if (match_string_p ("latile"))
5995 : {
5996 : /* Matched "volatile". */
5997 : d = DECL_VOLATILE;
5998 : }
5999 : }
6000 : break;
6001 : }
6002 : }
6003 :
6004 : /* No double colon and no recognizable decl_type, so assume that
6005 : we've been looking at something else the whole time. */
6006 : if (d == DECL_NONE)
6007 : {
6008 32606 : m = MATCH_NO;
6009 32606 : goto cleanup;
6010 : }
6011 :
6012 : /* Check to make sure any parens are paired up correctly. */
6013 115986 : if (gfc_match_parens () == MATCH_ERROR)
6014 : {
6015 1 : m = MATCH_ERROR;
6016 1 : goto cleanup;
6017 : }
6018 :
6019 115985 : seen[d]++;
6020 115985 : seen_at[d] = gfc_current_locus;
6021 :
6022 115985 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
6023 : {
6024 19639 : gfc_array_spec *as = NULL;
6025 :
6026 19639 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
6027 : d == DECL_CODIMENSION);
6028 :
6029 19639 : if (current_as == NULL)
6030 19615 : current_as = as;
6031 24 : else if (m == MATCH_YES)
6032 : {
6033 24 : if (!merge_array_spec (as, current_as, false))
6034 2 : m = MATCH_ERROR;
6035 24 : free (as);
6036 : }
6037 :
6038 19639 : if (m == MATCH_NO)
6039 : {
6040 0 : if (d == DECL_CODIMENSION)
6041 0 : gfc_error ("Missing codimension specification at %C");
6042 : else
6043 0 : gfc_error ("Missing dimension specification at %C");
6044 : m = MATCH_ERROR;
6045 : }
6046 :
6047 19639 : if (m == MATCH_ERROR)
6048 7 : goto cleanup;
6049 : }
6050 : }
6051 :
6052 : /* Since we've seen a double colon, we have to be looking at an
6053 : attr-spec. This means that we can now issue errors. */
6054 4820397 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6055 4641865 : if (seen[d] > 1)
6056 : {
6057 2 : switch (d)
6058 : {
6059 : case DECL_ALLOCATABLE:
6060 : attr = "ALLOCATABLE";
6061 : break;
6062 0 : case DECL_ASYNCHRONOUS:
6063 0 : attr = "ASYNCHRONOUS";
6064 0 : break;
6065 0 : case DECL_CODIMENSION:
6066 0 : attr = "CODIMENSION";
6067 0 : break;
6068 0 : case DECL_CONTIGUOUS:
6069 0 : attr = "CONTIGUOUS";
6070 0 : break;
6071 0 : case DECL_DIMENSION:
6072 0 : attr = "DIMENSION";
6073 0 : break;
6074 0 : case DECL_EXTERNAL:
6075 0 : attr = "EXTERNAL";
6076 0 : break;
6077 0 : case DECL_IN:
6078 0 : attr = "INTENT (IN)";
6079 0 : break;
6080 0 : case DECL_OUT:
6081 0 : attr = "INTENT (OUT)";
6082 0 : break;
6083 0 : case DECL_INOUT:
6084 0 : attr = "INTENT (IN OUT)";
6085 0 : break;
6086 0 : case DECL_INTRINSIC:
6087 0 : attr = "INTRINSIC";
6088 0 : break;
6089 0 : case DECL_OPTIONAL:
6090 0 : attr = "OPTIONAL";
6091 0 : break;
6092 0 : case DECL_KIND:
6093 0 : attr = "KIND";
6094 0 : break;
6095 0 : case DECL_LEN:
6096 0 : attr = "LEN";
6097 0 : break;
6098 0 : case DECL_PARAMETER:
6099 0 : attr = "PARAMETER";
6100 0 : break;
6101 0 : case DECL_POINTER:
6102 0 : attr = "POINTER";
6103 0 : break;
6104 0 : case DECL_PROTECTED:
6105 0 : attr = "PROTECTED";
6106 0 : break;
6107 0 : case DECL_PRIVATE:
6108 0 : attr = "PRIVATE";
6109 0 : break;
6110 0 : case DECL_PUBLIC:
6111 0 : attr = "PUBLIC";
6112 0 : break;
6113 0 : case DECL_SAVE:
6114 0 : attr = "SAVE";
6115 0 : break;
6116 0 : case DECL_STATIC:
6117 0 : attr = "STATIC";
6118 0 : break;
6119 1 : case DECL_AUTOMATIC:
6120 1 : attr = "AUTOMATIC";
6121 1 : break;
6122 0 : case DECL_TARGET:
6123 0 : attr = "TARGET";
6124 0 : break;
6125 0 : case DECL_IS_BIND_C:
6126 0 : attr = "IS_BIND_C";
6127 0 : break;
6128 0 : case DECL_VALUE:
6129 0 : attr = "VALUE";
6130 0 : break;
6131 1 : case DECL_VOLATILE:
6132 1 : attr = "VOLATILE";
6133 1 : break;
6134 0 : default:
6135 0 : attr = NULL; /* This shouldn't happen. */
6136 : }
6137 :
6138 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6139 2 : m = MATCH_ERROR;
6140 2 : goto cleanup;
6141 : }
6142 :
6143 : /* Now that we've dealt with duplicate attributes, add the attributes
6144 : to the current attribute. */
6145 4819577 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6146 : {
6147 4641118 : if (seen[d] == 0)
6148 4525149 : continue;
6149 : else
6150 115969 : attr_seen = 1;
6151 :
6152 115969 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6153 52 : && !flag_dec_static)
6154 : {
6155 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6156 : "%<-fdec-static%>",
6157 : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6158 2 : m = MATCH_ERROR;
6159 2 : goto cleanup;
6160 : }
6161 : /* Allow SAVE with STATIC, but don't complain. */
6162 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6163 0 : continue;
6164 :
6165 115967 : if (gfc_comp_struct (gfc_current_state ())
6166 6597 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6167 5645 : && d != DECL_POINTER && d != DECL_PRIVATE
6168 4013 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6169 : {
6170 3956 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6171 3956 : if (d == DECL_ALLOCATABLE)
6172 : {
6173 3377 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6174 : ? G_("ALLOCATABLE attribute at %C in a "
6175 : "TYPE definition")
6176 : : G_("ALLOCATABLE attribute at %C in a "
6177 : "STRUCTURE definition")))
6178 : {
6179 2 : m = MATCH_ERROR;
6180 2 : goto cleanup;
6181 : }
6182 : }
6183 579 : else if (d == DECL_KIND)
6184 : {
6185 269 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6186 : ? G_("KIND attribute at %C in a "
6187 : "TYPE definition")
6188 : : G_("KIND attribute at %C in a "
6189 : "STRUCTURE definition")))
6190 : {
6191 1 : m = MATCH_ERROR;
6192 1 : goto cleanup;
6193 : }
6194 268 : if (current_ts.type != BT_INTEGER)
6195 : {
6196 2 : gfc_error ("Component with KIND attribute at %C must be "
6197 : "INTEGER");
6198 2 : m = MATCH_ERROR;
6199 2 : goto cleanup;
6200 : }
6201 : }
6202 310 : else if (d == DECL_LEN)
6203 : {
6204 294 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6205 : ? G_("LEN attribute at %C in a "
6206 : "TYPE definition")
6207 : : G_("LEN attribute at %C in a "
6208 : "STRUCTURE definition")))
6209 : {
6210 0 : m = MATCH_ERROR;
6211 0 : goto cleanup;
6212 : }
6213 294 : if (current_ts.type != BT_INTEGER)
6214 : {
6215 1 : gfc_error ("Component with LEN attribute at %C must be "
6216 : "INTEGER");
6217 1 : m = MATCH_ERROR;
6218 1 : goto cleanup;
6219 : }
6220 : }
6221 : else
6222 : {
6223 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6224 : "TYPE definition")
6225 : : G_("Attribute at %L is not allowed in a "
6226 : "STRUCTURE definition"), &seen_at[d]);
6227 16 : m = MATCH_ERROR;
6228 16 : goto cleanup;
6229 : }
6230 : }
6231 :
6232 115945 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6233 468 : && gfc_current_state () != COMP_MODULE)
6234 : {
6235 147 : if (d == DECL_PRIVATE)
6236 : attr = "PRIVATE";
6237 : else
6238 43 : attr = "PUBLIC";
6239 147 : if (gfc_current_state () == COMP_DERIVED
6240 141 : && gfc_state_stack->previous
6241 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6242 : {
6243 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6244 : "at %L in a TYPE definition", attr,
6245 : &seen_at[d]))
6246 : {
6247 2 : m = MATCH_ERROR;
6248 2 : goto cleanup;
6249 : }
6250 : }
6251 : else
6252 : {
6253 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6254 : "specification part of a module", attr, &seen_at[d]);
6255 9 : m = MATCH_ERROR;
6256 9 : goto cleanup;
6257 : }
6258 : }
6259 :
6260 115934 : if (gfc_current_state () != COMP_DERIVED
6261 109368 : && (d == DECL_KIND || d == DECL_LEN))
6262 : {
6263 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6264 : "definition", &seen_at[d]);
6265 3 : m = MATCH_ERROR;
6266 3 : goto cleanup;
6267 : }
6268 :
6269 115931 : switch (d)
6270 : {
6271 17965 : case DECL_ALLOCATABLE:
6272 17965 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6273 17965 : break;
6274 :
6275 23 : case DECL_ASYNCHRONOUS:
6276 23 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6277 : t = false;
6278 : else
6279 23 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6280 : break;
6281 :
6282 65 : case DECL_CODIMENSION:
6283 65 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6284 65 : break;
6285 :
6286 2040 : case DECL_CONTIGUOUS:
6287 2040 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6288 : t = false;
6289 : else
6290 2039 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6291 : break;
6292 :
6293 19565 : case DECL_DIMENSION:
6294 19565 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6295 19565 : break;
6296 :
6297 176 : case DECL_EXTERNAL:
6298 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6299 176 : break;
6300 :
6301 20105 : case DECL_IN:
6302 20105 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6303 20105 : break;
6304 :
6305 3570 : case DECL_OUT:
6306 3570 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6307 3570 : break;
6308 :
6309 2969 : case DECL_INOUT:
6310 2969 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6311 2969 : break;
6312 :
6313 5 : case DECL_INTRINSIC:
6314 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6315 5 : break;
6316 :
6317 5039 : case DECL_OPTIONAL:
6318 5039 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6319 5039 : break;
6320 :
6321 266 : case DECL_KIND:
6322 266 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6323 266 : break;
6324 :
6325 293 : case DECL_LEN:
6326 293 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6327 293 : break;
6328 :
6329 14087 : case DECL_PARAMETER:
6330 14087 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6331 14087 : break;
6332 :
6333 12076 : case DECL_POINTER:
6334 12076 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6335 12076 : break;
6336 :
6337 50 : case DECL_PROTECTED:
6338 50 : if (gfc_current_state () != COMP_MODULE
6339 48 : || (gfc_current_ns->proc_name
6340 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6341 : {
6342 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6343 : "part of a module");
6344 2 : t = false;
6345 2 : break;
6346 : }
6347 :
6348 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6349 : t = false;
6350 : else
6351 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6352 : break;
6353 :
6354 213 : case DECL_PRIVATE:
6355 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6356 : &seen_at[d]);
6357 213 : break;
6358 :
6359 244 : case DECL_PUBLIC:
6360 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6361 : &seen_at[d]);
6362 244 : break;
6363 :
6364 1207 : case DECL_STATIC:
6365 1207 : case DECL_SAVE:
6366 1207 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6367 1207 : break;
6368 :
6369 37 : case DECL_AUTOMATIC:
6370 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6371 37 : break;
6372 :
6373 5266 : case DECL_TARGET:
6374 5266 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6375 5266 : break;
6376 :
6377 162 : case DECL_IS_BIND_C:
6378 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6379 162 : break;
6380 :
6381 10004 : case DECL_VALUE:
6382 10004 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6383 : t = false;
6384 : else
6385 10004 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6386 : break;
6387 :
6388 504 : case DECL_VOLATILE:
6389 504 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6390 : t = false;
6391 : else
6392 503 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6393 : break;
6394 :
6395 0 : default:
6396 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6397 : }
6398 :
6399 115925 : if (!t)
6400 : {
6401 35 : m = MATCH_ERROR;
6402 35 : goto cleanup;
6403 : }
6404 : }
6405 :
6406 : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6407 178459 : if ((gfc_current_state () == COMP_MODULE
6408 178459 : || gfc_current_state () == COMP_SUBMODULE)
6409 5667 : && !current_attr.save
6410 5485 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6411 5393 : current_attr.save = SAVE_IMPLICIT;
6412 :
6413 178459 : colon_seen = 1;
6414 178459 : return MATCH_YES;
6415 :
6416 32691 : cleanup:
6417 32691 : gfc_current_locus = start;
6418 32691 : gfc_free_array_spec (current_as);
6419 32691 : current_as = NULL;
6420 32691 : attr_seen = 0;
6421 32691 : return m;
6422 : }
6423 :
6424 :
6425 : /* Set the binding label, dest_label, either with the binding label
6426 : stored in the given gfc_typespec, ts, or if none was provided, it
6427 : will be the symbol name in all lower case, as required by the draft
6428 : (J3/04-007, section 15.4.1). If a binding label was given and
6429 : there is more than one argument (num_idents), it is an error. */
6430 :
6431 : static bool
6432 310 : set_binding_label (const char **dest_label, const char *sym_name,
6433 : int num_idents)
6434 : {
6435 310 : if (num_idents > 1 && has_name_equals)
6436 : {
6437 4 : gfc_error ("Multiple identifiers provided with "
6438 : "single NAME= specifier at %C");
6439 4 : return false;
6440 : }
6441 :
6442 306 : if (curr_binding_label)
6443 : /* Binding label given; store in temp holder till have sym. */
6444 107 : *dest_label = curr_binding_label;
6445 : else
6446 : {
6447 : /* No binding label given, and the NAME= specifier did not exist,
6448 : which means there was no NAME="". */
6449 199 : if (sym_name != NULL && has_name_equals == 0)
6450 169 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6451 : }
6452 :
6453 : return true;
6454 : }
6455 :
6456 :
6457 : /* Set the status of the given common block as being BIND(C) or not,
6458 : depending on the given parameter, is_bind_c. */
6459 :
6460 : static void
6461 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6462 : {
6463 76 : com_block->is_bind_c = is_bind_c;
6464 76 : return;
6465 : }
6466 :
6467 :
6468 : /* Verify that the given gfc_typespec is for a C interoperable type. */
6469 :
6470 : bool
6471 19896 : gfc_verify_c_interop (gfc_typespec *ts)
6472 : {
6473 19896 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6474 4276 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6475 8509 : ? true : false;
6476 15636 : else if (ts->type == BT_CLASS)
6477 : return false;
6478 15628 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6479 3897 : return false;
6480 :
6481 : return true;
6482 : }
6483 :
6484 :
6485 : /* Verify that the variables of a given common block, which has been
6486 : defined with the attribute specifier bind(c), to be of a C
6487 : interoperable type. Errors will be reported here, if
6488 : encountered. */
6489 :
6490 : bool
6491 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6492 : {
6493 1 : gfc_symbol *curr_sym = NULL;
6494 1 : bool retval = true;
6495 :
6496 1 : curr_sym = com_block->head;
6497 :
6498 : /* Make sure we have at least one symbol. */
6499 1 : if (curr_sym == NULL)
6500 : return retval;
6501 :
6502 : /* Here we know we have a symbol, so we'll execute this loop
6503 : at least once. */
6504 1 : do
6505 : {
6506 : /* The second to last param, 1, says this is in a common block. */
6507 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6508 1 : curr_sym = curr_sym->common_next;
6509 1 : } while (curr_sym != NULL);
6510 :
6511 : return retval;
6512 : }
6513 :
6514 :
6515 : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6516 : an appropriate error message is reported. */
6517 :
6518 : bool
6519 6746 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6520 : int is_in_common, gfc_common_head *com_block)
6521 : {
6522 6746 : bool bind_c_function = false;
6523 6746 : bool retval = true;
6524 :
6525 6746 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6526 6746 : bind_c_function = true;
6527 :
6528 6746 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6529 : {
6530 2583 : tmp_sym = tmp_sym->result;
6531 : /* Make sure it wasn't an implicitly typed result. */
6532 2583 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6533 : {
6534 1 : gfc_warning (OPT_Wc_binding_type,
6535 : "Implicitly declared BIND(C) function %qs at "
6536 : "%L may not be C interoperable", tmp_sym->name,
6537 : &tmp_sym->declared_at);
6538 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6539 : /* Mark it as C interoperable to prevent duplicate warnings. */
6540 1 : tmp_sym->ts.is_c_interop = 1;
6541 1 : tmp_sym->attr.is_c_interop = 1;
6542 : }
6543 : }
6544 :
6545 : /* Here, we know we have the bind(c) attribute, so if we have
6546 : enough type info, then verify that it's a C interop kind.
6547 : The info could be in the symbol already, or possibly still in
6548 : the given ts (current_ts), so look in both. */
6549 6746 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6550 : {
6551 2741 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6552 : {
6553 : /* See if we're dealing with a sym in a common block or not. */
6554 162 : if (is_in_common == 1 && warn_c_binding_type)
6555 : {
6556 0 : gfc_warning (OPT_Wc_binding_type,
6557 : "Variable %qs in common block %qs at %L "
6558 : "may not be a C interoperable "
6559 : "kind though common block %qs is BIND(C)",
6560 : tmp_sym->name, com_block->name,
6561 0 : &(tmp_sym->declared_at), com_block->name);
6562 : }
6563 : else
6564 : {
6565 162 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6566 160 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6567 : {
6568 3 : gfc_error ("Type declaration %qs at %L is not C "
6569 : "interoperable but it is BIND(C)",
6570 : tmp_sym->name, &(tmp_sym->declared_at));
6571 3 : retval = false;
6572 : }
6573 159 : else if (warn_c_binding_type)
6574 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6575 : "may not be a C interoperable "
6576 : "kind but it is BIND(C)",
6577 : tmp_sym->name, &(tmp_sym->declared_at));
6578 : }
6579 : }
6580 :
6581 : /* Variables declared w/in a common block can't be bind(c)
6582 : since there's no way for C to see these variables, so there's
6583 : semantically no reason for the attribute. */
6584 2741 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6585 : {
6586 1 : gfc_error ("Variable %qs in common block %qs at "
6587 : "%L cannot be declared with BIND(C) "
6588 : "since it is not a global",
6589 1 : tmp_sym->name, com_block->name,
6590 : &(tmp_sym->declared_at));
6591 1 : retval = false;
6592 : }
6593 :
6594 : /* Scalar variables that are bind(c) cannot have the pointer
6595 : or allocatable attributes. */
6596 2741 : if (tmp_sym->attr.is_bind_c == 1)
6597 : {
6598 2221 : if (tmp_sym->attr.pointer == 1)
6599 : {
6600 1 : gfc_error ("Variable %qs at %L cannot have both the "
6601 : "POINTER and BIND(C) attributes",
6602 : tmp_sym->name, &(tmp_sym->declared_at));
6603 1 : retval = false;
6604 : }
6605 :
6606 2221 : if (tmp_sym->attr.allocatable == 1)
6607 : {
6608 0 : gfc_error ("Variable %qs at %L cannot have both the "
6609 : "ALLOCATABLE and BIND(C) attributes",
6610 : tmp_sym->name, &(tmp_sym->declared_at));
6611 0 : retval = false;
6612 : }
6613 :
6614 : }
6615 :
6616 : /* If it is a BIND(C) function, make sure the return value is a
6617 : scalar value. The previous tests in this function made sure
6618 : the type is interoperable. */
6619 2741 : if (bind_c_function && tmp_sym->as != NULL)
6620 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6621 : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6622 :
6623 : /* BIND(C) functions cannot return a character string. */
6624 2583 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6625 68 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6626 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6627 : "type at %L must have length 1", tmp_sym->name,
6628 : &(tmp_sym->declared_at));
6629 : }
6630 :
6631 : /* See if the symbol has been marked as private. If it has, warn if
6632 : there is a binding label with default binding name. */
6633 6746 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6634 11 : && tmp_sym->binding_label
6635 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6636 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6637 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6638 4 : gfc_warning (OPT_Wsurprising,
6639 : "Symbol %qs at %L is marked PRIVATE but is accessible "
6640 : "via its default binding name %qs", tmp_sym->name,
6641 : &(tmp_sym->declared_at), tmp_sym->binding_label);
6642 :
6643 6746 : return retval;
6644 : }
6645 :
6646 :
6647 : /* Set the appropriate fields for a symbol that's been declared as
6648 : BIND(C) (the is_bind_c flag and the binding label), and verify that
6649 : the type is C interoperable. Errors are reported by the functions
6650 : used to set/test these fields. */
6651 :
6652 : static bool
6653 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6654 : {
6655 47 : bool retval = true;
6656 :
6657 : /* TODO: Do we need to make sure the vars aren't marked private? */
6658 :
6659 : /* Set the is_bind_c bit in symbol_attribute. */
6660 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6661 :
6662 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6663 : return false;
6664 :
6665 : return retval;
6666 : }
6667 :
6668 :
6669 : /* Set the fields marking the given common block as BIND(C), including
6670 : a binding label, and report any errors encountered. */
6671 :
6672 : static bool
6673 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6674 : {
6675 76 : bool retval = true;
6676 :
6677 : /* destLabel, common name, typespec (which may have binding label). */
6678 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6679 : num_idents))
6680 : return false;
6681 :
6682 : /* Set the given common block (com_block) to being bind(c) (1). */
6683 76 : set_com_block_bind_c (com_block, 1);
6684 :
6685 76 : return retval;
6686 : }
6687 :
6688 :
6689 : /* Retrieve the list of one or more identifiers that the given bind(c)
6690 : attribute applies to. */
6691 :
6692 : static bool
6693 102 : get_bind_c_idents (void)
6694 : {
6695 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6696 102 : int num_idents = 0;
6697 102 : gfc_symbol *tmp_sym = NULL;
6698 102 : match found_id;
6699 102 : gfc_common_head *com_block = NULL;
6700 :
6701 102 : if (gfc_match_name (name) == MATCH_YES)
6702 : {
6703 38 : found_id = MATCH_YES;
6704 38 : gfc_get_ha_symbol (name, &tmp_sym);
6705 : }
6706 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6707 : {
6708 64 : found_id = MATCH_YES;
6709 64 : com_block = gfc_get_common (name, 0);
6710 : }
6711 : else
6712 : {
6713 0 : gfc_error ("Need either entity or common block name for "
6714 : "attribute specification statement at %C");
6715 0 : return false;
6716 : }
6717 :
6718 : /* Save the current identifier and look for more. */
6719 123 : do
6720 : {
6721 : /* Increment the number of identifiers found for this spec stmt. */
6722 123 : num_idents++;
6723 :
6724 : /* Make sure we have a sym or com block, and verify that it can
6725 : be bind(c). Set the appropriate field(s) and look for more
6726 : identifiers. */
6727 123 : if (tmp_sym != NULL || com_block != NULL)
6728 : {
6729 123 : if (tmp_sym != NULL)
6730 : {
6731 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6732 : return false;
6733 : }
6734 : else
6735 : {
6736 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6737 : return false;
6738 : }
6739 :
6740 : /* Look to see if we have another identifier. */
6741 122 : tmp_sym = NULL;
6742 122 : if (gfc_match_eos () == MATCH_YES)
6743 : found_id = MATCH_NO;
6744 21 : else if (gfc_match_char (',') != MATCH_YES)
6745 : found_id = MATCH_NO;
6746 21 : else if (gfc_match_name (name) == MATCH_YES)
6747 : {
6748 9 : found_id = MATCH_YES;
6749 9 : gfc_get_ha_symbol (name, &tmp_sym);
6750 : }
6751 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6752 : {
6753 12 : found_id = MATCH_YES;
6754 12 : com_block = gfc_get_common (name, 0);
6755 : }
6756 : else
6757 : {
6758 0 : gfc_error ("Missing entity or common block name for "
6759 : "attribute specification statement at %C");
6760 0 : return false;
6761 : }
6762 : }
6763 : else
6764 : {
6765 0 : gfc_internal_error ("Missing symbol");
6766 : }
6767 122 : } while (found_id == MATCH_YES);
6768 :
6769 : /* if we get here we were successful */
6770 : return true;
6771 : }
6772 :
6773 :
6774 : /* Try and match a BIND(C) attribute specification statement. */
6775 :
6776 : match
6777 140 : gfc_match_bind_c_stmt (void)
6778 : {
6779 140 : match found_match = MATCH_NO;
6780 140 : gfc_typespec *ts;
6781 :
6782 140 : ts = ¤t_ts;
6783 :
6784 : /* This may not be necessary. */
6785 140 : gfc_clear_ts (ts);
6786 : /* Clear the temporary binding label holder. */
6787 140 : curr_binding_label = NULL;
6788 :
6789 : /* Look for the bind(c). */
6790 140 : found_match = gfc_match_bind_c (NULL, true);
6791 :
6792 140 : if (found_match == MATCH_YES)
6793 : {
6794 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6795 : return MATCH_ERROR;
6796 :
6797 : /* Look for the :: now, but it is not required. */
6798 102 : gfc_match (" :: ");
6799 :
6800 : /* Get the identifier(s) that needs to be updated. This may need to
6801 : change to hand the flag(s) for the attr specified so all identifiers
6802 : found can have all appropriate parts updated (assuming that the same
6803 : spec stmt can have multiple attrs, such as both bind(c) and
6804 : allocatable...). */
6805 102 : if (!get_bind_c_idents ())
6806 : /* Error message should have printed already. */
6807 : return MATCH_ERROR;
6808 : }
6809 :
6810 : return found_match;
6811 : }
6812 :
6813 :
6814 : /* Match a data declaration statement. */
6815 :
6816 : match
6817 1003769 : gfc_match_data_decl (void)
6818 : {
6819 1003769 : gfc_symbol *sym;
6820 1003769 : match m;
6821 1003769 : int elem;
6822 :
6823 1003769 : type_param_spec_list = NULL;
6824 1003769 : decl_type_param_list = NULL;
6825 :
6826 1003769 : num_idents_on_line = 0;
6827 :
6828 1003769 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6829 1003769 : if (m != MATCH_YES)
6830 : return m;
6831 :
6832 210046 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6833 33974 : && !gfc_comp_struct (gfc_current_state ()))
6834 : {
6835 30716 : sym = gfc_use_derived (current_ts.u.derived);
6836 :
6837 30716 : if (sym == NULL)
6838 : {
6839 22 : m = MATCH_ERROR;
6840 22 : goto cleanup;
6841 : }
6842 :
6843 30694 : current_ts.u.derived = sym;
6844 : }
6845 :
6846 210024 : m = match_attr_spec ();
6847 210024 : if (m == MATCH_ERROR)
6848 : {
6849 84 : m = MATCH_NO;
6850 84 : goto cleanup;
6851 : }
6852 :
6853 : /* F2018:C708. */
6854 209940 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6855 : {
6856 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6857 6 : m = MATCH_ERROR;
6858 6 : goto cleanup;
6859 : }
6860 :
6861 209934 : if (current_ts.type == BT_CLASS
6862 10561 : && current_ts.u.derived->attr.unlimited_polymorphic)
6863 1875 : goto ok;
6864 :
6865 208059 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6866 32070 : && current_ts.u.derived->components == NULL
6867 2778 : && !current_ts.u.derived->attr.zero_comp)
6868 : {
6869 :
6870 210 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6871 136 : goto ok;
6872 :
6873 74 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6874 47 : goto ok;
6875 :
6876 27 : gfc_find_symbol (current_ts.u.derived->name,
6877 27 : current_ts.u.derived->ns, 1, &sym);
6878 :
6879 : /* Any symbol that we find had better be a type definition
6880 : which has its components defined, or be a structure definition
6881 : actively being parsed. */
6882 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6883 26 : && (current_ts.u.derived->components != NULL
6884 26 : || current_ts.u.derived->attr.zero_comp
6885 26 : || current_ts.u.derived == gfc_new_block))
6886 26 : goto ok;
6887 :
6888 1 : gfc_error ("Derived type at %C has not been previously defined "
6889 : "and so cannot appear in a derived type definition");
6890 1 : m = MATCH_ERROR;
6891 1 : goto cleanup;
6892 : }
6893 :
6894 207849 : ok:
6895 : /* If we have an old-style character declaration, and no new-style
6896 : attribute specifications, then there a comma is optional between
6897 : the type specification and the variable list. */
6898 209933 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6899 1407 : gfc_match_char (',');
6900 :
6901 : /* Give the types/attributes to symbols that follow. Give the element
6902 : a number so that repeat character length expressions can be copied. */
6903 : elem = 1;
6904 274342 : for (;;)
6905 : {
6906 274342 : num_idents_on_line++;
6907 274342 : m = variable_decl (elem++);
6908 274340 : if (m == MATCH_ERROR)
6909 408 : goto cleanup;
6910 273932 : if (m == MATCH_NO)
6911 : break;
6912 :
6913 273921 : if (gfc_match_eos () == MATCH_YES)
6914 209491 : goto cleanup;
6915 64430 : if (gfc_match_char (',') != MATCH_YES)
6916 : break;
6917 : }
6918 :
6919 32 : if (!gfc_error_flag_test ())
6920 : {
6921 : /* An anonymous structure declaration is unambiguous; if we matched one
6922 : according to gfc_match_structure_decl, we need to return MATCH_YES
6923 : here to avoid confusing the remaining matchers, even if there was an
6924 : error during variable_decl. We must flush any such errors. Note this
6925 : causes the parser to gracefully continue parsing the remaining input
6926 : as a structure body, which likely follows. */
6927 8 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
6928 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6929 : {
6930 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
6931 : " at %C");
6932 : /* Skip the bad variable_decl and line up for the start of the
6933 : structure body. */
6934 1 : gfc_error_recovery ();
6935 1 : m = MATCH_YES;
6936 1 : goto cleanup;
6937 : }
6938 :
6939 7 : gfc_error ("Syntax error in data declaration at %C");
6940 : }
6941 :
6942 31 : m = MATCH_ERROR;
6943 :
6944 31 : gfc_free_data_all (gfc_current_ns);
6945 :
6946 210044 : cleanup:
6947 210044 : if (saved_kind_expr)
6948 168 : gfc_free_expr (saved_kind_expr);
6949 210044 : if (type_param_spec_list)
6950 883 : gfc_free_actual_arglist (type_param_spec_list);
6951 210044 : if (decl_type_param_list)
6952 863 : gfc_free_actual_arglist (decl_type_param_list);
6953 210044 : saved_kind_expr = NULL;
6954 210044 : gfc_free_array_spec (current_as);
6955 210044 : current_as = NULL;
6956 210044 : return m;
6957 : }
6958 :
6959 : static bool
6960 23647 : in_module_or_interface(void)
6961 : {
6962 23647 : if (gfc_current_state () == COMP_MODULE
6963 23647 : || gfc_current_state () == COMP_SUBMODULE
6964 23647 : || gfc_current_state () == COMP_INTERFACE)
6965 : return true;
6966 :
6967 19828 : if (gfc_state_stack->state == COMP_CONTAINS
6968 19035 : || gfc_state_stack->state == COMP_FUNCTION
6969 18938 : || gfc_state_stack->state == COMP_SUBROUTINE)
6970 : {
6971 890 : gfc_state_data *p;
6972 933 : for (p = gfc_state_stack->previous; p ; p = p->previous)
6973 : {
6974 929 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
6975 109 : || p->state == COMP_INTERFACE)
6976 : return true;
6977 : }
6978 : }
6979 : return false;
6980 : }
6981 :
6982 : /* Match a prefix associated with a function or subroutine
6983 : declaration. If the typespec pointer is nonnull, then a typespec
6984 : can be matched. Note that if nothing matches, MATCH_YES is
6985 : returned (the null string was matched). */
6986 :
6987 : match
6988 235584 : gfc_match_prefix (gfc_typespec *ts)
6989 : {
6990 235584 : bool seen_type;
6991 235584 : bool seen_impure;
6992 235584 : bool found_prefix;
6993 :
6994 235584 : gfc_clear_attr (¤t_attr);
6995 235584 : seen_type = false;
6996 235584 : seen_impure = false;
6997 :
6998 235584 : gcc_assert (!gfc_matching_prefix);
6999 235584 : gfc_matching_prefix = true;
7000 :
7001 245068 : do
7002 : {
7003 264310 : found_prefix = false;
7004 :
7005 : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
7006 : corresponding attribute seems natural and distinguishes these
7007 : procedures from procedure types of PROC_MODULE, which these are
7008 : as well. */
7009 264310 : if (gfc_match ("module% ") == MATCH_YES)
7010 : {
7011 23922 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
7012 275 : goto error;
7013 :
7014 23647 : if (!in_module_or_interface ())
7015 : {
7016 18942 : gfc_error ("MODULE prefix at %C found outside of a module, "
7017 : "submodule, or interface");
7018 18942 : goto error;
7019 : }
7020 :
7021 4705 : current_attr.module_procedure = 1;
7022 4705 : found_prefix = true;
7023 : }
7024 :
7025 245093 : if (!seen_type && ts != NULL)
7026 : {
7027 131796 : match m;
7028 131796 : m = gfc_match_decl_type_spec (ts, 0);
7029 131796 : if (m == MATCH_ERROR)
7030 15 : goto error;
7031 131781 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
7032 : {
7033 : seen_type = true;
7034 : found_prefix = true;
7035 : }
7036 : }
7037 :
7038 245078 : if (gfc_match ("elemental% ") == MATCH_YES)
7039 : {
7040 5151 : if (!gfc_add_elemental (¤t_attr, NULL))
7041 2 : goto error;
7042 :
7043 : found_prefix = true;
7044 : }
7045 :
7046 245076 : if (gfc_match ("pure% ") == MATCH_YES)
7047 : {
7048 2373 : if (!gfc_add_pure (¤t_attr, NULL))
7049 2 : goto error;
7050 :
7051 : found_prefix = true;
7052 : }
7053 :
7054 245074 : if (gfc_match ("recursive% ") == MATCH_YES)
7055 : {
7056 463 : if (!gfc_add_recursive (¤t_attr, NULL))
7057 2 : goto error;
7058 :
7059 : found_prefix = true;
7060 : }
7061 :
7062 : /* IMPURE is a somewhat special case, as it needs not set an actual
7063 : attribute but rather only prevents ELEMENTAL routines from being
7064 : automatically PURE. */
7065 245072 : if (gfc_match ("impure% ") == MATCH_YES)
7066 : {
7067 663 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7068 4 : goto error;
7069 :
7070 : seen_impure = true;
7071 : found_prefix = true;
7072 : }
7073 : }
7074 : while (found_prefix);
7075 :
7076 : /* IMPURE and PURE must not both appear, of course. */
7077 216342 : if (seen_impure && current_attr.pure)
7078 : {
7079 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7080 4 : goto error;
7081 : }
7082 :
7083 : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7084 215683 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7085 : {
7086 4510 : if (!gfc_add_pure (¤t_attr, NULL))
7087 0 : goto error;
7088 : }
7089 :
7090 : /* At this point, the next item is not a prefix. */
7091 216338 : gcc_assert (gfc_matching_prefix);
7092 :
7093 216338 : gfc_matching_prefix = false;
7094 216338 : return MATCH_YES;
7095 :
7096 19246 : error:
7097 19246 : gcc_assert (gfc_matching_prefix);
7098 19246 : gfc_matching_prefix = false;
7099 19246 : return MATCH_ERROR;
7100 : }
7101 :
7102 :
7103 : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7104 :
7105 : static bool
7106 61307 : copy_prefix (symbol_attribute *dest, locus *where)
7107 : {
7108 61307 : if (dest->module_procedure)
7109 : {
7110 664 : if (current_attr.elemental)
7111 7 : dest->elemental = 1;
7112 :
7113 664 : if (current_attr.pure)
7114 55 : dest->pure = 1;
7115 :
7116 664 : if (current_attr.recursive)
7117 8 : dest->recursive = 1;
7118 :
7119 : /* Module procedures are unusual in that the 'dest' is copied from
7120 : the interface declaration. However, this is an oportunity to
7121 : check that the submodule declaration is compliant with the
7122 : interface. */
7123 664 : if (dest->elemental && !current_attr.elemental)
7124 : {
7125 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7126 : "missing at %L", where);
7127 1 : return false;
7128 : }
7129 :
7130 663 : if (dest->pure && !current_attr.pure)
7131 : {
7132 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7133 : "missing at %L", where);
7134 1 : return false;
7135 : }
7136 :
7137 662 : if (dest->recursive && !current_attr.recursive)
7138 : {
7139 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7140 : "missing at %L", where);
7141 1 : return false;
7142 : }
7143 :
7144 : return true;
7145 : }
7146 :
7147 60643 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7148 : return false;
7149 :
7150 60641 : if (current_attr.pure && !gfc_add_pure (dest, where))
7151 : return false;
7152 :
7153 60641 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7154 : return false;
7155 :
7156 : return true;
7157 : }
7158 :
7159 :
7160 : /* Match a formal argument list or, if typeparam is true, a
7161 : type_param_name_list. */
7162 :
7163 : match
7164 473532 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7165 : int null_flag, bool typeparam)
7166 : {
7167 473532 : gfc_formal_arglist *head, *tail, *p, *q;
7168 473532 : char name[GFC_MAX_SYMBOL_LEN + 1];
7169 473532 : gfc_symbol *sym;
7170 473532 : match m;
7171 473532 : gfc_formal_arglist *formal = NULL;
7172 :
7173 473532 : head = tail = NULL;
7174 :
7175 : /* Keep the interface formal argument list and null it so that the
7176 : matching for the new declaration can be done. The numbers and
7177 : names of the arguments are checked here. The interface formal
7178 : arguments are retained in formal_arglist and the characteristics
7179 : are compared in resolve.cc(resolve_fl_procedure). See the remark
7180 : in get_proc_name about the eventual need to copy the formal_arglist
7181 : and populate the formal namespace of the interface symbol. */
7182 473532 : if (progname->attr.module_procedure
7183 668 : && progname->attr.host_assoc)
7184 : {
7185 180 : formal = progname->formal;
7186 180 : progname->formal = NULL;
7187 : }
7188 :
7189 473532 : if (gfc_match_char ('(') != MATCH_YES)
7190 : {
7191 280586 : if (null_flag)
7192 6392 : goto ok;
7193 : return MATCH_NO;
7194 : }
7195 :
7196 192946 : if (gfc_match_char (')') == MATCH_YES)
7197 : {
7198 10206 : if (typeparam)
7199 : {
7200 1 : gfc_error_now ("A type parameter list is required at %C");
7201 1 : m = MATCH_ERROR;
7202 1 : goto cleanup;
7203 : }
7204 : else
7205 10205 : goto ok;
7206 : }
7207 :
7208 243952 : for (;;)
7209 : {
7210 243952 : gfc_gobble_whitespace ();
7211 243952 : if (gfc_match_char ('*') == MATCH_YES)
7212 : {
7213 10274 : sym = NULL;
7214 10274 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7215 : "Alternate-return argument at %C"))
7216 : {
7217 1 : m = MATCH_ERROR;
7218 1 : goto cleanup;
7219 : }
7220 10273 : else if (typeparam)
7221 2 : gfc_error_now ("A parameter name is required at %C");
7222 : }
7223 : else
7224 : {
7225 233678 : locus loc = gfc_current_locus;
7226 233678 : m = gfc_match_name (name);
7227 233678 : if (m != MATCH_YES)
7228 : {
7229 15813 : if(typeparam)
7230 1 : gfc_error_now ("A parameter name is required at %C");
7231 15829 : goto cleanup;
7232 : }
7233 217865 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7234 :
7235 217865 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7236 16 : goto cleanup;
7237 217849 : else if (typeparam
7238 217849 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7239 0 : goto cleanup;
7240 : }
7241 :
7242 228122 : p = gfc_get_formal_arglist ();
7243 :
7244 228122 : if (head == NULL)
7245 : head = tail = p;
7246 : else
7247 : {
7248 60509 : tail->next = p;
7249 60509 : tail = p;
7250 : }
7251 :
7252 228122 : tail->sym = sym;
7253 :
7254 : /* We don't add the VARIABLE flavor because the name could be a
7255 : dummy procedure. We don't apply these attributes to formal
7256 : arguments of statement functions. */
7257 217849 : if (sym != NULL && !st_flag
7258 326676 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7259 98554 : || !gfc_missing_attr (&sym->attr, NULL)))
7260 : {
7261 0 : m = MATCH_ERROR;
7262 0 : goto cleanup;
7263 : }
7264 :
7265 : /* The name of a program unit can be in a different namespace,
7266 : so check for it explicitly. After the statement is accepted,
7267 : the name is checked for especially in gfc_get_symbol(). */
7268 228122 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7269 97337 : && strcmp (sym->name, gfc_new_block->name) == 0)
7270 : {
7271 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7272 : sym->name);
7273 0 : m = MATCH_ERROR;
7274 0 : goto cleanup;
7275 : }
7276 :
7277 228122 : if (gfc_match_char (')') == MATCH_YES)
7278 119853 : goto ok;
7279 :
7280 108269 : m = gfc_match_char (',');
7281 108269 : if (m != MATCH_YES)
7282 : {
7283 47057 : if (typeparam)
7284 1 : gfc_error_now ("Expected parameter list in type declaration "
7285 : "at %C");
7286 : else
7287 47056 : gfc_error ("Unexpected junk in formal argument list at %C");
7288 47057 : goto cleanup;
7289 : }
7290 : }
7291 :
7292 136450 : ok:
7293 : /* Check for duplicate symbols in the formal argument list. */
7294 136450 : if (head != NULL)
7295 : {
7296 178755 : for (p = head; p->next; p = p->next)
7297 : {
7298 58950 : if (p->sym == NULL)
7299 327 : continue;
7300 :
7301 234019 : for (q = p->next; q; q = q->next)
7302 175444 : if (p->sym == q->sym)
7303 : {
7304 48 : if (typeparam)
7305 1 : gfc_error_now ("Duplicate name %qs in parameter "
7306 : "list at %C", p->sym->name);
7307 : else
7308 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7309 : "list at %C", p->sym->name);
7310 :
7311 48 : m = MATCH_ERROR;
7312 48 : goto cleanup;
7313 : }
7314 : }
7315 : }
7316 :
7317 136402 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7318 : {
7319 0 : m = MATCH_ERROR;
7320 0 : goto cleanup;
7321 : }
7322 :
7323 : /* gfc_error_now used in following and return with MATCH_YES because
7324 : doing otherwise results in a cascade of extraneous errors and in
7325 : some cases an ICE in symbol.cc(gfc_release_symbol). */
7326 136402 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7327 : {
7328 179 : bool arg_count_mismatch = false;
7329 :
7330 179 : if (!formal && head)
7331 : arg_count_mismatch = true;
7332 :
7333 : /* Abbreviated module procedure declaration is not meant to have any
7334 : formal arguments! */
7335 179 : if (!progname->abr_modproc_decl && formal && !head)
7336 1 : arg_count_mismatch = true;
7337 :
7338 349 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7339 : {
7340 170 : if ((p->next != NULL && q->next == NULL)
7341 169 : || (p->next == NULL && q->next != NULL))
7342 : arg_count_mismatch = true;
7343 168 : else if ((p->sym == NULL && q->sym == NULL)
7344 168 : || (p->sym && q->sym
7345 166 : && strcmp (p->sym->name, q->sym->name) == 0))
7346 164 : continue;
7347 : else
7348 : {
7349 4 : if (q->sym == NULL)
7350 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7351 : "conflicts with alternate return at %C",
7352 : p->sym->name);
7353 3 : else if (p->sym == NULL)
7354 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7355 : "alternate return and conflicts with "
7356 : "%qs in the separate declaration at %C",
7357 : q->sym->name);
7358 : else
7359 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7360 : "argument names (%s/%s) at %C",
7361 : p->sym->name, q->sym->name);
7362 : }
7363 : }
7364 :
7365 179 : if (arg_count_mismatch)
7366 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7367 : "formal arguments at %C");
7368 : }
7369 :
7370 : return MATCH_YES;
7371 :
7372 62936 : cleanup:
7373 62936 : gfc_free_formal_arglist (head);
7374 62936 : return m;
7375 : }
7376 :
7377 :
7378 : /* Match a RESULT specification following a function declaration or
7379 : ENTRY statement. Also matches the end-of-statement. */
7380 :
7381 : static match
7382 7905 : match_result (gfc_symbol *function, gfc_symbol **result)
7383 : {
7384 7905 : char name[GFC_MAX_SYMBOL_LEN + 1];
7385 7905 : gfc_symbol *r;
7386 7905 : match m;
7387 :
7388 7905 : if (gfc_match (" result (") != MATCH_YES)
7389 : return MATCH_NO;
7390 :
7391 5862 : m = gfc_match_name (name);
7392 5862 : if (m != MATCH_YES)
7393 : return m;
7394 :
7395 : /* Get the right paren, and that's it because there could be the
7396 : bind(c) attribute after the result clause. */
7397 5862 : if (gfc_match_char (')') != MATCH_YES)
7398 : {
7399 : /* TODO: should report the missing right paren here. */
7400 : return MATCH_ERROR;
7401 : }
7402 :
7403 5862 : if (strcmp (function->name, name) == 0)
7404 : {
7405 1 : gfc_error ("RESULT variable at %C must be different than function name");
7406 1 : return MATCH_ERROR;
7407 : }
7408 :
7409 5861 : if (gfc_get_symbol (name, NULL, &r))
7410 : return MATCH_ERROR;
7411 :
7412 5861 : if (!gfc_add_result (&r->attr, r->name, NULL))
7413 : return MATCH_ERROR;
7414 :
7415 5861 : *result = r;
7416 :
7417 5861 : return MATCH_YES;
7418 : }
7419 :
7420 :
7421 : /* Match a function suffix, which could be a combination of a result
7422 : clause and BIND(C), either one, or neither. The draft does not
7423 : require them to come in a specific order. */
7424 :
7425 : static match
7426 7909 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7427 : {
7428 7909 : match is_bind_c; /* Found bind(c). */
7429 7909 : match is_result; /* Found result clause. */
7430 7909 : match found_match; /* Status of whether we've found a good match. */
7431 7909 : char peek_char; /* Character we're going to peek at. */
7432 7909 : bool allow_binding_name;
7433 :
7434 : /* Initialize to having found nothing. */
7435 7909 : found_match = MATCH_NO;
7436 7909 : is_bind_c = MATCH_NO;
7437 7909 : is_result = MATCH_NO;
7438 :
7439 : /* Get the next char to narrow between result and bind(c). */
7440 7909 : gfc_gobble_whitespace ();
7441 7909 : peek_char = gfc_peek_ascii_char ();
7442 :
7443 : /* C binding names are not allowed for internal procedures. */
7444 7909 : if (gfc_current_state () == COMP_CONTAINS
7445 4633 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7446 : allow_binding_name = false;
7447 : else
7448 6264 : allow_binding_name = true;
7449 :
7450 7909 : switch (peek_char)
7451 : {
7452 5491 : case 'r':
7453 : /* Look for result clause. */
7454 5491 : is_result = match_result (sym, result);
7455 5491 : if (is_result == MATCH_YES)
7456 : {
7457 : /* Now see if there is a bind(c) after it. */
7458 5490 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7459 : /* We've found the result clause and possibly bind(c). */
7460 5490 : found_match = MATCH_YES;
7461 : }
7462 : else
7463 : /* This should only be MATCH_ERROR. */
7464 : found_match = is_result;
7465 : break;
7466 2418 : case 'b':
7467 : /* Look for bind(c) first. */
7468 2418 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7469 2418 : if (is_bind_c == MATCH_YES)
7470 : {
7471 : /* Now see if a result clause followed it. */
7472 2414 : is_result = match_result (sym, result);
7473 2414 : found_match = MATCH_YES;
7474 : }
7475 : else
7476 : {
7477 : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7478 : found_match = MATCH_ERROR;
7479 : }
7480 : break;
7481 0 : default:
7482 0 : gfc_error ("Unexpected junk after function declaration at %C");
7483 0 : found_match = MATCH_ERROR;
7484 0 : break;
7485 : }
7486 :
7487 7904 : if (is_bind_c == MATCH_YES)
7488 : {
7489 : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7490 2563 : if (gfc_current_state () == COMP_CONTAINS
7491 416 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7492 2575 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7493 : "at %L may not be specified for an internal "
7494 : "procedure", &gfc_current_locus))
7495 : return MATCH_ERROR;
7496 :
7497 2560 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7498 : return MATCH_ERROR;
7499 : }
7500 :
7501 : return found_match;
7502 : }
7503 :
7504 :
7505 : /* Procedure pointer return value without RESULT statement:
7506 : Add "hidden" result variable named "ppr@". */
7507 :
7508 : static bool
7509 72747 : add_hidden_procptr_result (gfc_symbol *sym)
7510 : {
7511 72747 : bool case1,case2;
7512 :
7513 72747 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7514 : return false;
7515 :
7516 : /* First usage case: PROCEDURE and EXTERNAL statements. */
7517 1520 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7518 1520 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7519 73133 : && sym->attr.external;
7520 : /* Second usage case: INTERFACE statements. */
7521 13937 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7522 13937 : && gfc_state_stack->previous->state == COMP_FUNCTION
7523 72794 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7524 :
7525 72563 : if (case1 || case2)
7526 : {
7527 124 : gfc_symtree *stree;
7528 124 : if (case1)
7529 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7530 : else
7531 : {
7532 30 : gfc_symtree *st2;
7533 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7534 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7535 30 : st2->n.sym = stree->n.sym;
7536 30 : stree->n.sym->refs++;
7537 : }
7538 124 : sym->result = stree->n.sym;
7539 :
7540 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7541 124 : sym->result->attr.pointer = sym->attr.pointer;
7542 124 : sym->result->attr.external = sym->attr.external;
7543 124 : sym->result->attr.referenced = sym->attr.referenced;
7544 124 : sym->result->ts = sym->ts;
7545 124 : sym->attr.proc_pointer = 0;
7546 124 : sym->attr.pointer = 0;
7547 124 : sym->attr.external = 0;
7548 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7549 : {
7550 4 : sym->result->attr.pointer = 0;
7551 4 : sym->result->attr.proc_pointer = 1;
7552 : }
7553 :
7554 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7555 : }
7556 : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7557 72469 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7558 399 : && sym->result && sym->result != sym && sym->result->attr.external
7559 28 : && sym == gfc_current_ns->proc_name
7560 28 : && sym == sym->result->ns->proc_name
7561 28 : && strcmp ("ppr@", sym->result->name) == 0)
7562 : {
7563 28 : sym->result->attr.proc_pointer = 1;
7564 28 : sym->attr.pointer = 0;
7565 28 : return true;
7566 : }
7567 : else
7568 : return false;
7569 : }
7570 :
7571 :
7572 : /* Match the interface for a PROCEDURE declaration,
7573 : including brackets (R1212). */
7574 :
7575 : static match
7576 1552 : match_procedure_interface (gfc_symbol **proc_if)
7577 : {
7578 1552 : match m;
7579 1552 : gfc_symtree *st;
7580 1552 : locus old_loc, entry_loc;
7581 1552 : gfc_namespace *old_ns = gfc_current_ns;
7582 1552 : char name[GFC_MAX_SYMBOL_LEN + 1];
7583 :
7584 1552 : old_loc = entry_loc = gfc_current_locus;
7585 1552 : gfc_clear_ts (¤t_ts);
7586 :
7587 1552 : if (gfc_match (" (") != MATCH_YES)
7588 : {
7589 1 : gfc_current_locus = entry_loc;
7590 1 : return MATCH_NO;
7591 : }
7592 :
7593 : /* Get the type spec. for the procedure interface. */
7594 1551 : old_loc = gfc_current_locus;
7595 1551 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7596 1551 : gfc_gobble_whitespace ();
7597 1551 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7598 391 : goto got_ts;
7599 :
7600 1160 : if (m == MATCH_ERROR)
7601 : return m;
7602 :
7603 : /* Procedure interface is itself a procedure. */
7604 1160 : gfc_current_locus = old_loc;
7605 1160 : m = gfc_match_name (name);
7606 :
7607 : /* First look to see if it is already accessible in the current
7608 : namespace because it is use associated or contained. */
7609 1160 : st = NULL;
7610 1160 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7611 : return MATCH_ERROR;
7612 :
7613 : /* If it is still not found, then try the parent namespace, if it
7614 : exists and create the symbol there if it is still not found. */
7615 1160 : if (gfc_current_ns->parent)
7616 387 : gfc_current_ns = gfc_current_ns->parent;
7617 1160 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7618 : return MATCH_ERROR;
7619 :
7620 1160 : gfc_current_ns = old_ns;
7621 1160 : *proc_if = st->n.sym;
7622 :
7623 1160 : if (*proc_if)
7624 : {
7625 1160 : (*proc_if)->refs++;
7626 : /* Resolve interface if possible. That way, attr.procedure is only set
7627 : if it is declared by a later procedure-declaration-stmt, which is
7628 : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7629 1160 : while ((*proc_if)->ts.interface
7630 1167 : && *proc_if != (*proc_if)->ts.interface)
7631 7 : *proc_if = (*proc_if)->ts.interface;
7632 :
7633 1160 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7634 387 : && (*proc_if)->ts.type == BT_UNKNOWN
7635 1547 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7636 : (*proc_if)->name, NULL))
7637 : return MATCH_ERROR;
7638 : }
7639 :
7640 0 : got_ts:
7641 1551 : if (gfc_match (" )") != MATCH_YES)
7642 : {
7643 0 : gfc_current_locus = entry_loc;
7644 0 : return MATCH_NO;
7645 : }
7646 :
7647 : return MATCH_YES;
7648 : }
7649 :
7650 :
7651 : /* Match a PROCEDURE declaration (R1211). */
7652 :
7653 : static match
7654 1126 : match_procedure_decl (void)
7655 : {
7656 1126 : match m;
7657 1126 : gfc_symbol *sym, *proc_if = NULL;
7658 1126 : int num;
7659 1126 : gfc_expr *initializer = NULL;
7660 :
7661 : /* Parse interface (with brackets). */
7662 1126 : m = match_procedure_interface (&proc_if);
7663 1126 : if (m != MATCH_YES)
7664 : return m;
7665 :
7666 : /* Parse attributes (with colons). */
7667 1126 : m = match_attr_spec();
7668 1126 : if (m == MATCH_ERROR)
7669 : return MATCH_ERROR;
7670 :
7671 1125 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7672 : {
7673 17 : current_attr.is_bind_c = 1;
7674 17 : has_name_equals = 0;
7675 17 : curr_binding_label = NULL;
7676 : }
7677 :
7678 : /* Get procedure symbols. */
7679 79 : for(num=1;;num++)
7680 : {
7681 1204 : m = gfc_match_symbol (&sym, 0);
7682 1204 : if (m == MATCH_NO)
7683 1 : goto syntax;
7684 1203 : else if (m == MATCH_ERROR)
7685 : return m;
7686 :
7687 : /* Add current_attr to the symbol attributes. */
7688 1203 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7689 : return MATCH_ERROR;
7690 :
7691 1201 : if (sym->attr.is_bind_c)
7692 : {
7693 : /* Check for C1218. */
7694 54 : if (!proc_if || !proc_if->attr.is_bind_c)
7695 : {
7696 1 : gfc_error ("BIND(C) attribute at %C requires "
7697 : "an interface with BIND(C)");
7698 1 : return MATCH_ERROR;
7699 : }
7700 : /* Check for C1217. */
7701 53 : if (has_name_equals && sym->attr.pointer)
7702 : {
7703 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7704 : "POINTER attribute at %C");
7705 1 : return MATCH_ERROR;
7706 : }
7707 52 : if (has_name_equals && sym->attr.dummy)
7708 : {
7709 1 : gfc_error ("Dummy procedure at %C may not have "
7710 : "BIND(C) attribute with NAME");
7711 1 : return MATCH_ERROR;
7712 : }
7713 : /* Set binding label for BIND(C). */
7714 51 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7715 : return MATCH_ERROR;
7716 : }
7717 :
7718 1197 : if (!gfc_add_external (&sym->attr, NULL))
7719 : return MATCH_ERROR;
7720 :
7721 1193 : if (add_hidden_procptr_result (sym))
7722 67 : sym = sym->result;
7723 :
7724 1193 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7725 : return MATCH_ERROR;
7726 :
7727 : /* Set interface. */
7728 1192 : if (proc_if != NULL)
7729 : {
7730 853 : if (sym->ts.type != BT_UNKNOWN)
7731 : {
7732 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7733 : sym->name, &gfc_current_locus,
7734 : gfc_basic_typename (sym->ts.type));
7735 1 : return MATCH_ERROR;
7736 : }
7737 852 : sym->ts.interface = proc_if;
7738 852 : sym->attr.untyped = 1;
7739 852 : sym->attr.if_source = IFSRC_IFBODY;
7740 : }
7741 339 : else if (current_ts.type != BT_UNKNOWN)
7742 : {
7743 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7744 : return MATCH_ERROR;
7745 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7746 198 : sym->ts.interface->ts = current_ts;
7747 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7748 198 : sym->ts.interface->attr.function = 1;
7749 198 : sym->attr.function = 1;
7750 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7751 : }
7752 :
7753 1190 : if (gfc_match (" =>") == MATCH_YES)
7754 : {
7755 87 : if (!current_attr.pointer)
7756 : {
7757 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7758 0 : m = MATCH_ERROR;
7759 0 : goto cleanup;
7760 : }
7761 :
7762 87 : m = match_pointer_init (&initializer, 1);
7763 87 : if (m != MATCH_YES)
7764 1 : goto cleanup;
7765 :
7766 86 : if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
7767 0 : goto cleanup;
7768 :
7769 : }
7770 :
7771 1189 : if (gfc_match_eos () == MATCH_YES)
7772 : return MATCH_YES;
7773 79 : if (gfc_match_char (',') != MATCH_YES)
7774 0 : goto syntax;
7775 : }
7776 :
7777 1 : syntax:
7778 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7779 1 : return MATCH_ERROR;
7780 :
7781 1 : cleanup:
7782 : /* Free stuff up and return. */
7783 1 : gfc_free_expr (initializer);
7784 1 : return m;
7785 : }
7786 :
7787 :
7788 : static match
7789 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7790 :
7791 :
7792 : /* Match a procedure pointer component declaration (R445). */
7793 :
7794 : static match
7795 426 : match_ppc_decl (void)
7796 : {
7797 426 : match m;
7798 426 : gfc_symbol *proc_if = NULL;
7799 426 : gfc_typespec ts;
7800 426 : int num;
7801 426 : gfc_component *c;
7802 426 : gfc_expr *initializer = NULL;
7803 426 : gfc_typebound_proc* tb;
7804 426 : char name[GFC_MAX_SYMBOL_LEN + 1];
7805 :
7806 : /* Parse interface (with brackets). */
7807 426 : m = match_procedure_interface (&proc_if);
7808 426 : if (m != MATCH_YES)
7809 1 : goto syntax;
7810 :
7811 : /* Parse attributes. */
7812 425 : tb = XCNEW (gfc_typebound_proc);
7813 425 : tb->where = gfc_current_locus;
7814 425 : m = match_binding_attributes (tb, false, true);
7815 425 : if (m == MATCH_ERROR)
7816 : return m;
7817 :
7818 422 : gfc_clear_attr (¤t_attr);
7819 422 : current_attr.procedure = 1;
7820 422 : current_attr.proc_pointer = 1;
7821 422 : current_attr.access = tb->access;
7822 422 : current_attr.flavor = FL_PROCEDURE;
7823 :
7824 : /* Match the colons (required). */
7825 422 : if (gfc_match (" ::") != MATCH_YES)
7826 : {
7827 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7828 1 : return MATCH_ERROR;
7829 : }
7830 :
7831 : /* Check for C450. */
7832 421 : if (!tb->nopass && proc_if == NULL)
7833 : {
7834 2 : gfc_error("NOPASS or explicit interface required at %C");
7835 2 : return MATCH_ERROR;
7836 : }
7837 :
7838 419 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7839 : return MATCH_ERROR;
7840 :
7841 : /* Match PPC names. */
7842 418 : ts = current_ts;
7843 418 : for(num=1;;num++)
7844 : {
7845 419 : m = gfc_match_name (name);
7846 419 : if (m == MATCH_NO)
7847 0 : goto syntax;
7848 419 : else if (m == MATCH_ERROR)
7849 : return m;
7850 :
7851 419 : if (!gfc_add_component (gfc_current_block(), name, &c))
7852 : return MATCH_ERROR;
7853 :
7854 : /* Add current_attr to the symbol attributes. */
7855 419 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
7856 : return MATCH_ERROR;
7857 :
7858 419 : if (!gfc_add_external (&c->attr, NULL))
7859 : return MATCH_ERROR;
7860 :
7861 419 : if (!gfc_add_proc (&c->attr, name, NULL))
7862 : return MATCH_ERROR;
7863 :
7864 419 : if (num == 1)
7865 418 : c->tb = tb;
7866 : else
7867 : {
7868 1 : c->tb = XCNEW (gfc_typebound_proc);
7869 1 : c->tb->where = gfc_current_locus;
7870 1 : *c->tb = *tb;
7871 : }
7872 :
7873 419 : if (saved_kind_expr)
7874 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
7875 :
7876 : /* Set interface. */
7877 419 : if (proc_if != NULL)
7878 : {
7879 352 : c->ts.interface = proc_if;
7880 352 : c->attr.untyped = 1;
7881 352 : c->attr.if_source = IFSRC_IFBODY;
7882 : }
7883 67 : else if (ts.type != BT_UNKNOWN)
7884 : {
7885 29 : c->ts = ts;
7886 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7887 29 : c->ts.interface->result = c->ts.interface;
7888 29 : c->ts.interface->ts = ts;
7889 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
7890 29 : c->ts.interface->attr.function = 1;
7891 29 : c->attr.function = 1;
7892 29 : c->attr.if_source = IFSRC_UNKNOWN;
7893 : }
7894 :
7895 419 : if (gfc_match (" =>") == MATCH_YES)
7896 : {
7897 66 : m = match_pointer_init (&initializer, 1);
7898 66 : if (m != MATCH_YES)
7899 : {
7900 0 : gfc_free_expr (initializer);
7901 0 : return m;
7902 : }
7903 66 : c->initializer = initializer;
7904 : }
7905 :
7906 419 : if (gfc_match_eos () == MATCH_YES)
7907 : return MATCH_YES;
7908 1 : if (gfc_match_char (',') != MATCH_YES)
7909 0 : goto syntax;
7910 : }
7911 :
7912 1 : syntax:
7913 1 : gfc_error ("Syntax error in procedure pointer component at %C");
7914 1 : return MATCH_ERROR;
7915 : }
7916 :
7917 :
7918 : /* Match a PROCEDURE declaration inside an interface (R1206). */
7919 :
7920 : static match
7921 1561 : match_procedure_in_interface (void)
7922 : {
7923 1561 : match m;
7924 1561 : gfc_symbol *sym;
7925 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
7926 1561 : locus old_locus;
7927 :
7928 1561 : if (current_interface.type == INTERFACE_NAMELESS
7929 1561 : || current_interface.type == INTERFACE_ABSTRACT)
7930 : {
7931 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
7932 1 : return MATCH_ERROR;
7933 : }
7934 :
7935 : /* Check if the F2008 optional double colon appears. */
7936 1560 : gfc_gobble_whitespace ();
7937 1560 : old_locus = gfc_current_locus;
7938 1560 : if (gfc_match ("::") == MATCH_YES)
7939 : {
7940 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
7941 : "MODULE PROCEDURE statement at %L", &old_locus))
7942 : return MATCH_ERROR;
7943 : }
7944 : else
7945 685 : gfc_current_locus = old_locus;
7946 :
7947 2214 : for(;;)
7948 : {
7949 2214 : m = gfc_match_name (name);
7950 2214 : if (m == MATCH_NO)
7951 0 : goto syntax;
7952 2214 : else if (m == MATCH_ERROR)
7953 : return m;
7954 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
7955 : return MATCH_ERROR;
7956 :
7957 2214 : if (!gfc_add_interface (sym))
7958 : return MATCH_ERROR;
7959 :
7960 2213 : if (gfc_match_eos () == MATCH_YES)
7961 : break;
7962 655 : if (gfc_match_char (',') != MATCH_YES)
7963 0 : goto syntax;
7964 : }
7965 :
7966 : return MATCH_YES;
7967 :
7968 0 : syntax:
7969 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7970 0 : return MATCH_ERROR;
7971 : }
7972 :
7973 :
7974 : /* General matcher for PROCEDURE declarations. */
7975 :
7976 : static match match_procedure_in_type (void);
7977 :
7978 : match
7979 6252 : gfc_match_procedure (void)
7980 : {
7981 6252 : match m;
7982 :
7983 6252 : switch (gfc_current_state ())
7984 : {
7985 1126 : case COMP_NONE:
7986 1126 : case COMP_PROGRAM:
7987 1126 : case COMP_MODULE:
7988 1126 : case COMP_SUBMODULE:
7989 1126 : case COMP_SUBROUTINE:
7990 1126 : case COMP_FUNCTION:
7991 1126 : case COMP_BLOCK:
7992 1126 : m = match_procedure_decl ();
7993 1126 : break;
7994 1561 : case COMP_INTERFACE:
7995 1561 : m = match_procedure_in_interface ();
7996 1561 : break;
7997 426 : case COMP_DERIVED:
7998 426 : m = match_ppc_decl ();
7999 426 : break;
8000 3139 : case COMP_DERIVED_CONTAINS:
8001 3139 : m = match_procedure_in_type ();
8002 3139 : break;
8003 : default:
8004 : return MATCH_NO;
8005 : }
8006 :
8007 6252 : if (m != MATCH_YES)
8008 : return m;
8009 :
8010 6196 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
8011 4 : return MATCH_ERROR;
8012 :
8013 : return m;
8014 : }
8015 :
8016 :
8017 : /* Warn if a matched procedure has the same name as an intrinsic; this is
8018 : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
8019 : parser-state-stack to find out whether we're in a module. */
8020 :
8021 : static void
8022 61304 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
8023 : {
8024 61304 : bool in_module;
8025 :
8026 122608 : in_module = (gfc_state_stack->previous
8027 61304 : && (gfc_state_stack->previous->state == COMP_MODULE
8028 49898 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
8029 :
8030 61304 : gfc_warn_intrinsic_shadow (sym, in_module, func);
8031 61304 : }
8032 :
8033 :
8034 : /* Match a function declaration. */
8035 :
8036 : match
8037 125352 : gfc_match_function_decl (void)
8038 : {
8039 125352 : char name[GFC_MAX_SYMBOL_LEN + 1];
8040 125352 : gfc_symbol *sym, *result;
8041 125352 : locus old_loc;
8042 125352 : match m;
8043 125352 : match suffix_match;
8044 125352 : match found_match; /* Status returned by match func. */
8045 :
8046 125352 : if (gfc_current_state () != COMP_NONE
8047 78646 : && gfc_current_state () != COMP_INTERFACE
8048 51050 : && gfc_current_state () != COMP_CONTAINS)
8049 : return MATCH_NO;
8050 :
8051 125352 : gfc_clear_ts (¤t_ts);
8052 :
8053 125352 : old_loc = gfc_current_locus;
8054 :
8055 125352 : m = gfc_match_prefix (¤t_ts);
8056 125352 : if (m != MATCH_YES)
8057 : {
8058 9625 : gfc_current_locus = old_loc;
8059 9625 : return m;
8060 : }
8061 :
8062 115727 : if (gfc_match ("function% %n", name) != MATCH_YES)
8063 : {
8064 96777 : gfc_current_locus = old_loc;
8065 96777 : return MATCH_NO;
8066 : }
8067 :
8068 18950 : if (get_proc_name (name, &sym, false))
8069 : return MATCH_ERROR;
8070 :
8071 18945 : if (add_hidden_procptr_result (sym))
8072 20 : sym = sym->result;
8073 :
8074 18945 : if (current_attr.module_procedure)
8075 289 : sym->attr.module_procedure = 1;
8076 :
8077 18945 : gfc_new_block = sym;
8078 :
8079 18945 : m = gfc_match_formal_arglist (sym, 0, 0);
8080 18945 : if (m == MATCH_NO)
8081 : {
8082 6 : gfc_error ("Expected formal argument list in function "
8083 : "definition at %C");
8084 6 : m = MATCH_ERROR;
8085 6 : goto cleanup;
8086 : }
8087 18939 : else if (m == MATCH_ERROR)
8088 0 : goto cleanup;
8089 :
8090 18939 : result = NULL;
8091 :
8092 : /* According to the draft, the bind(c) and result clause can
8093 : come in either order after the formal_arg_list (i.e., either
8094 : can be first, both can exist together or by themselves or neither
8095 : one). Therefore, the match_result can't match the end of the
8096 : string, and check for the bind(c) or result clause in either order. */
8097 18939 : found_match = gfc_match_eos ();
8098 :
8099 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8100 : must have been marked BIND(C) with a BIND(C) attribute and that is
8101 : not allowed for procedures. */
8102 18939 : if (sym->attr.is_bind_c == 1)
8103 : {
8104 3 : sym->attr.is_bind_c = 0;
8105 :
8106 3 : if (gfc_state_stack->previous
8107 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8108 : {
8109 1 : locus loc;
8110 1 : loc = sym->old_symbol != NULL
8111 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8112 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8113 : "variables or common blocks", &loc);
8114 : }
8115 : }
8116 :
8117 18939 : if (found_match != MATCH_YES)
8118 : {
8119 : /* If we haven't found the end-of-statement, look for a suffix. */
8120 7678 : suffix_match = gfc_match_suffix (sym, &result);
8121 7678 : if (suffix_match == MATCH_YES)
8122 : /* Need to get the eos now. */
8123 7670 : found_match = gfc_match_eos ();
8124 : else
8125 : found_match = suffix_match;
8126 : }
8127 :
8128 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8129 : subprogram and a binding label is specified, it shall be the
8130 : same as the binding label specified in the corresponding module
8131 : procedure interface body. */
8132 18939 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8133 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8134 3 : && sym->binding_label && sym->old_symbol->binding_label
8135 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8136 : {
8137 1 : const char *null = "NULL", *s1, *s2;
8138 1 : s1 = sym->binding_label;
8139 1 : if (!s1) s1 = null;
8140 1 : s2 = sym->old_symbol->binding_label;
8141 1 : if (!s2) s2 = null;
8142 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8143 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8144 1 : return MATCH_ERROR;
8145 : }
8146 :
8147 18938 : if(found_match != MATCH_YES)
8148 : m = MATCH_ERROR;
8149 : else
8150 : {
8151 : /* Make changes to the symbol. */
8152 18930 : m = MATCH_ERROR;
8153 :
8154 18930 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8155 0 : goto cleanup;
8156 :
8157 18930 : if (!gfc_missing_attr (&sym->attr, NULL))
8158 0 : goto cleanup;
8159 :
8160 18930 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8161 : {
8162 1 : if(!sym->attr.module_procedure)
8163 1 : goto cleanup;
8164 : else
8165 0 : gfc_error_check ();
8166 : }
8167 :
8168 : /* Delay matching the function characteristics until after the
8169 : specification block by signalling kind=-1. */
8170 18929 : sym->declared_at = old_loc;
8171 18929 : if (current_ts.type != BT_UNKNOWN)
8172 6737 : current_ts.kind = -1;
8173 : else
8174 12192 : current_ts.kind = 0;
8175 :
8176 18929 : if (result == NULL)
8177 : {
8178 13280 : if (current_ts.type != BT_UNKNOWN
8179 13280 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8180 1 : goto cleanup;
8181 13279 : sym->result = sym;
8182 : }
8183 : else
8184 : {
8185 5649 : if (current_ts.type != BT_UNKNOWN
8186 5649 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8187 0 : goto cleanup;
8188 5649 : sym->result = result;
8189 : }
8190 :
8191 : /* Warn if this procedure has the same name as an intrinsic. */
8192 18928 : do_warn_intrinsic_shadow (sym, true);
8193 :
8194 18928 : return MATCH_YES;
8195 : }
8196 :
8197 16 : cleanup:
8198 16 : gfc_current_locus = old_loc;
8199 16 : return m;
8200 : }
8201 :
8202 :
8203 : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8204 : pass the name of the entry, rather than the gfc_current_block name, and
8205 : to return false upon finding an existing global entry. */
8206 :
8207 : static bool
8208 504 : add_global_entry (const char *name, const char *binding_label, bool sub,
8209 : locus *where)
8210 : {
8211 504 : gfc_gsymbol *s;
8212 504 : enum gfc_symbol_type type;
8213 :
8214 504 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8215 :
8216 : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8217 : name is a global identifier. */
8218 504 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8219 : {
8220 499 : s = gfc_get_gsymbol (name, false);
8221 :
8222 499 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8223 : {
8224 2 : gfc_global_used (s, where);
8225 2 : return false;
8226 : }
8227 : else
8228 : {
8229 497 : s->type = type;
8230 497 : s->sym_name = name;
8231 497 : s->where = *where;
8232 497 : s->defined = 1;
8233 497 : s->ns = gfc_current_ns;
8234 : }
8235 : }
8236 :
8237 : /* Don't add the symbol multiple times. */
8238 502 : if (binding_label
8239 502 : && (!gfc_notification_std (GFC_STD_F2008)
8240 0 : || strcmp (name, binding_label) != 0))
8241 : {
8242 5 : s = gfc_get_gsymbol (binding_label, true);
8243 :
8244 5 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8245 : {
8246 1 : gfc_global_used (s, where);
8247 1 : return false;
8248 : }
8249 : else
8250 : {
8251 4 : s->type = type;
8252 4 : s->sym_name = name;
8253 4 : s->binding_label = binding_label;
8254 4 : s->where = *where;
8255 4 : s->defined = 1;
8256 4 : s->ns = gfc_current_ns;
8257 : }
8258 : }
8259 :
8260 : return true;
8261 : }
8262 :
8263 :
8264 : /* Match an ENTRY statement. */
8265 :
8266 : match
8267 769 : gfc_match_entry (void)
8268 : {
8269 769 : gfc_symbol *proc;
8270 769 : gfc_symbol *result;
8271 769 : gfc_symbol *entry;
8272 769 : char name[GFC_MAX_SYMBOL_LEN + 1];
8273 769 : gfc_compile_state state;
8274 769 : match m;
8275 769 : gfc_entry_list *el;
8276 769 : locus old_loc;
8277 769 : bool module_procedure;
8278 769 : char peek_char;
8279 769 : match is_bind_c;
8280 :
8281 769 : m = gfc_match_name (name);
8282 769 : if (m != MATCH_YES)
8283 : return m;
8284 :
8285 769 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8286 : return MATCH_ERROR;
8287 :
8288 769 : state = gfc_current_state ();
8289 769 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8290 : {
8291 3 : switch (state)
8292 : {
8293 0 : case COMP_PROGRAM:
8294 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8295 0 : break;
8296 0 : case COMP_MODULE:
8297 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8298 0 : break;
8299 0 : case COMP_SUBMODULE:
8300 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8301 0 : break;
8302 0 : case COMP_BLOCK_DATA:
8303 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8304 : "a BLOCK DATA");
8305 0 : break;
8306 0 : case COMP_INTERFACE:
8307 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8308 : "an INTERFACE");
8309 0 : break;
8310 1 : case COMP_STRUCTURE:
8311 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8312 : "a STRUCTURE block");
8313 1 : break;
8314 0 : case COMP_DERIVED:
8315 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8316 : "a DERIVED TYPE block");
8317 0 : break;
8318 0 : case COMP_IF:
8319 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8320 : "an IF-THEN block");
8321 0 : break;
8322 0 : case COMP_DO:
8323 0 : case COMP_DO_CONCURRENT:
8324 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8325 : "a DO block");
8326 0 : break;
8327 0 : case COMP_SELECT:
8328 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8329 : "a SELECT block");
8330 0 : break;
8331 0 : case COMP_FORALL:
8332 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8333 : "a FORALL block");
8334 0 : break;
8335 0 : case COMP_WHERE:
8336 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8337 : "a WHERE block");
8338 0 : break;
8339 0 : case COMP_CONTAINS:
8340 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8341 : "a contained subprogram");
8342 0 : break;
8343 2 : default:
8344 2 : gfc_error ("Unexpected ENTRY statement at %C");
8345 : }
8346 3 : return MATCH_ERROR;
8347 : }
8348 :
8349 766 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8350 766 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8351 : {
8352 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8353 1 : return MATCH_ERROR;
8354 : }
8355 :
8356 1530 : module_procedure = gfc_current_ns->parent != NULL
8357 259 : && gfc_current_ns->parent->proc_name
8358 765 : && gfc_current_ns->parent->proc_name->attr.flavor
8359 259 : == FL_MODULE;
8360 :
8361 765 : if (gfc_current_ns->parent != NULL
8362 259 : && gfc_current_ns->parent->proc_name
8363 259 : && !module_procedure)
8364 : {
8365 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8366 : "contained procedure");
8367 0 : return MATCH_ERROR;
8368 : }
8369 :
8370 : /* Module function entries need special care in get_proc_name
8371 : because previous references within the function will have
8372 : created symbols attached to the current namespace. */
8373 765 : if (get_proc_name (name, &entry,
8374 : gfc_current_ns->parent != NULL
8375 765 : && module_procedure))
8376 : return MATCH_ERROR;
8377 :
8378 763 : proc = gfc_current_block ();
8379 :
8380 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8381 : must have been marked BIND(C) with a BIND(C) attribute and that is
8382 : not allowed for procedures. */
8383 763 : if (entry->attr.is_bind_c == 1)
8384 : {
8385 0 : locus loc;
8386 :
8387 0 : entry->attr.is_bind_c = 0;
8388 :
8389 0 : loc = entry->old_symbol != NULL
8390 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8391 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8392 : "variables or common blocks", &loc);
8393 : }
8394 :
8395 : /* Check what next non-whitespace character is so we can tell if there
8396 : is the required parens if we have a BIND(C). */
8397 763 : old_loc = gfc_current_locus;
8398 763 : gfc_gobble_whitespace ();
8399 763 : peek_char = gfc_peek_ascii_char ();
8400 :
8401 763 : if (state == COMP_SUBROUTINE)
8402 : {
8403 134 : m = gfc_match_formal_arglist (entry, 0, 1);
8404 134 : if (m != MATCH_YES)
8405 : return MATCH_ERROR;
8406 :
8407 : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8408 : never be an internal procedure. */
8409 134 : is_bind_c = gfc_match_bind_c (entry, true);
8410 134 : if (is_bind_c == MATCH_ERROR)
8411 : return MATCH_ERROR;
8412 134 : if (is_bind_c == MATCH_YES)
8413 : {
8414 22 : if (peek_char != '(')
8415 : {
8416 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8417 0 : return MATCH_ERROR;
8418 : }
8419 :
8420 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8421 22 : &(entry->declared_at), 1))
8422 : return MATCH_ERROR;
8423 :
8424 : }
8425 :
8426 134 : if (!gfc_current_ns->parent
8427 134 : && !add_global_entry (name, entry->binding_label, true,
8428 : &old_loc))
8429 : return MATCH_ERROR;
8430 :
8431 : /* An entry in a subroutine. */
8432 131 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8433 131 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8434 3 : return MATCH_ERROR;
8435 : }
8436 : else
8437 : {
8438 : /* An entry in a function.
8439 : We need to take special care because writing
8440 : ENTRY f()
8441 : as
8442 : ENTRY f
8443 : is allowed, whereas
8444 : ENTRY f() RESULT (r)
8445 : can't be written as
8446 : ENTRY f RESULT (r). */
8447 629 : if (gfc_match_eos () == MATCH_YES)
8448 : {
8449 24 : gfc_current_locus = old_loc;
8450 : /* Match the empty argument list, and add the interface to
8451 : the symbol. */
8452 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8453 : }
8454 : else
8455 605 : m = gfc_match_formal_arglist (entry, 0, 0);
8456 :
8457 629 : if (m != MATCH_YES)
8458 : return MATCH_ERROR;
8459 :
8460 628 : result = NULL;
8461 :
8462 628 : if (gfc_match_eos () == MATCH_YES)
8463 : {
8464 397 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8465 397 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8466 2 : return MATCH_ERROR;
8467 :
8468 395 : entry->result = entry;
8469 : }
8470 : else
8471 : {
8472 231 : m = gfc_match_suffix (entry, &result);
8473 231 : if (m == MATCH_NO)
8474 0 : gfc_syntax_error (ST_ENTRY);
8475 231 : if (m != MATCH_YES)
8476 : return MATCH_ERROR;
8477 :
8478 231 : if (result)
8479 : {
8480 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8481 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8482 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8483 0 : return MATCH_ERROR;
8484 212 : entry->result = result;
8485 : }
8486 : else
8487 : {
8488 19 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8489 19 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8490 0 : return MATCH_ERROR;
8491 19 : entry->result = entry;
8492 : }
8493 : }
8494 :
8495 626 : if (!gfc_current_ns->parent
8496 626 : && !add_global_entry (name, entry->binding_label, false,
8497 : &old_loc))
8498 : return MATCH_ERROR;
8499 : }
8500 :
8501 754 : if (gfc_match_eos () != MATCH_YES)
8502 : {
8503 0 : gfc_syntax_error (ST_ENTRY);
8504 0 : return MATCH_ERROR;
8505 : }
8506 :
8507 : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8508 754 : if (proc->attr.elemental && entry->attr.is_bind_c)
8509 : {
8510 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8511 : "elemental procedure", &entry->declared_at);
8512 2 : return MATCH_ERROR;
8513 : }
8514 :
8515 752 : entry->attr.recursive = proc->attr.recursive;
8516 752 : entry->attr.elemental = proc->attr.elemental;
8517 752 : entry->attr.pure = proc->attr.pure;
8518 :
8519 752 : el = gfc_get_entry_list ();
8520 752 : el->sym = entry;
8521 752 : el->next = gfc_current_ns->entries;
8522 752 : gfc_current_ns->entries = el;
8523 752 : if (el->next)
8524 84 : el->id = el->next->id + 1;
8525 : else
8526 668 : el->id = 1;
8527 :
8528 752 : new_st.op = EXEC_ENTRY;
8529 752 : new_st.ext.entry = el;
8530 :
8531 752 : return MATCH_YES;
8532 : }
8533 :
8534 :
8535 : /* Match a subroutine statement, including optional prefixes. */
8536 :
8537 : match
8538 792766 : gfc_match_subroutine (void)
8539 : {
8540 792766 : char name[GFC_MAX_SYMBOL_LEN + 1];
8541 792766 : gfc_symbol *sym;
8542 792766 : match m;
8543 792766 : match is_bind_c;
8544 792766 : char peek_char;
8545 792766 : bool allow_binding_name;
8546 792766 : locus loc;
8547 :
8548 792766 : if (gfc_current_state () != COMP_NONE
8549 751808 : && gfc_current_state () != COMP_INTERFACE
8550 730003 : && gfc_current_state () != COMP_CONTAINS)
8551 : return MATCH_NO;
8552 :
8553 103497 : m = gfc_match_prefix (NULL);
8554 103497 : if (m != MATCH_YES)
8555 : return m;
8556 :
8557 93882 : loc = gfc_current_locus;
8558 93882 : m = gfc_match ("subroutine% %n", name);
8559 93882 : if (m != MATCH_YES)
8560 : return m;
8561 :
8562 42413 : if (get_proc_name (name, &sym, false))
8563 : return MATCH_ERROR;
8564 :
8565 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8566 : the symbol existed before. */
8567 42401 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8568 : &gfc_current_locus);
8569 :
8570 42401 : if (current_attr.module_procedure)
8571 367 : sym->attr.module_procedure = 1;
8572 :
8573 42401 : if (add_hidden_procptr_result (sym))
8574 9 : sym = sym->result;
8575 :
8576 42401 : gfc_new_block = sym;
8577 :
8578 : /* Check what next non-whitespace character is so we can tell if there
8579 : is the required parens if we have a BIND(C). */
8580 42401 : gfc_gobble_whitespace ();
8581 42401 : peek_char = gfc_peek_ascii_char ();
8582 :
8583 42401 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8584 : return MATCH_ERROR;
8585 :
8586 42398 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8587 : return MATCH_ERROR;
8588 :
8589 : /* Make sure that it isn't already declared as BIND(C). If it is, it
8590 : must have been marked BIND(C) with a BIND(C) attribute and that is
8591 : not allowed for procedures. */
8592 42398 : if (sym->attr.is_bind_c == 1)
8593 : {
8594 4 : sym->attr.is_bind_c = 0;
8595 :
8596 4 : if (gfc_state_stack->previous
8597 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8598 : {
8599 2 : locus loc;
8600 2 : loc = sym->old_symbol != NULL
8601 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8602 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8603 : "variables or common blocks", &loc);
8604 : }
8605 : }
8606 :
8607 : /* C binding names are not allowed for internal procedures. */
8608 42398 : if (gfc_current_state () == COMP_CONTAINS
8609 25672 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8610 : allow_binding_name = false;
8611 : else
8612 27679 : allow_binding_name = true;
8613 :
8614 : /* Here, we are just checking if it has the bind(c) attribute, and if
8615 : so, then we need to make sure it's all correct. If it doesn't,
8616 : we still need to continue matching the rest of the subroutine line. */
8617 42398 : gfc_gobble_whitespace ();
8618 42398 : loc = gfc_current_locus;
8619 42398 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8620 42398 : if (is_bind_c == MATCH_ERROR)
8621 : {
8622 : /* There was an attempt at the bind(c), but it was wrong. An
8623 : error message should have been printed w/in the gfc_match_bind_c
8624 : so here we'll just return the MATCH_ERROR. */
8625 : return MATCH_ERROR;
8626 : }
8627 :
8628 42385 : if (is_bind_c == MATCH_YES)
8629 : {
8630 3968 : gfc_formal_arglist *arg;
8631 :
8632 : /* The following is allowed in the Fortran 2008 draft. */
8633 3968 : if (gfc_current_state () == COMP_CONTAINS
8634 1297 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8635 4379 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8636 : "at %L may not be specified for an internal "
8637 : "procedure", &gfc_current_locus))
8638 : return MATCH_ERROR;
8639 :
8640 3965 : if (peek_char != '(')
8641 : {
8642 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8643 1 : return MATCH_ERROR;
8644 : }
8645 :
8646 : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8647 : subprogram and a binding label is specified, it shall be the
8648 : same as the binding label specified in the corresponding module
8649 : procedure interface body. */
8650 3964 : if (sym->attr.module_procedure && sym->old_symbol
8651 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8652 3 : && sym->binding_label && sym->old_symbol->binding_label
8653 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8654 : {
8655 1 : const char *null = "NULL", *s1, *s2;
8656 1 : s1 = sym->binding_label;
8657 1 : if (!s1) s1 = null;
8658 1 : s2 = sym->old_symbol->binding_label;
8659 1 : if (!s2) s2 = null;
8660 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8661 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8662 1 : return MATCH_ERROR;
8663 : }
8664 :
8665 : /* Scan the dummy arguments for an alternate return. */
8666 12240 : for (arg = sym->formal; arg; arg = arg->next)
8667 8278 : if (!arg->sym)
8668 : {
8669 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8670 : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8671 1 : return MATCH_ERROR;
8672 : }
8673 :
8674 3962 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8675 : return MATCH_ERROR;
8676 : }
8677 :
8678 42378 : if (gfc_match_eos () != MATCH_YES)
8679 : {
8680 1 : gfc_syntax_error (ST_SUBROUTINE);
8681 1 : return MATCH_ERROR;
8682 : }
8683 :
8684 42377 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8685 : {
8686 4 : if(!sym->attr.module_procedure)
8687 : return MATCH_ERROR;
8688 : else
8689 3 : gfc_error_check ();
8690 : }
8691 :
8692 : /* Warn if it has the same name as an intrinsic. */
8693 42376 : do_warn_intrinsic_shadow (sym, false);
8694 :
8695 42376 : return MATCH_YES;
8696 : }
8697 :
8698 :
8699 : /* Check that the NAME identifier in a BIND attribute or statement
8700 : is conform to C identifier rules. */
8701 :
8702 : match
8703 1162 : check_bind_name_identifier (char **name)
8704 : {
8705 1162 : char *n = *name, *p;
8706 :
8707 : /* Remove leading spaces. */
8708 1188 : while (*n == ' ')
8709 26 : n++;
8710 :
8711 : /* On an empty string, free memory and set name to NULL. */
8712 1162 : if (*n == '\0')
8713 : {
8714 42 : free (*name);
8715 42 : *name = NULL;
8716 42 : return MATCH_YES;
8717 : }
8718 :
8719 : /* Remove trailing spaces. */
8720 1120 : p = n + strlen(n) - 1;
8721 1136 : while (*p == ' ')
8722 16 : *(p--) = '\0';
8723 :
8724 : /* Insert the identifier into the symbol table. */
8725 1120 : p = xstrdup (n);
8726 1120 : free (*name);
8727 1120 : *name = p;
8728 :
8729 : /* Now check that identifier is valid under C rules. */
8730 1120 : if (ISDIGIT (*p))
8731 : {
8732 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8733 2 : return MATCH_ERROR;
8734 : }
8735 :
8736 12355 : for (; *p; p++)
8737 11240 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8738 : {
8739 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8740 3 : return MATCH_ERROR;
8741 : }
8742 :
8743 : return MATCH_YES;
8744 : }
8745 :
8746 :
8747 : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8748 : given, and set the binding label in either the given symbol (if not
8749 : NULL), or in the current_ts. The symbol may be NULL because we may
8750 : encounter the BIND(C) before the declaration itself. Return
8751 : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8752 : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8753 : or MATCH_YES if the specifier was correct and the binding label and
8754 : bind(c) fields were set correctly for the given symbol or the
8755 : current_ts. If allow_binding_name is false, no binding name may be
8756 : given. */
8757 :
8758 : match
8759 50743 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8760 : {
8761 50743 : char *binding_label = NULL;
8762 50743 : gfc_expr *e = NULL;
8763 :
8764 : /* Initialize the flag that specifies whether we encountered a NAME=
8765 : specifier or not. */
8766 50743 : has_name_equals = 0;
8767 :
8768 : /* This much we have to be able to match, in this order, if
8769 : there is a bind(c) label. */
8770 50743 : if (gfc_match (" bind ( c ") != MATCH_YES)
8771 : return MATCH_NO;
8772 :
8773 : /* Now see if there is a binding label, or if we've reached the
8774 : end of the bind(c) attribute without one. */
8775 6841 : if (gfc_match_char (',') == MATCH_YES)
8776 : {
8777 1169 : if (gfc_match (" name = ") != MATCH_YES)
8778 : {
8779 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8780 : "at %C");
8781 : /* should give an error message here */
8782 1 : return MATCH_ERROR;
8783 : }
8784 :
8785 1168 : has_name_equals = 1;
8786 :
8787 1168 : if (gfc_match_init_expr (&e) != MATCH_YES)
8788 : {
8789 2 : gfc_free_expr (e);
8790 2 : return MATCH_ERROR;
8791 : }
8792 :
8793 1166 : if (!gfc_simplify_expr(e, 0))
8794 : {
8795 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8796 0 : gfc_free_expr (e);
8797 0 : return MATCH_ERROR;
8798 : }
8799 :
8800 1166 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8801 1163 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
8802 : {
8803 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
8804 : "default character kind");
8805 4 : gfc_free_expr(e);
8806 4 : return MATCH_ERROR;
8807 : }
8808 :
8809 : // Get a C string from the Fortran string constant
8810 2324 : binding_label = gfc_widechar_to_char (e->value.character.string,
8811 1162 : e->value.character.length);
8812 1162 : gfc_free_expr(e);
8813 :
8814 : // Check that it is valid (old gfc_match_name_C)
8815 1162 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
8816 : return MATCH_ERROR;
8817 : }
8818 :
8819 : /* Get the required right paren. */
8820 6829 : if (gfc_match_char (')') != MATCH_YES)
8821 : {
8822 1 : gfc_error ("Missing closing paren for binding label at %C");
8823 1 : return MATCH_ERROR;
8824 : }
8825 :
8826 6828 : if (has_name_equals && !allow_binding_name)
8827 : {
8828 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
8829 6 : return MATCH_ERROR;
8830 : }
8831 :
8832 6822 : if (has_name_equals && sym != NULL && sym->attr.dummy)
8833 : {
8834 2 : gfc_error ("For dummy procedure %s, no binding name is "
8835 : "allowed in BIND(C) at %C", sym->name);
8836 2 : return MATCH_ERROR;
8837 : }
8838 :
8839 :
8840 : /* Save the binding label to the symbol. If sym is null, we're
8841 : probably matching the typespec attributes of a declaration and
8842 : haven't gotten the name yet, and therefore, no symbol yet. */
8843 6820 : if (binding_label)
8844 : {
8845 1108 : if (sym != NULL)
8846 999 : sym->binding_label = binding_label;
8847 : else
8848 109 : curr_binding_label = binding_label;
8849 : }
8850 5712 : else if (allow_binding_name)
8851 : {
8852 : /* No binding label, but if symbol isn't null, we
8853 : can set the label for it here.
8854 : If name="" or allow_binding_name is false, no C binding name is
8855 : created. */
8856 5289 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
8857 5122 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
8858 : }
8859 :
8860 6820 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
8861 718 : && current_interface.type == INTERFACE_ABSTRACT)
8862 : {
8863 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8864 1 : return MATCH_ERROR;
8865 : }
8866 :
8867 : return MATCH_YES;
8868 : }
8869 :
8870 :
8871 : /* Return nonzero if we're currently compiling a contained procedure. */
8872 :
8873 : static int
8874 61609 : contained_procedure (void)
8875 : {
8876 61609 : gfc_state_data *s = gfc_state_stack;
8877 :
8878 61609 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
8879 60729 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
8880 35898 : return 1;
8881 :
8882 : return 0;
8883 : }
8884 :
8885 : /* Set the kind of each enumerator. The kind is selected such that it is
8886 : interoperable with the corresponding C enumeration type, making
8887 : sure that -fshort-enums is honored. */
8888 :
8889 : static void
8890 158 : set_enum_kind(void)
8891 : {
8892 158 : enumerator_history *current_history = NULL;
8893 158 : int kind;
8894 158 : int i;
8895 :
8896 158 : if (max_enum == NULL || enum_history == NULL)
8897 : return;
8898 :
8899 150 : if (!flag_short_enums)
8900 : return;
8901 :
8902 : i = 0;
8903 48 : do
8904 : {
8905 48 : kind = gfc_integer_kinds[i++].kind;
8906 : }
8907 48 : while (kind < gfc_c_int_kind
8908 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
8909 : kind) != ARITH_OK);
8910 :
8911 24 : current_history = enum_history;
8912 96 : while (current_history != NULL)
8913 : {
8914 72 : current_history->sym->ts.kind = kind;
8915 72 : current_history = current_history->next;
8916 : }
8917 : }
8918 :
8919 :
8920 : /* Match any of the various end-block statements. Returns the type of
8921 : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8922 : and END BLOCK statements cannot be replaced by a single END statement. */
8923 :
8924 : match
8925 181579 : gfc_match_end (gfc_statement *st)
8926 : {
8927 181579 : char name[GFC_MAX_SYMBOL_LEN + 1];
8928 181579 : gfc_compile_state state;
8929 181579 : locus old_loc;
8930 181579 : const char *block_name;
8931 181579 : const char *target;
8932 181579 : int eos_ok;
8933 181579 : match m;
8934 181579 : gfc_namespace *parent_ns, *ns, *prev_ns;
8935 181579 : gfc_namespace **nsp;
8936 181579 : bool abbreviated_modproc_decl = false;
8937 181579 : bool got_matching_end = false;
8938 :
8939 181579 : old_loc = gfc_current_locus;
8940 181579 : if (gfc_match ("end") != MATCH_YES)
8941 : return MATCH_NO;
8942 :
8943 176567 : state = gfc_current_state ();
8944 96243 : block_name = gfc_current_block () == NULL
8945 176567 : ? NULL : gfc_current_block ()->name;
8946 :
8947 176567 : switch (state)
8948 : {
8949 2868 : case COMP_ASSOCIATE:
8950 2868 : case COMP_BLOCK:
8951 2868 : case COMP_CHANGE_TEAM:
8952 2868 : if (startswith (block_name, "block@"))
8953 : block_name = NULL;
8954 : break;
8955 :
8956 17007 : case COMP_CONTAINS:
8957 17007 : case COMP_DERIVED_CONTAINS:
8958 17007 : case COMP_OMP_BEGIN_METADIRECTIVE:
8959 17007 : state = gfc_state_stack->previous->state;
8960 15468 : block_name = gfc_state_stack->previous->sym == NULL
8961 17007 : ? NULL : gfc_state_stack->previous->sym->name;
8962 17007 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
8963 17007 : && gfc_state_stack->previous->sym->abr_modproc_decl;
8964 : break;
8965 :
8966 : case COMP_OMP_METADIRECTIVE:
8967 : {
8968 : /* Metadirectives can be nested, so we need to drill down to the
8969 : first state that is not COMP_OMP_METADIRECTIVE. */
8970 : gfc_state_data *state_data = gfc_state_stack;
8971 :
8972 85 : do
8973 : {
8974 85 : state_data = state_data->previous;
8975 85 : state = state_data->state;
8976 77 : block_name = (state_data->sym == NULL
8977 85 : ? NULL : state_data->sym->name);
8978 170 : abbreviated_modproc_decl = (state_data->sym
8979 85 : && state_data->sym->abr_modproc_decl);
8980 : }
8981 85 : while (state == COMP_OMP_METADIRECTIVE);
8982 :
8983 83 : if (block_name && startswith (block_name, "block@"))
8984 : block_name = NULL;
8985 : }
8986 : break;
8987 :
8988 : default:
8989 : break;
8990 : }
8991 :
8992 83 : if (!abbreviated_modproc_decl)
8993 176566 : abbreviated_modproc_decl = gfc_current_block ()
8994 176566 : && gfc_current_block ()->abr_modproc_decl;
8995 :
8996 176567 : switch (state)
8997 : {
8998 27545 : case COMP_NONE:
8999 27545 : case COMP_PROGRAM:
9000 27545 : *st = ST_END_PROGRAM;
9001 27545 : target = " program";
9002 27545 : eos_ok = 1;
9003 27545 : break;
9004 :
9005 42554 : case COMP_SUBROUTINE:
9006 42554 : *st = ST_END_SUBROUTINE;
9007 42554 : if (!abbreviated_modproc_decl)
9008 : target = " subroutine";
9009 : else
9010 135 : target = " procedure";
9011 42554 : eos_ok = !contained_procedure ();
9012 42554 : break;
9013 :
9014 19055 : case COMP_FUNCTION:
9015 19055 : *st = ST_END_FUNCTION;
9016 19055 : if (!abbreviated_modproc_decl)
9017 : target = " function";
9018 : else
9019 110 : target = " procedure";
9020 19055 : eos_ok = !contained_procedure ();
9021 19055 : break;
9022 :
9023 87 : case COMP_BLOCK_DATA:
9024 87 : *st = ST_END_BLOCK_DATA;
9025 87 : target = " block data";
9026 87 : eos_ok = 1;
9027 87 : break;
9028 :
9029 9607 : case COMP_MODULE:
9030 9607 : *st = ST_END_MODULE;
9031 9607 : target = " module";
9032 9607 : eos_ok = 1;
9033 9607 : break;
9034 :
9035 232 : case COMP_SUBMODULE:
9036 232 : *st = ST_END_SUBMODULE;
9037 232 : target = " submodule";
9038 232 : eos_ok = 1;
9039 232 : break;
9040 :
9041 10514 : case COMP_INTERFACE:
9042 10514 : *st = ST_END_INTERFACE;
9043 10514 : target = " interface";
9044 10514 : eos_ok = 0;
9045 10514 : break;
9046 :
9047 257 : case COMP_MAP:
9048 257 : *st = ST_END_MAP;
9049 257 : target = " map";
9050 257 : eos_ok = 0;
9051 257 : break;
9052 :
9053 132 : case COMP_UNION:
9054 132 : *st = ST_END_UNION;
9055 132 : target = " union";
9056 132 : eos_ok = 0;
9057 132 : break;
9058 :
9059 313 : case COMP_STRUCTURE:
9060 313 : *st = ST_END_STRUCTURE;
9061 313 : target = " structure";
9062 313 : eos_ok = 0;
9063 313 : break;
9064 :
9065 12592 : case COMP_DERIVED:
9066 12592 : case COMP_DERIVED_CONTAINS:
9067 12592 : *st = ST_END_TYPE;
9068 12592 : target = " type";
9069 12592 : eos_ok = 0;
9070 12592 : break;
9071 :
9072 1459 : case COMP_ASSOCIATE:
9073 1459 : *st = ST_END_ASSOCIATE;
9074 1459 : target = " associate";
9075 1459 : eos_ok = 0;
9076 1459 : break;
9077 :
9078 1365 : case COMP_BLOCK:
9079 1365 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9080 1365 : *st = ST_END_BLOCK;
9081 1365 : target = " block";
9082 1365 : eos_ok = 0;
9083 1365 : break;
9084 :
9085 14738 : case COMP_IF:
9086 14738 : *st = ST_ENDIF;
9087 14738 : target = " if";
9088 14738 : eos_ok = 0;
9089 14738 : break;
9090 :
9091 30382 : case COMP_DO:
9092 30382 : case COMP_DO_CONCURRENT:
9093 30382 : *st = ST_ENDDO;
9094 30382 : target = " do";
9095 30382 : eos_ok = 0;
9096 30382 : break;
9097 :
9098 54 : case COMP_CRITICAL:
9099 54 : *st = ST_END_CRITICAL;
9100 54 : target = " critical";
9101 54 : eos_ok = 0;
9102 54 : break;
9103 :
9104 4559 : case COMP_SELECT:
9105 4559 : case COMP_SELECT_TYPE:
9106 4559 : case COMP_SELECT_RANK:
9107 4559 : *st = ST_END_SELECT;
9108 4559 : target = " select";
9109 4559 : eos_ok = 0;
9110 4559 : break;
9111 :
9112 508 : case COMP_FORALL:
9113 508 : *st = ST_END_FORALL;
9114 508 : target = " forall";
9115 508 : eos_ok = 0;
9116 508 : break;
9117 :
9118 373 : case COMP_WHERE:
9119 373 : *st = ST_END_WHERE;
9120 373 : target = " where";
9121 373 : eos_ok = 0;
9122 373 : break;
9123 :
9124 158 : case COMP_ENUM:
9125 158 : *st = ST_END_ENUM;
9126 158 : target = " enum";
9127 158 : eos_ok = 0;
9128 158 : last_initializer = NULL;
9129 158 : set_enum_kind ();
9130 158 : gfc_free_enum_history ();
9131 158 : break;
9132 :
9133 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9134 0 : *st = ST_OMP_END_METADIRECTIVE;
9135 0 : target = " metadirective";
9136 0 : eos_ok = 0;
9137 0 : break;
9138 :
9139 74 : case COMP_CHANGE_TEAM:
9140 74 : *st = ST_END_TEAM;
9141 74 : target = " team";
9142 74 : eos_ok = 0;
9143 74 : break;
9144 :
9145 9 : default:
9146 9 : gfc_error ("Unexpected END statement at %C");
9147 9 : goto cleanup;
9148 : }
9149 :
9150 176558 : old_loc = gfc_current_locus;
9151 176558 : if (gfc_match_eos () == MATCH_YES)
9152 : {
9153 20351 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9154 : {
9155 7949 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9156 : "instead of %s statement at %L",
9157 : abbreviated_modproc_decl ? "END PROCEDURE"
9158 3962 : : gfc_ascii_statement(*st), &old_loc))
9159 4 : goto cleanup;
9160 : }
9161 9 : else if (!eos_ok)
9162 : {
9163 : /* We would have required END [something]. */
9164 9 : gfc_error ("%s statement expected at %L",
9165 : gfc_ascii_statement (*st), &old_loc);
9166 9 : goto cleanup;
9167 : }
9168 :
9169 20338 : return MATCH_YES;
9170 : }
9171 :
9172 : /* Verify that we've got the sort of end-block that we're expecting. */
9173 156207 : if (gfc_match (target) != MATCH_YES)
9174 : {
9175 329 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9176 164 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9177 165 : goto cleanup;
9178 : }
9179 : else
9180 156042 : got_matching_end = true;
9181 :
9182 156042 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9183 : /* Emit errors of stat and errmsg parsing now to finish the block and
9184 : continue analysis of compilation unit. */
9185 2 : gfc_error_check ();
9186 :
9187 156042 : old_loc = gfc_current_locus;
9188 : /* If we're at the end, make sure a block name wasn't required. */
9189 156042 : if (gfc_match_eos () == MATCH_YES)
9190 : {
9191 103268 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9192 : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9193 : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9194 : && *st != ST_END_TEAM)
9195 : return MATCH_YES;
9196 :
9197 53016 : if (!block_name)
9198 : return MATCH_YES;
9199 :
9200 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9201 : block_name, gfc_ascii_statement (*st), &old_loc);
9202 :
9203 8 : return MATCH_ERROR;
9204 : }
9205 :
9206 : /* END INTERFACE has a special handler for its several possible endings. */
9207 52774 : if (*st == ST_END_INTERFACE)
9208 622 : return gfc_match_end_interface ();
9209 :
9210 : /* We haven't hit the end of statement, so what is left must be an
9211 : end-name. */
9212 52152 : m = gfc_match_space ();
9213 52152 : if (m == MATCH_YES)
9214 52152 : m = gfc_match_name (name);
9215 :
9216 52152 : if (m == MATCH_NO)
9217 0 : gfc_error ("Expected terminating name at %C");
9218 52152 : if (m != MATCH_YES)
9219 0 : goto cleanup;
9220 :
9221 52152 : if (block_name == NULL)
9222 15 : goto syntax;
9223 :
9224 : /* We have to pick out the declared submodule name from the composite
9225 : required by F2008:11.2.3 para 2, which ends in the declared name. */
9226 52137 : if (state == COMP_SUBMODULE)
9227 117 : block_name = strchr (block_name, '.') + 1;
9228 :
9229 52137 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9230 : {
9231 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9232 : gfc_ascii_statement (*st));
9233 8 : goto cleanup;
9234 : }
9235 : /* Procedure pointer as function result. */
9236 52129 : else if (strcmp (block_name, "ppr@") == 0
9237 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9238 : {
9239 0 : gfc_error ("Expected label %qs for %s statement at %C",
9240 0 : gfc_current_block ()->ns->proc_name->name,
9241 : gfc_ascii_statement (*st));
9242 0 : goto cleanup;
9243 : }
9244 :
9245 52129 : if (gfc_match_eos () == MATCH_YES)
9246 : return MATCH_YES;
9247 :
9248 0 : syntax:
9249 15 : gfc_syntax_error (*st);
9250 :
9251 210 : cleanup:
9252 210 : gfc_current_locus = old_loc;
9253 :
9254 : /* If we are missing an END BLOCK, we created a half-ready namespace.
9255 : Remove it from the parent namespace's sibling list. */
9256 :
9257 210 : if (state == COMP_BLOCK && !got_matching_end)
9258 : {
9259 7 : parent_ns = gfc_current_ns->parent;
9260 :
9261 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9262 :
9263 7 : prev_ns = NULL;
9264 7 : ns = *nsp;
9265 14 : while (ns)
9266 : {
9267 7 : if (ns == gfc_current_ns)
9268 : {
9269 7 : if (prev_ns == NULL)
9270 7 : *nsp = NULL;
9271 : else
9272 0 : prev_ns->sibling = ns->sibling;
9273 : }
9274 7 : prev_ns = ns;
9275 7 : ns = ns->sibling;
9276 : }
9277 :
9278 : /* The namespace can still be referenced by parser state and code nodes;
9279 : let normal block unwinding/freeing own its lifetime. */
9280 7 : gfc_current_ns = parent_ns;
9281 7 : gfc_state_stack = gfc_state_stack->previous;
9282 7 : state = gfc_current_state ();
9283 : }
9284 :
9285 : return MATCH_ERROR;
9286 : }
9287 :
9288 :
9289 :
9290 : /***************** Attribute declaration statements ****************/
9291 :
9292 : /* Set the attribute of a single variable. */
9293 :
9294 : static match
9295 10258 : attr_decl1 (void)
9296 : {
9297 10258 : char name[GFC_MAX_SYMBOL_LEN + 1];
9298 10258 : gfc_array_spec *as;
9299 :
9300 : /* Workaround -Wmaybe-uninitialized false positive during
9301 : profiledbootstrap by initializing them. */
9302 10258 : gfc_symbol *sym = NULL;
9303 10258 : locus var_locus;
9304 10258 : match m;
9305 :
9306 10258 : as = NULL;
9307 :
9308 10258 : m = gfc_match_name (name);
9309 10258 : if (m != MATCH_YES)
9310 0 : goto cleanup;
9311 :
9312 10258 : if (find_special (name, &sym, false))
9313 : return MATCH_ERROR;
9314 :
9315 10258 : if (!check_function_name (name))
9316 : {
9317 7 : m = MATCH_ERROR;
9318 7 : goto cleanup;
9319 : }
9320 :
9321 10251 : var_locus = gfc_current_locus;
9322 :
9323 : /* Deal with possible array specification for certain attributes. */
9324 10251 : if (current_attr.dimension
9325 8674 : || current_attr.codimension
9326 8652 : || current_attr.allocatable
9327 8228 : || current_attr.pointer
9328 7517 : || current_attr.target)
9329 : {
9330 2960 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9331 : !current_attr.dimension
9332 1383 : && !current_attr.pointer
9333 3632 : && !current_attr.target);
9334 2960 : if (m == MATCH_ERROR)
9335 2 : goto cleanup;
9336 :
9337 2958 : if (current_attr.dimension && m == MATCH_NO)
9338 : {
9339 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9340 : "statement", &var_locus);
9341 0 : m = MATCH_ERROR;
9342 0 : goto cleanup;
9343 : }
9344 :
9345 2958 : if (current_attr.dimension && sym->value)
9346 : {
9347 1 : gfc_error ("Dimensions specified for %s at %L after its "
9348 : "initialization", sym->name, &var_locus);
9349 1 : m = MATCH_ERROR;
9350 1 : goto cleanup;
9351 : }
9352 :
9353 2957 : if (current_attr.codimension && m == MATCH_NO)
9354 : {
9355 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9356 : "statement", &var_locus);
9357 0 : m = MATCH_ERROR;
9358 0 : goto cleanup;
9359 : }
9360 :
9361 2957 : if ((current_attr.allocatable || current_attr.pointer)
9362 1135 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9363 : {
9364 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9365 0 : m = MATCH_ERROR;
9366 0 : goto cleanup;
9367 : }
9368 : }
9369 :
9370 10248 : if (sym->ts.type == BT_CLASS
9371 200 : && sym->ts.u.derived
9372 200 : && sym->ts.u.derived->attr.is_class)
9373 : {
9374 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9375 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9376 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9377 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9378 177 : if (CLASS_DATA (sym)->as)
9379 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9380 : }
9381 8673 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9382 18900 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9383 : {
9384 22 : m = MATCH_ERROR;
9385 22 : goto cleanup;
9386 : }
9387 10226 : if (!gfc_set_array_spec (sym, as, &var_locus))
9388 : {
9389 18 : m = MATCH_ERROR;
9390 18 : goto cleanup;
9391 : }
9392 :
9393 10208 : if (sym->attr.cray_pointee && sym->as != NULL)
9394 : {
9395 : /* Fix the array spec. */
9396 2 : m = gfc_mod_pointee_as (sym->as);
9397 2 : if (m == MATCH_ERROR)
9398 0 : goto cleanup;
9399 : }
9400 :
9401 10208 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9402 : {
9403 0 : m = MATCH_ERROR;
9404 0 : goto cleanup;
9405 : }
9406 :
9407 5711 : if ((current_attr.external || current_attr.intrinsic)
9408 6134 : && sym->attr.flavor != FL_PROCEDURE
9409 16310 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9410 : {
9411 0 : m = MATCH_ERROR;
9412 0 : goto cleanup;
9413 : }
9414 :
9415 10208 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9416 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9417 136 : && !current_attr.external)
9418 : {
9419 136 : sym->attr.pointer = 0;
9420 136 : sym->attr.allocatable = 0;
9421 136 : sym->attr.dimension = 0;
9422 136 : sym->attr.codimension = 0;
9423 136 : gfc_free_array_spec (sym->as);
9424 136 : sym->as = NULL;
9425 : }
9426 10072 : else if (sym->ts.type == BT_CLASS
9427 10072 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9428 : {
9429 0 : m = MATCH_ERROR;
9430 0 : goto cleanup;
9431 : }
9432 :
9433 10208 : add_hidden_procptr_result (sym);
9434 :
9435 10208 : return MATCH_YES;
9436 :
9437 50 : cleanup:
9438 50 : gfc_free_array_spec (as);
9439 50 : return m;
9440 : }
9441 :
9442 :
9443 : /* Generic attribute declaration subroutine. Used for attributes that
9444 : just have a list of names. */
9445 :
9446 : static match
9447 6596 : attr_decl (void)
9448 : {
9449 6596 : match m;
9450 :
9451 : /* Gobble the optional double colon, by simply ignoring the result
9452 : of gfc_match(). */
9453 6596 : gfc_match (" ::");
9454 :
9455 10258 : for (;;)
9456 : {
9457 10258 : m = attr_decl1 ();
9458 10258 : if (m != MATCH_YES)
9459 : break;
9460 :
9461 10208 : if (gfc_match_eos () == MATCH_YES)
9462 : {
9463 : m = MATCH_YES;
9464 : break;
9465 : }
9466 :
9467 3662 : if (gfc_match_char (',') != MATCH_YES)
9468 : {
9469 0 : gfc_error ("Unexpected character in variable list at %C");
9470 0 : m = MATCH_ERROR;
9471 0 : break;
9472 : }
9473 : }
9474 :
9475 6596 : return m;
9476 : }
9477 :
9478 :
9479 : /* This routine matches Cray Pointer declarations of the form:
9480 : pointer ( <pointer>, <pointee> )
9481 : or
9482 : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9483 : The pointer, if already declared, should be an integer. Otherwise, we
9484 : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9485 : be either a scalar, or an array declaration. No space is allocated for
9486 : the pointee. For the statement
9487 : pointer (ipt, ar(10))
9488 : any subsequent uses of ar will be translated (in C-notation) as
9489 : ar(i) => ((<type> *) ipt)(i)
9490 : After gimplification, pointee variable will disappear in the code. */
9491 :
9492 : static match
9493 334 : cray_pointer_decl (void)
9494 : {
9495 334 : match m;
9496 334 : gfc_array_spec *as = NULL;
9497 334 : gfc_symbol *cptr; /* Pointer symbol. */
9498 334 : gfc_symbol *cpte; /* Pointee symbol. */
9499 334 : locus var_locus;
9500 334 : bool done = false;
9501 :
9502 334 : while (!done)
9503 : {
9504 347 : if (gfc_match_char ('(') != MATCH_YES)
9505 : {
9506 1 : gfc_error ("Expected %<(%> at %C");
9507 1 : return MATCH_ERROR;
9508 : }
9509 :
9510 : /* Match pointer. */
9511 346 : var_locus = gfc_current_locus;
9512 346 : gfc_clear_attr (¤t_attr);
9513 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9514 346 : current_ts.type = BT_INTEGER;
9515 346 : current_ts.kind = gfc_index_integer_kind;
9516 :
9517 346 : m = gfc_match_symbol (&cptr, 0);
9518 346 : if (m != MATCH_YES)
9519 : {
9520 2 : gfc_error ("Expected variable name at %C");
9521 2 : return m;
9522 : }
9523 :
9524 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9525 : return MATCH_ERROR;
9526 :
9527 341 : gfc_set_sym_referenced (cptr);
9528 :
9529 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9530 : {
9531 327 : cptr->ts.type = BT_INTEGER;
9532 327 : cptr->ts.kind = gfc_index_integer_kind;
9533 : }
9534 14 : else if (cptr->ts.type != BT_INTEGER)
9535 : {
9536 1 : gfc_error ("Cray pointer at %C must be an integer");
9537 1 : return MATCH_ERROR;
9538 : }
9539 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9540 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9541 : " memory addresses require %d bytes",
9542 : cptr->ts.kind, gfc_index_integer_kind);
9543 :
9544 340 : if (gfc_match_char (',') != MATCH_YES)
9545 : {
9546 2 : gfc_error ("Expected \",\" at %C");
9547 2 : return MATCH_ERROR;
9548 : }
9549 :
9550 : /* Match Pointee. */
9551 338 : var_locus = gfc_current_locus;
9552 338 : gfc_clear_attr (¤t_attr);
9553 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9554 338 : current_ts.type = BT_UNKNOWN;
9555 338 : current_ts.kind = 0;
9556 :
9557 338 : m = gfc_match_symbol (&cpte, 0);
9558 338 : if (m != MATCH_YES)
9559 : {
9560 2 : gfc_error ("Expected variable name at %C");
9561 2 : return m;
9562 : }
9563 :
9564 : /* Check for an optional array spec. */
9565 336 : m = gfc_match_array_spec (&as, true, false);
9566 336 : if (m == MATCH_ERROR)
9567 : {
9568 0 : gfc_free_array_spec (as);
9569 0 : return m;
9570 : }
9571 336 : else if (m == MATCH_NO)
9572 : {
9573 226 : gfc_free_array_spec (as);
9574 226 : as = NULL;
9575 : }
9576 :
9577 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9578 : return MATCH_ERROR;
9579 :
9580 329 : gfc_set_sym_referenced (cpte);
9581 :
9582 329 : if (cpte->as == NULL)
9583 : {
9584 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9585 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9586 : }
9587 82 : else if (as != NULL)
9588 : {
9589 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9590 1 : gfc_free_array_spec (as);
9591 1 : return MATCH_ERROR;
9592 : }
9593 :
9594 328 : as = NULL;
9595 :
9596 328 : if (cpte->as != NULL)
9597 : {
9598 : /* Fix array spec. */
9599 190 : m = gfc_mod_pointee_as (cpte->as);
9600 190 : if (m == MATCH_ERROR)
9601 : return m;
9602 : }
9603 :
9604 : /* Point the Pointee at the Pointer. */
9605 328 : cpte->cp_pointer = cptr;
9606 :
9607 328 : if (gfc_match_char (')') != MATCH_YES)
9608 : {
9609 2 : gfc_error ("Expected \")\" at %C");
9610 2 : return MATCH_ERROR;
9611 : }
9612 326 : m = gfc_match_char (',');
9613 326 : if (m != MATCH_YES)
9614 313 : done = true; /* Stop searching for more declarations. */
9615 :
9616 : }
9617 :
9618 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9619 313 : || gfc_match_eos () != MATCH_YES)
9620 : {
9621 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9622 0 : return MATCH_ERROR;
9623 : }
9624 : return MATCH_YES;
9625 : }
9626 :
9627 :
9628 : match
9629 3117 : gfc_match_external (void)
9630 : {
9631 :
9632 3117 : gfc_clear_attr (¤t_attr);
9633 3117 : current_attr.external = 1;
9634 :
9635 3117 : return attr_decl ();
9636 : }
9637 :
9638 :
9639 : match
9640 208 : gfc_match_intent (void)
9641 : {
9642 208 : sym_intent intent;
9643 :
9644 : /* This is not allowed within a BLOCK construct! */
9645 208 : if (gfc_current_state () == COMP_BLOCK)
9646 : {
9647 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9648 2 : return MATCH_ERROR;
9649 : }
9650 :
9651 206 : intent = match_intent_spec ();
9652 206 : if (intent == INTENT_UNKNOWN)
9653 : return MATCH_ERROR;
9654 :
9655 206 : gfc_clear_attr (¤t_attr);
9656 206 : current_attr.intent = intent;
9657 :
9658 206 : return attr_decl ();
9659 : }
9660 :
9661 :
9662 : match
9663 1477 : gfc_match_intrinsic (void)
9664 : {
9665 :
9666 1477 : gfc_clear_attr (¤t_attr);
9667 1477 : current_attr.intrinsic = 1;
9668 :
9669 1477 : return attr_decl ();
9670 : }
9671 :
9672 :
9673 : match
9674 220 : gfc_match_optional (void)
9675 : {
9676 : /* This is not allowed within a BLOCK construct! */
9677 220 : if (gfc_current_state () == COMP_BLOCK)
9678 : {
9679 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9680 2 : return MATCH_ERROR;
9681 : }
9682 :
9683 218 : gfc_clear_attr (¤t_attr);
9684 218 : current_attr.optional = 1;
9685 :
9686 218 : return attr_decl ();
9687 : }
9688 :
9689 :
9690 : match
9691 903 : gfc_match_pointer (void)
9692 : {
9693 903 : gfc_gobble_whitespace ();
9694 903 : if (gfc_peek_ascii_char () == '(')
9695 : {
9696 335 : if (!flag_cray_pointer)
9697 : {
9698 1 : gfc_error ("Cray pointer declaration at %C requires "
9699 : "%<-fcray-pointer%> flag");
9700 1 : return MATCH_ERROR;
9701 : }
9702 334 : return cray_pointer_decl ();
9703 : }
9704 : else
9705 : {
9706 568 : gfc_clear_attr (¤t_attr);
9707 568 : current_attr.pointer = 1;
9708 :
9709 568 : return attr_decl ();
9710 : }
9711 : }
9712 :
9713 :
9714 : match
9715 162 : gfc_match_allocatable (void)
9716 : {
9717 162 : gfc_clear_attr (¤t_attr);
9718 162 : current_attr.allocatable = 1;
9719 :
9720 162 : return attr_decl ();
9721 : }
9722 :
9723 :
9724 : match
9725 23 : gfc_match_codimension (void)
9726 : {
9727 23 : gfc_clear_attr (¤t_attr);
9728 23 : current_attr.codimension = 1;
9729 :
9730 23 : return attr_decl ();
9731 : }
9732 :
9733 :
9734 : match
9735 80 : gfc_match_contiguous (void)
9736 : {
9737 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9738 : return MATCH_ERROR;
9739 :
9740 79 : gfc_clear_attr (¤t_attr);
9741 79 : current_attr.contiguous = 1;
9742 :
9743 79 : return attr_decl ();
9744 : }
9745 :
9746 :
9747 : match
9748 647 : gfc_match_dimension (void)
9749 : {
9750 647 : gfc_clear_attr (¤t_attr);
9751 647 : current_attr.dimension = 1;
9752 :
9753 647 : return attr_decl ();
9754 : }
9755 :
9756 :
9757 : match
9758 99 : gfc_match_target (void)
9759 : {
9760 99 : gfc_clear_attr (¤t_attr);
9761 99 : current_attr.target = 1;
9762 :
9763 99 : return attr_decl ();
9764 : }
9765 :
9766 :
9767 : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9768 : statement. */
9769 :
9770 : static match
9771 1707 : access_attr_decl (gfc_statement st)
9772 : {
9773 1707 : char name[GFC_MAX_SYMBOL_LEN + 1];
9774 1707 : interface_type type;
9775 1707 : gfc_user_op *uop;
9776 1707 : gfc_symbol *sym, *dt_sym;
9777 1707 : gfc_intrinsic_op op;
9778 1707 : match m;
9779 1707 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9780 :
9781 1707 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9782 0 : goto done;
9783 :
9784 2831 : for (;;)
9785 : {
9786 2831 : m = gfc_match_generic_spec (&type, name, &op);
9787 2831 : if (m == MATCH_NO)
9788 0 : goto syntax;
9789 2831 : if (m == MATCH_ERROR)
9790 0 : goto done;
9791 :
9792 2831 : switch (type)
9793 : {
9794 0 : case INTERFACE_NAMELESS:
9795 0 : case INTERFACE_ABSTRACT:
9796 0 : goto syntax;
9797 :
9798 2757 : case INTERFACE_GENERIC:
9799 2757 : case INTERFACE_DTIO:
9800 :
9801 2757 : if (gfc_get_symbol (name, NULL, &sym))
9802 0 : goto done;
9803 :
9804 2757 : if (type == INTERFACE_DTIO
9805 26 : && gfc_current_ns->proc_name
9806 26 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9807 26 : && sym->attr.flavor == FL_UNKNOWN)
9808 2 : sym->attr.flavor = FL_PROCEDURE;
9809 :
9810 2757 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9811 4 : goto done;
9812 :
9813 323 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9814 2803 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9815 0 : goto done;
9816 :
9817 : break;
9818 :
9819 70 : case INTERFACE_INTRINSIC_OP:
9820 70 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9821 : {
9822 70 : gfc_intrinsic_op other_op;
9823 :
9824 70 : gfc_current_ns->operator_access[op] = access;
9825 :
9826 : /* Handle the case if there is another op with the same
9827 : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9828 70 : other_op = gfc_equivalent_op (op);
9829 :
9830 70 : if (other_op != INTRINSIC_NONE)
9831 21 : gfc_current_ns->operator_access[other_op] = access;
9832 : }
9833 : else
9834 : {
9835 0 : gfc_error ("Access specification of the %s operator at %C has "
9836 : "already been specified", gfc_op2string (op));
9837 0 : goto done;
9838 : }
9839 :
9840 : break;
9841 :
9842 4 : case INTERFACE_USER_OP:
9843 4 : uop = gfc_get_uop (name);
9844 :
9845 4 : if (uop->access == ACCESS_UNKNOWN)
9846 : {
9847 3 : uop->access = access;
9848 : }
9849 : else
9850 : {
9851 1 : gfc_error ("Access specification of the .%s. operator at %C "
9852 : "has already been specified", uop->name);
9853 1 : goto done;
9854 : }
9855 :
9856 3 : break;
9857 : }
9858 :
9859 2826 : if (gfc_match_char (',') == MATCH_NO)
9860 : break;
9861 : }
9862 :
9863 1702 : if (gfc_match_eos () != MATCH_YES)
9864 0 : goto syntax;
9865 : return MATCH_YES;
9866 :
9867 0 : syntax:
9868 0 : gfc_syntax_error (st);
9869 :
9870 : done:
9871 : return MATCH_ERROR;
9872 : }
9873 :
9874 :
9875 : match
9876 23 : gfc_match_protected (void)
9877 : {
9878 23 : gfc_symbol *sym;
9879 23 : match m;
9880 23 : char c;
9881 :
9882 : /* PROTECTED has already been seen, but must be followed by whitespace
9883 : or ::. */
9884 23 : c = gfc_peek_ascii_char ();
9885 23 : if (!gfc_is_whitespace (c) && c != ':')
9886 : return MATCH_NO;
9887 :
9888 22 : if (!gfc_current_ns->proc_name
9889 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
9890 : {
9891 3 : gfc_error ("PROTECTED at %C only allowed in specification "
9892 : "part of a module");
9893 3 : return MATCH_ERROR;
9894 :
9895 : }
9896 :
9897 19 : gfc_match (" ::");
9898 :
9899 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
9900 : return MATCH_ERROR;
9901 :
9902 : /* PROTECTED has an entity-list. */
9903 18 : if (gfc_match_eos () == MATCH_YES)
9904 0 : goto syntax;
9905 :
9906 26 : for(;;)
9907 : {
9908 26 : m = gfc_match_symbol (&sym, 0);
9909 26 : switch (m)
9910 : {
9911 26 : case MATCH_YES:
9912 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
9913 : return MATCH_ERROR;
9914 25 : goto next_item;
9915 :
9916 : case MATCH_NO:
9917 : break;
9918 :
9919 : case MATCH_ERROR:
9920 : return MATCH_ERROR;
9921 : }
9922 :
9923 25 : next_item:
9924 25 : if (gfc_match_eos () == MATCH_YES)
9925 : break;
9926 8 : if (gfc_match_char (',') != MATCH_YES)
9927 0 : goto syntax;
9928 : }
9929 :
9930 : return MATCH_YES;
9931 :
9932 0 : syntax:
9933 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
9934 0 : return MATCH_ERROR;
9935 : }
9936 :
9937 :
9938 : /* The PRIVATE statement is a bit weird in that it can be an attribute
9939 : declaration, but also works as a standalone statement inside of a
9940 : type declaration or a module. */
9941 :
9942 : match
9943 28493 : gfc_match_private (gfc_statement *st)
9944 : {
9945 28493 : gfc_state_data *prev;
9946 :
9947 28493 : if (gfc_match ("private") != MATCH_YES)
9948 : return MATCH_NO;
9949 :
9950 : /* Try matching PRIVATE without an access-list. */
9951 1576 : if (gfc_match_eos () == MATCH_YES)
9952 : {
9953 1289 : prev = gfc_state_stack->previous;
9954 1289 : if (gfc_current_state () != COMP_MODULE
9955 366 : && !(gfc_current_state () == COMP_DERIVED
9956 333 : && prev && prev->state == COMP_MODULE)
9957 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9958 32 : && prev->previous && prev->previous->state == COMP_MODULE))
9959 : {
9960 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9961 : "specification part of a module");
9962 2 : return MATCH_ERROR;
9963 : }
9964 :
9965 1287 : *st = ST_PRIVATE;
9966 1287 : return MATCH_YES;
9967 : }
9968 :
9969 : /* At this point in free-form source code, PRIVATE must be followed
9970 : by whitespace or ::. */
9971 287 : if (gfc_current_form == FORM_FREE)
9972 : {
9973 285 : char c = gfc_peek_ascii_char ();
9974 285 : if (!gfc_is_whitespace (c) && c != ':')
9975 : return MATCH_NO;
9976 : }
9977 :
9978 286 : prev = gfc_state_stack->previous;
9979 286 : if (gfc_current_state () != COMP_MODULE
9980 1 : && !(gfc_current_state () == COMP_DERIVED
9981 0 : && prev && prev->state == COMP_MODULE)
9982 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9983 0 : && prev->previous && prev->previous->state == COMP_MODULE))
9984 : {
9985 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9986 : "specification part of a module");
9987 1 : return MATCH_ERROR;
9988 : }
9989 :
9990 285 : *st = ST_ATTR_DECL;
9991 285 : return access_attr_decl (ST_PRIVATE);
9992 : }
9993 :
9994 :
9995 : match
9996 1820 : gfc_match_public (gfc_statement *st)
9997 : {
9998 1820 : if (gfc_match ("public") != MATCH_YES)
9999 : return MATCH_NO;
10000 :
10001 : /* Try matching PUBLIC without an access-list. */
10002 1469 : if (gfc_match_eos () == MATCH_YES)
10003 : {
10004 45 : if (gfc_current_state () != COMP_MODULE)
10005 : {
10006 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10007 : "specification part of a module");
10008 2 : return MATCH_ERROR;
10009 : }
10010 :
10011 43 : *st = ST_PUBLIC;
10012 43 : return MATCH_YES;
10013 : }
10014 :
10015 : /* At this point in free-form source code, PUBLIC must be followed
10016 : by whitespace or ::. */
10017 1424 : if (gfc_current_form == FORM_FREE)
10018 : {
10019 1422 : char c = gfc_peek_ascii_char ();
10020 1422 : if (!gfc_is_whitespace (c) && c != ':')
10021 : return MATCH_NO;
10022 : }
10023 :
10024 1423 : if (gfc_current_state () != COMP_MODULE)
10025 : {
10026 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
10027 : "specification part of a module");
10028 1 : return MATCH_ERROR;
10029 : }
10030 :
10031 1422 : *st = ST_ATTR_DECL;
10032 1422 : return access_attr_decl (ST_PUBLIC);
10033 : }
10034 :
10035 :
10036 : /* Workhorse for gfc_match_parameter. */
10037 :
10038 : static match
10039 7643 : do_parm (void)
10040 : {
10041 7643 : gfc_symbol *sym;
10042 7643 : gfc_expr *init;
10043 7643 : match m;
10044 7643 : bool t;
10045 :
10046 7643 : m = gfc_match_symbol (&sym, 0);
10047 7643 : if (m == MATCH_NO)
10048 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10049 :
10050 7643 : if (m != MATCH_YES)
10051 : return m;
10052 :
10053 7643 : if (gfc_match_char ('=') == MATCH_NO)
10054 : {
10055 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10056 0 : return MATCH_ERROR;
10057 : }
10058 :
10059 7643 : m = gfc_match_init_expr (&init);
10060 7643 : if (m == MATCH_NO)
10061 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10062 7643 : if (m != MATCH_YES)
10063 : return m;
10064 :
10065 7642 : if (sym->ts.type == BT_UNKNOWN
10066 7642 : && !gfc_set_default_type (sym, 1, NULL))
10067 : {
10068 1 : m = MATCH_ERROR;
10069 1 : goto cleanup;
10070 : }
10071 :
10072 7641 : if (!gfc_check_assign_symbol (sym, NULL, init)
10073 7641 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10074 : {
10075 1 : m = MATCH_ERROR;
10076 1 : goto cleanup;
10077 : }
10078 :
10079 7640 : if (sym->value)
10080 : {
10081 1 : gfc_error ("Initializing already initialized variable at %C");
10082 1 : m = MATCH_ERROR;
10083 1 : goto cleanup;
10084 : }
10085 :
10086 7639 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
10087 7639 : return (t) ? MATCH_YES : MATCH_ERROR;
10088 :
10089 3 : cleanup:
10090 3 : gfc_free_expr (init);
10091 3 : return m;
10092 : }
10093 :
10094 :
10095 : /* Match a parameter statement, with the weird syntax that these have. */
10096 :
10097 : match
10098 6930 : gfc_match_parameter (void)
10099 : {
10100 6930 : const char *term = " )%t";
10101 6930 : match m;
10102 :
10103 6930 : if (gfc_match_char ('(') == MATCH_NO)
10104 : {
10105 : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10106 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10107 : return MATCH_NO;
10108 6929 : term = " %t";
10109 : }
10110 :
10111 7643 : for (;;)
10112 : {
10113 7643 : m = do_parm ();
10114 7643 : if (m != MATCH_YES)
10115 : break;
10116 :
10117 7639 : if (gfc_match (term) == MATCH_YES)
10118 : break;
10119 :
10120 714 : if (gfc_match_char (',') != MATCH_YES)
10121 : {
10122 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10123 0 : m = MATCH_ERROR;
10124 0 : break;
10125 : }
10126 : }
10127 :
10128 : return m;
10129 : }
10130 :
10131 :
10132 : match
10133 8 : gfc_match_automatic (void)
10134 : {
10135 8 : gfc_symbol *sym;
10136 8 : match m;
10137 8 : bool seen_symbol = false;
10138 :
10139 8 : if (!flag_dec_static)
10140 : {
10141 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10142 : "%<-fdec-static%>",
10143 : "AUTOMATIC"
10144 : );
10145 2 : return MATCH_ERROR;
10146 : }
10147 :
10148 6 : gfc_match (" ::");
10149 :
10150 6 : for (;;)
10151 : {
10152 6 : m = gfc_match_symbol (&sym, 0);
10153 6 : switch (m)
10154 : {
10155 : case MATCH_NO:
10156 : break;
10157 :
10158 : case MATCH_ERROR:
10159 : return MATCH_ERROR;
10160 :
10161 4 : case MATCH_YES:
10162 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10163 : return MATCH_ERROR;
10164 : seen_symbol = true;
10165 : break;
10166 : }
10167 :
10168 4 : if (gfc_match_eos () == MATCH_YES)
10169 : break;
10170 0 : if (gfc_match_char (',') != MATCH_YES)
10171 0 : goto syntax;
10172 : }
10173 :
10174 4 : if (!seen_symbol)
10175 : {
10176 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10177 2 : return MATCH_ERROR;
10178 : }
10179 :
10180 : return MATCH_YES;
10181 :
10182 0 : syntax:
10183 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10184 0 : return MATCH_ERROR;
10185 : }
10186 :
10187 :
10188 : match
10189 7 : gfc_match_static (void)
10190 : {
10191 7 : gfc_symbol *sym;
10192 7 : match m;
10193 7 : bool seen_symbol = false;
10194 :
10195 7 : if (!flag_dec_static)
10196 : {
10197 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10198 : "%<-fdec-static%>",
10199 : "STATIC");
10200 2 : return MATCH_ERROR;
10201 : }
10202 :
10203 5 : gfc_match (" ::");
10204 :
10205 5 : for (;;)
10206 : {
10207 5 : m = gfc_match_symbol (&sym, 0);
10208 5 : switch (m)
10209 : {
10210 : case MATCH_NO:
10211 : break;
10212 :
10213 : case MATCH_ERROR:
10214 : return MATCH_ERROR;
10215 :
10216 3 : case MATCH_YES:
10217 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10218 : &gfc_current_locus))
10219 : return MATCH_ERROR;
10220 : seen_symbol = true;
10221 : break;
10222 : }
10223 :
10224 3 : if (gfc_match_eos () == MATCH_YES)
10225 : break;
10226 0 : if (gfc_match_char (',') != MATCH_YES)
10227 0 : goto syntax;
10228 : }
10229 :
10230 3 : if (!seen_symbol)
10231 : {
10232 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10233 2 : return MATCH_ERROR;
10234 : }
10235 :
10236 : return MATCH_YES;
10237 :
10238 0 : syntax:
10239 0 : gfc_error ("Syntax error in STATIC statement at %C");
10240 0 : return MATCH_ERROR;
10241 : }
10242 :
10243 :
10244 : /* Save statements have a special syntax. */
10245 :
10246 : match
10247 272 : gfc_match_save (void)
10248 : {
10249 272 : char n[GFC_MAX_SYMBOL_LEN+1];
10250 272 : gfc_common_head *c;
10251 272 : gfc_symbol *sym;
10252 272 : match m;
10253 :
10254 272 : if (gfc_match_eos () == MATCH_YES)
10255 : {
10256 150 : if (gfc_current_ns->seen_save)
10257 : {
10258 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10259 : "follows previous SAVE statement"))
10260 : return MATCH_ERROR;
10261 : }
10262 :
10263 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10264 149 : return MATCH_YES;
10265 : }
10266 :
10267 122 : if (gfc_current_ns->save_all)
10268 : {
10269 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10270 : "blanket SAVE statement"))
10271 : return MATCH_ERROR;
10272 : }
10273 :
10274 121 : gfc_match (" ::");
10275 :
10276 183 : for (;;)
10277 : {
10278 183 : m = gfc_match_symbol (&sym, 0);
10279 183 : switch (m)
10280 : {
10281 181 : case MATCH_YES:
10282 181 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10283 : &gfc_current_locus))
10284 : return MATCH_ERROR;
10285 179 : goto next_item;
10286 :
10287 : case MATCH_NO:
10288 : break;
10289 :
10290 : case MATCH_ERROR:
10291 : return MATCH_ERROR;
10292 : }
10293 :
10294 2 : m = gfc_match (" / %n /", &n);
10295 2 : if (m == MATCH_ERROR)
10296 : return MATCH_ERROR;
10297 2 : if (m == MATCH_NO)
10298 0 : goto syntax;
10299 :
10300 : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10301 : saved-entity-list that does not specify a common-block-name. */
10302 2 : if (gfc_current_state () == COMP_BLOCK)
10303 : {
10304 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10305 : "in a BLOCK construct", n);
10306 1 : return MATCH_ERROR;
10307 : }
10308 :
10309 1 : c = gfc_get_common (n, 0);
10310 1 : c->saved = 1;
10311 :
10312 1 : gfc_current_ns->seen_save = 1;
10313 :
10314 180 : next_item:
10315 180 : if (gfc_match_eos () == MATCH_YES)
10316 : break;
10317 62 : if (gfc_match_char (',') != MATCH_YES)
10318 0 : goto syntax;
10319 : }
10320 :
10321 : return MATCH_YES;
10322 :
10323 0 : syntax:
10324 0 : if (gfc_current_ns->seen_save)
10325 : {
10326 0 : gfc_error ("Syntax error in SAVE statement at %C");
10327 0 : return MATCH_ERROR;
10328 : }
10329 : else
10330 : return MATCH_NO;
10331 : }
10332 :
10333 :
10334 : match
10335 93 : gfc_match_value (void)
10336 : {
10337 93 : gfc_symbol *sym;
10338 93 : match m;
10339 :
10340 : /* This is not allowed within a BLOCK construct! */
10341 93 : if (gfc_current_state () == COMP_BLOCK)
10342 : {
10343 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10344 2 : return MATCH_ERROR;
10345 : }
10346 :
10347 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10348 : return MATCH_ERROR;
10349 :
10350 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10351 : {
10352 : return MATCH_ERROR;
10353 : }
10354 :
10355 90 : if (gfc_match_eos () == MATCH_YES)
10356 0 : goto syntax;
10357 :
10358 116 : for(;;)
10359 : {
10360 116 : m = gfc_match_symbol (&sym, 0);
10361 116 : switch (m)
10362 : {
10363 116 : case MATCH_YES:
10364 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10365 : return MATCH_ERROR;
10366 109 : goto next_item;
10367 :
10368 : case MATCH_NO:
10369 : break;
10370 :
10371 : case MATCH_ERROR:
10372 : return MATCH_ERROR;
10373 : }
10374 :
10375 109 : next_item:
10376 109 : if (gfc_match_eos () == MATCH_YES)
10377 : break;
10378 26 : if (gfc_match_char (',') != MATCH_YES)
10379 0 : goto syntax;
10380 : }
10381 :
10382 : return MATCH_YES;
10383 :
10384 0 : syntax:
10385 0 : gfc_error ("Syntax error in VALUE statement at %C");
10386 0 : return MATCH_ERROR;
10387 : }
10388 :
10389 :
10390 : match
10391 45 : gfc_match_volatile (void)
10392 : {
10393 45 : gfc_symbol *sym;
10394 45 : char *name;
10395 45 : match m;
10396 :
10397 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10398 : return MATCH_ERROR;
10399 :
10400 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10401 : {
10402 : return MATCH_ERROR;
10403 : }
10404 :
10405 44 : if (gfc_match_eos () == MATCH_YES)
10406 1 : goto syntax;
10407 :
10408 48 : for(;;)
10409 : {
10410 : /* VOLATILE is special because it can be added to host-associated
10411 : symbols locally. Except for coarrays. */
10412 48 : m = gfc_match_symbol (&sym, 1);
10413 48 : switch (m)
10414 : {
10415 48 : case MATCH_YES:
10416 48 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10417 48 : strcpy (name, sym->name);
10418 48 : if (!check_function_name (name))
10419 : return MATCH_ERROR;
10420 : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10421 : for variable in a BLOCK which is defined outside of the BLOCK. */
10422 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10423 : {
10424 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10425 : "%C, which is use-/host-associated", sym->name);
10426 2 : return MATCH_ERROR;
10427 : }
10428 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10429 : return MATCH_ERROR;
10430 42 : goto next_item;
10431 :
10432 : case MATCH_NO:
10433 : break;
10434 :
10435 : case MATCH_ERROR:
10436 : return MATCH_ERROR;
10437 : }
10438 :
10439 42 : next_item:
10440 42 : if (gfc_match_eos () == MATCH_YES)
10441 : break;
10442 5 : if (gfc_match_char (',') != MATCH_YES)
10443 0 : goto syntax;
10444 : }
10445 :
10446 : return MATCH_YES;
10447 :
10448 1 : syntax:
10449 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10450 1 : return MATCH_ERROR;
10451 : }
10452 :
10453 :
10454 : match
10455 11 : gfc_match_asynchronous (void)
10456 : {
10457 11 : gfc_symbol *sym;
10458 11 : char *name;
10459 11 : match m;
10460 :
10461 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10462 : return MATCH_ERROR;
10463 :
10464 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10465 : {
10466 : return MATCH_ERROR;
10467 : }
10468 :
10469 10 : if (gfc_match_eos () == MATCH_YES)
10470 0 : goto syntax;
10471 :
10472 10 : for(;;)
10473 : {
10474 : /* ASYNCHRONOUS is special because it can be added to host-associated
10475 : symbols locally. */
10476 10 : m = gfc_match_symbol (&sym, 1);
10477 10 : switch (m)
10478 : {
10479 10 : case MATCH_YES:
10480 10 : name = XALLOCAVAR (char, strlen (sym->name) + 1);
10481 10 : strcpy (name, sym->name);
10482 10 : if (!check_function_name (name))
10483 : return MATCH_ERROR;
10484 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10485 : return MATCH_ERROR;
10486 7 : goto next_item;
10487 :
10488 : case MATCH_NO:
10489 : break;
10490 :
10491 : case MATCH_ERROR:
10492 : return MATCH_ERROR;
10493 : }
10494 :
10495 7 : next_item:
10496 7 : if (gfc_match_eos () == MATCH_YES)
10497 : break;
10498 0 : if (gfc_match_char (',') != MATCH_YES)
10499 0 : goto syntax;
10500 : }
10501 :
10502 : return MATCH_YES;
10503 :
10504 0 : syntax:
10505 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10506 0 : return MATCH_ERROR;
10507 : }
10508 :
10509 :
10510 : /* Match a module procedure statement in a submodule. */
10511 :
10512 : match
10513 750390 : gfc_match_submod_proc (void)
10514 : {
10515 750390 : char name[GFC_MAX_SYMBOL_LEN + 1];
10516 750390 : gfc_symbol *sym, *fsym;
10517 750390 : match m;
10518 750390 : gfc_formal_arglist *formal, *head, *tail;
10519 :
10520 750390 : if (gfc_current_state () != COMP_CONTAINS
10521 15077 : || !(gfc_state_stack->previous
10522 15077 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10523 15077 : || gfc_state_stack->previous->state == COMP_MODULE)))
10524 : return MATCH_NO;
10525 :
10526 7517 : m = gfc_match (" module% procedure% %n", name);
10527 7517 : if (m != MATCH_YES)
10528 : return m;
10529 :
10530 247 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10531 : "at %C"))
10532 : return MATCH_ERROR;
10533 :
10534 247 : if (get_proc_name (name, &sym, false))
10535 : return MATCH_ERROR;
10536 :
10537 : /* Make sure that the result field is appropriately filled. */
10538 247 : if (sym->tlink && sym->tlink->attr.function)
10539 : {
10540 110 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10541 : {
10542 66 : sym->result = sym->tlink->result;
10543 66 : if (!sym->result->attr.use_assoc)
10544 : {
10545 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10546 : sym->result->name);
10547 20 : st->n.sym = sym->result;
10548 20 : sym->result->refs++;
10549 : }
10550 : }
10551 : else
10552 44 : sym->result = sym;
10553 : }
10554 :
10555 : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10556 : the symbol existed before. */
10557 247 : sym->declared_at = gfc_current_locus;
10558 :
10559 247 : if (!sym->attr.module_procedure)
10560 : return MATCH_ERROR;
10561 :
10562 : /* Signal match_end to expect "end procedure". */
10563 245 : sym->abr_modproc_decl = 1;
10564 :
10565 : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10566 245 : sym->attr.if_source = IFSRC_DECL;
10567 :
10568 245 : gfc_new_block = sym;
10569 :
10570 : /* Make a new formal arglist with the symbols in the procedure
10571 : namespace. */
10572 245 : head = tail = NULL;
10573 555 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10574 : {
10575 310 : if (formal == sym->formal)
10576 219 : head = tail = gfc_get_formal_arglist ();
10577 : else
10578 : {
10579 91 : tail->next = gfc_get_formal_arglist ();
10580 91 : tail = tail->next;
10581 : }
10582 :
10583 310 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10584 0 : goto cleanup;
10585 :
10586 310 : tail->sym = fsym;
10587 310 : gfc_set_sym_referenced (fsym);
10588 : }
10589 :
10590 : /* The dummy symbols get cleaned up, when the formal_namespace of the
10591 : interface declaration is cleared. This allows us to add the
10592 : explicit interface as is done for other type of procedure. */
10593 245 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10594 : &gfc_current_locus))
10595 : return MATCH_ERROR;
10596 :
10597 245 : if (gfc_match_eos () != MATCH_YES)
10598 : {
10599 : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10600 : undone, such that the st->n.sym->formal points to the original symbol;
10601 : if now this namespace is finalized, the formal namespace is freed,
10602 : but it might be still needed in the parent namespace. */
10603 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10604 1 : st->n.sym = NULL;
10605 1 : gfc_free_symbol (sym->tlink);
10606 1 : sym->tlink = NULL;
10607 1 : sym->refs--;
10608 1 : gfc_syntax_error (ST_MODULE_PROC);
10609 1 : return MATCH_ERROR;
10610 : }
10611 :
10612 : return MATCH_YES;
10613 :
10614 0 : cleanup:
10615 0 : gfc_free_formal_arglist (head);
10616 0 : return MATCH_ERROR;
10617 : }
10618 :
10619 :
10620 : /* Match a module procedure statement. Note that we have to modify
10621 : symbols in the parent's namespace because the current one was there
10622 : to receive symbols that are in an interface's formal argument list. */
10623 :
10624 : match
10625 1571 : gfc_match_modproc (void)
10626 : {
10627 1571 : char name[GFC_MAX_SYMBOL_LEN + 1];
10628 1571 : gfc_symbol *sym;
10629 1571 : match m;
10630 1571 : locus old_locus;
10631 1571 : gfc_namespace *module_ns;
10632 1571 : gfc_interface *old_interface_head, *interface;
10633 :
10634 1571 : if (gfc_state_stack->previous == NULL
10635 1569 : || (gfc_state_stack->state != COMP_INTERFACE
10636 5 : && (gfc_state_stack->state != COMP_CONTAINS
10637 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10638 1564 : || current_interface.type == INTERFACE_NAMELESS
10639 1564 : || current_interface.type == INTERFACE_ABSTRACT)
10640 : {
10641 8 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10642 : "interface");
10643 8 : return MATCH_ERROR;
10644 : }
10645 :
10646 1563 : module_ns = gfc_current_ns->parent;
10647 1569 : for (; module_ns; module_ns = module_ns->parent)
10648 1569 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10649 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10650 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10651 12 : && !module_ns->proc_name->attr.contained))
10652 : break;
10653 :
10654 1563 : if (module_ns == NULL)
10655 : return MATCH_ERROR;
10656 :
10657 : /* Store the current state of the interface. We will need it if we
10658 : end up with a syntax error and need to recover. */
10659 1563 : old_interface_head = gfc_current_interface_head ();
10660 :
10661 : /* Check if the F2008 optional double colon appears. */
10662 1563 : gfc_gobble_whitespace ();
10663 1563 : old_locus = gfc_current_locus;
10664 1563 : if (gfc_match ("::") == MATCH_YES)
10665 : {
10666 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10667 : "MODULE PROCEDURE statement at %L", &old_locus))
10668 : return MATCH_ERROR;
10669 : }
10670 : else
10671 1538 : gfc_current_locus = old_locus;
10672 :
10673 1918 : for (;;)
10674 : {
10675 1918 : bool last = false;
10676 1918 : old_locus = gfc_current_locus;
10677 :
10678 1918 : m = gfc_match_name (name);
10679 1918 : if (m == MATCH_NO)
10680 1 : goto syntax;
10681 1917 : if (m != MATCH_YES)
10682 : return MATCH_ERROR;
10683 :
10684 : /* Check for syntax error before starting to add symbols to the
10685 : current namespace. */
10686 1917 : if (gfc_match_eos () == MATCH_YES)
10687 : last = true;
10688 :
10689 360 : if (!last && gfc_match_char (',') != MATCH_YES)
10690 2 : goto syntax;
10691 :
10692 : /* Now we're sure the syntax is valid, we process this item
10693 : further. */
10694 1915 : if (gfc_get_symbol (name, module_ns, &sym))
10695 : return MATCH_ERROR;
10696 :
10697 1915 : if (sym->attr.intrinsic)
10698 : {
10699 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10700 : "PROCEDURE", &old_locus);
10701 1 : return MATCH_ERROR;
10702 : }
10703 :
10704 1914 : if (sym->attr.proc != PROC_MODULE
10705 1914 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10706 : return MATCH_ERROR;
10707 :
10708 1911 : if (!gfc_add_interface (sym))
10709 : return MATCH_ERROR;
10710 :
10711 1908 : sym->attr.mod_proc = 1;
10712 1908 : sym->declared_at = old_locus;
10713 :
10714 1908 : if (last)
10715 : break;
10716 : }
10717 :
10718 : return MATCH_YES;
10719 :
10720 3 : syntax:
10721 : /* Restore the previous state of the interface. */
10722 3 : interface = gfc_current_interface_head ();
10723 3 : gfc_set_current_interface_head (old_interface_head);
10724 :
10725 : /* Free the new interfaces. */
10726 10 : while (interface != old_interface_head)
10727 : {
10728 4 : gfc_interface *i = interface->next;
10729 4 : free (interface);
10730 4 : interface = i;
10731 : }
10732 :
10733 : /* And issue a syntax error. */
10734 3 : gfc_syntax_error (ST_MODULE_PROC);
10735 3 : return MATCH_ERROR;
10736 : }
10737 :
10738 :
10739 : /* Check a derived type that is being extended. */
10740 :
10741 : static gfc_symbol*
10742 1467 : check_extended_derived_type (char *name)
10743 : {
10744 1467 : gfc_symbol *extended;
10745 :
10746 1467 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10747 : {
10748 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10749 0 : return NULL;
10750 : }
10751 :
10752 1467 : extended = gfc_find_dt_in_generic (extended);
10753 :
10754 : /* F08:C428. */
10755 1467 : if (!extended)
10756 : {
10757 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10758 2 : return NULL;
10759 : }
10760 :
10761 1465 : if (extended->attr.flavor != FL_DERIVED)
10762 : {
10763 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10764 : "derived type", name);
10765 0 : return NULL;
10766 : }
10767 :
10768 1465 : if (extended->attr.is_bind_c)
10769 : {
10770 1 : gfc_error ("%qs cannot be extended at %C because it "
10771 : "is BIND(C)", extended->name);
10772 1 : return NULL;
10773 : }
10774 :
10775 1464 : if (extended->attr.sequence)
10776 : {
10777 1 : gfc_error ("%qs cannot be extended at %C because it "
10778 : "is a SEQUENCE type", extended->name);
10779 1 : return NULL;
10780 : }
10781 :
10782 : return extended;
10783 : }
10784 :
10785 :
10786 : /* Match the optional attribute specifiers for a type declaration.
10787 : Return MATCH_ERROR if an error is encountered in one of the handled
10788 : attributes (public, private, bind(c)), MATCH_NO if what's found is
10789 : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10790 : checking on attribute conflicts needs to be done. */
10791 :
10792 : static match
10793 18924 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10794 : {
10795 : /* See if the derived type is marked as private. */
10796 18924 : if (gfc_match (" , private") == MATCH_YES)
10797 : {
10798 15 : if (gfc_current_state () != COMP_MODULE)
10799 : {
10800 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
10801 : "specification part of a module");
10802 1 : return MATCH_ERROR;
10803 : }
10804 :
10805 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10806 : return MATCH_ERROR;
10807 : }
10808 18909 : else if (gfc_match (" , public") == MATCH_YES)
10809 : {
10810 546 : if (gfc_current_state () != COMP_MODULE)
10811 : {
10812 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
10813 : "specification part of a module");
10814 0 : return MATCH_ERROR;
10815 : }
10816 :
10817 546 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10818 : return MATCH_ERROR;
10819 : }
10820 18363 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
10821 : {
10822 : /* If the type is defined to be bind(c) it then needs to make
10823 : sure that all fields are interoperable. This will
10824 : need to be a semantic check on the finished derived type.
10825 : See 15.2.3 (lines 9-12) of F2003 draft. */
10826 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10827 : return MATCH_ERROR;
10828 :
10829 : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10830 : }
10831 17956 : else if (gfc_match (" , abstract") == MATCH_YES)
10832 : {
10833 330 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
10834 : return MATCH_ERROR;
10835 :
10836 329 : if (!gfc_add_abstract (attr, &gfc_current_locus))
10837 : return MATCH_ERROR;
10838 : }
10839 17626 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
10840 : {
10841 1468 : if (!gfc_add_extension (attr, &gfc_current_locus))
10842 : return MATCH_ERROR;
10843 : }
10844 : else
10845 16158 : return MATCH_NO;
10846 :
10847 : /* If we get here, something matched. */
10848 : return MATCH_YES;
10849 : }
10850 :
10851 :
10852 : /* Common function for type declaration blocks similar to derived types, such
10853 : as STRUCTURES and MAPs. Unlike derived types, a structure type
10854 : does NOT have a generic symbol matching the name given by the user.
10855 : STRUCTUREs can share names with variables and PARAMETERs so we must allow
10856 : for the creation of an independent symbol.
10857 : Other parameters are a message to prefix errors with, the name of the new
10858 : type to be created, and the flavor to add to the resulting symbol. */
10859 :
10860 : static bool
10861 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
10862 : gfc_symbol **result)
10863 : {
10864 717 : gfc_symbol *sym;
10865 717 : locus where;
10866 :
10867 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
10868 :
10869 717 : if (decl)
10870 717 : where = *decl;
10871 : else
10872 0 : where = gfc_current_locus;
10873 :
10874 717 : if (gfc_get_symbol (name, NULL, &sym))
10875 : return false;
10876 :
10877 717 : if (!sym)
10878 : {
10879 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
10880 : return false;
10881 : }
10882 :
10883 717 : if (sym->components != NULL || sym->attr.zero_comp)
10884 : {
10885 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
10886 : sym->name, &sym->declared_at);
10887 3 : return false;
10888 : }
10889 :
10890 714 : sym->declared_at = where;
10891 :
10892 714 : if (sym->attr.flavor != fl
10893 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
10894 : return false;
10895 :
10896 714 : if (!sym->hash_value)
10897 : /* Set the hash for the compound name for this type. */
10898 713 : sym->hash_value = gfc_hash_value (sym);
10899 :
10900 : /* Normally the type is expected to have been completely parsed by the time
10901 : a field declaration with this type is seen. For unions, maps, and nested
10902 : structure declarations, we need to indicate that it is okay that we
10903 : haven't seen any components yet. This will be updated after the structure
10904 : is fully parsed. */
10905 714 : sym->attr.zero_comp = 0;
10906 :
10907 : /* Structures always act like derived-types with the SEQUENCE attribute */
10908 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
10909 :
10910 714 : if (result) *result = sym;
10911 :
10912 : return true;
10913 : }
10914 :
10915 :
10916 : /* Match the opening of a MAP block. Like a struct within a union in C;
10917 : behaves identical to STRUCTURE blocks. */
10918 :
10919 : match
10920 259 : gfc_match_map (void)
10921 : {
10922 : /* Counter used to give unique internal names to map structures. */
10923 259 : static unsigned int gfc_map_id = 0;
10924 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
10925 259 : gfc_symbol *sym;
10926 259 : locus old_loc;
10927 :
10928 259 : old_loc = gfc_current_locus;
10929 :
10930 259 : if (gfc_match_eos () != MATCH_YES)
10931 : {
10932 1 : gfc_error ("Junk after MAP statement at %C");
10933 1 : gfc_current_locus = old_loc;
10934 1 : return MATCH_ERROR;
10935 : }
10936 :
10937 : /* Map blocks are anonymous so we make up unique names for the symbol table
10938 : which are invalid Fortran identifiers. */
10939 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
10940 :
10941 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
10942 : return MATCH_ERROR;
10943 :
10944 258 : gfc_new_block = sym;
10945 :
10946 258 : return MATCH_YES;
10947 : }
10948 :
10949 :
10950 : /* Match the opening of a UNION block. */
10951 :
10952 : match
10953 133 : gfc_match_union (void)
10954 : {
10955 : /* Counter used to give unique internal names to union types. */
10956 133 : static unsigned int gfc_union_id = 0;
10957 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
10958 133 : gfc_symbol *sym;
10959 133 : locus old_loc;
10960 :
10961 133 : old_loc = gfc_current_locus;
10962 :
10963 133 : if (gfc_match_eos () != MATCH_YES)
10964 : {
10965 1 : gfc_error ("Junk after UNION statement at %C");
10966 1 : gfc_current_locus = old_loc;
10967 1 : return MATCH_ERROR;
10968 : }
10969 :
10970 : /* Unions are anonymous so we make up unique names for the symbol table
10971 : which are invalid Fortran identifiers. */
10972 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
10973 :
10974 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
10975 : return MATCH_ERROR;
10976 :
10977 132 : gfc_new_block = sym;
10978 :
10979 132 : return MATCH_YES;
10980 : }
10981 :
10982 :
10983 : /* Match the beginning of a STRUCTURE declaration. This is similar to
10984 : matching the beginning of a derived type declaration with a few
10985 : twists. The resulting type symbol has no access control or other
10986 : interesting attributes. */
10987 :
10988 : match
10989 336 : gfc_match_structure_decl (void)
10990 : {
10991 : /* Counter used to give unique internal names to anonymous structures. */
10992 336 : static unsigned int gfc_structure_id = 0;
10993 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
10994 336 : gfc_symbol *sym;
10995 336 : match m;
10996 336 : locus where;
10997 :
10998 336 : if (!flag_dec_structure)
10999 : {
11000 3 : gfc_error ("%s at %C is a DEC extension, enable with "
11001 : "%<-fdec-structure%>",
11002 : "STRUCTURE");
11003 3 : return MATCH_ERROR;
11004 : }
11005 :
11006 333 : name[0] = '\0';
11007 :
11008 333 : m = gfc_match (" /%n/", name);
11009 333 : if (m != MATCH_YES)
11010 : {
11011 : /* Non-nested structure declarations require a structure name. */
11012 24 : if (!gfc_comp_struct (gfc_current_state ()))
11013 : {
11014 4 : gfc_error ("Structure name expected in non-nested structure "
11015 : "declaration at %C");
11016 4 : return MATCH_ERROR;
11017 : }
11018 : /* This is an anonymous structure; make up a unique name for it
11019 : (upper-case letters never make it to symbol names from the source).
11020 : The important thing is initializing the type variable
11021 : and setting gfc_new_symbol, which is immediately used by
11022 : parse_structure () and variable_decl () to add components of
11023 : this type. */
11024 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
11025 : }
11026 :
11027 329 : where = gfc_current_locus;
11028 : /* No field list allowed after non-nested structure declaration. */
11029 329 : if (!gfc_comp_struct (gfc_current_state ())
11030 296 : && gfc_match_eos () != MATCH_YES)
11031 : {
11032 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
11033 1 : return MATCH_ERROR;
11034 : }
11035 :
11036 : /* Make sure the name is not the name of an intrinsic type. */
11037 328 : if (gfc_is_intrinsic_typename (name))
11038 : {
11039 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11040 : " intrinsic type", name);
11041 1 : return MATCH_ERROR;
11042 : }
11043 :
11044 : /* Store the actual type symbol for the structure with an upper-case first
11045 : letter (an invalid Fortran identifier). */
11046 :
11047 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11048 : return MATCH_ERROR;
11049 :
11050 324 : gfc_new_block = sym;
11051 324 : return MATCH_YES;
11052 : }
11053 :
11054 :
11055 : /* This function does some work to determine which matcher should be used to
11056 : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11057 : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11058 : * and [parameterized] derived type declarations. */
11059 :
11060 : match
11061 518582 : gfc_match_type (gfc_statement *st)
11062 : {
11063 518582 : char name[GFC_MAX_SYMBOL_LEN + 1];
11064 518582 : match m;
11065 518582 : locus old_loc;
11066 :
11067 : /* Requires -fdec. */
11068 518582 : if (!flag_dec)
11069 : return MATCH_NO;
11070 :
11071 2483 : m = gfc_match ("type");
11072 2483 : if (m != MATCH_YES)
11073 : return m;
11074 : /* If we already have an error in the buffer, it is probably from failing to
11075 : * match a derived type data declaration. Let it happen. */
11076 20 : else if (gfc_error_flag_test ())
11077 : return MATCH_NO;
11078 :
11079 20 : old_loc = gfc_current_locus;
11080 20 : *st = ST_NONE;
11081 :
11082 : /* If we see an attribute list before anything else it's definitely a derived
11083 : * type declaration. */
11084 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11085 8 : goto derived;
11086 :
11087 : /* By now "TYPE" has already been matched. If we do not see a name, this may
11088 : * be something like "TYPE *" or "TYPE <fmt>". */
11089 12 : m = gfc_match_name (name);
11090 12 : if (m != MATCH_YES)
11091 : {
11092 : /* Let print match if it can, otherwise throw an error from
11093 : * gfc_match_derived_decl. */
11094 7 : gfc_current_locus = old_loc;
11095 7 : if (gfc_match_print () == MATCH_YES)
11096 : {
11097 7 : *st = ST_WRITE;
11098 7 : return MATCH_YES;
11099 : }
11100 0 : goto derived;
11101 : }
11102 :
11103 : /* Check for EOS. */
11104 5 : if (gfc_match_eos () == MATCH_YES)
11105 : {
11106 : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11107 : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11108 : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11109 : * symbol which can be printed. */
11110 3 : gfc_current_locus = old_loc;
11111 3 : m = gfc_match_derived_decl ();
11112 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11113 : {
11114 2 : *st = ST_DERIVED_DECL;
11115 2 : return m;
11116 : }
11117 : }
11118 : else
11119 : {
11120 : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11121 : like <type name(parameter)>. */
11122 2 : gfc_gobble_whitespace ();
11123 2 : bool paren = gfc_peek_ascii_char () == '(';
11124 2 : if (paren)
11125 : {
11126 1 : if (strcmp ("is", name) == 0)
11127 1 : goto typeis;
11128 : else
11129 0 : goto derived;
11130 : }
11131 : }
11132 :
11133 : /* Treat TYPE... like PRINT... */
11134 2 : gfc_current_locus = old_loc;
11135 2 : *st = ST_WRITE;
11136 2 : return gfc_match_print ();
11137 :
11138 8 : derived:
11139 8 : gfc_current_locus = old_loc;
11140 8 : *st = ST_DERIVED_DECL;
11141 8 : return gfc_match_derived_decl ();
11142 :
11143 1 : typeis:
11144 1 : gfc_current_locus = old_loc;
11145 1 : *st = ST_TYPE_IS;
11146 1 : return gfc_match_type_is ();
11147 : }
11148 :
11149 :
11150 : /* Match the beginning of a derived type declaration. If a type name
11151 : was the result of a function, then it is possible to have a symbol
11152 : already to be known as a derived type yet have no components. */
11153 :
11154 : match
11155 16165 : gfc_match_derived_decl (void)
11156 : {
11157 16165 : char name[GFC_MAX_SYMBOL_LEN + 1];
11158 16165 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11159 16165 : symbol_attribute attr;
11160 16165 : gfc_symbol *sym, *gensym;
11161 16165 : gfc_symbol *extended;
11162 16165 : match m;
11163 16165 : match is_type_attr_spec = MATCH_NO;
11164 16165 : bool seen_attr = false;
11165 16165 : gfc_interface *intr = NULL, *head;
11166 16165 : bool parameterized_type = false;
11167 16165 : bool seen_colons = false;
11168 :
11169 16165 : if (gfc_comp_struct (gfc_current_state ()))
11170 : return MATCH_NO;
11171 :
11172 16161 : name[0] = '\0';
11173 16161 : parent[0] = '\0';
11174 16161 : gfc_clear_attr (&attr);
11175 16161 : extended = NULL;
11176 :
11177 18924 : do
11178 : {
11179 18924 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11180 18924 : if (is_type_attr_spec == MATCH_ERROR)
11181 : return MATCH_ERROR;
11182 18921 : if (is_type_attr_spec == MATCH_YES)
11183 2763 : seen_attr = true;
11184 18921 : } while (is_type_attr_spec == MATCH_YES);
11185 :
11186 : /* Deal with derived type extensions. The extension attribute has
11187 : been added to 'attr' but now the parent type must be found and
11188 : checked. */
11189 16158 : if (parent[0])
11190 1467 : extended = check_extended_derived_type (parent);
11191 :
11192 16158 : if (parent[0] && !extended)
11193 : return MATCH_ERROR;
11194 :
11195 16154 : m = gfc_match (" ::");
11196 16154 : if (m == MATCH_YES)
11197 : {
11198 : seen_colons = true;
11199 : }
11200 10215 : else if (seen_attr)
11201 : {
11202 5 : gfc_error ("Expected :: in TYPE definition at %C");
11203 5 : return MATCH_ERROR;
11204 : }
11205 :
11206 : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11207 : But, we need to simply return for TYPE(. */
11208 10210 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11209 : {
11210 10162 : char c = gfc_peek_ascii_char ();
11211 10162 : if (c == '(')
11212 : return m;
11213 10084 : if (!gfc_is_whitespace (c))
11214 : {
11215 4 : gfc_error ("Mangled derived type definition at %C");
11216 4 : return MATCH_NO;
11217 : }
11218 : }
11219 :
11220 16067 : m = gfc_match (" %n ", name);
11221 16067 : if (m != MATCH_YES)
11222 : return m;
11223 :
11224 : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11225 : derived type named 'is'.
11226 : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11227 : and checking if this is a(n intrinsic) typename. This picks up
11228 : misplaced TYPE IS statements such as in select_type_1.f03. */
11229 16055 : if (gfc_peek_ascii_char () == '(')
11230 : {
11231 3847 : if (gfc_current_state () == COMP_SELECT_TYPE
11232 421 : || (!seen_colons && !strcmp (name, "is")))
11233 : return MATCH_NO;
11234 : parameterized_type = true;
11235 : }
11236 :
11237 12627 : m = gfc_match_eos ();
11238 12627 : if (m != MATCH_YES && !parameterized_type)
11239 : return m;
11240 :
11241 : /* Make sure the name is not the name of an intrinsic type. */
11242 12624 : if (gfc_is_intrinsic_typename (name))
11243 : {
11244 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11245 : "type", name);
11246 18 : return MATCH_ERROR;
11247 : }
11248 :
11249 12606 : if (gfc_get_symbol (name, NULL, &gensym))
11250 : return MATCH_ERROR;
11251 :
11252 12606 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11253 : {
11254 5 : if (gensym->ts.u.derived)
11255 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11256 : "of %s", gensym->name, gfc_typename (&gensym->ts));
11257 : else
11258 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11259 : gensym->name);
11260 5 : return MATCH_ERROR;
11261 : }
11262 :
11263 12601 : if (!gensym->attr.generic
11264 12601 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11265 : return MATCH_ERROR;
11266 :
11267 12597 : if (!gensym->attr.function
11268 12597 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11269 : return MATCH_ERROR;
11270 :
11271 12596 : if (gensym->attr.dummy)
11272 : {
11273 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11274 : name, &gensym->declared_at);
11275 1 : return MATCH_ERROR;
11276 : }
11277 :
11278 12595 : sym = gfc_find_dt_in_generic (gensym);
11279 :
11280 12595 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11281 : {
11282 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11283 : "defined", sym->name);
11284 1 : return MATCH_ERROR;
11285 : }
11286 :
11287 12594 : if (!sym)
11288 : {
11289 : /* Use upper case to save the actual derived-type symbol. */
11290 12504 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11291 12504 : sym->name = gfc_get_string ("%s", gensym->name);
11292 12504 : head = gensym->generic;
11293 12504 : intr = gfc_get_interface ();
11294 12504 : intr->sym = sym;
11295 12504 : intr->where = gfc_current_locus;
11296 12504 : intr->sym->declared_at = gfc_current_locus;
11297 12504 : intr->next = head;
11298 12504 : gensym->generic = intr;
11299 12504 : gensym->attr.if_source = IFSRC_DECL;
11300 : }
11301 :
11302 : /* The symbol may already have the derived attribute without the
11303 : components. The ways this can happen is via a function
11304 : definition, an INTRINSIC statement or a subtype in another
11305 : derived type that is a pointer. The first part of the AND clause
11306 : is true if the symbol is not the return value of a function. */
11307 12594 : if (sym->attr.flavor != FL_DERIVED
11308 12594 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11309 : return MATCH_ERROR;
11310 :
11311 12594 : if (attr.access != ACCESS_UNKNOWN
11312 12594 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11313 : return MATCH_ERROR;
11314 12594 : else if (sym->attr.access == ACCESS_UNKNOWN
11315 12038 : && gensym->attr.access != ACCESS_UNKNOWN
11316 12921 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11317 : sym->name, NULL))
11318 : return MATCH_ERROR;
11319 :
11320 12594 : if (sym->attr.access != ACCESS_UNKNOWN
11321 883 : && gensym->attr.access == ACCESS_UNKNOWN)
11322 556 : gensym->attr.access = sym->attr.access;
11323 :
11324 : /* See if the derived type was labeled as bind(c). */
11325 12594 : if (attr.is_bind_c != 0)
11326 404 : sym->attr.is_bind_c = attr.is_bind_c;
11327 :
11328 : /* Construct the f2k_derived namespace if it is not yet there. */
11329 12594 : if (!sym->f2k_derived)
11330 12594 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11331 :
11332 12594 : if (parameterized_type)
11333 : {
11334 : /* Ignore error or mismatches by going to the end of the statement
11335 : in order to avoid the component declarations causing problems. */
11336 419 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11337 419 : if (m != MATCH_YES)
11338 4 : gfc_error_recovery ();
11339 : else
11340 415 : sym->attr.pdt_template = 1;
11341 419 : m = gfc_match_eos ();
11342 419 : if (m != MATCH_YES)
11343 : {
11344 1 : gfc_error_recovery ();
11345 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11346 : }
11347 : }
11348 :
11349 12594 : if (extended && !sym->components)
11350 : {
11351 1463 : gfc_component *p;
11352 1463 : gfc_formal_arglist *f, *g, *h;
11353 :
11354 : /* Add the extended derived type as the first component. */
11355 1463 : gfc_add_component (sym, parent, &p);
11356 1463 : extended->refs++;
11357 1463 : gfc_set_sym_referenced (extended);
11358 :
11359 1463 : p->ts.type = BT_DERIVED;
11360 1463 : p->ts.u.derived = extended;
11361 1463 : p->initializer = gfc_default_initializer (&p->ts);
11362 :
11363 : /* Set extension level. */
11364 1463 : if (extended->attr.extension == 255)
11365 : {
11366 : /* Since the extension field is 8 bit wide, we can only have
11367 : up to 255 extension levels. */
11368 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11369 : extended->name, &extended->declared_at);
11370 0 : return MATCH_ERROR;
11371 : }
11372 1463 : sym->attr.extension = extended->attr.extension + 1;
11373 :
11374 : /* Provide the links between the extended type and its extension. */
11375 1463 : if (!extended->f2k_derived)
11376 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11377 :
11378 : /* Copy the extended type-param-name-list from the extended type,
11379 : append those of the extension and add the whole lot to the
11380 : extension. */
11381 1463 : if (extended->attr.pdt_template)
11382 : {
11383 34 : g = h = NULL;
11384 34 : sym->attr.pdt_template = 1;
11385 99 : for (f = extended->formal; f; f = f->next)
11386 : {
11387 65 : if (f == extended->formal)
11388 : {
11389 34 : g = gfc_get_formal_arglist ();
11390 34 : h = g;
11391 : }
11392 : else
11393 : {
11394 31 : g->next = gfc_get_formal_arglist ();
11395 31 : g = g->next;
11396 : }
11397 65 : g->sym = f->sym;
11398 : }
11399 34 : g->next = sym->formal;
11400 34 : sym->formal = h;
11401 : }
11402 : }
11403 :
11404 12594 : if (!sym->hash_value)
11405 : /* Set the hash for the compound name for this type. */
11406 12594 : sym->hash_value = gfc_hash_value (sym);
11407 :
11408 : /* Take over the ABSTRACT attribute. */
11409 12594 : sym->attr.abstract = attr.abstract;
11410 :
11411 12594 : gfc_new_block = sym;
11412 :
11413 12594 : return MATCH_YES;
11414 : }
11415 :
11416 :
11417 : /* Cray Pointees can be declared as:
11418 : pointer (ipt, a (n,m,...,*)) */
11419 :
11420 : match
11421 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11422 : {
11423 240 : as->cray_pointee = true; /* This will be useful to know later. */
11424 240 : if (as->type == AS_ASSUMED_SIZE)
11425 72 : as->cp_was_assumed = true;
11426 168 : else if (as->type == AS_ASSUMED_SHAPE)
11427 : {
11428 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11429 0 : return MATCH_ERROR;
11430 : }
11431 : return MATCH_YES;
11432 : }
11433 :
11434 :
11435 : /* Match the enum definition statement, here we are trying to match
11436 : the first line of enum definition statement.
11437 : Returns MATCH_YES if match is found. */
11438 :
11439 : match
11440 158 : gfc_match_enum (void)
11441 : {
11442 158 : match m;
11443 :
11444 158 : m = gfc_match_eos ();
11445 158 : if (m != MATCH_YES)
11446 : return m;
11447 :
11448 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11449 0 : return MATCH_ERROR;
11450 :
11451 : return MATCH_YES;
11452 : }
11453 :
11454 :
11455 : /* Returns an initializer whose value is one higher than the value of the
11456 : LAST_INITIALIZER argument. If the argument is NULL, the
11457 : initializers value will be set to zero. The initializer's kind
11458 : will be set to gfc_c_int_kind.
11459 :
11460 : If -fshort-enums is given, the appropriate kind will be selected
11461 : later after all enumerators have been parsed. A warning is issued
11462 : here if an initializer exceeds gfc_c_int_kind. */
11463 :
11464 : static gfc_expr *
11465 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11466 : {
11467 377 : gfc_expr *result;
11468 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11469 :
11470 377 : mpz_init (result->value.integer);
11471 :
11472 377 : if (last_initializer != NULL)
11473 : {
11474 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11475 266 : result->where = last_initializer->where;
11476 :
11477 266 : if (gfc_check_integer_range (result->value.integer,
11478 : gfc_c_int_kind) != ARITH_OK)
11479 : {
11480 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11481 0 : return NULL;
11482 : }
11483 : }
11484 : else
11485 : {
11486 : /* Control comes here, if it's the very first enumerator and no
11487 : initializer has been given. It will be initialized to zero. */
11488 111 : mpz_set_si (result->value.integer, 0);
11489 : }
11490 :
11491 : return result;
11492 : }
11493 :
11494 :
11495 : /* Match a variable name with an optional initializer. When this
11496 : subroutine is called, a variable is expected to be parsed next.
11497 : Depending on what is happening at the moment, updates either the
11498 : symbol table or the current interface. */
11499 :
11500 : static match
11501 549 : enumerator_decl (void)
11502 : {
11503 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11504 549 : gfc_expr *initializer;
11505 549 : gfc_array_spec *as = NULL;
11506 549 : gfc_symbol *sym;
11507 549 : locus var_locus;
11508 549 : match m;
11509 549 : bool t;
11510 549 : locus old_locus;
11511 :
11512 549 : initializer = NULL;
11513 549 : old_locus = gfc_current_locus;
11514 :
11515 : /* When we get here, we've just matched a list of attributes and
11516 : maybe a type and a double colon. The next thing we expect to see
11517 : is the name of the symbol. */
11518 549 : m = gfc_match_name (name);
11519 549 : if (m != MATCH_YES)
11520 1 : goto cleanup;
11521 :
11522 548 : var_locus = gfc_current_locus;
11523 :
11524 : /* OK, we've successfully matched the declaration. Now put the
11525 : symbol in the current namespace. If we fail to create the symbol,
11526 : bail out. */
11527 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11528 : {
11529 1 : m = MATCH_ERROR;
11530 1 : goto cleanup;
11531 : }
11532 :
11533 : /* The double colon must be present in order to have initializers.
11534 : Otherwise the statement is ambiguous with an assignment statement. */
11535 547 : if (colon_seen)
11536 : {
11537 471 : if (gfc_match_char ('=') == MATCH_YES)
11538 : {
11539 170 : m = gfc_match_init_expr (&initializer);
11540 170 : if (m == MATCH_NO)
11541 : {
11542 0 : gfc_error ("Expected an initialization expression at %C");
11543 0 : m = MATCH_ERROR;
11544 : }
11545 :
11546 170 : if (m != MATCH_YES)
11547 2 : goto cleanup;
11548 : }
11549 : }
11550 :
11551 : /* If we do not have an initializer, the initialization value of the
11552 : previous enumerator (stored in last_initializer) is incremented
11553 : by 1 and is used to initialize the current enumerator. */
11554 545 : if (initializer == NULL)
11555 377 : initializer = enum_initializer (last_initializer, old_locus);
11556 :
11557 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11558 : {
11559 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11560 : &var_locus);
11561 2 : m = MATCH_ERROR;
11562 2 : goto cleanup;
11563 : }
11564 :
11565 : /* Store this current initializer, for the next enumerator variable
11566 : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11567 : use last_initializer below. */
11568 543 : last_initializer = initializer;
11569 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
11570 :
11571 : /* Maintain enumerator history. */
11572 543 : gfc_find_symbol (name, NULL, 0, &sym);
11573 543 : create_enum_history (sym, last_initializer);
11574 :
11575 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11576 :
11577 6 : cleanup:
11578 : /* Free stuff up and return. */
11579 6 : gfc_free_expr (initializer);
11580 :
11581 6 : return m;
11582 : }
11583 :
11584 :
11585 : /* Match the enumerator definition statement. */
11586 :
11587 : match
11588 794275 : gfc_match_enumerator_def (void)
11589 : {
11590 794275 : match m;
11591 794275 : bool t;
11592 :
11593 794275 : gfc_clear_ts (¤t_ts);
11594 :
11595 794275 : m = gfc_match (" enumerator");
11596 794275 : if (m != MATCH_YES)
11597 : return m;
11598 :
11599 269 : m = gfc_match (" :: ");
11600 269 : if (m == MATCH_ERROR)
11601 : return m;
11602 :
11603 269 : colon_seen = (m == MATCH_YES);
11604 :
11605 269 : if (gfc_current_state () != COMP_ENUM)
11606 : {
11607 4 : gfc_error ("ENUM definition statement expected before %C");
11608 4 : gfc_free_enum_history ();
11609 4 : return MATCH_ERROR;
11610 : }
11611 :
11612 265 : (¤t_ts)->type = BT_INTEGER;
11613 265 : (¤t_ts)->kind = gfc_c_int_kind;
11614 :
11615 265 : gfc_clear_attr (¤t_attr);
11616 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11617 265 : if (!t)
11618 : {
11619 0 : m = MATCH_ERROR;
11620 0 : goto cleanup;
11621 : }
11622 :
11623 549 : for (;;)
11624 : {
11625 549 : m = enumerator_decl ();
11626 549 : if (m == MATCH_ERROR)
11627 : {
11628 6 : gfc_free_enum_history ();
11629 6 : goto cleanup;
11630 : }
11631 543 : if (m == MATCH_NO)
11632 : break;
11633 :
11634 542 : if (gfc_match_eos () == MATCH_YES)
11635 256 : goto cleanup;
11636 286 : if (gfc_match_char (',') != MATCH_YES)
11637 : break;
11638 : }
11639 :
11640 3 : if (gfc_current_state () == COMP_ENUM)
11641 : {
11642 3 : gfc_free_enum_history ();
11643 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11644 3 : m = MATCH_ERROR;
11645 : }
11646 :
11647 0 : cleanup:
11648 265 : gfc_free_array_spec (current_as);
11649 265 : current_as = NULL;
11650 265 : return m;
11651 :
11652 : }
11653 :
11654 :
11655 : /* Match binding attributes. */
11656 :
11657 : static match
11658 4572 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11659 : {
11660 4572 : bool found_passing = false;
11661 4572 : bool seen_ptr = false;
11662 4572 : match m = MATCH_YES;
11663 :
11664 : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11665 : this case the defaults are in there. */
11666 4572 : ba->access = ACCESS_UNKNOWN;
11667 4572 : ba->pass_arg = NULL;
11668 4572 : ba->pass_arg_num = 0;
11669 4572 : ba->nopass = 0;
11670 4572 : ba->non_overridable = 0;
11671 4572 : ba->deferred = 0;
11672 4572 : ba->ppc = ppc;
11673 :
11674 : /* If we find a comma, we believe there are binding attributes. */
11675 4572 : m = gfc_match_char (',');
11676 4572 : if (m == MATCH_NO)
11677 2363 : goto done;
11678 :
11679 2751 : do
11680 : {
11681 : /* Access specifier. */
11682 :
11683 2751 : m = gfc_match (" public");
11684 2751 : if (m == MATCH_ERROR)
11685 0 : goto error;
11686 2751 : if (m == MATCH_YES)
11687 : {
11688 250 : if (ba->access != ACCESS_UNKNOWN)
11689 : {
11690 0 : gfc_error ("Duplicate access-specifier at %C");
11691 0 : goto error;
11692 : }
11693 :
11694 250 : ba->access = ACCESS_PUBLIC;
11695 250 : continue;
11696 : }
11697 :
11698 2501 : m = gfc_match (" private");
11699 2501 : if (m == MATCH_ERROR)
11700 0 : goto error;
11701 2501 : if (m == MATCH_YES)
11702 : {
11703 163 : if (ba->access != ACCESS_UNKNOWN)
11704 : {
11705 1 : gfc_error ("Duplicate access-specifier at %C");
11706 1 : goto error;
11707 : }
11708 :
11709 162 : ba->access = ACCESS_PRIVATE;
11710 162 : continue;
11711 : }
11712 :
11713 : /* If inside GENERIC, the following is not allowed. */
11714 2338 : if (!generic)
11715 : {
11716 :
11717 : /* NOPASS flag. */
11718 2337 : m = gfc_match (" nopass");
11719 2337 : if (m == MATCH_ERROR)
11720 0 : goto error;
11721 2337 : if (m == MATCH_YES)
11722 : {
11723 701 : if (found_passing)
11724 : {
11725 1 : gfc_error ("Binding attributes already specify passing,"
11726 : " illegal NOPASS at %C");
11727 1 : goto error;
11728 : }
11729 :
11730 700 : found_passing = true;
11731 700 : ba->nopass = 1;
11732 700 : continue;
11733 : }
11734 :
11735 : /* PASS possibly including argument. */
11736 1636 : m = gfc_match (" pass");
11737 1636 : if (m == MATCH_ERROR)
11738 0 : goto error;
11739 1636 : if (m == MATCH_YES)
11740 : {
11741 891 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11742 :
11743 891 : if (found_passing)
11744 : {
11745 2 : gfc_error ("Binding attributes already specify passing,"
11746 : " illegal PASS at %C");
11747 2 : goto error;
11748 : }
11749 :
11750 889 : m = gfc_match (" ( %n )", arg);
11751 889 : if (m == MATCH_ERROR)
11752 0 : goto error;
11753 889 : if (m == MATCH_YES)
11754 480 : ba->pass_arg = gfc_get_string ("%s", arg);
11755 889 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11756 :
11757 889 : found_passing = true;
11758 889 : ba->nopass = 0;
11759 889 : continue;
11760 889 : }
11761 :
11762 745 : if (ppc)
11763 : {
11764 : /* POINTER flag. */
11765 424 : m = gfc_match (" pointer");
11766 424 : if (m == MATCH_ERROR)
11767 0 : goto error;
11768 424 : if (m == MATCH_YES)
11769 : {
11770 424 : if (seen_ptr)
11771 : {
11772 1 : gfc_error ("Duplicate POINTER attribute at %C");
11773 1 : goto error;
11774 : }
11775 :
11776 423 : seen_ptr = true;
11777 423 : continue;
11778 : }
11779 : }
11780 : else
11781 : {
11782 : /* NON_OVERRIDABLE flag. */
11783 321 : m = gfc_match (" non_overridable");
11784 321 : if (m == MATCH_ERROR)
11785 0 : goto error;
11786 321 : if (m == MATCH_YES)
11787 : {
11788 62 : if (ba->non_overridable)
11789 : {
11790 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11791 1 : goto error;
11792 : }
11793 :
11794 61 : ba->non_overridable = 1;
11795 61 : continue;
11796 : }
11797 :
11798 : /* DEFERRED flag. */
11799 259 : m = gfc_match (" deferred");
11800 259 : if (m == MATCH_ERROR)
11801 0 : goto error;
11802 259 : if (m == MATCH_YES)
11803 : {
11804 259 : if (ba->deferred)
11805 : {
11806 1 : gfc_error ("Duplicate DEFERRED at %C");
11807 1 : goto error;
11808 : }
11809 :
11810 258 : ba->deferred = 1;
11811 258 : continue;
11812 : }
11813 : }
11814 :
11815 : }
11816 :
11817 : /* Nothing matching found. */
11818 1 : if (generic)
11819 1 : gfc_error ("Expected access-specifier at %C");
11820 : else
11821 0 : gfc_error ("Expected binding attribute at %C");
11822 1 : goto error;
11823 : }
11824 2743 : while (gfc_match_char (',') == MATCH_YES);
11825 :
11826 : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11827 2201 : if (ba->non_overridable && ba->deferred)
11828 : {
11829 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11830 1 : goto error;
11831 : }
11832 :
11833 : m = MATCH_YES;
11834 :
11835 4563 : done:
11836 4563 : if (ba->access == ACCESS_UNKNOWN)
11837 4152 : ba->access = ppc ? gfc_current_block()->component_access
11838 : : gfc_typebound_default_access;
11839 :
11840 4563 : if (ppc && !seen_ptr)
11841 : {
11842 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
11843 : " at %C");
11844 2 : goto error;
11845 : }
11846 :
11847 : return m;
11848 :
11849 : error:
11850 : return MATCH_ERROR;
11851 : }
11852 :
11853 :
11854 : /* Match a PROCEDURE specific binding inside a derived type. */
11855 :
11856 : static match
11857 3139 : match_procedure_in_type (void)
11858 : {
11859 3139 : char name[GFC_MAX_SYMBOL_LEN + 1];
11860 3139 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
11861 3139 : char* target = NULL, *ifc = NULL;
11862 3139 : gfc_typebound_proc tb;
11863 3139 : bool seen_colons;
11864 3139 : bool seen_attrs;
11865 3139 : match m;
11866 3139 : gfc_symtree* stree;
11867 3139 : gfc_namespace* ns;
11868 3139 : gfc_symbol* block;
11869 3139 : int num;
11870 :
11871 : /* Check current state. */
11872 3139 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
11873 3139 : block = gfc_state_stack->previous->sym;
11874 3139 : gcc_assert (block);
11875 :
11876 : /* Try to match PROCEDURE(interface). */
11877 3139 : if (gfc_match (" (") == MATCH_YES)
11878 : {
11879 260 : m = gfc_match_name (target_buf);
11880 260 : if (m == MATCH_ERROR)
11881 : return m;
11882 260 : if (m != MATCH_YES)
11883 : {
11884 1 : gfc_error ("Interface-name expected after %<(%> at %C");
11885 1 : return MATCH_ERROR;
11886 : }
11887 :
11888 259 : if (gfc_match (" )") != MATCH_YES)
11889 : {
11890 1 : gfc_error ("%<)%> expected at %C");
11891 1 : return MATCH_ERROR;
11892 : }
11893 :
11894 : ifc = target_buf;
11895 : }
11896 :
11897 : /* Construct the data structure. */
11898 3137 : memset (&tb, 0, sizeof (tb));
11899 3137 : tb.where = gfc_current_locus;
11900 :
11901 : /* Match binding attributes. */
11902 3137 : m = match_binding_attributes (&tb, false, false);
11903 3137 : if (m == MATCH_ERROR)
11904 : return m;
11905 3130 : seen_attrs = (m == MATCH_YES);
11906 :
11907 : /* Check that attribute DEFERRED is given if an interface is specified. */
11908 3130 : if (tb.deferred && !ifc)
11909 : {
11910 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
11911 1 : return MATCH_ERROR;
11912 : }
11913 3129 : if (ifc && !tb.deferred)
11914 : {
11915 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11916 1 : return MATCH_ERROR;
11917 : }
11918 :
11919 : /* Match the colons. */
11920 3128 : m = gfc_match (" ::");
11921 3128 : if (m == MATCH_ERROR)
11922 : return m;
11923 3128 : seen_colons = (m == MATCH_YES);
11924 3128 : if (seen_attrs && !seen_colons)
11925 : {
11926 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
11927 4 : return MATCH_ERROR;
11928 : }
11929 :
11930 : /* Match the binding names. */
11931 19 : for(num=1;;num++)
11932 : {
11933 3143 : m = gfc_match_name (name);
11934 3143 : if (m == MATCH_ERROR)
11935 : return m;
11936 3143 : if (m == MATCH_NO)
11937 : {
11938 5 : gfc_error ("Expected binding name at %C");
11939 5 : return MATCH_ERROR;
11940 : }
11941 :
11942 3138 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
11943 : return MATCH_ERROR;
11944 :
11945 : /* Try to match the '=> target', if it's there. */
11946 3137 : target = ifc;
11947 3137 : m = gfc_match (" =>");
11948 3137 : if (m == MATCH_ERROR)
11949 : return m;
11950 3137 : if (m == MATCH_YES)
11951 : {
11952 1245 : if (tb.deferred)
11953 : {
11954 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11955 1 : return MATCH_ERROR;
11956 : }
11957 :
11958 1244 : if (!seen_colons)
11959 : {
11960 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11961 : " at %C");
11962 1 : return MATCH_ERROR;
11963 : }
11964 :
11965 1243 : m = gfc_match_name (target_buf);
11966 1243 : if (m == MATCH_ERROR)
11967 : return m;
11968 1243 : if (m == MATCH_NO)
11969 : {
11970 2 : gfc_error ("Expected binding target after %<=>%> at %C");
11971 2 : return MATCH_ERROR;
11972 : }
11973 : target = target_buf;
11974 : }
11975 :
11976 : /* If no target was found, it has the same name as the binding. */
11977 1892 : if (!target)
11978 1638 : target = name;
11979 :
11980 : /* Get the namespace to insert the symbols into. */
11981 3133 : ns = block->f2k_derived;
11982 3133 : gcc_assert (ns);
11983 :
11984 : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11985 3133 : if (tb.deferred && !block->attr.abstract)
11986 : {
11987 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
11988 : "is not ABSTRACT", block->name);
11989 1 : return MATCH_ERROR;
11990 : }
11991 :
11992 : /* See if we already have a binding with this name in the symtree which
11993 : would be an error. If a GENERIC already targeted this binding, it may
11994 : be already there but then typebound is still NULL. */
11995 3132 : stree = gfc_find_symtree (ns->tb_sym_root, name);
11996 3132 : if (stree && stree->n.tb)
11997 : {
11998 2 : gfc_error ("There is already a procedure with binding name %qs for "
11999 : "the derived type %qs at %C", name, block->name);
12000 2 : return MATCH_ERROR;
12001 : }
12002 :
12003 : /* Insert it and set attributes. */
12004 :
12005 3035 : if (!stree)
12006 : {
12007 3035 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
12008 3035 : gcc_assert (stree);
12009 : }
12010 3130 : stree->n.tb = gfc_get_typebound_proc (&tb);
12011 :
12012 3130 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
12013 : false))
12014 : return MATCH_ERROR;
12015 3130 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
12016 3130 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
12017 3130 : target, &stree->n.tb->u.specific->n.sym->declared_at);
12018 :
12019 3130 : if (gfc_match_eos () == MATCH_YES)
12020 : return MATCH_YES;
12021 20 : if (gfc_match_char (',') != MATCH_YES)
12022 1 : goto syntax;
12023 : }
12024 :
12025 1 : syntax:
12026 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
12027 1 : return MATCH_ERROR;
12028 : }
12029 :
12030 :
12031 : /* Match a GENERIC statement.
12032 : F2018 15.4.3.3 GENERIC statement
12033 :
12034 : A GENERIC statement specifies a generic identifier for one or more specific
12035 : procedures, in the same way as a generic interface block that does not contain
12036 : interface bodies.
12037 :
12038 : R1510 generic-stmt is:
12039 : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12040 :
12041 : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12042 : procedure that was specified previously in any accessible interface with the
12043 : same generic identifier.
12044 :
12045 : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12046 :
12047 : For GENERIC statements outside of a derived type, use is made of the existing,
12048 : typebound matching functions to obtain access-spec and generic-spec. After
12049 : this the standard INTERFACE machinery is used. */
12050 :
12051 : static match
12052 100 : match_generic_stmt (void)
12053 : {
12054 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12055 : /* Allow space for OPERATOR(...). */
12056 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12057 : /* Generics other than uops */
12058 100 : gfc_symbol* generic_spec = NULL;
12059 : /* Generic uops */
12060 100 : gfc_user_op *generic_uop = NULL;
12061 : /* For the matching calls */
12062 100 : gfc_typebound_proc tbattr;
12063 100 : gfc_namespace* ns = gfc_current_ns;
12064 100 : interface_type op_type;
12065 100 : gfc_intrinsic_op op;
12066 100 : match m;
12067 100 : gfc_symtree* st;
12068 : /* The specific-procedure-list */
12069 100 : gfc_interface *generic = NULL;
12070 : /* The head of the specific-procedure-list */
12071 100 : gfc_interface **generic_tail = NULL;
12072 :
12073 100 : memset (&tbattr, 0, sizeof (tbattr));
12074 100 : tbattr.where = gfc_current_locus;
12075 :
12076 : /* See if we get an access-specifier. */
12077 100 : m = match_binding_attributes (&tbattr, true, false);
12078 100 : tbattr.where = gfc_current_locus;
12079 100 : if (m == MATCH_ERROR)
12080 0 : goto error;
12081 :
12082 : /* Now the colons, those are required. */
12083 100 : if (gfc_match (" ::") != MATCH_YES)
12084 : {
12085 0 : gfc_error ("Expected %<::%> at %C");
12086 0 : goto error;
12087 : }
12088 :
12089 : /* Match the generic-spec name; depending on type (operator / generic) format
12090 : it for future error messages in 'generic_spec_name'. */
12091 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12092 100 : if (m == MATCH_ERROR)
12093 : return MATCH_ERROR;
12094 100 : if (m == MATCH_NO)
12095 : {
12096 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12097 0 : goto error;
12098 : }
12099 :
12100 100 : switch (op_type)
12101 : {
12102 63 : case INTERFACE_GENERIC:
12103 63 : case INTERFACE_DTIO:
12104 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12105 63 : break;
12106 :
12107 22 : case INTERFACE_USER_OP:
12108 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12109 22 : break;
12110 :
12111 13 : case INTERFACE_INTRINSIC_OP:
12112 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12113 : gfc_op2string (op));
12114 13 : break;
12115 :
12116 2 : case INTERFACE_NAMELESS:
12117 2 : gfc_error ("Malformed GENERIC statement at %C");
12118 2 : goto error;
12119 0 : break;
12120 :
12121 0 : default:
12122 0 : gcc_unreachable ();
12123 : }
12124 :
12125 : /* Match the required =>. */
12126 98 : if (gfc_match (" =>") != MATCH_YES)
12127 : {
12128 1 : gfc_error ("Expected %<=>%> at %C");
12129 1 : goto error;
12130 : }
12131 :
12132 :
12133 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12134 : {
12135 1 : gfc_error ("The access specification at %L not in a module",
12136 : &tbattr.where);
12137 1 : goto error;
12138 : }
12139 :
12140 : /* Try to find existing generic-spec with this name for this operator;
12141 : if there is something, check that it is another generic-spec and then
12142 : extend it rather than building a new symbol. Otherwise, create a new
12143 : one with the right attributes. */
12144 :
12145 96 : switch (op_type)
12146 : {
12147 61 : case INTERFACE_DTIO:
12148 61 : case INTERFACE_GENERIC:
12149 61 : st = gfc_find_symtree (ns->sym_root, name);
12150 61 : generic_spec = st ? st->n.sym : NULL;
12151 61 : if (generic_spec)
12152 : {
12153 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12154 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12155 : {
12156 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12157 : "name of an entity declared at %L that is not a "
12158 : "procedure", name, &generic_spec->declared_at);
12159 1 : goto error;
12160 : }
12161 :
12162 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12163 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12164 : {
12165 0 : gfc_error ("There's already a non-generic procedure with "
12166 : "name %qs at %C", generic_spec->name);
12167 0 : goto error;
12168 : }
12169 :
12170 24 : if (tbattr.access != ACCESS_UNKNOWN)
12171 : {
12172 2 : if (generic_spec->attr.access != tbattr.access)
12173 : {
12174 1 : gfc_error ("The access specification at %L conflicts with "
12175 : "that already given to %qs", &tbattr.where,
12176 : generic_spec->name);
12177 1 : goto error;
12178 : }
12179 : else
12180 : {
12181 1 : gfc_error ("The access specification at %L repeats that "
12182 : "already given to %qs", &tbattr.where,
12183 : generic_spec->name);
12184 1 : goto error;
12185 : }
12186 : }
12187 :
12188 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12189 : {
12190 1 : gfc_error ("The generic-spec in the generic statement at %C "
12191 : "has a type from the declaration at %L",
12192 : &generic_spec->declared_at);
12193 1 : goto error;
12194 : }
12195 : }
12196 :
12197 : /* Now create the generic_spec if it doesn't already exist and provide
12198 : is with the appropriate attributes. */
12199 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12200 : {
12201 45 : if (!generic_spec)
12202 : {
12203 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12204 36 : gfc_set_sym_referenced (generic_spec);
12205 36 : generic_spec->attr.access = tbattr.access;
12206 : }
12207 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12208 0 : generic_spec->attr.access = tbattr.access;
12209 45 : generic_spec->refs++;
12210 45 : generic_spec->attr.generic = 1;
12211 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12212 :
12213 45 : generic_spec->declared_at = gfc_current_locus;
12214 : }
12215 :
12216 : /* Prepare to add the specific procedures. */
12217 57 : generic = generic_spec->generic;
12218 57 : generic_tail = &generic_spec->generic;
12219 57 : break;
12220 :
12221 22 : case INTERFACE_USER_OP:
12222 22 : st = gfc_find_symtree (ns->uop_root, name);
12223 22 : generic_uop = st ? st->n.uop : NULL;
12224 2 : if (generic_uop)
12225 : {
12226 2 : if (generic_uop->access != ACCESS_UNKNOWN
12227 2 : && tbattr.access != ACCESS_UNKNOWN)
12228 : {
12229 2 : if (generic_uop->access != tbattr.access)
12230 : {
12231 1 : gfc_error ("The user operator at %L must have the same "
12232 : "access specification as already defined user "
12233 : "operator %qs", &tbattr.where, generic_spec_name);
12234 1 : goto error;
12235 : }
12236 : else
12237 : {
12238 1 : gfc_error ("The user operator at %L repeats the access "
12239 : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12240 1 : goto error;
12241 : }
12242 : }
12243 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12244 0 : generic_uop->access = tbattr.access;
12245 : }
12246 : else
12247 : {
12248 20 : generic_uop = gfc_get_uop (name);
12249 20 : generic_uop->access = tbattr.access;
12250 : }
12251 :
12252 : /* Prepare to add the specific procedures. */
12253 20 : generic = generic_uop->op;
12254 20 : generic_tail = &generic_uop->op;
12255 20 : break;
12256 :
12257 13 : case INTERFACE_INTRINSIC_OP:
12258 13 : generic = ns->op[op];
12259 13 : generic_tail = &ns->op[op];
12260 13 : break;
12261 :
12262 0 : default:
12263 0 : gcc_unreachable ();
12264 : }
12265 :
12266 : /* Now, match all following names in the specific-procedure-list. */
12267 154 : do
12268 : {
12269 154 : m = gfc_match_name (name);
12270 154 : if (m == MATCH_ERROR)
12271 0 : goto error;
12272 154 : if (m == MATCH_NO)
12273 : {
12274 0 : gfc_error ("Expected specific procedure name at %C");
12275 0 : goto error;
12276 : }
12277 :
12278 154 : if (op_type == INTERFACE_GENERIC
12279 95 : && !strcmp (generic_spec->name, name))
12280 : {
12281 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12282 : "with that of the generic-spec", name);
12283 2 : goto error;
12284 : }
12285 :
12286 152 : generic = *generic_tail;
12287 242 : for (; generic; generic = generic->next)
12288 : {
12289 90 : if (!strcmp (generic->sym->name, name))
12290 : {
12291 0 : gfc_error ("%qs already defined as a specific procedure for the"
12292 : " generic %qs at %C", name, generic_spec->name);
12293 0 : goto error;
12294 : }
12295 : }
12296 :
12297 152 : gfc_find_sym_tree (name, ns, 1, &st);
12298 152 : if (!st)
12299 : {
12300 : /* This might be a procedure that has not yet been parsed. If
12301 : so gfc_fixup_sibling_symbols will replace this symbol with
12302 : that of the procedure. */
12303 75 : gfc_get_sym_tree (name, ns, &st, false);
12304 75 : st->n.sym->refs++;
12305 : }
12306 :
12307 152 : generic = gfc_get_interface();
12308 152 : generic->next = *generic_tail;
12309 152 : *generic_tail = generic;
12310 152 : generic->where = gfc_current_locus;
12311 152 : generic->sym = st->n.sym;
12312 : }
12313 152 : while (gfc_match (" ,") == MATCH_YES);
12314 :
12315 88 : if (gfc_match_eos () != MATCH_YES)
12316 : {
12317 0 : gfc_error ("Junk after GENERIC statement at %C");
12318 0 : goto error;
12319 : }
12320 :
12321 88 : gfc_commit_symbols ();
12322 88 : return MATCH_YES;
12323 :
12324 : error:
12325 : return MATCH_ERROR;
12326 : }
12327 :
12328 :
12329 : /* Match a GENERIC procedure binding inside a derived type. */
12330 :
12331 : static match
12332 910 : match_typebound_generic (void)
12333 : {
12334 910 : char name[GFC_MAX_SYMBOL_LEN + 1];
12335 910 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12336 910 : gfc_symbol* block;
12337 910 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12338 910 : gfc_typebound_proc* tb;
12339 910 : gfc_namespace* ns;
12340 910 : interface_type op_type;
12341 910 : gfc_intrinsic_op op;
12342 910 : match m;
12343 :
12344 : /* Check current state. */
12345 910 : if (gfc_current_state () == COMP_DERIVED)
12346 : {
12347 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12348 0 : return MATCH_ERROR;
12349 : }
12350 910 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12351 : return MATCH_NO;
12352 910 : block = gfc_state_stack->previous->sym;
12353 910 : ns = block->f2k_derived;
12354 910 : gcc_assert (block && ns);
12355 :
12356 910 : memset (&tbattr, 0, sizeof (tbattr));
12357 910 : tbattr.where = gfc_current_locus;
12358 :
12359 : /* See if we get an access-specifier. */
12360 910 : m = match_binding_attributes (&tbattr, true, false);
12361 910 : if (m == MATCH_ERROR)
12362 1 : goto error;
12363 :
12364 : /* Now the colons, those are required. */
12365 909 : if (gfc_match (" ::") != MATCH_YES)
12366 : {
12367 0 : gfc_error ("Expected %<::%> at %C");
12368 0 : goto error;
12369 : }
12370 :
12371 : /* Match the binding name; depending on type (operator / generic) format
12372 : it for future error messages into bind_name. */
12373 :
12374 909 : m = gfc_match_generic_spec (&op_type, name, &op);
12375 909 : if (m == MATCH_ERROR)
12376 : return MATCH_ERROR;
12377 909 : if (m == MATCH_NO)
12378 : {
12379 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12380 0 : goto error;
12381 : }
12382 :
12383 909 : switch (op_type)
12384 : {
12385 456 : case INTERFACE_GENERIC:
12386 456 : case INTERFACE_DTIO:
12387 456 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12388 456 : break;
12389 :
12390 29 : case INTERFACE_USER_OP:
12391 29 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12392 29 : break;
12393 :
12394 423 : case INTERFACE_INTRINSIC_OP:
12395 423 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12396 : gfc_op2string (op));
12397 423 : break;
12398 :
12399 1 : case INTERFACE_NAMELESS:
12400 1 : gfc_error ("Malformed GENERIC statement at %C");
12401 1 : goto error;
12402 0 : break;
12403 :
12404 0 : default:
12405 0 : gcc_unreachable ();
12406 : }
12407 :
12408 : /* Match the required =>. */
12409 908 : if (gfc_match (" =>") != MATCH_YES)
12410 : {
12411 0 : gfc_error ("Expected %<=>%> at %C");
12412 0 : goto error;
12413 : }
12414 :
12415 : /* Try to find existing GENERIC binding with this name / for this operator;
12416 : if there is something, check that it is another GENERIC and then extend
12417 : it rather than building a new node. Otherwise, create it and put it
12418 : at the right position. */
12419 :
12420 908 : switch (op_type)
12421 : {
12422 485 : case INTERFACE_DTIO:
12423 485 : case INTERFACE_USER_OP:
12424 485 : case INTERFACE_GENERIC:
12425 485 : {
12426 485 : const bool is_op = (op_type == INTERFACE_USER_OP);
12427 485 : gfc_symtree* st;
12428 :
12429 485 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12430 485 : tb = st ? st->n.tb : NULL;
12431 : break;
12432 : }
12433 :
12434 423 : case INTERFACE_INTRINSIC_OP:
12435 423 : tb = ns->tb_op[op];
12436 423 : break;
12437 :
12438 0 : default:
12439 0 : gcc_unreachable ();
12440 : }
12441 :
12442 434 : if (tb)
12443 : {
12444 9 : if (!tb->is_generic)
12445 : {
12446 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12447 1 : gfc_error ("There's already a non-generic procedure with binding name"
12448 : " %qs for the derived type %qs at %C",
12449 : bind_name, block->name);
12450 1 : goto error;
12451 : }
12452 :
12453 8 : if (tb->access != tbattr.access)
12454 : {
12455 2 : gfc_error ("Binding at %C must have the same access as already"
12456 : " defined binding %qs", bind_name);
12457 2 : goto error;
12458 : }
12459 : }
12460 : else
12461 : {
12462 899 : tb = gfc_get_typebound_proc (NULL);
12463 899 : tb->where = gfc_current_locus;
12464 899 : tb->access = tbattr.access;
12465 899 : tb->is_generic = 1;
12466 899 : tb->u.generic = NULL;
12467 :
12468 899 : switch (op_type)
12469 : {
12470 476 : case INTERFACE_DTIO:
12471 476 : case INTERFACE_GENERIC:
12472 476 : case INTERFACE_USER_OP:
12473 476 : {
12474 476 : const bool is_op = (op_type == INTERFACE_USER_OP);
12475 476 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12476 : &ns->tb_sym_root, name);
12477 476 : gcc_assert (st);
12478 476 : st->n.tb = tb;
12479 :
12480 476 : break;
12481 : }
12482 :
12483 423 : case INTERFACE_INTRINSIC_OP:
12484 423 : ns->tb_op[op] = tb;
12485 423 : break;
12486 :
12487 0 : default:
12488 0 : gcc_unreachable ();
12489 : }
12490 : }
12491 :
12492 : /* Now, match all following names as specific targets. */
12493 1056 : do
12494 : {
12495 1056 : gfc_symtree* target_st;
12496 1056 : gfc_tbp_generic* target;
12497 :
12498 1056 : m = gfc_match_name (name);
12499 1056 : if (m == MATCH_ERROR)
12500 0 : goto error;
12501 1056 : if (m == MATCH_NO)
12502 : {
12503 1 : gfc_error ("Expected specific binding name at %C");
12504 1 : goto error;
12505 : }
12506 :
12507 1055 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12508 :
12509 : /* See if this is a duplicate specification. */
12510 1284 : for (target = tb->u.generic; target; target = target->next)
12511 230 : if (target_st == target->specific_st)
12512 : {
12513 1 : gfc_error ("%qs already defined as specific binding for the"
12514 : " generic %qs at %C", name, bind_name);
12515 1 : goto error;
12516 : }
12517 :
12518 1054 : target = gfc_get_tbp_generic ();
12519 1054 : target->specific_st = target_st;
12520 1054 : target->specific = NULL;
12521 1054 : target->next = tb->u.generic;
12522 1054 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12523 1054 : || (op_type == INTERFACE_INTRINSIC_OP));
12524 1054 : tb->u.generic = target;
12525 : }
12526 1054 : while (gfc_match (" ,") == MATCH_YES);
12527 :
12528 : /* Here should be the end. */
12529 903 : if (gfc_match_eos () != MATCH_YES)
12530 : {
12531 1 : gfc_error ("Junk after GENERIC binding at %C");
12532 1 : goto error;
12533 : }
12534 :
12535 : return MATCH_YES;
12536 :
12537 : error:
12538 : return MATCH_ERROR;
12539 : }
12540 :
12541 :
12542 : match
12543 1010 : gfc_match_generic ()
12544 : {
12545 1010 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12546 1008 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12547 100 : return match_generic_stmt ();
12548 : else
12549 910 : return match_typebound_generic ();
12550 : }
12551 :
12552 :
12553 : /* Match a FINAL declaration inside a derived type. */
12554 :
12555 : match
12556 448 : gfc_match_final_decl (void)
12557 : {
12558 448 : char name[GFC_MAX_SYMBOL_LEN + 1];
12559 448 : gfc_symbol* sym;
12560 448 : match m;
12561 448 : gfc_namespace* module_ns;
12562 448 : bool first, last;
12563 448 : gfc_symbol* block;
12564 :
12565 448 : if (gfc_current_form == FORM_FREE)
12566 : {
12567 448 : char c = gfc_peek_ascii_char ();
12568 448 : if (!gfc_is_whitespace (c) && c != ':')
12569 : return MATCH_NO;
12570 : }
12571 :
12572 447 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12573 : {
12574 1 : if (gfc_current_form == FORM_FIXED)
12575 : return MATCH_NO;
12576 :
12577 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12578 : "CONTAINS section");
12579 1 : return MATCH_ERROR;
12580 : }
12581 :
12582 446 : block = gfc_state_stack->previous->sym;
12583 446 : gcc_assert (block);
12584 :
12585 446 : if (gfc_state_stack->previous->previous
12586 446 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12587 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12588 : {
12589 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12590 : " specification part of a MODULE");
12591 0 : return MATCH_ERROR;
12592 : }
12593 :
12594 446 : module_ns = gfc_current_ns;
12595 446 : gcc_assert (module_ns);
12596 446 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12597 :
12598 : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12599 446 : if (gfc_match (" ::") == MATCH_ERROR)
12600 : return MATCH_ERROR;
12601 :
12602 : /* Match the sequence of procedure names. */
12603 : first = true;
12604 : last = false;
12605 532 : do
12606 : {
12607 532 : gfc_finalizer* f;
12608 :
12609 532 : if (first && gfc_match_eos () == MATCH_YES)
12610 : {
12611 2 : gfc_error ("Empty FINAL at %C");
12612 2 : return MATCH_ERROR;
12613 : }
12614 :
12615 530 : m = gfc_match_name (name);
12616 530 : if (m == MATCH_NO)
12617 : {
12618 1 : gfc_error ("Expected module procedure name at %C");
12619 1 : return MATCH_ERROR;
12620 : }
12621 529 : else if (m != MATCH_YES)
12622 : return MATCH_ERROR;
12623 :
12624 529 : if (gfc_match_eos () == MATCH_YES)
12625 : last = true;
12626 87 : if (!last && gfc_match_char (',') != MATCH_YES)
12627 : {
12628 1 : gfc_error ("Expected %<,%> at %C");
12629 1 : return MATCH_ERROR;
12630 : }
12631 :
12632 528 : if (gfc_get_symbol (name, module_ns, &sym))
12633 : {
12634 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12635 0 : return MATCH_ERROR;
12636 : }
12637 :
12638 : /* Mark the symbol as module procedure. */
12639 528 : if (sym->attr.proc != PROC_MODULE
12640 528 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12641 : return MATCH_ERROR;
12642 :
12643 : /* Check if we already have this symbol in the list, this is an error. */
12644 709 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12645 182 : if (f->proc_sym == sym)
12646 : {
12647 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12648 : name);
12649 1 : return MATCH_ERROR;
12650 : }
12651 :
12652 : /* Add this symbol to the list of finalizers. */
12653 527 : gcc_assert (block->f2k_derived);
12654 527 : sym->refs++;
12655 527 : f = XCNEW (gfc_finalizer);
12656 527 : f->proc_sym = sym;
12657 527 : f->proc_tree = NULL;
12658 527 : f->where = gfc_current_locus;
12659 527 : f->next = block->f2k_derived->finalizers;
12660 527 : block->f2k_derived->finalizers = f;
12661 :
12662 527 : first = false;
12663 : }
12664 527 : while (!last);
12665 :
12666 : return MATCH_YES;
12667 : }
12668 :
12669 :
12670 : const ext_attr_t ext_attr_list[] = {
12671 : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12672 : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12673 : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12674 : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12675 : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12676 : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12677 : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12678 : { "noinline", EXT_ATTR_NOINLINE, NULL },
12679 : { "noreturn", EXT_ATTR_NORETURN, NULL },
12680 : { "weak", EXT_ATTR_WEAK, NULL },
12681 : { NULL, EXT_ATTR_LAST, NULL }
12682 : };
12683 :
12684 : /* Match a !GCC$ ATTRIBUTES statement of the form:
12685 : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12686 : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12687 :
12688 : TODO: We should support all GCC attributes using the same syntax for
12689 : the attribute list, i.e. the list in C
12690 : __attributes(( attribute-list ))
12691 : matches then
12692 : !GCC$ ATTRIBUTES attribute-list ::
12693 : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12694 : saved into a TREE.
12695 :
12696 : As there is absolutely no risk of confusion, we should never return
12697 : MATCH_NO. */
12698 : match
12699 2976 : gfc_match_gcc_attributes (void)
12700 : {
12701 2976 : symbol_attribute attr;
12702 2976 : char name[GFC_MAX_SYMBOL_LEN + 1];
12703 2976 : unsigned id;
12704 2976 : gfc_symbol *sym;
12705 2976 : match m;
12706 :
12707 2976 : gfc_clear_attr (&attr);
12708 2976 : for(;;)
12709 : {
12710 2976 : char ch;
12711 :
12712 2976 : if (gfc_match_name (name) != MATCH_YES)
12713 : return MATCH_ERROR;
12714 :
12715 17941 : for (id = 0; id < EXT_ATTR_LAST; id++)
12716 17941 : if (strcmp (name, ext_attr_list[id].name) == 0)
12717 : break;
12718 :
12719 2976 : if (id == EXT_ATTR_LAST)
12720 : {
12721 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12722 0 : return MATCH_ERROR;
12723 : }
12724 :
12725 2976 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12726 : return MATCH_ERROR;
12727 :
12728 2976 : gfc_gobble_whitespace ();
12729 2976 : ch = gfc_next_ascii_char ();
12730 2976 : if (ch == ':')
12731 : {
12732 : /* This is the successful exit condition for the loop. */
12733 2976 : if (gfc_next_ascii_char () == ':')
12734 : break;
12735 : }
12736 :
12737 0 : if (ch == ',')
12738 0 : continue;
12739 :
12740 0 : goto syntax;
12741 0 : }
12742 :
12743 2976 : if (gfc_match_eos () == MATCH_YES)
12744 0 : goto syntax;
12745 :
12746 2991 : for(;;)
12747 : {
12748 2991 : m = gfc_match_name (name);
12749 2991 : if (m != MATCH_YES)
12750 : return m;
12751 :
12752 2991 : if (find_special (name, &sym, true))
12753 : return MATCH_ERROR;
12754 :
12755 2991 : sym->attr.ext_attr |= attr.ext_attr;
12756 :
12757 2991 : if (gfc_match_eos () == MATCH_YES)
12758 : break;
12759 :
12760 15 : if (gfc_match_char (',') != MATCH_YES)
12761 0 : goto syntax;
12762 : }
12763 :
12764 : return MATCH_YES;
12765 :
12766 0 : syntax:
12767 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
12768 0 : return MATCH_ERROR;
12769 : }
12770 :
12771 :
12772 : /* Match a !GCC$ UNROLL statement of the form:
12773 : !GCC$ UNROLL n
12774 :
12775 : The parameter n is the number of times we are supposed to unroll.
12776 :
12777 : When we come here, we have already matched the !GCC$ UNROLL string. */
12778 : match
12779 19 : gfc_match_gcc_unroll (void)
12780 : {
12781 19 : int value;
12782 :
12783 : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
12784 19 : if (gfc_match_small_int (&value) == MATCH_YES)
12785 : {
12786 19 : if (value < 0 || value > USHRT_MAX)
12787 : {
12788 2 : gfc_error ("%<GCC unroll%> directive requires a"
12789 : " non-negative integral constant"
12790 : " less than or equal to %u at %C",
12791 : USHRT_MAX
12792 : );
12793 2 : return MATCH_ERROR;
12794 : }
12795 17 : if (gfc_match_eos () == MATCH_YES)
12796 : {
12797 17 : directive_unroll = value == 0 ? 1 : value;
12798 17 : return MATCH_YES;
12799 : }
12800 : }
12801 :
12802 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
12803 0 : return MATCH_ERROR;
12804 : }
12805 :
12806 : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
12807 :
12808 : The parameter b is name of a middle-end built-in.
12809 : FLAGS is optional and must be one of:
12810 : - (inbranch)
12811 : - (notinbranch)
12812 :
12813 : IF('target') is optional and TARGET is a name of a multilib ABI.
12814 :
12815 : When we come here, we have already matched the !GCC$ builtin string. */
12816 :
12817 : match
12818 3378489 : gfc_match_gcc_builtin (void)
12819 : {
12820 3378489 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
12821 3378489 : char target[GFC_MAX_SYMBOL_LEN + 1];
12822 :
12823 3378489 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
12824 : return MATCH_ERROR;
12825 :
12826 3378489 : gfc_simd_clause clause = SIMD_NONE;
12827 3378489 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
12828 : clause = SIMD_NOTINBRANCH;
12829 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
12830 15 : clause = SIMD_INBRANCH;
12831 :
12832 3378489 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
12833 : {
12834 3378459 : if (strcmp (target, "fastmath") == 0)
12835 : {
12836 0 : if (!fast_math_flags_set_p (&global_options))
12837 : return MATCH_YES;
12838 : }
12839 : else
12840 : {
12841 3378459 : const char *abi = targetm.get_multilib_abi_name ();
12842 3378459 : if (abi == NULL || strcmp (abi, target) != 0)
12843 : return MATCH_YES;
12844 : }
12845 : }
12846 :
12847 1667282 : if (gfc_vectorized_builtins == NULL)
12848 30881 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
12849 :
12850 1667282 : char *r = XNEWVEC (char, strlen (builtin) + 32);
12851 1667282 : sprintf (r, "__builtin_%s", builtin);
12852 :
12853 1667282 : bool existed;
12854 1667282 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
12855 1667282 : value |= clause;
12856 1667282 : if (existed)
12857 23 : free (r);
12858 :
12859 : return MATCH_YES;
12860 : }
12861 :
12862 : /* Match an !GCC$ IVDEP statement.
12863 : When we come here, we have already matched the !GCC$ IVDEP string. */
12864 :
12865 : match
12866 3 : gfc_match_gcc_ivdep (void)
12867 : {
12868 3 : if (gfc_match_eos () == MATCH_YES)
12869 : {
12870 3 : directive_ivdep = true;
12871 3 : return MATCH_YES;
12872 : }
12873 :
12874 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
12875 0 : return MATCH_ERROR;
12876 : }
12877 :
12878 : /* Match an !GCC$ VECTOR statement.
12879 : When we come here, we have already matched the !GCC$ VECTOR string. */
12880 :
12881 : match
12882 3 : gfc_match_gcc_vector (void)
12883 : {
12884 3 : if (gfc_match_eos () == MATCH_YES)
12885 : {
12886 3 : directive_vector = true;
12887 3 : directive_novector = false;
12888 3 : return MATCH_YES;
12889 : }
12890 :
12891 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
12892 0 : return MATCH_ERROR;
12893 : }
12894 :
12895 : /* Match an !GCC$ NOVECTOR statement.
12896 : When we come here, we have already matched the !GCC$ NOVECTOR string. */
12897 :
12898 : match
12899 3 : gfc_match_gcc_novector (void)
12900 : {
12901 3 : if (gfc_match_eos () == MATCH_YES)
12902 : {
12903 3 : directive_novector = true;
12904 3 : directive_vector = false;
12905 3 : return MATCH_YES;
12906 : }
12907 :
12908 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
12909 0 : return MATCH_ERROR;
12910 : }
|
