Branch data Line data Source code
1 : : /* Declaration statement matcher
2 : : Copyright (C) 2002-2025 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 : :
33 : : /* Macros to access allocate memory for gfc_data_variable,
34 : : gfc_data_value and gfc_data. */
35 : : #define gfc_get_data_variable() XCNEW (gfc_data_variable)
36 : : #define gfc_get_data_value() XCNEW (gfc_data_value)
37 : : #define gfc_get_data() XCNEW (gfc_data)
38 : :
39 : :
40 : : static bool set_binding_label (const char **, const char *, int);
41 : :
42 : :
43 : : /* This flag is set if an old-style length selector is matched
44 : : during a type-declaration statement. */
45 : :
46 : : static int old_char_selector;
47 : :
48 : : /* When variables acquire types and attributes from a declaration
49 : : statement, they get them from the following static variables. The
50 : : first part of a declaration sets these variables and the second
51 : : part copies these into symbol structures. */
52 : :
53 : : static gfc_typespec current_ts;
54 : :
55 : : static symbol_attribute current_attr;
56 : : static gfc_array_spec *current_as;
57 : : static int colon_seen;
58 : : static int attr_seen;
59 : :
60 : : /* The current binding label (if any). */
61 : : static const char* curr_binding_label;
62 : : /* Need to know how many identifiers are on the current data declaration
63 : : line in case we're given the BIND(C) attribute with a NAME= specifier. */
64 : : static int num_idents_on_line;
65 : : /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
66 : : can supply a name if the curr_binding_label is nil and NAME= was not. */
67 : : static int has_name_equals = 0;
68 : :
69 : : /* Initializer of the previous enumerator. */
70 : :
71 : : static gfc_expr *last_initializer;
72 : :
73 : : /* History of all the enumerators is maintained, so that
74 : : kind values of all the enumerators could be updated depending
75 : : upon the maximum initialized value. */
76 : :
77 : : typedef struct enumerator_history
78 : : {
79 : : gfc_symbol *sym;
80 : : gfc_expr *initializer;
81 : : struct enumerator_history *next;
82 : : }
83 : : enumerator_history;
84 : :
85 : : /* Header of enum history chain. */
86 : :
87 : : static enumerator_history *enum_history = NULL;
88 : :
89 : : /* Pointer of enum history node containing largest initializer. */
90 : :
91 : : static enumerator_history *max_enum = NULL;
92 : :
93 : : /* gfc_new_block points to the symbol of a newly matched block. */
94 : :
95 : : gfc_symbol *gfc_new_block;
96 : :
97 : : bool gfc_matching_function;
98 : :
99 : : /* Set upon parsing a !GCC$ unroll n directive for use in the next loop. */
100 : : int directive_unroll = -1;
101 : :
102 : : /* Set upon parsing supported !GCC$ pragmas for use in the next loop. */
103 : : bool directive_ivdep = false;
104 : : bool directive_vector = false;
105 : : bool directive_novector = false;
106 : :
107 : : /* Map of middle-end built-ins that should be vectorized. */
108 : : hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
109 : :
110 : : /* If a kind expression of a component of a parameterized derived type is
111 : : parameterized, temporarily store the expression here. */
112 : : static gfc_expr *saved_kind_expr = NULL;
113 : :
114 : : /* Used to store the parameter list arising in a PDT declaration and
115 : : in the typespec of a PDT variable or component. */
116 : : static gfc_actual_arglist *decl_type_param_list;
117 : : static gfc_actual_arglist *type_param_spec_list;
118 : :
119 : : /********************* DATA statement subroutines *********************/
120 : :
121 : : static bool in_match_data = false;
122 : :
123 : : bool
124 : 8199 : gfc_in_match_data (void)
125 : : {
126 : 8199 : return in_match_data;
127 : : }
128 : :
129 : : static void
130 : 4834 : set_in_match_data (bool set_value)
131 : : {
132 : 4834 : in_match_data = set_value;
133 : 2417 : }
134 : :
135 : : /* Free a gfc_data_variable structure and everything beneath it. */
136 : :
137 : : static void
138 : 5656 : free_variable (gfc_data_variable *p)
139 : : {
140 : 5656 : gfc_data_variable *q;
141 : :
142 : 8741 : for (; p; p = q)
143 : : {
144 : 3085 : q = p->next;
145 : 3085 : gfc_free_expr (p->expr);
146 : 3085 : gfc_free_iterator (&p->iter, 0);
147 : 3085 : free_variable (p->list);
148 : 3085 : free (p);
149 : : }
150 : 5656 : }
151 : :
152 : :
153 : : /* Free a gfc_data_value structure and everything beneath it. */
154 : :
155 : : static void
156 : 2571 : free_value (gfc_data_value *p)
157 : : {
158 : 2571 : gfc_data_value *q;
159 : :
160 : 10878 : for (; p; p = q)
161 : : {
162 : 8307 : q = p->next;
163 : 8307 : mpz_clear (p->repeat);
164 : 8307 : gfc_free_expr (p->expr);
165 : 8307 : free (p);
166 : : }
167 : 2571 : }
168 : :
169 : :
170 : : /* Free a list of gfc_data structures. */
171 : :
172 : : void
173 : 507585 : gfc_free_data (gfc_data *p)
174 : : {
175 : 507585 : gfc_data *q;
176 : :
177 : 510156 : for (; p; p = q)
178 : : {
179 : 2571 : q = p->next;
180 : 2571 : free_variable (p->var);
181 : 2571 : free_value (p->value);
182 : 2571 : free (p);
183 : : }
184 : 507585 : }
185 : :
186 : :
187 : : /* Free all data in a namespace. */
188 : :
189 : : static void
190 : 38 : gfc_free_data_all (gfc_namespace *ns)
191 : : {
192 : 38 : gfc_data *d;
193 : :
194 : 44 : for (;ns->data;)
195 : : {
196 : 6 : d = ns->data->next;
197 : 6 : free (ns->data);
198 : 6 : ns->data = d;
199 : : }
200 : 38 : }
201 : :
202 : : /* Reject data parsed since the last restore point was marked. */
203 : :
204 : : void
205 : 8807934 : gfc_reject_data (gfc_namespace *ns)
206 : : {
207 : 8807934 : gfc_data *d;
208 : :
209 : 8807936 : while (ns->data && ns->data != ns->old_data)
210 : : {
211 : 2 : d = ns->data->next;
212 : 2 : free (ns->data);
213 : 2 : ns->data = d;
214 : : }
215 : 8807934 : }
216 : :
217 : : static match var_element (gfc_data_variable *);
218 : :
219 : : /* Match a list of variables terminated by an iterator and a right
220 : : parenthesis. */
221 : :
222 : : static match
223 : 153 : var_list (gfc_data_variable *parent)
224 : : {
225 : 153 : gfc_data_variable *tail, var;
226 : 153 : match m;
227 : :
228 : 153 : m = var_element (&var);
229 : 153 : if (m == MATCH_ERROR)
230 : : return MATCH_ERROR;
231 : 153 : if (m == MATCH_NO)
232 : 0 : goto syntax;
233 : :
234 : 153 : tail = gfc_get_data_variable ();
235 : 153 : *tail = var;
236 : :
237 : 153 : parent->list = tail;
238 : :
239 : 155 : for (;;)
240 : : {
241 : 154 : if (gfc_match_char (',') != MATCH_YES)
242 : 0 : goto syntax;
243 : :
244 : 154 : m = gfc_match_iterator (&parent->iter, 1);
245 : 154 : if (m == MATCH_YES)
246 : : break;
247 : 1 : if (m == MATCH_ERROR)
248 : : return MATCH_ERROR;
249 : :
250 : 1 : m = var_element (&var);
251 : 1 : if (m == MATCH_ERROR)
252 : : return MATCH_ERROR;
253 : 1 : if (m == MATCH_NO)
254 : 0 : goto syntax;
255 : :
256 : 1 : tail->next = gfc_get_data_variable ();
257 : 1 : tail = tail->next;
258 : :
259 : 1 : *tail = var;
260 : : }
261 : :
262 : 153 : if (gfc_match_char (')') != MATCH_YES)
263 : 0 : goto syntax;
264 : : return MATCH_YES;
265 : :
266 : 0 : syntax:
267 : 0 : gfc_syntax_error (ST_DATA);
268 : 0 : return MATCH_ERROR;
269 : : }
270 : :
271 : :
272 : : /* Match a single element in a data variable list, which can be a
273 : : variable-iterator list. */
274 : :
275 : : static match
276 : 3043 : var_element (gfc_data_variable *new_var)
277 : : {
278 : 3043 : match m;
279 : 3043 : gfc_symbol *sym;
280 : :
281 : 3043 : memset (new_var, 0, sizeof (gfc_data_variable));
282 : :
283 : 3043 : if (gfc_match_char ('(') == MATCH_YES)
284 : 153 : return var_list (new_var);
285 : :
286 : 2890 : m = gfc_match_variable (&new_var->expr, 0);
287 : 2890 : if (m != MATCH_YES)
288 : : return m;
289 : :
290 : 2886 : if (new_var->expr->expr_type == EXPR_CONSTANT
291 : 2 : && new_var->expr->symtree == NULL)
292 : : {
293 : 2 : gfc_error ("Inquiry parameter cannot appear in a "
294 : : "data-stmt-object-list at %C");
295 : 2 : return MATCH_ERROR;
296 : : }
297 : :
298 : 2884 : sym = new_var->expr->symtree->n.sym;
299 : :
300 : : /* Symbol should already have an associated type. */
301 : 2884 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
302 : : return MATCH_ERROR;
303 : :
304 : 2883 : if (!sym->attr.function && gfc_current_ns->parent
305 : 148 : && gfc_current_ns->parent == sym->ns)
306 : : {
307 : 1 : gfc_error ("Host associated variable %qs may not be in the DATA "
308 : : "statement at %C", sym->name);
309 : 1 : return MATCH_ERROR;
310 : : }
311 : :
312 : 2882 : if (gfc_current_state () != COMP_BLOCK_DATA
313 : 2729 : && sym->attr.in_common
314 : 2911 : && !gfc_notify_std (GFC_STD_GNU, "initialization of "
315 : : "common block variable %qs in DATA statement at %C",
316 : : sym->name))
317 : : return MATCH_ERROR;
318 : :
319 : 2880 : if (!gfc_add_data (&sym->attr, sym->name, &new_var->expr->where))
320 : : return MATCH_ERROR;
321 : :
322 : : return MATCH_YES;
323 : : }
324 : :
325 : :
326 : : /* Match the top-level list of data variables. */
327 : :
328 : : static match
329 : 2514 : top_var_list (gfc_data *d)
330 : : {
331 : 2514 : gfc_data_variable var, *tail, *new_var;
332 : 2514 : match m;
333 : :
334 : 2514 : tail = NULL;
335 : :
336 : 2889 : for (;;)
337 : : {
338 : 2889 : m = var_element (&var);
339 : 2889 : if (m == MATCH_NO)
340 : 0 : goto syntax;
341 : 2889 : if (m == MATCH_ERROR)
342 : : return MATCH_ERROR;
343 : :
344 : 2874 : new_var = gfc_get_data_variable ();
345 : 2874 : *new_var = var;
346 : 2874 : if (new_var->expr)
347 : 2749 : new_var->expr->where = gfc_current_locus;
348 : :
349 : 2874 : if (tail == NULL)
350 : 2499 : d->var = new_var;
351 : : else
352 : 375 : tail->next = new_var;
353 : :
354 : 2874 : tail = new_var;
355 : :
356 : 2874 : if (gfc_match_char ('/') == MATCH_YES)
357 : : break;
358 : 378 : if (gfc_match_char (',') != MATCH_YES)
359 : 3 : goto syntax;
360 : : }
361 : :
362 : : return MATCH_YES;
363 : :
364 : 3 : syntax:
365 : 3 : gfc_syntax_error (ST_DATA);
366 : 3 : gfc_free_data_all (gfc_current_ns);
367 : 3 : return MATCH_ERROR;
368 : : }
369 : :
370 : :
371 : : static match
372 : 8708 : match_data_constant (gfc_expr **result)
373 : : {
374 : 8708 : char name[GFC_MAX_SYMBOL_LEN + 1];
375 : 8708 : gfc_symbol *sym, *dt_sym = NULL;
376 : 8708 : gfc_expr *expr;
377 : 8708 : match m;
378 : 8708 : locus old_loc;
379 : 8708 : gfc_symtree *symtree;
380 : :
381 : 8708 : m = gfc_match_literal_constant (&expr, 1);
382 : 8708 : if (m == MATCH_YES)
383 : : {
384 : 8363 : *result = expr;
385 : 8363 : return MATCH_YES;
386 : : }
387 : :
388 : 345 : if (m == MATCH_ERROR)
389 : : return MATCH_ERROR;
390 : :
391 : 337 : m = gfc_match_null (result);
392 : 337 : if (m != MATCH_NO)
393 : : return m;
394 : :
395 : 329 : old_loc = gfc_current_locus;
396 : :
397 : : /* Should this be a structure component, try to match it
398 : : before matching a name. */
399 : 329 : m = gfc_match_rvalue (result);
400 : 329 : if (m == MATCH_ERROR)
401 : : return m;
402 : :
403 : 329 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
404 : : {
405 : 4 : if (!gfc_simplify_expr (*result, 0))
406 : 0 : m = MATCH_ERROR;
407 : 4 : return m;
408 : : }
409 : 319 : else if (m == MATCH_YES)
410 : : {
411 : : /* If a parameter inquiry ends up here, symtree is NULL but **result
412 : : contains the right constant expression. Check here. */
413 : 319 : if ((*result)->symtree == NULL
414 : 37 : && (*result)->expr_type == EXPR_CONSTANT
415 : 37 : && ((*result)->ts.type == BT_INTEGER
416 : 1 : || (*result)->ts.type == BT_REAL))
417 : : return m;
418 : :
419 : : /* F2018:R845 data-stmt-constant is initial-data-target.
420 : : A data-stmt-constant shall be ... initial-data-target if and
421 : : only if the corresponding data-stmt-object has the POINTER
422 : : attribute. ... If data-stmt-constant is initial-data-target
423 : : the corresponding data statement object shall be
424 : : data-pointer-initialization compatible (7.5.4.6) with the initial
425 : : data target; the data statement object is initially associated
426 : : with the target. */
427 : 283 : if ((*result)->symtree
428 : 282 : && (*result)->symtree->n.sym->attr.save
429 : 218 : && (*result)->symtree->n.sym->attr.target)
430 : : return m;
431 : 250 : gfc_free_expr (*result);
432 : : }
433 : :
434 : 256 : gfc_current_locus = old_loc;
435 : :
436 : 256 : m = gfc_match_name (name);
437 : 256 : if (m != MATCH_YES)
438 : : return m;
439 : :
440 : 250 : if (gfc_find_sym_tree (name, NULL, 1, &symtree))
441 : : return MATCH_ERROR;
442 : :
443 : 250 : sym = symtree->n.sym;
444 : :
445 : 250 : if (sym && sym->attr.generic)
446 : 60 : dt_sym = gfc_find_dt_in_generic (sym);
447 : :
448 : 60 : if (sym == NULL
449 : 250 : || (sym->attr.flavor != FL_PARAMETER
450 : 65 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
451 : : {
452 : 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
453 : : name);
454 : 5 : *result = NULL;
455 : 5 : return MATCH_ERROR;
456 : : }
457 : 245 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
458 : 60 : return gfc_match_structure_constructor (dt_sym, symtree, result);
459 : :
460 : : /* Check to see if the value is an initialization array expression. */
461 : 185 : if (sym->value->expr_type == EXPR_ARRAY)
462 : : {
463 : 67 : gfc_current_locus = old_loc;
464 : :
465 : 67 : m = gfc_match_init_expr (result);
466 : 67 : if (m == MATCH_ERROR)
467 : : return m;
468 : :
469 : 66 : if (m == MATCH_YES)
470 : : {
471 : 66 : if (!gfc_simplify_expr (*result, 0))
472 : 0 : m = MATCH_ERROR;
473 : :
474 : 66 : if ((*result)->expr_type == EXPR_CONSTANT)
475 : : return m;
476 : : else
477 : : {
478 : 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
479 : 2 : return MATCH_ERROR;
480 : : }
481 : : }
482 : : }
483 : :
484 : 118 : *result = gfc_copy_expr (sym->value);
485 : 118 : return MATCH_YES;
486 : : }
487 : :
488 : :
489 : : /* Match a list of values in a DATA statement. The leading '/' has
490 : : already been seen at this point. */
491 : :
492 : : static match
493 : 2557 : top_val_list (gfc_data *data)
494 : : {
495 : 2557 : gfc_data_value *new_val, *tail;
496 : 2557 : gfc_expr *expr;
497 : 2557 : match m;
498 : :
499 : 2557 : tail = NULL;
500 : :
501 : 8344 : for (;;)
502 : : {
503 : 8344 : m = match_data_constant (&expr);
504 : 8344 : if (m == MATCH_NO)
505 : 3 : goto syntax;
506 : 8341 : if (m == MATCH_ERROR)
507 : : return MATCH_ERROR;
508 : :
509 : 8319 : new_val = gfc_get_data_value ();
510 : 8319 : mpz_init (new_val->repeat);
511 : :
512 : 8319 : if (tail == NULL)
513 : 2532 : data->value = new_val;
514 : : else
515 : 5787 : tail->next = new_val;
516 : :
517 : 8319 : tail = new_val;
518 : :
519 : 8319 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
520 : : {
521 : 8114 : tail->expr = expr;
522 : 8114 : mpz_set_ui (tail->repeat, 1);
523 : : }
524 : : else
525 : : {
526 : 205 : mpz_set (tail->repeat, expr->value.integer);
527 : 205 : gfc_free_expr (expr);
528 : :
529 : 205 : m = match_data_constant (&tail->expr);
530 : 205 : if (m == MATCH_NO)
531 : 0 : goto syntax;
532 : 205 : if (m == MATCH_ERROR)
533 : : return MATCH_ERROR;
534 : : }
535 : :
536 : 8315 : if (gfc_match_char ('/') == MATCH_YES)
537 : : break;
538 : 5788 : if (gfc_match_char (',') == MATCH_NO)
539 : 1 : goto syntax;
540 : : }
541 : :
542 : : return MATCH_YES;
543 : :
544 : 4 : syntax:
545 : 4 : gfc_syntax_error (ST_DATA);
546 : 4 : gfc_free_data_all (gfc_current_ns);
547 : 4 : return MATCH_ERROR;
548 : : }
549 : :
550 : :
551 : : /* Matches an old style initialization. */
552 : :
553 : : static match
554 : 70 : match_old_style_init (const char *name)
555 : : {
556 : 70 : match m;
557 : 70 : gfc_symtree *st;
558 : 70 : gfc_symbol *sym;
559 : 70 : gfc_data *newdata, *nd;
560 : :
561 : : /* Set up data structure to hold initializers. */
562 : 70 : gfc_find_sym_tree (name, NULL, 0, &st);
563 : 70 : sym = st->n.sym;
564 : :
565 : 70 : newdata = gfc_get_data ();
566 : 70 : newdata->var = gfc_get_data_variable ();
567 : 70 : newdata->var->expr = gfc_get_variable_expr (st);
568 : 70 : newdata->var->expr->where = sym->declared_at;
569 : 70 : newdata->where = gfc_current_locus;
570 : :
571 : : /* Match initial value list. This also eats the terminal '/'. */
572 : 70 : m = top_val_list (newdata);
573 : 70 : if (m != MATCH_YES)
574 : : {
575 : 1 : free (newdata);
576 : 1 : return m;
577 : : }
578 : :
579 : : /* Check that a BOZ did not creep into an old-style initialization. */
580 : 137 : for (nd = newdata; nd; nd = nd->next)
581 : : {
582 : 69 : if (nd->value->expr->ts.type == BT_BOZ
583 : 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
584 : : "initialization"), &nd->value->expr->where))
585 : : return MATCH_ERROR;
586 : :
587 : 68 : if (nd->var->expr->ts.type != BT_INTEGER
588 : 27 : && nd->var->expr->ts.type != BT_REAL
589 : 21 : && nd->value->expr->ts.type == BT_BOZ)
590 : : {
591 : 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
592 : : "a %qs variable in an old-style initialization"),
593 : 0 : &nd->value->expr->where,
594 : : gfc_typename (&nd->value->expr->ts));
595 : 0 : return MATCH_ERROR;
596 : : }
597 : : }
598 : :
599 : 68 : if (gfc_pure (NULL))
600 : : {
601 : 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
602 : 1 : free (newdata);
603 : 1 : return MATCH_ERROR;
604 : : }
605 : 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
606 : :
607 : : /* Mark the variable as having appeared in a data statement. */
608 : 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
609 : : {
610 : 2 : free (newdata);
611 : 2 : return MATCH_ERROR;
612 : : }
613 : :
614 : : /* Chain in namespace list of DATA initializers. */
615 : 65 : newdata->next = gfc_current_ns->data;
616 : 65 : gfc_current_ns->data = newdata;
617 : :
618 : 65 : return m;
619 : : }
620 : :
621 : :
622 : : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
623 : : we are matching a DATA statement and are therefore issuing an error
624 : : if we encounter something unexpected, if not, we're trying to match
625 : : an old-style initialization expression of the form INTEGER I /2/. */
626 : :
627 : : match
628 : 2419 : gfc_match_data (void)
629 : : {
630 : 2419 : gfc_data *new_data;
631 : 2419 : gfc_expr *e;
632 : 2419 : gfc_ref *ref;
633 : 2419 : match m;
634 : 2419 : char c;
635 : :
636 : : /* DATA has been matched. In free form source code, the next character
637 : : needs to be whitespace or '(' from an implied do-loop. Check that
638 : : here. */
639 : 2419 : c = gfc_peek_ascii_char ();
640 : 2419 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
641 : : return MATCH_NO;
642 : :
643 : : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
644 : 2418 : if ((gfc_current_state () == COMP_FUNCTION
645 : 2418 : || gfc_current_state () == COMP_SUBROUTINE)
646 : 1153 : && gfc_state_stack->previous->state == COMP_INTERFACE)
647 : : {
648 : 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
649 : 1 : return MATCH_ERROR;
650 : : }
651 : :
652 : 2417 : set_in_match_data (true);
653 : :
654 : 2611 : for (;;)
655 : : {
656 : 2514 : new_data = gfc_get_data ();
657 : 2514 : new_data->where = gfc_current_locus;
658 : :
659 : 2514 : m = top_var_list (new_data);
660 : 2514 : if (m != MATCH_YES)
661 : 18 : goto cleanup;
662 : :
663 : 2496 : if (new_data->var->iter.var
664 : 116 : && new_data->var->iter.var->ts.type == BT_INTEGER
665 : 73 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
666 : 67 : && new_data->var->list
667 : 67 : && new_data->var->list->expr
668 : 54 : && new_data->var->list->expr->ts.type == BT_CHARACTER
669 : 3 : && new_data->var->list->expr->ref
670 : 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
671 : : {
672 : 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
673 : : "statement", &new_data->var->list->expr->where);
674 : 1 : goto cleanup;
675 : : }
676 : :
677 : : /* Check for an entity with an allocatable component, which is not
678 : : allowed. */
679 : 2495 : e = new_data->var->expr;
680 : 2495 : if (e)
681 : : {
682 : 2380 : bool invalid;
683 : :
684 : 2380 : invalid = false;
685 : 3602 : for (ref = e->ref; ref; ref = ref->next)
686 : 1222 : if ((ref->type == REF_COMPONENT
687 : 140 : && ref->u.c.component->attr.allocatable)
688 : 1220 : || (ref->type == REF_ARRAY
689 : 1032 : && e->symtree->n.sym->attr.pointer != 1
690 : 1029 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
691 : 1222 : invalid = true;
692 : :
693 : 2380 : if (invalid)
694 : : {
695 : 2 : gfc_error ("Allocatable component or deferred-shaped array "
696 : : "near %C in DATA statement");
697 : 2 : goto cleanup;
698 : : }
699 : :
700 : : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
701 : : as a data-stmt-object shall not be an object designator in which
702 : : a pointer appears other than as the entire rightmost part-ref. */
703 : 2378 : if (!e->ref && e->ts.type == BT_DERIVED
704 : 43 : && e->symtree->n.sym->attr.pointer)
705 : 4 : goto partref;
706 : :
707 : 2374 : ref = e->ref;
708 : 2374 : if (e->symtree->n.sym->ts.type == BT_DERIVED
709 : 125 : && e->symtree->n.sym->attr.pointer
710 : 1 : && ref->type == REF_COMPONENT)
711 : 1 : goto partref;
712 : :
713 : 3587 : for (; ref; ref = ref->next)
714 : 1215 : if (ref->type == REF_COMPONENT
715 : 135 : && ref->u.c.component->attr.pointer
716 : 27 : && ref->next)
717 : 1 : goto partref;
718 : : }
719 : :
720 : 2487 : m = top_val_list (new_data);
721 : 2487 : if (m != MATCH_YES)
722 : 29 : goto cleanup;
723 : :
724 : 2458 : new_data->next = gfc_current_ns->data;
725 : 2458 : gfc_current_ns->data = new_data;
726 : :
727 : : /* A BOZ literal constant cannot appear in a structure constructor.
728 : : Check for that here for a data statement value. */
729 : 2458 : if (new_data->value->expr->ts.type == BT_DERIVED
730 : 37 : && new_data->value->expr->value.constructor)
731 : : {
732 : 35 : gfc_constructor *c;
733 : 35 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
734 : 106 : for (; c; c = gfc_constructor_next (c))
735 : 36 : if (c->expr && c->expr->ts.type == BT_BOZ)
736 : : {
737 : 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
738 : : "structure constructor", &c->expr->where);
739 : 0 : return MATCH_ERROR;
740 : : }
741 : : }
742 : :
743 : 2458 : if (gfc_match_eos () == MATCH_YES)
744 : : break;
745 : :
746 : 97 : gfc_match_char (','); /* Optional comma */
747 : 97 : }
748 : :
749 : 2361 : set_in_match_data (false);
750 : :
751 : 2361 : if (gfc_pure (NULL))
752 : : {
753 : 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
754 : 0 : return MATCH_ERROR;
755 : : }
756 : 2361 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
757 : :
758 : 2361 : return MATCH_YES;
759 : :
760 : 6 : partref:
761 : :
762 : 6 : gfc_error ("part-ref with pointer attribute near %L is not "
763 : : "rightmost part-ref of data-stmt-object",
764 : : &e->where);
765 : :
766 : 56 : cleanup:
767 : 56 : set_in_match_data (false);
768 : 56 : gfc_free_data (new_data);
769 : 56 : return MATCH_ERROR;
770 : : }
771 : :
772 : :
773 : : /************************ Declaration statements *********************/
774 : :
775 : :
776 : : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
777 : : list). The difference here is the expression is a list of constants
778 : : and is surrounded by '/'.
779 : : The typespec ts must match the typespec of the variable which the
780 : : clist is initializing.
781 : : The arrayspec tells whether this should match a list of constants
782 : : corresponding to array elements or a scalar (as == NULL). */
783 : :
784 : : static match
785 : 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
786 : : {
787 : 74 : gfc_constructor_base array_head = NULL;
788 : 74 : gfc_expr *expr = NULL;
789 : 74 : match m = MATCH_ERROR;
790 : 74 : locus where;
791 : 74 : mpz_t repeat, cons_size, as_size;
792 : 74 : bool scalar;
793 : 74 : int cmp;
794 : :
795 : 74 : gcc_assert (ts);
796 : :
797 : : /* We have already matched '/' - now look for a constant list, as with
798 : : top_val_list from decl.cc, but append the result to an array. */
799 : 74 : if (gfc_match ("/") == MATCH_YES)
800 : : {
801 : 1 : gfc_error ("Empty old style initializer list at %C");
802 : 1 : return MATCH_ERROR;
803 : : }
804 : :
805 : 73 : where = gfc_current_locus;
806 : 73 : scalar = !as || !as->rank;
807 : :
808 : 42 : if (!scalar && !spec_size (as, &as_size))
809 : : {
810 : 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
811 : 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
812 : : /* Nothing to cleanup yet. */
813 : 1 : return MATCH_ERROR;
814 : : }
815 : :
816 : 72 : mpz_init_set_ui (repeat, 0);
817 : :
818 : 143 : for (;;)
819 : : {
820 : 143 : m = match_data_constant (&expr);
821 : 143 : if (m != MATCH_YES)
822 : 3 : expr = NULL; /* match_data_constant may set expr to garbage */
823 : 3 : if (m == MATCH_NO)
824 : 2 : goto syntax;
825 : 141 : if (m == MATCH_ERROR)
826 : 1 : goto cleanup;
827 : :
828 : : /* Found r in repeat spec r*c; look for the constant to repeat. */
829 : 140 : if ( gfc_match_char ('*') == MATCH_YES)
830 : : {
831 : 18 : if (scalar)
832 : : {
833 : 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
834 : 1 : goto cleanup;
835 : : }
836 : 17 : if (expr->ts.type != BT_INTEGER)
837 : : {
838 : 1 : gfc_error ("Repeat spec must be an integer at %C");
839 : 1 : goto cleanup;
840 : : }
841 : 16 : mpz_set (repeat, expr->value.integer);
842 : 16 : gfc_free_expr (expr);
843 : 16 : expr = NULL;
844 : :
845 : 16 : m = match_data_constant (&expr);
846 : 16 : if (m == MATCH_NO)
847 : : {
848 : 1 : m = MATCH_ERROR;
849 : 1 : gfc_error ("Expected data constant after repeat spec at %C");
850 : : }
851 : 16 : if (m != MATCH_YES)
852 : 1 : goto cleanup;
853 : : }
854 : : /* No repeat spec, we matched the data constant itself. */
855 : : else
856 : 122 : mpz_set_ui (repeat, 1);
857 : :
858 : 137 : if (!scalar)
859 : : {
860 : : /* Add the constant initializer as many times as repeated. */
861 : 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
862 : : {
863 : : /* Make sure types of elements match */
864 : 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
865 : 12 : && !gfc_convert_type (expr, ts, 1))
866 : 0 : goto cleanup;
867 : :
868 : 144 : gfc_constructor_append_expr (&array_head,
869 : : gfc_copy_expr (expr), &gfc_current_locus);
870 : : }
871 : :
872 : 107 : gfc_free_expr (expr);
873 : 107 : expr = NULL;
874 : : }
875 : :
876 : : /* For scalar initializers quit after one element. */
877 : : else
878 : : {
879 : 30 : if(gfc_match_char ('/') != MATCH_YES)
880 : : {
881 : 1 : gfc_error ("End of scalar initializer expected at %C");
882 : 1 : goto cleanup;
883 : : }
884 : : break;
885 : : }
886 : :
887 : 107 : if (gfc_match_char ('/') == MATCH_YES)
888 : : break;
889 : 72 : if (gfc_match_char (',') == MATCH_NO)
890 : 1 : goto syntax;
891 : : }
892 : :
893 : : /* If we break early from here out, we encountered an error. */
894 : 64 : m = MATCH_ERROR;
895 : :
896 : : /* Set up expr as an array constructor. */
897 : 64 : if (!scalar)
898 : : {
899 : 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
900 : 35 : expr->ts = *ts;
901 : 35 : expr->value.constructor = array_head;
902 : :
903 : : /* Validate sizes. We built expr ourselves, so cons_size will be
904 : : constant (we fail above for non-constant expressions).
905 : : We still need to verify that the sizes match. */
906 : 35 : gcc_assert (gfc_array_size (expr, &cons_size));
907 : 35 : cmp = mpz_cmp (cons_size, as_size);
908 : 35 : if (cmp < 0)
909 : 2 : gfc_error ("Not enough elements in array initializer at %C");
910 : 33 : else if (cmp > 0)
911 : 3 : gfc_error ("Too many elements in array initializer at %C");
912 : 35 : mpz_clear (cons_size);
913 : 35 : if (cmp)
914 : 5 : goto cleanup;
915 : :
916 : : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
917 : 30 : expr->rank = as->rank;
918 : 30 : expr->corank = as->corank;
919 : 30 : expr->shape = gfc_get_shape (as->rank);
920 : 66 : for (int i = 0; i < as->rank; ++i)
921 : 36 : spec_dimen_size (as, i, &expr->shape[i]);
922 : : }
923 : :
924 : : /* Make sure scalar types match. */
925 : 29 : else if (!gfc_compare_types (&expr->ts, ts)
926 : 29 : && !gfc_convert_type (expr, ts, 1))
927 : 2 : goto cleanup;
928 : :
929 : 57 : if (expr->ts.u.cl)
930 : 1 : expr->ts.u.cl->length_from_typespec = 1;
931 : :
932 : 57 : *result = expr;
933 : 57 : m = MATCH_YES;
934 : 57 : goto done;
935 : :
936 : 3 : syntax:
937 : 3 : m = MATCH_ERROR;
938 : 3 : gfc_error ("Syntax error in old style initializer list at %C");
939 : :
940 : 15 : cleanup:
941 : 15 : if (expr)
942 : 10 : expr->value.constructor = NULL;
943 : 15 : gfc_free_expr (expr);
944 : 15 : gfc_constructor_free (array_head);
945 : :
946 : 72 : done:
947 : 72 : mpz_clear (repeat);
948 : 72 : if (!scalar)
949 : 41 : mpz_clear (as_size);
950 : : return m;
951 : : }
952 : :
953 : :
954 : : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
955 : :
956 : : static bool
957 : 88 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
958 : : {
959 : 88 : if ((from->type == AS_ASSUMED_RANK && to->corank)
960 : 86 : || (to->type == AS_ASSUMED_RANK && from->corank))
961 : : {
962 : 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
963 : 5 : return false;
964 : : }
965 : :
966 : 83 : if (to->rank == 0 && from->rank > 0)
967 : : {
968 : 36 : to->rank = from->rank;
969 : 36 : to->type = from->type;
970 : 36 : to->cray_pointee = from->cray_pointee;
971 : 36 : to->cp_was_assumed = from->cp_was_assumed;
972 : :
973 : 110 : for (int i = to->corank - 1; i >= 0; i--)
974 : : {
975 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
976 : : cleans up elsewhere. */
977 : 74 : int j = from->rank + i;
978 : 74 : if (j >= GFC_MAX_DIMENSIONS)
979 : : break;
980 : :
981 : 74 : to->lower[j] = to->lower[i];
982 : 74 : to->upper[j] = to->upper[i];
983 : : }
984 : 85 : for (int i = 0; i < from->rank; i++)
985 : : {
986 : 49 : if (copy)
987 : : {
988 : 33 : to->lower[i] = gfc_copy_expr (from->lower[i]);
989 : 33 : to->upper[i] = gfc_copy_expr (from->upper[i]);
990 : : }
991 : : else
992 : : {
993 : 16 : to->lower[i] = from->lower[i];
994 : 16 : to->upper[i] = from->upper[i];
995 : : }
996 : : }
997 : : }
998 : 47 : else if (to->corank == 0 && from->corank > 0)
999 : : {
1000 : 22 : to->corank = from->corank;
1001 : 22 : to->cotype = from->cotype;
1002 : :
1003 : 75 : for (int i = 0; i < from->corank; i++)
1004 : : {
1005 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
1006 : : cleans up elsewhere. */
1007 : 54 : int k = from->rank + i;
1008 : 54 : int j = to->rank + i;
1009 : 54 : if (j >= GFC_MAX_DIMENSIONS)
1010 : : break;
1011 : :
1012 : 53 : if (copy)
1013 : : {
1014 : 24 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1015 : 24 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1016 : : }
1017 : : else
1018 : : {
1019 : 29 : to->lower[j] = from->lower[k];
1020 : 29 : to->upper[j] = from->upper[k];
1021 : : }
1022 : : }
1023 : : }
1024 : :
1025 : 83 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1026 : : {
1027 : 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1028 : : "allowed dimensions of %d",
1029 : : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1030 : 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1031 : 1 : return false;
1032 : : }
1033 : : return true;
1034 : : }
1035 : :
1036 : :
1037 : : /* Match an intent specification. Since this can only happen after an
1038 : : INTENT word, a legal intent-spec must follow. */
1039 : :
1040 : : static sym_intent
1041 : 26552 : match_intent_spec (void)
1042 : : {
1043 : :
1044 : 26552 : if (gfc_match (" ( in out )") == MATCH_YES)
1045 : : return INTENT_INOUT;
1046 : 23591 : if (gfc_match (" ( in )") == MATCH_YES)
1047 : : return INTENT_IN;
1048 : 3546 : if (gfc_match (" ( out )") == MATCH_YES)
1049 : : return INTENT_OUT;
1050 : :
1051 : 2 : gfc_error ("Bad INTENT specification at %C");
1052 : 2 : return INTENT_UNKNOWN;
1053 : : }
1054 : :
1055 : :
1056 : : /* Matches a character length specification, which is either a
1057 : : specification expression, '*', or ':'. */
1058 : :
1059 : : static match
1060 : 26535 : char_len_param_value (gfc_expr **expr, bool *deferred)
1061 : : {
1062 : 26535 : match m;
1063 : 26535 : gfc_expr *p;
1064 : :
1065 : 26535 : *expr = NULL;
1066 : 26535 : *deferred = false;
1067 : :
1068 : 26535 : if (gfc_match_char ('*') == MATCH_YES)
1069 : : return MATCH_YES;
1070 : :
1071 : 20098 : if (gfc_match_char (':') == MATCH_YES)
1072 : : {
1073 : 3258 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1074 : : return MATCH_ERROR;
1075 : :
1076 : 3256 : *deferred = true;
1077 : :
1078 : 3256 : return MATCH_YES;
1079 : : }
1080 : :
1081 : 16840 : m = gfc_match_expr (expr);
1082 : :
1083 : 16840 : if (m == MATCH_NO || m == MATCH_ERROR)
1084 : : return m;
1085 : :
1086 : 16835 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1087 : : return MATCH_ERROR;
1088 : :
1089 : : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1090 : 16829 : p = gfc_copy_expr (*expr);
1091 : 16829 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1092 : 14304 : gfc_replace_expr (*expr, p);
1093 : : else
1094 : 2525 : gfc_free_expr (p);
1095 : :
1096 : 16829 : if ((*expr)->expr_type == EXPR_FUNCTION)
1097 : : {
1098 : 1014 : if ((*expr)->ts.type == BT_INTEGER
1099 : 1013 : || ((*expr)->ts.type == BT_UNKNOWN
1100 : 1013 : && strcmp((*expr)->symtree->name, "null") != 0))
1101 : : return MATCH_YES;
1102 : :
1103 : 2 : goto syntax;
1104 : : }
1105 : 15815 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1106 : : {
1107 : : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1108 : : processor dependent and its value is greater than or equal to zero.
1109 : : F2008, 4.4.3.2: If the character length parameter value evaluates
1110 : : to a negative value, the length of character entities declared
1111 : : is zero. */
1112 : :
1113 : 14236 : if ((*expr)->ts.type == BT_INTEGER)
1114 : : {
1115 : 14218 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1116 : 4 : mpz_set_si ((*expr)->value.integer, 0);
1117 : : }
1118 : : else
1119 : 18 : goto syntax;
1120 : : }
1121 : 1579 : else if ((*expr)->expr_type == EXPR_ARRAY)
1122 : 8 : goto syntax;
1123 : 1571 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1124 : : {
1125 : 1173 : bool t;
1126 : 1173 : gfc_expr *e;
1127 : :
1128 : 1173 : e = gfc_copy_expr (*expr);
1129 : :
1130 : : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1131 : : which causes an ICE if gfc_reduce_init_expr() is called. */
1132 : 1173 : if (e->ref && e->ref->type == REF_ARRAY
1133 : 8 : && e->ref->u.ar.type == AR_UNKNOWN
1134 : 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1135 : 2 : goto syntax;
1136 : :
1137 : 1171 : t = gfc_reduce_init_expr (e);
1138 : :
1139 : 1171 : if (!t && e->ts.type == BT_UNKNOWN
1140 : 7 : && e->symtree->n.sym->attr.untyped == 1
1141 : 7 : && (flag_implicit_none
1142 : 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1143 : 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1144 : : {
1145 : 7 : gfc_free_expr (e);
1146 : 7 : goto syntax;
1147 : : }
1148 : :
1149 : 1164 : if ((e->ref && e->ref->type == REF_ARRAY
1150 : 4 : && e->ref->u.ar.type != AR_ELEMENT)
1151 : 1163 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1152 : : {
1153 : 2 : gfc_free_expr (e);
1154 : 2 : goto syntax;
1155 : : }
1156 : :
1157 : 1162 : gfc_free_expr (e);
1158 : : }
1159 : :
1160 : 15778 : if (gfc_seen_div0)
1161 : 52 : m = MATCH_ERROR;
1162 : :
1163 : : return m;
1164 : :
1165 : 39 : syntax:
1166 : 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1167 : 39 : return MATCH_ERROR;
1168 : : }
1169 : :
1170 : :
1171 : : /* A character length is a '*' followed by a literal integer or a
1172 : : char_len_param_value in parenthesis. */
1173 : :
1174 : : static match
1175 : 60946 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1176 : : {
1177 : 60946 : int length;
1178 : 60946 : match m;
1179 : :
1180 : 60946 : *deferred = false;
1181 : 60946 : m = gfc_match_char ('*');
1182 : 60946 : if (m != MATCH_YES)
1183 : : return m;
1184 : :
1185 : 2653 : m = gfc_match_small_literal_int (&length, NULL);
1186 : 2653 : if (m == MATCH_ERROR)
1187 : : return m;
1188 : :
1189 : 2653 : if (m == MATCH_YES)
1190 : : {
1191 : 2137 : if (obsolescent_check
1192 : 2137 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1193 : : return MATCH_ERROR;
1194 : 2137 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1195 : 2137 : return m;
1196 : : }
1197 : :
1198 : 516 : if (gfc_match_char ('(') == MATCH_NO)
1199 : 0 : goto syntax;
1200 : :
1201 : 516 : m = char_len_param_value (expr, deferred);
1202 : 516 : if (m != MATCH_YES && gfc_matching_function)
1203 : : {
1204 : 0 : gfc_undo_symbols ();
1205 : 0 : m = MATCH_YES;
1206 : : }
1207 : :
1208 : 1 : if (m == MATCH_ERROR)
1209 : : return m;
1210 : 515 : if (m == MATCH_NO)
1211 : 0 : goto syntax;
1212 : :
1213 : 515 : if (gfc_match_char (')') == MATCH_NO)
1214 : : {
1215 : 0 : gfc_free_expr (*expr);
1216 : 0 : *expr = NULL;
1217 : 0 : goto syntax;
1218 : : }
1219 : :
1220 : : return MATCH_YES;
1221 : :
1222 : 0 : syntax:
1223 : 0 : gfc_error ("Syntax error in character length specification at %C");
1224 : 0 : return MATCH_ERROR;
1225 : : }
1226 : :
1227 : :
1228 : : /* Special subroutine for finding a symbol. Check if the name is found
1229 : : in the current name space. If not, and we're compiling a function or
1230 : : subroutine and the parent compilation unit is an interface, then check
1231 : : to see if the name we've been given is the name of the interface
1232 : : (located in another namespace). */
1233 : :
1234 : : static int
1235 : 275677 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1236 : : {
1237 : 275677 : gfc_state_data *s;
1238 : 275677 : gfc_symtree *st;
1239 : 275677 : int i;
1240 : :
1241 : 275677 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1242 : 275677 : if (i == 0)
1243 : : {
1244 : 275677 : *result = st ? st->n.sym : NULL;
1245 : 275677 : goto end;
1246 : : }
1247 : :
1248 : 0 : if (gfc_current_state () != COMP_SUBROUTINE
1249 : 0 : && gfc_current_state () != COMP_FUNCTION)
1250 : 0 : goto end;
1251 : :
1252 : 0 : s = gfc_state_stack->previous;
1253 : 0 : if (s == NULL)
1254 : 0 : goto end;
1255 : :
1256 : 0 : if (s->state != COMP_INTERFACE)
1257 : 0 : goto end;
1258 : 0 : if (s->sym == NULL)
1259 : 0 : goto end; /* Nameless interface. */
1260 : :
1261 : 0 : if (strcmp (name, s->sym->name) == 0)
1262 : : {
1263 : 0 : *result = s->sym;
1264 : 0 : return 0;
1265 : : }
1266 : :
1267 : 0 : end:
1268 : : return i;
1269 : : }
1270 : :
1271 : :
1272 : : /* Special subroutine for getting a symbol node associated with a
1273 : : procedure name, used in SUBROUTINE and FUNCTION statements. The
1274 : : symbol is created in the parent using with symtree node in the
1275 : : child unit pointing to the symbol. If the current namespace has no
1276 : : parent, then the symbol is just created in the current unit. */
1277 : :
1278 : : static int
1279 : 61915 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1280 : : {
1281 : 61915 : gfc_symtree *st;
1282 : 61915 : gfc_symbol *sym;
1283 : 61915 : int rc = 0;
1284 : :
1285 : : /* Module functions have to be left in their own namespace because
1286 : : they have potentially (almost certainly!) already been referenced.
1287 : : In this sense, they are rather like external functions. This is
1288 : : fixed up in resolve.cc(resolve_entries), where the symbol name-
1289 : : space is set to point to the master function, so that the fake
1290 : : result mechanism can work. */
1291 : 61915 : if (module_fcn_entry)
1292 : : {
1293 : : /* Present if entry is declared to be a module procedure. */
1294 : 259 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1295 : :
1296 : 259 : if (*result == NULL)
1297 : 216 : rc = gfc_get_symbol (name, NULL, result);
1298 : 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1299 : 43 : && (*result)->ts.type == BT_UNKNOWN
1300 : 86 : && sym->attr.flavor == FL_UNKNOWN)
1301 : : /* Pick up the typespec for the entry, if declared in the function
1302 : : body. Note that this symbol is FL_UNKNOWN because it will
1303 : : only have appeared in a type declaration. The local symtree
1304 : : is set to point to the module symbol and a unique symtree
1305 : : to the local version. This latter ensures a correct clearing
1306 : : of the symbols. */
1307 : : {
1308 : : /* If the ENTRY proceeds its specification, we need to ensure
1309 : : that this does not raise a "has no IMPLICIT type" error. */
1310 : 43 : if (sym->ts.type == BT_UNKNOWN)
1311 : 23 : sym->attr.untyped = 1;
1312 : :
1313 : 43 : (*result)->ts = sym->ts;
1314 : :
1315 : : /* Put the symbol in the procedure namespace so that, should
1316 : : the ENTRY precede its specification, the specification
1317 : : can be applied. */
1318 : 43 : (*result)->ns = gfc_current_ns;
1319 : :
1320 : 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1321 : 43 : st->n.sym = *result;
1322 : 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1323 : 43 : sym->refs++;
1324 : 43 : st->n.sym = sym;
1325 : : }
1326 : : }
1327 : : else
1328 : 61656 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1329 : :
1330 : 61915 : if (rc)
1331 : : return rc;
1332 : :
1333 : 61914 : sym = *result;
1334 : 61914 : if (sym->attr.proc == PROC_ST_FUNCTION)
1335 : : return rc;
1336 : :
1337 : 61914 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1338 : : {
1339 : : /* Create a partially populated interface symbol to carry the
1340 : : characteristics of the procedure and the result. */
1341 : 432 : sym->tlink = gfc_new_symbol (name, sym->ns);
1342 : 432 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1343 : 432 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1344 : 432 : if (sym->attr.dimension)
1345 : 17 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1346 : :
1347 : : /* Ideally, at this point, a copy would be made of the formal
1348 : : arguments and their namespace. However, this does not appear
1349 : : to be necessary, albeit at the expense of not being able to
1350 : : use gfc_compare_interfaces directly. */
1351 : :
1352 : 432 : if (sym->result && sym->result != sym)
1353 : : {
1354 : 103 : sym->tlink->result = sym->result;
1355 : 103 : sym->result = NULL;
1356 : : }
1357 : 329 : else if (sym->result)
1358 : : {
1359 : 83 : sym->tlink->result = sym->tlink;
1360 : : }
1361 : : }
1362 : 61482 : else if (sym && !sym->gfc_new
1363 : 23504 : && gfc_current_state () != COMP_INTERFACE)
1364 : : {
1365 : : /* Trap another encompassed procedure with the same name. All
1366 : : these conditions are necessary to avoid picking up an entry
1367 : : whose name clashes with that of the encompassing procedure;
1368 : : this is handled using gsymbols to register unique, globally
1369 : : accessible names. */
1370 : 22506 : if (sym->attr.flavor != 0
1371 : 20485 : && sym->attr.proc != 0
1372 : 2171 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1373 : 7 : && sym->attr.if_source != IFSRC_UNKNOWN)
1374 : : {
1375 : 7 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1376 : : name, &sym->declared_at);
1377 : 7 : return true;
1378 : : }
1379 : 22499 : if (sym->attr.flavor != 0
1380 : 20478 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1381 : : {
1382 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1383 : : name, &sym->declared_at);
1384 : 1 : return true;
1385 : : }
1386 : :
1387 : 22498 : if (sym->attr.external && sym->attr.procedure
1388 : 2 : && gfc_current_state () == COMP_CONTAINS)
1389 : : {
1390 : 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1391 : : "procedure defined at %L",
1392 : : name, &sym->declared_at);
1393 : 1 : return true;
1394 : : }
1395 : :
1396 : : /* Trap a procedure with a name the same as interface in the
1397 : : encompassing scope. */
1398 : 22497 : if (sym->attr.generic != 0
1399 : 60 : && (sym->attr.subroutine || sym->attr.function)
1400 : 1 : && !sym->attr.mod_proc)
1401 : : {
1402 : 1 : gfc_error_now ("Name %qs at %C is already defined"
1403 : : " as a generic interface at %L",
1404 : : name, &sym->declared_at);
1405 : 1 : return true;
1406 : : }
1407 : :
1408 : : /* Trap declarations of attributes in encompassing scope. The
1409 : : signature for this is that ts.kind is nonzero for no-CLASS
1410 : : entity. For a CLASS entity, ts.kind is zero. */
1411 : 22496 : if ((sym->ts.kind != 0
1412 : 22155 : || sym->ts.type == BT_CLASS
1413 : 22154 : || sym->ts.type == BT_DERIVED)
1414 : 365 : && !sym->attr.implicit_type
1415 : 364 : && sym->attr.proc == 0
1416 : 346 : && gfc_current_ns->parent != NULL
1417 : 137 : && sym->attr.access == 0
1418 : 135 : && !module_fcn_entry)
1419 : : {
1420 : 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1421 : : "from a previous declaration", name);
1422 : 5 : return true;
1423 : : }
1424 : : }
1425 : :
1426 : : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1427 : : subroutine-stmt of a module subprogram or of a nonabstract interface
1428 : : body that is declared in the scoping unit of a module or submodule. */
1429 : 61899 : if (sym->attr.external
1430 : 92 : && (sym->attr.subroutine || sym->attr.function)
1431 : 91 : && sym->attr.if_source == IFSRC_IFBODY
1432 : 91 : && !current_attr.module_procedure
1433 : 3 : && sym->attr.proc == PROC_MODULE
1434 : 3 : && gfc_state_stack->state == COMP_CONTAINS)
1435 : : {
1436 : 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1437 : : "clashes with internal procedure defined at %C",
1438 : : name, &sym->declared_at);
1439 : 1 : return true;
1440 : : }
1441 : :
1442 : 61898 : if (sym && !sym->gfc_new
1443 : 23920 : && sym->attr.flavor != FL_UNKNOWN
1444 : 21522 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1445 : 215 : && gfc_state_stack->state == COMP_CONTAINS
1446 : 210 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1447 : : {
1448 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1449 : : name, &sym->declared_at);
1450 : 1 : return true;
1451 : : }
1452 : :
1453 : 61897 : if (gfc_current_ns->parent == NULL || *result == NULL)
1454 : : return rc;
1455 : :
1456 : : /* Module function entries will already have a symtree in
1457 : : the current namespace but will need one at module level. */
1458 : 50014 : if (module_fcn_entry)
1459 : : {
1460 : : /* Present if entry is declared to be a module procedure. */
1461 : 257 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1462 : 257 : if (st == NULL)
1463 : 216 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1464 : : }
1465 : : else
1466 : 49757 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1467 : :
1468 : 50014 : st->n.sym = sym;
1469 : 50014 : sym->refs++;
1470 : :
1471 : : /* See if the procedure should be a module procedure. */
1472 : :
1473 : 50014 : if (((sym->ns->proc_name != NULL
1474 : 50014 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1475 : 20310 : && sym->attr.proc != PROC_MODULE)
1476 : 50014 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1477 : 67751 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1478 : : rc = 2;
1479 : :
1480 : : return rc;
1481 : : }
1482 : :
1483 : :
1484 : : /* Verify that the given symbol representing a parameter is C
1485 : : interoperable, by checking to see if it was marked as such after
1486 : : its declaration. If the given symbol is not interoperable, a
1487 : : warning is reported, thus removing the need to return the status to
1488 : : the calling function. The standard does not require the user use
1489 : : one of the iso_c_binding named constants to declare an
1490 : : interoperable parameter, but we can't be sure if the param is C
1491 : : interop or not if the user doesn't. For example, integer(4) may be
1492 : : legal Fortran, but doesn't have meaning in C. It may interop with
1493 : : a number of the C types, which causes a problem because the
1494 : : compiler can't know which one. This code is almost certainly not
1495 : : portable, and the user will get what they deserve if the C type
1496 : : across platforms isn't always interoperable with integer(4). If
1497 : : the user had used something like integer(c_int) or integer(c_long),
1498 : : the compiler could have automatically handled the varying sizes
1499 : : across platforms. */
1500 : :
1501 : : bool
1502 : 16361 : gfc_verify_c_interop_param (gfc_symbol *sym)
1503 : : {
1504 : 16361 : int is_c_interop = 0;
1505 : 16361 : bool retval = true;
1506 : :
1507 : : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1508 : : Don't repeat the checks here. */
1509 : 16361 : if (sym->attr.implicit_type)
1510 : : return true;
1511 : :
1512 : : /* For subroutines or functions that are passed to a BIND(C) procedure,
1513 : : they're interoperable if they're BIND(C) and their params are all
1514 : : interoperable. */
1515 : 16361 : if (sym->attr.flavor == FL_PROCEDURE)
1516 : : {
1517 : 4 : if (sym->attr.is_bind_c == 0)
1518 : : {
1519 : 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1520 : : "attribute to be C interoperable", sym->name,
1521 : : &(sym->declared_at));
1522 : 0 : return false;
1523 : : }
1524 : : else
1525 : : {
1526 : 4 : if (sym->attr.is_c_interop == 1)
1527 : : /* We've already checked this procedure; don't check it again. */
1528 : : return true;
1529 : : else
1530 : 4 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1531 : 4 : sym->common_block);
1532 : : }
1533 : : }
1534 : :
1535 : : /* See if we've stored a reference to a procedure that owns sym. */
1536 : 16357 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1537 : : {
1538 : 16357 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1539 : : {
1540 : 16318 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;
1541 : 16318 : bool f2018_added = false;
1542 : :
1543 : 16318 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1544 : :
1545 : : /* F2018:18.3.6 has the following text:
1546 : : "(5) any dummy argument without the VALUE attribute corresponds to
1547 : : a formal parameter of the prototype that is of a pointer type, and
1548 : : either
1549 : : • the dummy argument is interoperable with an entity of the
1550 : : referenced type (ISO/IEC 9899:2011, 6.2.5, 7.19, and 7.20.1) of
1551 : : the formal parameter (this is equivalent to the F2008 text),
1552 : : • the dummy argument is a nonallocatable nonpointer variable of
1553 : : type CHARACTER with assumed character length and the formal
1554 : : parameter is a pointer to CFI_cdesc_t,
1555 : : • the dummy argument is allocatable, assumed-shape, assumed-rank,
1556 : : or a pointer without the CONTIGUOUS attribute, and the formal
1557 : : parameter is a pointer to CFI_cdesc_t, or
1558 : : • the dummy argument is assumed-type and not allocatable,
1559 : : assumed-shape, assumed-rank, or a pointer, and the formal
1560 : : parameter is a pointer to void," */
1561 : 3720 : if (is_c_interop == 0 && !sym->attr.value && f2018_allowed)
1562 : : {
1563 : 2354 : bool as_ar = (sym->as
1564 : 2354 : && (sym->as->type == AS_ASSUMED_SHAPE
1565 : 2109 : || sym->as->type == AS_ASSUMED_RANK));
1566 : 4708 : bool cond1 = (sym->ts.type == BT_CHARACTER
1567 : 1564 : && !(sym->ts.u.cl && sym->ts.u.cl->length)
1568 : 904 : && !sym->attr.allocatable
1569 : 3240 : && !sym->attr.pointer);
1570 : 4708 : bool cond2 = (sym->attr.allocatable
1571 : 2257 : || as_ar
1572 : 3370 : || (IS_POINTER (sym) && !sym->attr.contiguous));
1573 : 4708 : bool cond3 = (sym->ts.type == BT_ASSUMED
1574 : 0 : && !sym->attr.allocatable
1575 : 0 : && !sym->attr.pointer
1576 : 2354 : && !as_ar);
1577 : 2354 : f2018_added = cond1 || cond2 || cond3;
1578 : : }
1579 : :
1580 : 16318 : if (is_c_interop != 1 && !f2018_added)
1581 : : {
1582 : : /* Make personalized messages to give better feedback. */
1583 : 1828 : if (sym->ts.type == BT_DERIVED)
1584 : 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1585 : : "BIND(C) procedure %qs but is not C interoperable "
1586 : : "because derived type %qs is not C interoperable",
1587 : : sym->name, &(sym->declared_at),
1588 : 1 : sym->ns->proc_name->name,
1589 : 1 : sym->ts.u.derived->name);
1590 : 1827 : else if (sym->ts.type == BT_CLASS)
1591 : 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1592 : : "BIND(C) procedure %qs but is not C interoperable "
1593 : : "because it is polymorphic",
1594 : : sym->name, &(sym->declared_at),
1595 : 6 : sym->ns->proc_name->name);
1596 : 1821 : else if (warn_c_binding_type)
1597 : 39 : gfc_warning (OPT_Wc_binding_type,
1598 : : "Variable %qs at %L is a dummy argument of the "
1599 : : "BIND(C) procedure %qs but may not be C "
1600 : : "interoperable",
1601 : : sym->name, &(sym->declared_at),
1602 : 39 : sym->ns->proc_name->name);
1603 : : }
1604 : :
1605 : : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1606 : 16318 : if (sym->attr.pointer && sym->attr.contiguous)
1607 : 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1608 : : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1609 : 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1610 : :
1611 : : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1612 : : procedure that are default-initialized are not permitted. */
1613 : 15680 : if ((sym->attr.pointer || sym->attr.allocatable)
1614 : 1037 : && sym->ts.type == BT_DERIVED
1615 : 16696 : && gfc_has_default_initializer (sym->ts.u.derived))
1616 : : {
1617 : 8 : gfc_error ("Default-initialized dummy argument %qs with %s "
1618 : : "attribute at %L is not permitted in BIND(C) "
1619 : : "procedure %qs", sym->name,
1620 : 4 : (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
1621 : 4 : &sym->declared_at, sym->ns->proc_name->name);
1622 : 4 : retval = false;
1623 : : }
1624 : :
1625 : : /* Character strings are only C interoperable if they have a
1626 : : length of 1. However, as an argument they are also interoperable
1627 : : when passed as descriptor (which requires len=: or len=*). */
1628 : 16318 : if (sym->ts.type == BT_CHARACTER)
1629 : : {
1630 : 2338 : gfc_charlen *cl = sym->ts.u.cl;
1631 : :
1632 : 2338 : if (sym->attr.allocatable || sym->attr.pointer)
1633 : : {
1634 : : /* F2018, 18.3.6 (6). */
1635 : 193 : if (!sym->ts.deferred)
1636 : : {
1637 : 64 : if (sym->attr.allocatable)
1638 : 32 : gfc_error ("Allocatable character dummy argument %qs "
1639 : : "at %L must have deferred length as "
1640 : : "procedure %qs is BIND(C)", sym->name,
1641 : 32 : &sym->declared_at, sym->ns->proc_name->name);
1642 : : else
1643 : 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1644 : : "must have deferred length as procedure %qs "
1645 : : "is BIND(C)", sym->name, &sym->declared_at,
1646 : 32 : sym->ns->proc_name->name);
1647 : : retval = false;
1648 : : }
1649 : 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1650 : : "Deferred-length character dummy "
1651 : : "argument %qs at %L of procedure "
1652 : : "%qs with BIND(C) attribute",
1653 : : sym->name, &sym->declared_at,
1654 : 129 : sym->ns->proc_name->name))
1655 : 102 : retval = false;
1656 : : }
1657 : 2145 : else if (sym->attr.value
1658 : 354 : && (!cl || !cl->length
1659 : 354 : || cl->length->expr_type != EXPR_CONSTANT
1660 : 354 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1661 : : {
1662 : 1 : gfc_error ("Character dummy argument %qs at %L must be "
1663 : : "of length 1 as it has the VALUE attribute",
1664 : : sym->name, &sym->declared_at);
1665 : 1 : retval = false;
1666 : : }
1667 : 2144 : else if (!cl || !cl->length)
1668 : : {
1669 : : /* Assumed length; F2018, 18.3.6 (5)(2).
1670 : : Uses the CFI array descriptor - also for scalars and
1671 : : explicit-size/assumed-size arrays. */
1672 : 957 : if (!gfc_notify_std (GFC_STD_F2018,
1673 : : "Assumed-length character dummy argument "
1674 : : "%qs at %L of procedure %qs with BIND(C) "
1675 : : "attribute", sym->name, &sym->declared_at,
1676 : 957 : sym->ns->proc_name->name))
1677 : 102 : retval = false;
1678 : : }
1679 : 1187 : else if (cl->length->expr_type != EXPR_CONSTANT
1680 : 873 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1681 : : {
1682 : : /* F2018, 18.3.6, (5), item 4. */
1683 : 653 : if (!sym->attr.dimension
1684 : 645 : || sym->as->type == AS_ASSUMED_SIZE
1685 : 639 : || sym->as->type == AS_EXPLICIT)
1686 : : {
1687 : 20 : gfc_error ("Character dummy argument %qs at %L must be "
1688 : : "of constant length of one or assumed length, "
1689 : : "unless it has assumed shape or assumed rank, "
1690 : : "as procedure %qs has the BIND(C) attribute",
1691 : : sym->name, &sym->declared_at,
1692 : 20 : sym->ns->proc_name->name);
1693 : 20 : retval = false;
1694 : : }
1695 : : /* else: valid only since F2018 - and an assumed-shape/rank
1696 : : array; however, gfc_notify_std is already called when
1697 : : those array types are used. Thus, silently accept F200x. */
1698 : : }
1699 : : }
1700 : :
1701 : : /* We have to make sure that any param to a bind(c) routine does
1702 : : not have the allocatable, pointer, or optional attributes,
1703 : : according to J3/04-007, section 5.1. */
1704 : 16318 : if (sym->attr.allocatable == 1
1705 : 16717 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1706 : : "ALLOCATABLE attribute in procedure %qs "
1707 : : "with BIND(C)", sym->name,
1708 : : &(sym->declared_at),
1709 : 399 : sym->ns->proc_name->name))
1710 : : retval = false;
1711 : :
1712 : 16318 : if (sym->attr.pointer == 1
1713 : 16956 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1714 : : "POINTER attribute in procedure %qs "
1715 : : "with BIND(C)", sym->name,
1716 : : &(sym->declared_at),
1717 : 638 : sym->ns->proc_name->name))
1718 : : retval = false;
1719 : :
1720 : 16318 : if (sym->attr.optional == 1 && sym->attr.value)
1721 : : {
1722 : 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1723 : : "and the VALUE attribute because procedure %qs "
1724 : : "is BIND(C)", sym->name, &(sym->declared_at),
1725 : 9 : sym->ns->proc_name->name);
1726 : 9 : retval = false;
1727 : : }
1728 : 16309 : else if (sym->attr.optional == 1
1729 : 17253 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1730 : : "at %L with OPTIONAL attribute in "
1731 : : "procedure %qs which is BIND(C)",
1732 : : sym->name, &(sym->declared_at),
1733 : 944 : sym->ns->proc_name->name))
1734 : : retval = false;
1735 : :
1736 : : /* Make sure that if it has the dimension attribute, that it is
1737 : : either assumed size or explicit shape. Deferred shape is already
1738 : : covered by the pointer/allocatable attribute. */
1739 : 5399 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1740 : 17648 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1741 : : "at %L as dummy argument to the BIND(C) "
1742 : : "procedure %qs at %L", sym->name,
1743 : : &(sym->declared_at),
1744 : : sym->ns->proc_name->name,
1745 : 1330 : &(sym->ns->proc_name->declared_at)))
1746 : : retval = false;
1747 : : }
1748 : : }
1749 : :
1750 : : return retval;
1751 : : }
1752 : :
1753 : :
1754 : :
1755 : : /* Function called by variable_decl() that adds a name to the symbol table. */
1756 : :
1757 : : static bool
1758 : 255037 : build_sym (const char *name, int elem, gfc_charlen *cl, bool cl_deferred,
1759 : : gfc_array_spec **as, locus *var_locus)
1760 : : {
1761 : 255037 : symbol_attribute attr;
1762 : 255037 : gfc_symbol *sym;
1763 : 255037 : int upper;
1764 : 255037 : gfc_symtree *st, *host_st = NULL;
1765 : :
1766 : : /* Symbols in a submodule are host associated from the parent module or
1767 : : submodules. Therefore, they can be overridden by declarations in the
1768 : : submodule scope. Deal with this by attaching the existing symbol to
1769 : : a new symtree and recycling the old symtree with a new symbol... */
1770 : 255037 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1771 : 255037 : if (((st && st->import_only) || (gfc_current_ns->import_state == IMPORT_ALL))
1772 : 3 : && gfc_current_ns->parent)
1773 : 3 : host_st = gfc_find_symtree (gfc_current_ns->parent->sym_root, name);
1774 : :
1775 : 255037 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1776 : 12 : && st->n.sym != NULL
1777 : 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1778 : : {
1779 : 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1780 : 12 : s->n.sym = st->n.sym;
1781 : 12 : sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
1782 : :
1783 : 12 : st->n.sym = sym;
1784 : 12 : sym->refs++;
1785 : 12 : gfc_set_sym_referenced (sym);
1786 : 12 : }
1787 : : /* ...Check that F2018 IMPORT, ONLY and IMPORT, ALL statements, within the
1788 : : current scope are not violated by local redeclarations. Note that there is
1789 : : no need to guard for std >= F2018 because import_only and IMPORT_ALL are
1790 : : only set for these standards. */
1791 : 255025 : else if (host_st && host_st->n.sym
1792 : 2 : && host_st->n.sym != gfc_current_ns->proc_name
1793 : 2 : && !(st && st->n.sym
1794 : 1 : && (st->n.sym->attr.dummy || st->n.sym->attr.result)))
1795 : : {
1796 : 2 : gfc_error ("F2018: C8102 %s at %L is already imported by an %s "
1797 : : "statement and must not be re-declared", name, var_locus,
1798 : 1 : (st && st->import_only) ? "IMPORT, ONLY" : "IMPORT, ALL");
1799 : 2 : return false;
1800 : : }
1801 : : /* ...Otherwise generate a new symtree and new symbol. */
1802 : 255023 : else if (gfc_get_symbol (name, NULL, &sym, var_locus))
1803 : : return false;
1804 : :
1805 : : /* Check if the name has already been defined as a type. The
1806 : : first letter of the symtree will be in upper case then. Of
1807 : : course, this is only necessary if the upper case letter is
1808 : : actually different. */
1809 : :
1810 : 255035 : upper = TOUPPER(name[0]);
1811 : 255035 : if (upper != name[0])
1812 : : {
1813 : 254397 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1814 : 254397 : gfc_symtree *st;
1815 : :
1816 : 254397 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1817 : 254397 : strcpy (u_name, name);
1818 : 254397 : u_name[0] = upper;
1819 : :
1820 : 254397 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1821 : :
1822 : : /* STRUCTURE types can alias symbol names */
1823 : 254397 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1824 : : {
1825 : 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1826 : : &st->n.sym->declared_at);
1827 : 1 : return false;
1828 : : }
1829 : : }
1830 : :
1831 : : /* Start updating the symbol table. Add basic type attribute if present. */
1832 : 255034 : if (current_ts.type != BT_UNKNOWN
1833 : 255034 : && (sym->attr.implicit_type == 0
1834 : 185 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1835 : 509887 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1836 : : return false;
1837 : :
1838 : 255008 : if (sym->ts.type == BT_CHARACTER)
1839 : : {
1840 : 28389 : if (elem > 1)
1841 : 4051 : sym->ts.u.cl = gfc_new_charlen (sym->ns, cl);
1842 : : else
1843 : 24338 : sym->ts.u.cl = cl;
1844 : 28389 : sym->ts.deferred = cl_deferred;
1845 : : }
1846 : :
1847 : : /* Add dimension attribute if present. */
1848 : 255008 : if (!gfc_set_array_spec (sym, *as, var_locus))
1849 : : return false;
1850 : 255006 : *as = NULL;
1851 : :
1852 : : /* Add attribute to symbol. The copy is so that we can reset the
1853 : : dimension attribute. */
1854 : 255006 : attr = current_attr;
1855 : 255006 : attr.dimension = 0;
1856 : 255006 : attr.codimension = 0;
1857 : :
1858 : 255006 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1859 : : return false;
1860 : :
1861 : : /* Finish any work that may need to be done for the binding label,
1862 : : if it's a bind(c). The bind(c) attr is found before the symbol
1863 : : is made, and before the symbol name (for data decls), so the
1864 : : current_ts is holding the binding label, or nothing if the
1865 : : name= attr wasn't given. Therefore, test here if we're dealing
1866 : : with a bind(c) and make sure the binding label is set correctly. */
1867 : 254992 : if (sym->attr.is_bind_c == 1)
1868 : : {
1869 : 1300 : if (!sym->binding_label)
1870 : : {
1871 : : /* Set the binding label and verify that if a NAME= was specified
1872 : : then only one identifier was in the entity-decl-list. */
1873 : 136 : if (!set_binding_label (&sym->binding_label, sym->name,
1874 : : num_idents_on_line))
1875 : : return false;
1876 : : }
1877 : : }
1878 : :
1879 : : /* See if we know we're in a common block, and if it's a bind(c)
1880 : : common then we need to make sure we're an interoperable type. */
1881 : 254990 : if (sym->attr.in_common == 1)
1882 : : {
1883 : : /* Test the common block object. */
1884 : 614 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1885 : 6 : && sym->ts.is_c_interop != 1)
1886 : : {
1887 : 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1888 : : "must be declared with a C interoperable "
1889 : : "kind since common block %qs is BIND(C)",
1890 : : sym->name, sym->common_block->name,
1891 : 0 : sym->common_block->name);
1892 : 0 : gfc_clear_error ();
1893 : : }
1894 : : }
1895 : :
1896 : 254990 : sym->attr.implied_index = 0;
1897 : :
1898 : : /* Use the parameter expressions for a parameterized derived type. */
1899 : 254990 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1900 : 35514 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1901 : 852 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1902 : :
1903 : 254990 : if (sym->ts.type == BT_CLASS)
1904 : 10690 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1905 : :
1906 : : return true;
1907 : : }
1908 : :
1909 : :
1910 : : /* Set character constant to the given length. The constant will be padded or
1911 : : truncated. If we're inside an array constructor without a typespec, we
1912 : : additionally check that all elements have the same length; check_len -1
1913 : : means no checking. */
1914 : :
1915 : : void
1916 : 13970 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1917 : : gfc_charlen_t check_len)
1918 : : {
1919 : 13970 : gfc_char_t *s;
1920 : 13970 : gfc_charlen_t slen;
1921 : :
1922 : 13970 : if (expr->ts.type != BT_CHARACTER)
1923 : : return;
1924 : :
1925 : 13968 : if (expr->expr_type != EXPR_CONSTANT)
1926 : : {
1927 : 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1928 : 1 : return;
1929 : : }
1930 : :
1931 : 13967 : slen = expr->value.character.length;
1932 : 13967 : if (len != slen)
1933 : : {
1934 : 2093 : s = gfc_get_wide_string (len + 1);
1935 : 2093 : memcpy (s, expr->value.character.string,
1936 : 2093 : MIN (len, slen) * sizeof (gfc_char_t));
1937 : 2093 : if (len > slen)
1938 : 1802 : gfc_wide_memset (&s[slen], ' ', len - slen);
1939 : :
1940 : 2093 : if (warn_character_truncation && slen > len)
1941 : 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1942 : : "CHARACTER expression at %L is being truncated "
1943 : : "(%ld/%ld)", &expr->where,
1944 : : (long) slen, (long) len);
1945 : :
1946 : : /* Apply the standard by 'hand' otherwise it gets cleared for
1947 : : initializers. */
1948 : 2093 : if (check_len != -1 && slen != check_len)
1949 : : {
1950 : 3 : if (!(gfc_option.allow_std & GFC_STD_GNU))
1951 : 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
1952 : : "at %L must have the same length (%ld/%ld)",
1953 : : &expr->where, (long) slen,
1954 : : (long) check_len);
1955 : : else
1956 : 3 : gfc_notify_std (GFC_STD_LEGACY,
1957 : : "The CHARACTER elements of the array constructor "
1958 : : "at %L must have the same length (%ld/%ld)",
1959 : : &expr->where, (long) slen,
1960 : : (long) check_len);
1961 : : }
1962 : :
1963 : 2093 : s[len] = '\0';
1964 : 2093 : free (expr->value.character.string);
1965 : 2093 : expr->value.character.string = s;
1966 : 2093 : expr->value.character.length = len;
1967 : : /* If explicit representation was given, clear it
1968 : : as it is no longer needed after padding. */
1969 : 2093 : if (expr->representation.length)
1970 : : {
1971 : 45 : expr->representation.length = 0;
1972 : 45 : free (expr->representation.string);
1973 : 45 : expr->representation.string = NULL;
1974 : : }
1975 : : }
1976 : : }
1977 : :
1978 : :
1979 : : /* Function to create and update the enumerator history
1980 : : using the information passed as arguments.
1981 : : Pointer "max_enum" is also updated, to point to
1982 : : enum history node containing largest initializer.
1983 : :
1984 : : SYM points to the symbol node of enumerator.
1985 : : INIT points to its enumerator value. */
1986 : :
1987 : : static void
1988 : 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
1989 : : {
1990 : 543 : enumerator_history *new_enum_history;
1991 : 543 : gcc_assert (sym != NULL && init != NULL);
1992 : :
1993 : 543 : new_enum_history = XCNEW (enumerator_history);
1994 : :
1995 : 543 : new_enum_history->sym = sym;
1996 : 543 : new_enum_history->initializer = init;
1997 : 543 : new_enum_history->next = NULL;
1998 : :
1999 : 543 : if (enum_history == NULL)
2000 : : {
2001 : 160 : enum_history = new_enum_history;
2002 : 160 : max_enum = enum_history;
2003 : : }
2004 : : else
2005 : : {
2006 : 383 : new_enum_history->next = enum_history;
2007 : 383 : enum_history = new_enum_history;
2008 : :
2009 : 383 : if (mpz_cmp (max_enum->initializer->value.integer,
2010 : 383 : new_enum_history->initializer->value.integer) < 0)
2011 : 381 : max_enum = new_enum_history;
2012 : : }
2013 : 543 : }
2014 : :
2015 : :
2016 : : /* Function to free enum kind history. */
2017 : :
2018 : : void
2019 : 175 : gfc_free_enum_history (void)
2020 : : {
2021 : 175 : enumerator_history *current = enum_history;
2022 : 175 : enumerator_history *next;
2023 : :
2024 : 718 : while (current != NULL)
2025 : : {
2026 : 543 : next = current->next;
2027 : 543 : free (current);
2028 : 543 : current = next;
2029 : : }
2030 : 175 : max_enum = NULL;
2031 : 175 : enum_history = NULL;
2032 : 175 : }
2033 : :
2034 : :
2035 : : /* Function to fix initializer character length if the length of the
2036 : : symbol or component is constant. */
2037 : :
2038 : : static bool
2039 : 2691 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
2040 : : {
2041 : 2691 : if (!gfc_specification_expr (ts->u.cl->length))
2042 : : return false;
2043 : :
2044 : 2691 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
2045 : :
2046 : : /* resolve_charlen will complain later on if the length
2047 : : is too large. Just skip the initialization in that case. */
2048 : 2691 : if (mpz_cmp (ts->u.cl->length->value.integer,
2049 : 2691 : gfc_integer_kinds[k].huge) <= 0)
2050 : : {
2051 : 2690 : HOST_WIDE_INT len
2052 : 2690 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
2053 : :
2054 : 2690 : if (init->expr_type == EXPR_CONSTANT)
2055 : 1956 : gfc_set_constant_character_len (len, init, -1);
2056 : 734 : else if (init->expr_type == EXPR_ARRAY)
2057 : : {
2058 : 733 : gfc_constructor *cons;
2059 : :
2060 : : /* Build a new charlen to prevent simplification from
2061 : : deleting the length before it is resolved. */
2062 : 733 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2063 : 733 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
2064 : 733 : cons = gfc_constructor_first (init->value.constructor);
2065 : 4971 : for (; cons; cons = gfc_constructor_next (cons))
2066 : 3505 : gfc_set_constant_character_len (len, cons->expr, -1);
2067 : : }
2068 : : }
2069 : :
2070 : : return true;
2071 : : }
2072 : :
2073 : :
2074 : : /* Function called by variable_decl() that adds an initialization
2075 : : expression to a symbol. */
2076 : :
2077 : : static bool
2078 : 262475 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
2079 : : {
2080 : 262475 : symbol_attribute attr;
2081 : 262475 : gfc_symbol *sym;
2082 : 262475 : gfc_expr *init;
2083 : :
2084 : 262475 : init = *initp;
2085 : 262475 : if (find_special (name, &sym, false))
2086 : : return false;
2087 : :
2088 : 262475 : attr = sym->attr;
2089 : :
2090 : : /* If this symbol is confirming an implicit parameter type,
2091 : : then an initialization expression is not allowed. */
2092 : 262475 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2093 : : {
2094 : 1 : if (*initp != NULL)
2095 : : {
2096 : 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2097 : : sym->name);
2098 : 0 : return false;
2099 : : }
2100 : : else
2101 : : return true;
2102 : : }
2103 : :
2104 : 262474 : if (init == NULL)
2105 : : {
2106 : : /* An initializer is required for PARAMETER declarations. */
2107 : 230832 : if (attr.flavor == FL_PARAMETER)
2108 : : {
2109 : 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2110 : 1 : return false;
2111 : : }
2112 : : }
2113 : : else
2114 : : {
2115 : : /* If a variable appears in a DATA block, it cannot have an
2116 : : initializer. */
2117 : 31642 : if (sym->attr.data)
2118 : : {
2119 : 0 : gfc_error ("Variable %qs at %C with an initializer already "
2120 : : "appears in a DATA statement", sym->name);
2121 : 0 : return false;
2122 : : }
2123 : :
2124 : : /* Check if the assignment can happen. This has to be put off
2125 : : until later for derived type variables and procedure pointers. */
2126 : 30526 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2127 : 30503 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2128 : 30453 : && !sym->attr.proc_pointer
2129 : 62009 : && !gfc_check_assign_symbol (sym, NULL, init))
2130 : : return false;
2131 : :
2132 : 31611 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2133 : 3371 : && init->ts.type == BT_CHARACTER)
2134 : : {
2135 : : /* Update symbol character length according initializer. */
2136 : 3207 : if (!gfc_check_assign_symbol (sym, NULL, init))
2137 : : return false;
2138 : :
2139 : 3207 : if (sym->ts.u.cl->length == NULL)
2140 : : {
2141 : 832 : gfc_charlen_t clen;
2142 : : /* If there are multiple CHARACTER variables declared on the
2143 : : same line, we don't want them to share the same length. */
2144 : 832 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2145 : :
2146 : 832 : if (sym->attr.flavor == FL_PARAMETER)
2147 : : {
2148 : 823 : if (init->expr_type == EXPR_CONSTANT)
2149 : : {
2150 : 540 : clen = init->value.character.length;
2151 : 540 : sym->ts.u.cl->length
2152 : 540 : = gfc_get_int_expr (gfc_charlen_int_kind,
2153 : : NULL, clen);
2154 : : }
2155 : 283 : else if (init->expr_type == EXPR_ARRAY)
2156 : : {
2157 : 283 : if (init->ts.u.cl && init->ts.u.cl->length)
2158 : : {
2159 : 271 : const gfc_expr *length = init->ts.u.cl->length;
2160 : 271 : if (length->expr_type != EXPR_CONSTANT)
2161 : : {
2162 : 1 : gfc_error ("Cannot initialize parameter array "
2163 : : "at %L "
2164 : : "with variable length elements",
2165 : : &sym->declared_at);
2166 : 1 : return false;
2167 : : }
2168 : 270 : clen = mpz_get_si (length->value.integer);
2169 : 270 : }
2170 : 12 : else if (init->value.constructor)
2171 : : {
2172 : 12 : gfc_constructor *c;
2173 : 12 : c = gfc_constructor_first (init->value.constructor);
2174 : 12 : clen = c->expr->value.character.length;
2175 : : }
2176 : : else
2177 : 0 : gcc_unreachable ();
2178 : 282 : sym->ts.u.cl->length
2179 : 282 : = gfc_get_int_expr (gfc_charlen_int_kind,
2180 : : NULL, clen);
2181 : : }
2182 : 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2183 : 0 : sym->ts.u.cl->length =
2184 : 0 : gfc_copy_expr (init->ts.u.cl->length);
2185 : : }
2186 : : }
2187 : : /* Update initializer character length according to symbol. */
2188 : 2375 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2189 : 2375 : && !fix_initializer_charlen (&sym->ts, init))
2190 : : return false;
2191 : : }
2192 : :
2193 : 31610 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2194 : 3743 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2195 : : {
2196 : 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2197 : : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2198 : 3 : return false;
2199 : : }
2200 : :
2201 : : /* If sym is implied-shape, set its upper bounds from init. */
2202 : 31607 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2203 : 3740 : && sym->as->type == AS_IMPLIED_SHAPE)
2204 : : {
2205 : 1030 : int dim;
2206 : :
2207 : 1030 : if (init->rank == 0)
2208 : : {
2209 : 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2210 : : " with scalar", &sym->declared_at);
2211 : 1 : return false;
2212 : : }
2213 : :
2214 : : /* The shape may be NULL for EXPR_ARRAY, set it. */
2215 : 1029 : if (init->shape == NULL)
2216 : : {
2217 : 5 : if (init->expr_type != EXPR_ARRAY)
2218 : : {
2219 : 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2220 : 2 : return false;
2221 : : }
2222 : :
2223 : 3 : init->shape = gfc_get_shape (1);
2224 : 3 : if (!gfc_array_size (init, &init->shape[0]))
2225 : : {
2226 : 1 : gfc_error ("Cannot determine shape of initializer at %L",
2227 : : &init->where);
2228 : 1 : free (init->shape);
2229 : 1 : init->shape = NULL;
2230 : 1 : return false;
2231 : : }
2232 : : }
2233 : :
2234 : 2153 : for (dim = 0; dim < sym->as->rank; ++dim)
2235 : : {
2236 : 1128 : int k;
2237 : 1128 : gfc_expr *e, *lower;
2238 : :
2239 : 1128 : lower = sym->as->lower[dim];
2240 : :
2241 : : /* If the lower bound is an array element from another
2242 : : parameterized array, then it is marked with EXPR_VARIABLE and
2243 : : is an initialization expression. Try to reduce it. */
2244 : 1128 : if (lower->expr_type == EXPR_VARIABLE)
2245 : 7 : gfc_reduce_init_expr (lower);
2246 : :
2247 : 1128 : if (lower->expr_type == EXPR_CONSTANT)
2248 : : {
2249 : : /* All dimensions must be without upper bound. */
2250 : 1127 : gcc_assert (!sym->as->upper[dim]);
2251 : :
2252 : 1127 : k = lower->ts.kind;
2253 : 1127 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2254 : 1127 : mpz_add (e->value.integer, lower->value.integer,
2255 : 1127 : init->shape[dim]);
2256 : 1127 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2257 : 1127 : sym->as->upper[dim] = e;
2258 : : }
2259 : : else
2260 : : {
2261 : 1 : gfc_error ("Non-constant lower bound in implied-shape"
2262 : : " declaration at %L", &lower->where);
2263 : 1 : return false;
2264 : : }
2265 : : }
2266 : :
2267 : 1025 : sym->as->type = AS_EXPLICIT;
2268 : : }
2269 : :
2270 : : /* Ensure that explicit bounds are simplified. */
2271 : 31602 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2272 : 3735 : && sym->as->type == AS_EXPLICIT)
2273 : : {
2274 : 8302 : for (int dim = 0; dim < sym->as->rank; ++dim)
2275 : : {
2276 : 4579 : gfc_expr *e;
2277 : :
2278 : 4579 : e = sym->as->lower[dim];
2279 : 4579 : if (e->expr_type != EXPR_CONSTANT)
2280 : 12 : gfc_reduce_init_expr (e);
2281 : :
2282 : 4579 : e = sym->as->upper[dim];
2283 : 4579 : if (e->expr_type != EXPR_CONSTANT)
2284 : 96 : gfc_reduce_init_expr (e);
2285 : : }
2286 : : }
2287 : :
2288 : : /* Need to check if the expression we initialized this
2289 : : to was one of the iso_c_binding named constants. If so,
2290 : : and we're a parameter (constant), let it be iso_c.
2291 : : For example:
2292 : : integer(c_int), parameter :: my_int = c_int
2293 : : integer(my_int) :: my_int_2
2294 : : If we mark my_int as iso_c (since we can see it's value
2295 : : is equal to one of the named constants), then my_int_2
2296 : : will be considered C interoperable. */
2297 : 31602 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2298 : : {
2299 : 27119 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2300 : 27119 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2301 : : /* attr bits needed for module files. */
2302 : 27119 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2303 : 27119 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2304 : 27119 : if (init->ts.is_iso_c)
2305 : 109 : sym->ts.f90_type = init->ts.f90_type;
2306 : : }
2307 : :
2308 : : /* Catch the case: type(t), parameter :: x = z'1'. */
2309 : 31602 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2310 : : {
2311 : 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2312 : : "literal constant", name, &sym->declared_at);
2313 : 1 : return false;
2314 : : }
2315 : :
2316 : : /* Add initializer. Make sure we keep the ranks sane. */
2317 : 31601 : if (sym->attr.dimension && init->rank == 0)
2318 : : {
2319 : 1234 : mpz_t size;
2320 : 1234 : gfc_expr *array;
2321 : 1234 : int n;
2322 : 1234 : if (sym->attr.flavor == FL_PARAMETER
2323 : 438 : && gfc_is_constant_expr (init)
2324 : 438 : && (init->expr_type == EXPR_CONSTANT
2325 : 31 : || init->expr_type == EXPR_STRUCTURE)
2326 : 1672 : && spec_size (sym->as, &size))
2327 : : {
2328 : 434 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2329 : : &init->where);
2330 : 434 : if (init->ts.type == BT_DERIVED)
2331 : 31 : array->ts.u.derived = init->ts.u.derived;
2332 : 67549 : for (n = 0; n < (int)mpz_get_si (size); n++)
2333 : 133937 : gfc_constructor_append_expr (&array->value.constructor,
2334 : : n == 0
2335 : : ? init
2336 : 66822 : : gfc_copy_expr (init),
2337 : : &init->where);
2338 : :
2339 : 434 : array->shape = gfc_get_shape (sym->as->rank);
2340 : 994 : for (n = 0; n < sym->as->rank; n++)
2341 : 560 : spec_dimen_size (sym->as, n, &array->shape[n]);
2342 : :
2343 : 434 : init = array;
2344 : 434 : mpz_clear (size);
2345 : : }
2346 : 1234 : init->rank = sym->as->rank;
2347 : 1234 : init->corank = sym->as->corank;
2348 : : }
2349 : :
2350 : 31601 : sym->value = init;
2351 : 31601 : if (sym->attr.save == SAVE_NONE)
2352 : 27231 : sym->attr.save = SAVE_IMPLICIT;
2353 : 31601 : *initp = NULL;
2354 : : }
2355 : :
2356 : : return true;
2357 : : }
2358 : :
2359 : :
2360 : : /* Function called by variable_decl() that adds a name to a structure
2361 : : being built. */
2362 : :
2363 : : static bool
2364 : 17154 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2365 : : gfc_array_spec **as)
2366 : : {
2367 : 17154 : gfc_state_data *s;
2368 : 17154 : gfc_component *c;
2369 : :
2370 : : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2371 : : constructing, it must have the pointer attribute. */
2372 : 17154 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2373 : 3175 : && current_ts.u.derived == gfc_current_block ()
2374 : 261 : && current_attr.pointer == 0)
2375 : : {
2376 : 99 : if (current_attr.allocatable
2377 : 99 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2378 : : "must have the POINTER attribute"))
2379 : : {
2380 : : return false;
2381 : : }
2382 : 98 : else if (current_attr.allocatable == 0)
2383 : : {
2384 : 0 : gfc_error ("Component at %C must have the POINTER attribute");
2385 : 0 : return false;
2386 : : }
2387 : : }
2388 : :
2389 : : /* F03:C437. */
2390 : 17153 : if (current_ts.type == BT_CLASS
2391 : 806 : && !(current_attr.pointer || current_attr.allocatable))
2392 : : {
2393 : 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2394 : : "or pointer", name);
2395 : 5 : return false;
2396 : : }
2397 : :
2398 : 17148 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2399 : : {
2400 : 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2401 : : {
2402 : 0 : gfc_error ("Array component of structure at %C must have explicit "
2403 : : "or deferred shape");
2404 : 0 : return false;
2405 : : }
2406 : : }
2407 : :
2408 : : /* If we are in a nested union/map definition, gfc_add_component will not
2409 : : properly find repeated components because:
2410 : : (i) gfc_add_component does a flat search, where components of unions
2411 : : and maps are implicity chained so nested components may conflict.
2412 : : (ii) Unions and maps are not linked as components of their parent
2413 : : structures until after they are parsed.
2414 : : For (i) we use gfc_find_component which searches recursively, and for (ii)
2415 : : we search each block directly from the parse stack until we find the top
2416 : : level structure. */
2417 : :
2418 : 17148 : s = gfc_state_stack;
2419 : 17148 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2420 : : {
2421 : 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2422 : : {
2423 : 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2424 : 1434 : if (c != NULL)
2425 : : {
2426 : 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2427 : : name, &c->loc);
2428 : 0 : return false;
2429 : : }
2430 : : /* Break after we've searched the entire chain. */
2431 : 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2432 : : break;
2433 : 1000 : s = s->previous;
2434 : : }
2435 : : }
2436 : :
2437 : 17148 : if (!gfc_add_component (gfc_current_block(), name, &c))
2438 : : return false;
2439 : :
2440 : 17142 : c->ts = current_ts;
2441 : 17142 : if (c->ts.type == BT_CHARACTER)
2442 : 1905 : c->ts.u.cl = cl;
2443 : :
2444 : 17142 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2445 : 13973 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2446 : 2067 : && saved_kind_expr != NULL)
2447 : 176 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2448 : :
2449 : 17142 : c->attr = current_attr;
2450 : :
2451 : 17142 : c->initializer = *init;
2452 : 17142 : *init = NULL;
2453 : :
2454 : : /* Update initializer character length according to component. */
2455 : 1905 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2456 : 1512 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2457 : 1451 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2458 : 17461 : && !fix_initializer_charlen (&c->ts, c->initializer))
2459 : : return false;
2460 : :
2461 : 17142 : c->as = *as;
2462 : 17142 : if (c->as != NULL)
2463 : : {
2464 : 4333 : if (c->as->corank)
2465 : 97 : c->attr.codimension = 1;
2466 : 4333 : if (c->as->rank)
2467 : 4264 : c->attr.dimension = 1;
2468 : : }
2469 : 17142 : *as = NULL;
2470 : :
2471 : 17142 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2472 : :
2473 : : /* Check array components. */
2474 : 17142 : if (!c->attr.dimension)
2475 : 12878 : goto scalar;
2476 : :
2477 : 4264 : if (c->attr.pointer)
2478 : : {
2479 : 678 : if (c->as->type != AS_DEFERRED)
2480 : : {
2481 : 5 : gfc_error ("Pointer array component of structure at %C must have a "
2482 : : "deferred shape");
2483 : 5 : return false;
2484 : : }
2485 : : }
2486 : 3586 : else if (c->attr.allocatable)
2487 : : {
2488 : 2053 : const char *err = G_("Allocatable component of structure at %C must have "
2489 : : "a deferred shape");
2490 : 2053 : if (c->as->type != AS_DEFERRED)
2491 : : {
2492 : 14 : if (c->ts.type == BT_CLASS || c->ts.type == BT_DERIVED)
2493 : : {
2494 : : /* Issue an immediate error and allow this component to pass for
2495 : : the sake of clean error recovery. Set the error flag for the
2496 : : containing derived type so that finalizers are not built. */
2497 : 4 : gfc_error_now (err);
2498 : 4 : s->sym->error = 1;
2499 : 4 : c->as->type = AS_DEFERRED;
2500 : : }
2501 : : else
2502 : : {
2503 : 10 : gfc_error (err);
2504 : 10 : return false;
2505 : : }
2506 : : }
2507 : : }
2508 : : else
2509 : : {
2510 : 1533 : if (c->as->type != AS_EXPLICIT)
2511 : : {
2512 : 7 : gfc_error ("Array component of structure at %C must have an "
2513 : : "explicit shape");
2514 : 7 : return false;
2515 : : }
2516 : : }
2517 : :
2518 : 1526 : scalar:
2519 : 17120 : if (c->ts.type == BT_CLASS)
2520 : 798 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2521 : :
2522 : 16322 : if (c->attr.pdt_kind || c->attr.pdt_len)
2523 : : {
2524 : 491 : gfc_symbol *sym;
2525 : 491 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2526 : : 0, &sym);
2527 : 491 : if (sym == NULL)
2528 : : {
2529 : 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2530 : : "in the type parameter name list at %L",
2531 : 0 : c->name, &gfc_current_block ()->declared_at);
2532 : 0 : return false;
2533 : : }
2534 : 491 : sym->ts = c->ts;
2535 : 491 : sym->attr.pdt_kind = c->attr.pdt_kind;
2536 : 491 : sym->attr.pdt_len = c->attr.pdt_len;
2537 : 491 : if (c->initializer)
2538 : 183 : sym->value = gfc_copy_expr (c->initializer);
2539 : 491 : sym->attr.flavor = FL_VARIABLE;
2540 : : }
2541 : :
2542 : 16322 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2543 : 2368 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2544 : 80 : && decl_type_param_list)
2545 : 80 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2546 : :
2547 : : return true;
2548 : : }
2549 : :
2550 : :
2551 : : /* Match a 'NULL()', and possibly take care of some side effects. */
2552 : :
2553 : : match
2554 : 1669 : gfc_match_null (gfc_expr **result)
2555 : : {
2556 : 1669 : gfc_symbol *sym;
2557 : 1669 : match m, m2 = MATCH_NO;
2558 : :
2559 : 1669 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2560 : : return MATCH_ERROR;
2561 : :
2562 : 1669 : if (m == MATCH_NO)
2563 : : {
2564 : 505 : locus old_loc;
2565 : 505 : char name[GFC_MAX_SYMBOL_LEN + 1];
2566 : :
2567 : 505 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2568 : 499 : return m2;
2569 : :
2570 : 6 : old_loc = gfc_current_locus;
2571 : 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2572 : : return MATCH_ERROR;
2573 : 6 : if (m2 != MATCH_YES
2574 : 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2575 : : return MATCH_ERROR;
2576 : 6 : if (m2 == MATCH_NO)
2577 : : {
2578 : 0 : gfc_current_locus = old_loc;
2579 : 0 : return MATCH_NO;
2580 : : }
2581 : : }
2582 : :
2583 : : /* The NULL symbol now has to be/become an intrinsic function. */
2584 : 1170 : if (gfc_get_symbol ("null", NULL, &sym))
2585 : : {
2586 : 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2587 : 0 : return MATCH_ERROR;
2588 : : }
2589 : :
2590 : 1170 : gfc_intrinsic_symbol (sym);
2591 : :
2592 : 1170 : if (sym->attr.proc != PROC_INTRINSIC
2593 : 820 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2594 : 1989 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2595 : 819 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2596 : 0 : return MATCH_ERROR;
2597 : :
2598 : 1170 : *result = gfc_get_null_expr (&gfc_current_locus);
2599 : :
2600 : : /* Invalid per F2008, C512. */
2601 : 1170 : if (m2 == MATCH_YES)
2602 : : {
2603 : 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2604 : 6 : return MATCH_ERROR;
2605 : : }
2606 : :
2607 : : return MATCH_YES;
2608 : : }
2609 : :
2610 : :
2611 : : /* Match the initialization expr for a data pointer or procedure pointer. */
2612 : :
2613 : : static match
2614 : 1333 : match_pointer_init (gfc_expr **init, int procptr)
2615 : : {
2616 : 1333 : match m;
2617 : :
2618 : 1333 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2619 : : {
2620 : 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2621 : : "a PURE procedure");
2622 : 1 : return MATCH_ERROR;
2623 : : }
2624 : 1332 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2625 : :
2626 : : /* Match NULL() initialization. */
2627 : 1332 : m = gfc_match_null (init);
2628 : 1332 : if (m != MATCH_NO)
2629 : : return m;
2630 : :
2631 : : /* Match non-NULL initialization. */
2632 : 170 : gfc_matching_ptr_assignment = !procptr;
2633 : 170 : gfc_matching_procptr_assignment = procptr;
2634 : 170 : m = gfc_match_rvalue (init);
2635 : 170 : gfc_matching_ptr_assignment = 0;
2636 : 170 : gfc_matching_procptr_assignment = 0;
2637 : 170 : if (m == MATCH_ERROR)
2638 : : return MATCH_ERROR;
2639 : 169 : else if (m == MATCH_NO)
2640 : : {
2641 : 2 : gfc_error ("Error in pointer initialization at %C");
2642 : 2 : return MATCH_ERROR;
2643 : : }
2644 : :
2645 : 167 : if (!procptr && !gfc_resolve_expr (*init))
2646 : : return MATCH_ERROR;
2647 : :
2648 : 166 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2649 : : "initialization at %C"))
2650 : : return MATCH_ERROR;
2651 : :
2652 : : return MATCH_YES;
2653 : : }
2654 : :
2655 : :
2656 : : static bool
2657 : 281914 : check_function_name (char *name)
2658 : : {
2659 : : /* In functions that have a RESULT variable defined, the function name always
2660 : : refers to function calls. Therefore, the name is not allowed to appear in
2661 : : specification statements. When checking this, be careful about
2662 : : 'hidden' procedure pointer results ('ppr@'). */
2663 : :
2664 : 281914 : if (gfc_current_state () == COMP_FUNCTION)
2665 : : {
2666 : 45125 : gfc_symbol *block = gfc_current_block ();
2667 : 45125 : if (block && block->result && block->result != block
2668 : 14856 : && strcmp (block->result->name, "ppr@") != 0
2669 : 14797 : && strcmp (block->name, name) == 0)
2670 : : {
2671 : 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2672 : : "from appearing in a specification statement",
2673 : : block->result->name, &block->result->declared_at, name);
2674 : 9 : return false;
2675 : : }
2676 : : }
2677 : :
2678 : : return true;
2679 : : }
2680 : :
2681 : :
2682 : : /* Match a variable name with an optional initializer. When this
2683 : : subroutine is called, a variable is expected to be parsed next.
2684 : : Depending on what is happening at the moment, updates either the
2685 : : symbol table or the current interface. */
2686 : :
2687 : : static match
2688 : 271873 : variable_decl (int elem)
2689 : : {
2690 : 271873 : char name[GFC_MAX_SYMBOL_LEN + 1];
2691 : 271873 : static unsigned int fill_id = 0;
2692 : 271873 : gfc_expr *initializer, *char_len;
2693 : 271873 : gfc_array_spec *as;
2694 : 271873 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2695 : 271873 : gfc_charlen *cl;
2696 : 271873 : bool cl_deferred;
2697 : 271873 : locus var_locus;
2698 : 271873 : match m;
2699 : 271873 : bool t;
2700 : 271873 : gfc_symbol *sym;
2701 : 271873 : char c;
2702 : :
2703 : 271873 : initializer = NULL;
2704 : 271873 : as = NULL;
2705 : 271873 : cp_as = NULL;
2706 : :
2707 : : /* When we get here, we've just matched a list of attributes and
2708 : : maybe a type and a double colon. The next thing we expect to see
2709 : : is the name of the symbol. */
2710 : :
2711 : : /* If we are parsing a structure with legacy support, we allow the symbol
2712 : : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2713 : 271873 : m = MATCH_NO;
2714 : 271873 : gfc_gobble_whitespace ();
2715 : 271873 : var_locus = gfc_current_locus;
2716 : 271873 : c = gfc_peek_ascii_char ();
2717 : 271873 : if (c == '%')
2718 : : {
2719 : 12 : gfc_next_ascii_char (); /* Burn % character. */
2720 : 12 : m = gfc_match ("fill");
2721 : 12 : if (m == MATCH_YES)
2722 : : {
2723 : 11 : if (gfc_current_state () != COMP_STRUCTURE)
2724 : : {
2725 : 2 : if (flag_dec_structure)
2726 : 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2727 : : else
2728 : 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2729 : : "%<-fdec-structure%>", "%FILL");
2730 : 2 : m = MATCH_ERROR;
2731 : 2 : goto cleanup;
2732 : : }
2733 : :
2734 : 9 : if (attr_seen)
2735 : : {
2736 : 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2737 : 1 : m = MATCH_ERROR;
2738 : 1 : goto cleanup;
2739 : : }
2740 : :
2741 : : /* %FILL components are given invalid fortran names. */
2742 : 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2743 : : }
2744 : : else
2745 : : {
2746 : 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2747 : 1 : return MATCH_ERROR;
2748 : : }
2749 : : }
2750 : : else
2751 : : {
2752 : 271861 : m = gfc_match_name (name);
2753 : 271860 : if (m != MATCH_YES)
2754 : 10 : goto cleanup;
2755 : : }
2756 : :
2757 : : /* Now we could see the optional array spec. or character length. */
2758 : 271858 : m = gfc_match_array_spec (&as, true, true);
2759 : 271857 : if (m == MATCH_ERROR)
2760 : 56 : goto cleanup;
2761 : :
2762 : 271801 : if (m == MATCH_NO)
2763 : 212504 : as = gfc_copy_array_spec (current_as);
2764 : 59297 : else if (current_as
2765 : 59297 : && !merge_array_spec (current_as, as, true))
2766 : : {
2767 : 4 : m = MATCH_ERROR;
2768 : 4 : goto cleanup;
2769 : : }
2770 : :
2771 : 271797 : var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
2772 : : &gfc_current_locus);
2773 : 271797 : if (flag_cray_pointer)
2774 : 3063 : cp_as = gfc_copy_array_spec (as);
2775 : :
2776 : : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2777 : : determine (and check) whether it can be implied-shape. If it
2778 : : was parsed as assumed-size, change it because PARAMETERs cannot
2779 : : be assumed-size.
2780 : :
2781 : : An explicit-shape-array cannot appear under several conditions.
2782 : : That check is done here as well. */
2783 : 271797 : if (as)
2784 : : {
2785 : 81765 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2786 : : {
2787 : 2 : m = MATCH_ERROR;
2788 : 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2789 : : name, &var_locus);
2790 : 2 : goto cleanup;
2791 : : }
2792 : :
2793 : 81763 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2794 : 6447 : && current_attr.flavor == FL_PARAMETER)
2795 : 982 : as->type = AS_IMPLIED_SHAPE;
2796 : :
2797 : 81763 : if (as->type == AS_IMPLIED_SHAPE
2798 : 81763 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2799 : : &var_locus))
2800 : : {
2801 : 1 : m = MATCH_ERROR;
2802 : 1 : goto cleanup;
2803 : : }
2804 : :
2805 : 81762 : gfc_seen_div0 = false;
2806 : :
2807 : : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2808 : : constant expressions shall appear only in a subprogram, derived
2809 : : type definition, BLOCK construct, or interface body. */
2810 : 81762 : if (as->type == AS_EXPLICIT
2811 : 41079 : && gfc_current_state () != COMP_BLOCK
2812 : : && gfc_current_state () != COMP_DERIVED
2813 : : && gfc_current_state () != COMP_FUNCTION
2814 : : && gfc_current_state () != COMP_INTERFACE
2815 : : && gfc_current_state () != COMP_SUBROUTINE)
2816 : : {
2817 : : gfc_expr *e;
2818 : 49097 : bool not_constant = false;
2819 : :
2820 : 49097 : for (int i = 0; i < as->rank; i++)
2821 : : {
2822 : 28001 : e = gfc_copy_expr (as->lower[i]);
2823 : 28001 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2824 : : {
2825 : 0 : m = MATCH_ERROR;
2826 : 0 : goto cleanup;
2827 : : }
2828 : :
2829 : 28001 : gfc_simplify_expr (e, 0);
2830 : 28001 : if (e && (e->expr_type != EXPR_CONSTANT))
2831 : : {
2832 : : not_constant = true;
2833 : : break;
2834 : : }
2835 : 28001 : gfc_free_expr (e);
2836 : :
2837 : 28001 : e = gfc_copy_expr (as->upper[i]);
2838 : 28001 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2839 : : {
2840 : 4 : m = MATCH_ERROR;
2841 : 4 : goto cleanup;
2842 : : }
2843 : :
2844 : 27997 : gfc_simplify_expr (e, 0);
2845 : 27997 : if (e && (e->expr_type != EXPR_CONSTANT))
2846 : : {
2847 : : not_constant = true;
2848 : : break;
2849 : : }
2850 : 27984 : gfc_free_expr (e);
2851 : : }
2852 : :
2853 : 21109 : if (not_constant && e->ts.type != BT_INTEGER)
2854 : : {
2855 : 4 : gfc_error ("Explicit array shape at %C must be constant of "
2856 : : "INTEGER type and not %s type",
2857 : : gfc_basic_typename (e->ts.type));
2858 : 4 : m = MATCH_ERROR;
2859 : 4 : goto cleanup;
2860 : : }
2861 : 9 : if (not_constant)
2862 : : {
2863 : 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2864 : 9 : m = MATCH_ERROR;
2865 : 9 : goto cleanup;
2866 : : }
2867 : : }
2868 : 81745 : if (as->type == AS_EXPLICIT)
2869 : : {
2870 : 98561 : for (int i = 0; i < as->rank; i++)
2871 : : {
2872 : 57499 : gfc_expr *e, *n;
2873 : 57499 : e = as->lower[i];
2874 : 57499 : if (e->expr_type != EXPR_CONSTANT)
2875 : : {
2876 : 452 : n = gfc_copy_expr (e);
2877 : 452 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2878 : : {
2879 : 0 : m = MATCH_ERROR;
2880 : 0 : goto cleanup;
2881 : : }
2882 : :
2883 : 452 : if (n->expr_type == EXPR_CONSTANT)
2884 : 22 : gfc_replace_expr (e, n);
2885 : : else
2886 : 430 : gfc_free_expr (n);
2887 : : }
2888 : 57499 : e = as->upper[i];
2889 : 57499 : if (e->expr_type != EXPR_CONSTANT)
2890 : : {
2891 : 6564 : n = gfc_copy_expr (e);
2892 : 6564 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2893 : : {
2894 : 0 : m = MATCH_ERROR;
2895 : 0 : goto cleanup;
2896 : : }
2897 : :
2898 : 6564 : if (n->expr_type == EXPR_CONSTANT)
2899 : 45 : gfc_replace_expr (e, n);
2900 : : else
2901 : 6519 : gfc_free_expr (n);
2902 : : }
2903 : : /* For an explicit-shape spec with constant bounds, ensure
2904 : : that the effective upper bound is not lower than the
2905 : : respective lower bound minus one. Otherwise adjust it so
2906 : : that the extent is trivially derived to be zero. */
2907 : 57499 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2908 : 57069 : && as->upper[i]->expr_type == EXPR_CONSTANT
2909 : 50974 : && as->lower[i]->ts.type == BT_INTEGER
2910 : 50974 : && as->upper[i]->ts.type == BT_INTEGER
2911 : 50969 : && mpz_cmp (as->upper[i]->value.integer,
2912 : 50969 : as->lower[i]->value.integer) < 0)
2913 : 1211 : mpz_sub_ui (as->upper[i]->value.integer,
2914 : : as->lower[i]->value.integer, 1);
2915 : : }
2916 : : }
2917 : : }
2918 : :
2919 : 271777 : char_len = NULL;
2920 : 271777 : cl = NULL;
2921 : 271777 : cl_deferred = false;
2922 : :
2923 : 271777 : if (current_ts.type == BT_CHARACTER)
2924 : : {
2925 : 30334 : switch (match_char_length (&char_len, &cl_deferred, false))
2926 : : {
2927 : 435 : case MATCH_YES:
2928 : 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2929 : :
2930 : 435 : cl->length = char_len;
2931 : 435 : break;
2932 : :
2933 : : /* Non-constant lengths need to be copied after the first
2934 : : element. Also copy assumed lengths. */
2935 : 29898 : case MATCH_NO:
2936 : 29898 : if (elem > 1
2937 : 3820 : && (current_ts.u.cl->length == NULL
2938 : 2633 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2939 : : {
2940 : 1242 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2941 : 1242 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
2942 : : }
2943 : : else
2944 : 28656 : cl = current_ts.u.cl;
2945 : :
2946 : 29898 : cl_deferred = current_ts.deferred;
2947 : :
2948 : 29898 : break;
2949 : :
2950 : 1 : case MATCH_ERROR:
2951 : 1 : goto cleanup;
2952 : : }
2953 : : }
2954 : :
2955 : : /* The dummy arguments and result of the abbreviated form of MODULE
2956 : : PROCEDUREs, used in SUBMODULES should not be redefined. */
2957 : 271776 : if (gfc_current_ns->proc_name
2958 : 267294 : && gfc_current_ns->proc_name->abr_modproc_decl)
2959 : : {
2960 : 44 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2961 : 44 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2962 : : {
2963 : 2 : m = MATCH_ERROR;
2964 : 2 : gfc_error ("%qs at %L is a redefinition of the declaration "
2965 : : "in the corresponding interface for MODULE "
2966 : : "PROCEDURE %qs", sym->name, &var_locus,
2967 : 2 : gfc_current_ns->proc_name->name);
2968 : 2 : goto cleanup;
2969 : : }
2970 : : }
2971 : :
2972 : : /* %FILL components may not have initializers. */
2973 : 271774 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
2974 : : {
2975 : 1 : gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
2976 : : &var_locus);
2977 : 1 : m = MATCH_ERROR;
2978 : 1 : goto cleanup;
2979 : : }
2980 : :
2981 : : /* If this symbol has already shown up in a Cray Pointer declaration,
2982 : : and this is not a component declaration,
2983 : : then we want to set the type & bail out. */
2984 : 271773 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2985 : : {
2986 : 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2987 : 2959 : if (sym != NULL && sym->attr.cray_pointee)
2988 : : {
2989 : 101 : m = MATCH_YES;
2990 : 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
2991 : : {
2992 : 1 : m = MATCH_ERROR;
2993 : 1 : goto cleanup;
2994 : : }
2995 : :
2996 : : /* Check to see if we have an array specification. */
2997 : 100 : if (cp_as != NULL)
2998 : : {
2999 : 49 : if (sym->as != NULL)
3000 : : {
3001 : 1 : gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
3002 : 1 : gfc_free_array_spec (cp_as);
3003 : 1 : m = MATCH_ERROR;
3004 : 1 : goto cleanup;
3005 : : }
3006 : : else
3007 : : {
3008 : 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
3009 : 0 : gfc_internal_error ("Cannot set pointee array spec.");
3010 : :
3011 : : /* Fix the array spec. */
3012 : 48 : m = gfc_mod_pointee_as (sym->as);
3013 : 48 : if (m == MATCH_ERROR)
3014 : 0 : goto cleanup;
3015 : : }
3016 : : }
3017 : 99 : goto cleanup;
3018 : : }
3019 : : else
3020 : : {
3021 : 2858 : gfc_free_array_spec (cp_as);
3022 : : }
3023 : : }
3024 : :
3025 : : /* Procedure pointer as function result. */
3026 : 271672 : if (gfc_current_state () == COMP_FUNCTION
3027 : 43765 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
3028 : 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
3029 : 7 : strcpy (name, "ppr@");
3030 : :
3031 : 271672 : if (gfc_current_state () == COMP_FUNCTION
3032 : 43765 : && strcmp (name, gfc_current_block ()->name) == 0
3033 : 7481 : && gfc_current_block ()->result
3034 : 7481 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
3035 : 16 : strcpy (name, "ppr@");
3036 : :
3037 : : /* OK, we've successfully matched the declaration. Now put the
3038 : : symbol in the current namespace, because it might be used in the
3039 : : optional initialization expression for this symbol, e.g. this is
3040 : : perfectly legal:
3041 : :
3042 : : integer, parameter :: i = huge(i)
3043 : :
3044 : : This is only true for parameters or variables of a basic type.
3045 : : For components of derived types, it is not true, so we don't
3046 : : create a symbol for those yet. If we fail to create the symbol,
3047 : : bail out. */
3048 : 271672 : if (!gfc_comp_struct (gfc_current_state ())
3049 : 254489 : && !build_sym (name, elem, cl, cl_deferred, &as, &var_locus))
3050 : : {
3051 : 47 : m = MATCH_ERROR;
3052 : 47 : goto cleanup;
3053 : : }
3054 : :
3055 : 271625 : if (!check_function_name (name))
3056 : : {
3057 : 0 : m = MATCH_ERROR;
3058 : 0 : goto cleanup;
3059 : : }
3060 : :
3061 : : /* We allow old-style initializations of the form
3062 : : integer i /2/, j(4) /3*3, 1/
3063 : : (if no colon has been seen). These are different from data
3064 : : statements in that initializers are only allowed to apply to the
3065 : : variable immediately preceding, i.e.
3066 : : integer i, j /1, 2/
3067 : : is not allowed. Therefore we have to do some work manually, that
3068 : : could otherwise be left to the matchers for DATA statements. */
3069 : :
3070 : 271625 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
3071 : : {
3072 : 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
3073 : : "initialization at %C"))
3074 : : return MATCH_ERROR;
3075 : :
3076 : : /* Allow old style initializations for components of STRUCTUREs and MAPs
3077 : : but not components of derived types. */
3078 : 146 : else if (gfc_current_state () == COMP_DERIVED)
3079 : : {
3080 : 2 : gfc_error ("Invalid old style initialization for derived type "
3081 : : "component at %C");
3082 : 2 : m = MATCH_ERROR;
3083 : 2 : goto cleanup;
3084 : : }
3085 : :
3086 : : /* For structure components, read the initializer as a special
3087 : : expression and let the rest of this function apply the initializer
3088 : : as usual. */
3089 : 144 : else if (gfc_comp_struct (gfc_current_state ()))
3090 : : {
3091 : 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3092 : 74 : if (m == MATCH_NO)
3093 : : gfc_error ("Syntax error in old style initialization of %s at %C",
3094 : : name);
3095 : 74 : if (m != MATCH_YES)
3096 : 14 : goto cleanup;
3097 : : }
3098 : :
3099 : : /* Otherwise we treat the old style initialization just like a
3100 : : DATA declaration for the current variable. */
3101 : : else
3102 : 70 : return match_old_style_init (name);
3103 : : }
3104 : :
3105 : : /* The double colon must be present in order to have initializers.
3106 : : Otherwise the statement is ambiguous with an assignment statement. */
3107 : 271539 : if (colon_seen)
3108 : : {
3109 : 226757 : if (gfc_match (" =>") == MATCH_YES)
3110 : : {
3111 : 1180 : if (!current_attr.pointer)
3112 : : {
3113 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3114 : 0 : m = MATCH_ERROR;
3115 : 0 : goto cleanup;
3116 : : }
3117 : :
3118 : 1180 : m = match_pointer_init (&initializer, 0);
3119 : 1180 : if (m != MATCH_YES)
3120 : 10 : goto cleanup;
3121 : :
3122 : : /* The target of a pointer initialization must have the SAVE
3123 : : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3124 : : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3125 : 1170 : if (initializer->expr_type == EXPR_VARIABLE
3126 : 128 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3127 : 25 : && (gfc_current_state () == COMP_PROGRAM
3128 : : || gfc_current_state () == COMP_MODULE
3129 : 25 : || gfc_current_state () == COMP_SUBMODULE))
3130 : 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3131 : : }
3132 : 225577 : else if (gfc_match_char ('=') == MATCH_YES)
3133 : : {
3134 : 25294 : if (current_attr.pointer)
3135 : : {
3136 : 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3137 : : "not %<=%>");
3138 : 0 : m = MATCH_ERROR;
3139 : 0 : goto cleanup;
3140 : : }
3141 : :
3142 : 25294 : if (gfc_comp_struct (gfc_current_state ())
3143 : 2347 : && gfc_current_block ()->attr.pdt_template)
3144 : : {
3145 : 195 : m = gfc_match_expr (&initializer);
3146 : 195 : if (initializer && initializer->ts.type == BT_UNKNOWN)
3147 : 65 : initializer->ts = current_ts;
3148 : : }
3149 : : else
3150 : 25099 : m = gfc_match_init_expr (&initializer);
3151 : :
3152 : 25294 : if (m == MATCH_NO)
3153 : : {
3154 : 0 : gfc_error ("Expected an initialization expression at %C");
3155 : 0 : m = MATCH_ERROR;
3156 : : }
3157 : :
3158 : 9641 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3159 : 25296 : && !gfc_comp_struct (gfc_state_stack->state))
3160 : : {
3161 : 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3162 : : "a PURE procedure");
3163 : 1 : m = MATCH_ERROR;
3164 : : }
3165 : :
3166 : 25294 : if (current_attr.flavor != FL_PARAMETER
3167 : 9641 : && !gfc_comp_struct (gfc_state_stack->state))
3168 : 7294 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3169 : :
3170 : 25294 : if (m != MATCH_YES)
3171 : 155 : goto cleanup;
3172 : : }
3173 : : }
3174 : :
3175 : 271374 : if (initializer != NULL && current_attr.allocatable
3176 : 3 : && gfc_comp_struct (gfc_current_state ()))
3177 : : {
3178 : 2 : gfc_error ("Initialization of allocatable component at %C is not "
3179 : : "allowed");
3180 : 2 : m = MATCH_ERROR;
3181 : 2 : goto cleanup;
3182 : : }
3183 : :
3184 : 271372 : if (gfc_current_state () == COMP_DERIVED
3185 : 16141 : && initializer && initializer->ts.type == BT_HOLLERITH)
3186 : : {
3187 : 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3188 : : "constant at %L is not allowed", &initializer->where);
3189 : 1 : m = MATCH_ERROR;
3190 : 1 : goto cleanup;
3191 : : }
3192 : :
3193 : 271371 : if (gfc_current_state () == COMP_DERIVED
3194 : 16140 : && gfc_current_block ()->attr.pdt_template)
3195 : : {
3196 : 894 : gfc_symbol *param;
3197 : 894 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3198 : : 0, ¶m);
3199 : 894 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3200 : : {
3201 : 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3202 : : "not appear in the type parameter list at %L",
3203 : 1 : &gfc_current_block ()->declared_at);
3204 : 1 : m = MATCH_ERROR;
3205 : 4 : goto cleanup;
3206 : : }
3207 : 893 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3208 : : {
3209 : 1 : gfc_error ("The component at %C that appears in the type parameter "
3210 : : "list at %L has neither the KIND nor LEN attribute",
3211 : 1 : &gfc_current_block ()->declared_at);
3212 : 1 : m = MATCH_ERROR;
3213 : 1 : goto cleanup;
3214 : : }
3215 : 892 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3216 : : {
3217 : 1 : gfc_error ("The component at %C which is a type parameter must be "
3218 : : "a scalar");
3219 : 1 : m = MATCH_ERROR;
3220 : 1 : goto cleanup;
3221 : : }
3222 : 891 : else if (param && initializer)
3223 : : {
3224 : 184 : if (initializer->ts.type == BT_BOZ)
3225 : : {
3226 : 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3227 : : "initializer", &initializer->where);
3228 : 1 : m = MATCH_ERROR;
3229 : 1 : goto cleanup;
3230 : : }
3231 : 183 : param->value = gfc_copy_expr (initializer);
3232 : : }
3233 : : }
3234 : :
3235 : : /* Before adding a possible initializer, do a simple check for compatibility
3236 : : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3237 : : good thing. */
3238 : 27174 : if (current_ts.type == BT_DERIVED && initializer
3239 : 272739 : && (gfc_numeric_ts (&initializer->ts)
3240 : 1370 : || initializer->ts.type == BT_LOGICAL
3241 : 1370 : || initializer->ts.type == BT_CHARACTER))
3242 : : {
3243 : 2 : gfc_error ("Incompatible initialization between a derived type "
3244 : : "entity and an entity with %qs type at %C",
3245 : : gfc_typename (initializer));
3246 : 2 : m = MATCH_ERROR;
3247 : 2 : goto cleanup;
3248 : : }
3249 : :
3250 : :
3251 : : /* Add the initializer. Note that it is fine if initializer is
3252 : : NULL here, because we sometimes also need to check if a
3253 : : declaration *must* have an initialization expression. */
3254 : 271365 : if (!gfc_comp_struct (gfc_current_state ()))
3255 : 254211 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
3256 : : else
3257 : : {
3258 : 17154 : if (current_ts.type == BT_DERIVED
3259 : 2368 : && !current_attr.pointer && !initializer)
3260 : 1823 : initializer = gfc_default_initializer (¤t_ts);
3261 : 17154 : t = build_struct (name, cl, &initializer, &as);
3262 : :
3263 : : /* If we match a nested structure definition we expect to see the
3264 : : * body even if the variable declarations blow up, so we need to keep
3265 : : * the structure declaration around. */
3266 : 17154 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3267 : 34 : gfc_commit_symbol (gfc_new_block);
3268 : : }
3269 : :
3270 : 271511 : m = (t) ? MATCH_YES : MATCH_ERROR;
3271 : :
3272 : 271800 : cleanup:
3273 : : /* Free stuff up and return. */
3274 : 271800 : gfc_seen_div0 = false;
3275 : 271800 : gfc_free_expr (initializer);
3276 : 271800 : gfc_free_array_spec (as);
3277 : :
3278 : 271800 : return m;
3279 : : }
3280 : :
3281 : :
3282 : : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3283 : : This assumes that the byte size is equal to the kind number for
3284 : : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3285 : :
3286 : : static match
3287 : 104968 : gfc_match_old_kind_spec (gfc_typespec *ts)
3288 : : {
3289 : 104968 : match m;
3290 : 104968 : int original_kind;
3291 : :
3292 : 104968 : if (gfc_match_char ('*') != MATCH_YES)
3293 : : return MATCH_NO;
3294 : :
3295 : 1138 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3296 : 1138 : if (m != MATCH_YES)
3297 : : return MATCH_ERROR;
3298 : :
3299 : 1138 : original_kind = ts->kind;
3300 : :
3301 : : /* Massage the kind numbers for complex types. */
3302 : 1138 : if (ts->type == BT_COMPLEX)
3303 : : {
3304 : 79 : if (ts->kind % 2)
3305 : : {
3306 : 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3307 : : gfc_basic_typename (ts->type), original_kind);
3308 : 0 : return MATCH_ERROR;
3309 : : }
3310 : 79 : ts->kind /= 2;
3311 : :
3312 : : }
3313 : :
3314 : 1138 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3315 : 0 : ts->kind = 8;
3316 : :
3317 : 1138 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3318 : : {
3319 : 846 : if (ts->kind == 4)
3320 : : {
3321 : 212 : if (flag_real4_kind == 8)
3322 : 24 : ts->kind = 8;
3323 : 212 : if (flag_real4_kind == 10)
3324 : 24 : ts->kind = 10;
3325 : 212 : if (flag_real4_kind == 16)
3326 : 24 : ts->kind = 16;
3327 : : }
3328 : 634 : else if (ts->kind == 8)
3329 : : {
3330 : 629 : if (flag_real8_kind == 4)
3331 : 24 : ts->kind = 4;
3332 : 629 : if (flag_real8_kind == 10)
3333 : 24 : ts->kind = 10;
3334 : 629 : if (flag_real8_kind == 16)
3335 : 24 : ts->kind = 16;
3336 : : }
3337 : : }
3338 : :
3339 : 1138 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3340 : : {
3341 : 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3342 : : gfc_basic_typename (ts->type), original_kind);
3343 : 8 : return MATCH_ERROR;
3344 : : }
3345 : :
3346 : 1130 : if (!gfc_notify_std (GFC_STD_GNU,
3347 : : "Nonstandard type declaration %s*%d at %C",
3348 : : gfc_basic_typename(ts->type), original_kind))
3349 : : return MATCH_ERROR;
3350 : :
3351 : : return MATCH_YES;
3352 : : }
3353 : :
3354 : :
3355 : : /* Match a kind specification. Since kinds are generally optional, we
3356 : : usually return MATCH_NO if something goes wrong. If a "kind="
3357 : : string is found, then we know we have an error. */
3358 : :
3359 : : match
3360 : 154275 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3361 : : {
3362 : 154275 : locus where, loc;
3363 : 154275 : gfc_expr *e;
3364 : 154275 : match m, n;
3365 : 154275 : char c;
3366 : :
3367 : 154275 : m = MATCH_NO;
3368 : 154275 : n = MATCH_YES;
3369 : 154275 : e = NULL;
3370 : 154275 : saved_kind_expr = NULL;
3371 : :
3372 : 154275 : where = loc = gfc_current_locus;
3373 : :
3374 : 154275 : if (kind_expr_only)
3375 : 0 : goto kind_expr;
3376 : :
3377 : 154275 : if (gfc_match_char ('(') == MATCH_NO)
3378 : : return MATCH_NO;
3379 : :
3380 : : /* Also gobbles optional text. */
3381 : 47872 : if (gfc_match (" kind = ") == MATCH_YES)
3382 : 47872 : m = MATCH_ERROR;
3383 : :
3384 : 47872 : loc = gfc_current_locus;
3385 : :
3386 : 47872 : kind_expr:
3387 : :
3388 : 47872 : n = gfc_match_init_expr (&e);
3389 : :
3390 : 47872 : if (gfc_derived_parameter_expr (e))
3391 : : {
3392 : 142 : ts->kind = 0;
3393 : 142 : saved_kind_expr = gfc_copy_expr (e);
3394 : 142 : goto close_brackets;
3395 : : }
3396 : :
3397 : 47730 : if (n != MATCH_YES)
3398 : : {
3399 : 345 : if (gfc_matching_function)
3400 : : {
3401 : : /* The function kind expression might include use associated or
3402 : : imported parameters and try again after the specification
3403 : : expressions..... */
3404 : 317 : if (gfc_match_char (')') != MATCH_YES)
3405 : : {
3406 : 1 : gfc_error ("Missing right parenthesis at %C");
3407 : 1 : m = MATCH_ERROR;
3408 : 1 : goto no_match;
3409 : : }
3410 : :
3411 : 316 : gfc_free_expr (e);
3412 : 316 : gfc_undo_symbols ();
3413 : 316 : return MATCH_YES;
3414 : : }
3415 : : else
3416 : : {
3417 : : /* ....or else, the match is real. */
3418 : 28 : if (n == MATCH_NO)
3419 : 0 : gfc_error ("Expected initialization expression at %C");
3420 : 28 : if (n != MATCH_YES)
3421 : 28 : return MATCH_ERROR;
3422 : : }
3423 : : }
3424 : :
3425 : 47385 : if (e->rank != 0)
3426 : : {
3427 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3428 : 0 : m = MATCH_ERROR;
3429 : 0 : goto no_match;
3430 : : }
3431 : :
3432 : 47385 : if (gfc_extract_int (e, &ts->kind, 1))
3433 : : {
3434 : 0 : m = MATCH_ERROR;
3435 : 0 : goto no_match;
3436 : : }
3437 : :
3438 : : /* Before throwing away the expression, let's see if we had a
3439 : : C interoperable kind (and store the fact). */
3440 : 47385 : if (e->ts.is_c_interop == 1)
3441 : : {
3442 : : /* Mark this as C interoperable if being declared with one
3443 : : of the named constants from iso_c_binding. */
3444 : 17598 : ts->is_c_interop = e->ts.is_iso_c;
3445 : 17598 : ts->f90_type = e->ts.f90_type;
3446 : 17598 : if (e->symtree)
3447 : 17597 : ts->interop_kind = e->symtree->n.sym;
3448 : : }
3449 : :
3450 : 47385 : gfc_free_expr (e);
3451 : 47385 : e = NULL;
3452 : :
3453 : : /* Ignore errors to this point, if we've gotten here. This means
3454 : : we ignore the m=MATCH_ERROR from above. */
3455 : 47385 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3456 : : {
3457 : 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3458 : : gfc_basic_typename (ts->type));
3459 : 7 : gfc_current_locus = where;
3460 : 7 : return MATCH_ERROR;
3461 : : }
3462 : :
3463 : : /* Warn if, e.g., c_int is used for a REAL variable, but not
3464 : : if, e.g., c_double is used for COMPLEX as the standard
3465 : : explicitly says that the kind type parameter for complex and real
3466 : : variable is the same, i.e. c_float == c_float_complex. */
3467 : 47378 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3468 : 17 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3469 : 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3470 : 13 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3471 : : "is %s", gfc_basic_typename (ts->f90_type), &where,
3472 : : gfc_basic_typename (ts->type));
3473 : :
3474 : 47365 : close_brackets:
3475 : :
3476 : 47520 : gfc_gobble_whitespace ();
3477 : 47520 : if ((c = gfc_next_ascii_char ()) != ')'
3478 : 47520 : && (ts->type != BT_CHARACTER || c != ','))
3479 : : {
3480 : 0 : if (ts->type == BT_CHARACTER)
3481 : 0 : gfc_error ("Missing right parenthesis or comma at %C");
3482 : : else
3483 : 0 : gfc_error ("Missing right parenthesis at %C");
3484 : 0 : m = MATCH_ERROR;
3485 : 0 : goto no_match;
3486 : : }
3487 : : else
3488 : : /* All tests passed. */
3489 : 47520 : m = MATCH_YES;
3490 : :
3491 : 47520 : if(m == MATCH_ERROR)
3492 : : gfc_current_locus = where;
3493 : :
3494 : 47520 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3495 : 0 : ts->kind = 8;
3496 : :
3497 : 47520 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3498 : : {
3499 : 13642 : if (ts->kind == 4)
3500 : : {
3501 : 4397 : if (flag_real4_kind == 8)
3502 : 54 : ts->kind = 8;
3503 : 4397 : if (flag_real4_kind == 10)
3504 : 54 : ts->kind = 10;
3505 : 4397 : if (flag_real4_kind == 16)
3506 : 54 : ts->kind = 16;
3507 : : }
3508 : 9245 : else if (ts->kind == 8)
3509 : : {
3510 : 6289 : if (flag_real8_kind == 4)
3511 : 48 : ts->kind = 4;
3512 : 6289 : if (flag_real8_kind == 10)
3513 : 48 : ts->kind = 10;
3514 : 6289 : if (flag_real8_kind == 16)
3515 : 48 : ts->kind = 16;
3516 : : }
3517 : : }
3518 : :
3519 : : /* Return what we know from the test(s). */
3520 : : return m;
3521 : :
3522 : 1 : no_match:
3523 : 1 : gfc_free_expr (e);
3524 : 1 : gfc_current_locus = where;
3525 : 1 : return m;
3526 : : }
3527 : :
3528 : :
3529 : : static match
3530 : 4669 : match_char_kind (int * kind, int * is_iso_c)
3531 : : {
3532 : 4669 : locus where;
3533 : 4669 : gfc_expr *e;
3534 : 4669 : match m, n;
3535 : 4669 : bool fail;
3536 : :
3537 : 4669 : m = MATCH_NO;
3538 : 4669 : e = NULL;
3539 : 4669 : where = gfc_current_locus;
3540 : :
3541 : 4669 : n = gfc_match_init_expr (&e);
3542 : :
3543 : 4669 : if (n != MATCH_YES && gfc_matching_function)
3544 : : {
3545 : : /* The expression might include use-associated or imported
3546 : : parameters and try again after the specification
3547 : : expressions. */
3548 : 7 : gfc_free_expr (e);
3549 : 7 : gfc_undo_symbols ();
3550 : 7 : return MATCH_YES;
3551 : : }
3552 : :
3553 : 7 : if (n == MATCH_NO)
3554 : 2 : gfc_error ("Expected initialization expression at %C");
3555 : 4662 : if (n != MATCH_YES)
3556 : : return MATCH_ERROR;
3557 : :
3558 : 4655 : if (e->rank != 0)
3559 : : {
3560 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3561 : 0 : m = MATCH_ERROR;
3562 : 0 : goto no_match;
3563 : : }
3564 : :
3565 : 4655 : if (gfc_derived_parameter_expr (e))
3566 : : {
3567 : 14 : saved_kind_expr = e;
3568 : 14 : *kind = 0;
3569 : 14 : return MATCH_YES;
3570 : : }
3571 : :
3572 : 4641 : fail = gfc_extract_int (e, kind, 1);
3573 : 4641 : *is_iso_c = e->ts.is_iso_c;
3574 : 4641 : if (fail)
3575 : : {
3576 : 0 : m = MATCH_ERROR;
3577 : 0 : goto no_match;
3578 : : }
3579 : :
3580 : 4641 : gfc_free_expr (e);
3581 : :
3582 : : /* Ignore errors to this point, if we've gotten here. This means
3583 : : we ignore the m=MATCH_ERROR from above. */
3584 : 4641 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3585 : : {
3586 : 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3587 : 14 : m = MATCH_ERROR;
3588 : : }
3589 : : else
3590 : : /* All tests passed. */
3591 : : m = MATCH_YES;
3592 : :
3593 : 14 : if (m == MATCH_ERROR)
3594 : 14 : gfc_current_locus = where;
3595 : :
3596 : : /* Return what we know from the test(s). */
3597 : : return m;
3598 : :
3599 : 0 : no_match:
3600 : 0 : gfc_free_expr (e);
3601 : 0 : gfc_current_locus = where;
3602 : 0 : return m;
3603 : : }
3604 : :
3605 : :
3606 : : /* Match the various kind/length specifications in a CHARACTER
3607 : : declaration. We don't return MATCH_NO. */
3608 : :
3609 : : match
3610 : 30612 : gfc_match_char_spec (gfc_typespec *ts)
3611 : : {
3612 : 30612 : int kind, seen_length, is_iso_c;
3613 : 30612 : gfc_charlen *cl;
3614 : 30612 : gfc_expr *len;
3615 : 30612 : match m;
3616 : 30612 : bool deferred;
3617 : :
3618 : 30612 : len = NULL;
3619 : 30612 : seen_length = 0;
3620 : 30612 : kind = 0;
3621 : 30612 : is_iso_c = 0;
3622 : 30612 : deferred = false;
3623 : :
3624 : : /* Try the old-style specification first. */
3625 : 30612 : old_char_selector = 0;
3626 : :
3627 : 30612 : m = match_char_length (&len, &deferred, true);
3628 : 30612 : if (m != MATCH_NO)
3629 : : {
3630 : 2217 : if (m == MATCH_YES)
3631 : 2217 : old_char_selector = 1;
3632 : 2217 : seen_length = 1;
3633 : 2217 : goto done;
3634 : : }
3635 : :
3636 : 28395 : m = gfc_match_char ('(');
3637 : 28395 : if (m != MATCH_YES)
3638 : : {
3639 : 1844 : m = MATCH_YES; /* Character without length is a single char. */
3640 : 1844 : goto done;
3641 : : }
3642 : :
3643 : : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3644 : 26551 : if (gfc_match (" kind =") == MATCH_YES)
3645 : : {
3646 : 3252 : m = match_char_kind (&kind, &is_iso_c);
3647 : :
3648 : 3252 : if (m == MATCH_ERROR)
3649 : 16 : goto done;
3650 : 3236 : if (m == MATCH_NO)
3651 : : goto syntax;
3652 : :
3653 : 3236 : if (gfc_match (" , len =") == MATCH_NO)
3654 : 516 : goto rparen;
3655 : :
3656 : 2720 : m = char_len_param_value (&len, &deferred);
3657 : 2720 : if (m == MATCH_NO)
3658 : 0 : goto syntax;
3659 : 2720 : if (m == MATCH_ERROR)
3660 : 2 : goto done;
3661 : 2718 : seen_length = 1;
3662 : :
3663 : 2718 : goto rparen;
3664 : : }
3665 : :
3666 : : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3667 : 23299 : if (gfc_match (" len =") == MATCH_YES)
3668 : : {
3669 : 13713 : m = char_len_param_value (&len, &deferred);
3670 : 13713 : if (m == MATCH_NO)
3671 : 2 : goto syntax;
3672 : 13711 : if (m == MATCH_ERROR)
3673 : 8 : goto done;
3674 : 13703 : seen_length = 1;
3675 : :
3676 : 13703 : if (gfc_match_char (')') == MATCH_YES)
3677 : 12428 : goto done;
3678 : :
3679 : 1275 : if (gfc_match (" , kind =") != MATCH_YES)
3680 : 0 : goto syntax;
3681 : :
3682 : 1275 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3683 : 2 : goto done;
3684 : :
3685 : 1273 : goto rparen;
3686 : : }
3687 : :
3688 : : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3689 : 9586 : m = char_len_param_value (&len, &deferred);
3690 : 9586 : if (m == MATCH_NO)
3691 : 0 : goto syntax;
3692 : 9586 : if (m == MATCH_ERROR)
3693 : 44 : goto done;
3694 : 9542 : seen_length = 1;
3695 : :
3696 : 9542 : m = gfc_match_char (')');
3697 : 9542 : if (m == MATCH_YES)
3698 : 9398 : goto done;
3699 : :
3700 : 144 : if (gfc_match_char (',') != MATCH_YES)
3701 : 2 : goto syntax;
3702 : :
3703 : 142 : gfc_match (" kind ="); /* Gobble optional text. */
3704 : :
3705 : 142 : m = match_char_kind (&kind, &is_iso_c);
3706 : 142 : if (m == MATCH_ERROR)
3707 : 3 : goto done;
3708 : : if (m == MATCH_NO)
3709 : : goto syntax;
3710 : :
3711 : 4646 : rparen:
3712 : : /* Require a right-paren at this point. */
3713 : 4646 : m = gfc_match_char (')');
3714 : 4646 : if (m == MATCH_YES)
3715 : 4646 : goto done;
3716 : :
3717 : 0 : syntax:
3718 : 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3719 : 4 : m = MATCH_ERROR;
3720 : 4 : gfc_free_expr (len);
3721 : 4 : return m;
3722 : :
3723 : 30608 : done:
3724 : : /* Deal with character functions after USE and IMPORT statements. */
3725 : 30608 : if (gfc_matching_function)
3726 : : {
3727 : 1417 : gfc_free_expr (len);
3728 : 1417 : gfc_undo_symbols ();
3729 : 1417 : return MATCH_YES;
3730 : : }
3731 : :
3732 : 29191 : if (m != MATCH_YES)
3733 : : {
3734 : 65 : gfc_free_expr (len);
3735 : 65 : return m;
3736 : : }
3737 : :
3738 : : /* Do some final massaging of the length values. */
3739 : 29126 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3740 : :
3741 : 29126 : if (seen_length == 0)
3742 : 2308 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3743 : : else
3744 : : {
3745 : : /* If gfortran ends up here, then len may be reducible to a constant.
3746 : : Try to do that here. If it does not reduce, simply assign len to
3747 : : charlen. A complication occurs with user-defined generic functions,
3748 : : which are not resolved. Use a private namespace to deal with
3749 : : generic functions. */
3750 : :
3751 : 26818 : if (len && len->expr_type != EXPR_CONSTANT)
3752 : : {
3753 : 2534 : gfc_namespace *old_ns;
3754 : 2534 : gfc_expr *e;
3755 : :
3756 : 2534 : old_ns = gfc_current_ns;
3757 : 2534 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3758 : :
3759 : 2534 : e = gfc_copy_expr (len);
3760 : 2534 : gfc_push_suppress_errors ();
3761 : 2534 : gfc_reduce_init_expr (e);
3762 : 2534 : gfc_pop_suppress_errors ();
3763 : 2534 : if (e->expr_type == EXPR_CONSTANT)
3764 : : {
3765 : 294 : gfc_replace_expr (len, e);
3766 : 294 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3767 : 7 : mpz_set_ui (len->value.integer, 0);
3768 : : }
3769 : : else
3770 : 2240 : gfc_free_expr (e);
3771 : :
3772 : 2534 : gfc_free_namespace (gfc_current_ns);
3773 : 2534 : gfc_current_ns = old_ns;
3774 : : }
3775 : :
3776 : 26818 : cl->length = len;
3777 : : }
3778 : :
3779 : 29126 : ts->u.cl = cl;
3780 : 29126 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3781 : 29126 : ts->deferred = deferred;
3782 : :
3783 : : /* We have to know if it was a C interoperable kind so we can
3784 : : do accurate type checking of bind(c) procs, etc. */
3785 : 29126 : if (kind != 0)
3786 : : /* Mark this as C interoperable if being declared with one
3787 : : of the named constants from iso_c_binding. */
3788 : 4552 : ts->is_c_interop = is_iso_c;
3789 : 24574 : else if (len != NULL)
3790 : : /* Here, we might have parsed something such as: character(c_char)
3791 : : In this case, the parsing code above grabs the c_char when
3792 : : looking for the length (line 1690, roughly). it's the last
3793 : : testcase for parsing the kind params of a character variable.
3794 : : However, it's not actually the length. this seems like it
3795 : : could be an error.
3796 : : To see if the user used a C interop kind, test the expr
3797 : : of the so called length, and see if it's C interoperable. */
3798 : 15622 : ts->is_c_interop = len->ts.is_iso_c;
3799 : :
3800 : : return MATCH_YES;
3801 : : }
3802 : :
3803 : :
3804 : : /* Matches a RECORD declaration. */
3805 : :
3806 : : static match
3807 : 933878 : match_record_decl (char *name)
3808 : : {
3809 : 933878 : locus old_loc;
3810 : 933878 : old_loc = gfc_current_locus;
3811 : 933878 : match m;
3812 : :
3813 : 933878 : m = gfc_match (" record /");
3814 : 933878 : if (m == MATCH_YES)
3815 : : {
3816 : 353 : if (!flag_dec_structure)
3817 : : {
3818 : 6 : gfc_current_locus = old_loc;
3819 : 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3820 : : "%<-fdec-structure%>");
3821 : 6 : return MATCH_ERROR;
3822 : : }
3823 : 347 : m = gfc_match (" %n/", name);
3824 : 347 : if (m == MATCH_YES)
3825 : : return MATCH_YES;
3826 : : }
3827 : :
3828 : 933528 : gfc_current_locus = old_loc;
3829 : 933528 : if (flag_dec_structure
3830 : 933528 : && (gfc_match (" record% ") == MATCH_YES
3831 : 8026 : || gfc_match (" record%t") == MATCH_YES))
3832 : 6 : gfc_error ("Structure name expected after RECORD at %C");
3833 : 933528 : if (m == MATCH_NO)
3834 : : return MATCH_NO;
3835 : :
3836 : : return MATCH_ERROR;
3837 : : }
3838 : :
3839 : :
3840 : : /* In parsing a PDT, it is possible that one of the type parameters has the
3841 : : same name as a previously declared symbol that is not a type parameter.
3842 : : Intercept this now by looking for the symtree in f2k_derived. */
3843 : :
3844 : : static bool
3845 : 770 : correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
3846 : : {
3847 : 770 : if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
3848 : : return false;
3849 : :
3850 : 614 : if (!(e->symtree->n.sym->attr.pdt_len
3851 : 76 : || e->symtree->n.sym->attr.pdt_kind))
3852 : : {
3853 : 36 : gfc_symtree *st;
3854 : 36 : st = gfc_find_symtree (pdt->f2k_derived->sym_root,
3855 : : e->symtree->n.sym->name);
3856 : 36 : if (st && st->n.sym
3857 : 30 : && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
3858 : : {
3859 : 30 : gfc_expr *new_expr;
3860 : 30 : gfc_set_sym_referenced (st->n.sym);
3861 : 30 : new_expr = gfc_get_expr ();
3862 : 30 : new_expr->ts = st->n.sym->ts;
3863 : 30 : new_expr->expr_type = EXPR_VARIABLE;
3864 : 30 : new_expr->symtree = st;
3865 : 30 : new_expr->where = e->where;
3866 : 30 : gfc_replace_expr (e, new_expr);
3867 : : }
3868 : : }
3869 : :
3870 : : return false;
3871 : : }
3872 : :
3873 : :
3874 : : void
3875 : 548 : gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
3876 : : {
3877 : 548 : if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
3878 : : return;
3879 : 534 : gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
3880 : : }
3881 : :
3882 : : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3883 : : of expressions to substitute into the possibly parameterized expression
3884 : : 'e'. Using a list is inefficient but should not be too bad since the
3885 : : number of type parameters is not likely to be large. */
3886 : : static bool
3887 : 2695 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3888 : : int* f)
3889 : : {
3890 : 2695 : gfc_actual_arglist *param;
3891 : 2695 : gfc_expr *copy;
3892 : :
3893 : 2695 : if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
3894 : : return false;
3895 : :
3896 : 1208 : gcc_assert (e->symtree);
3897 : 1208 : if (e->symtree->n.sym->attr.pdt_kind
3898 : 906 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
3899 : 406 : || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
3900 : : {
3901 : 1215 : for (param = type_param_spec_list; param; param = param->next)
3902 : 1206 : if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3903 : : break;
3904 : :
3905 : 811 : if (param && param->expr)
3906 : : {
3907 : 802 : copy = gfc_copy_expr (param->expr);
3908 : 802 : *e = *copy;
3909 : 802 : free (copy);
3910 : : /* Catch variables declared without a value expression. */
3911 : 802 : if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_PROCEDURE)
3912 : 13 : e->ts = e->symtree->n.sym->ts;
3913 : : }
3914 : : }
3915 : :
3916 : : return false;
3917 : : }
3918 : :
3919 : :
3920 : : static bool
3921 : 847 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3922 : : {
3923 : 847 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3924 : : }
3925 : :
3926 : :
3927 : : bool
3928 : 1547 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3929 : : {
3930 : 1547 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3931 : 1547 : type_param_spec_list = param_list;
3932 : 1547 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3933 : 1547 : type_param_spec_list = old_param_spec_list;
3934 : 1547 : return res;
3935 : : }
3936 : :
3937 : : /* Determines the instance of a parameterized derived type to be used by
3938 : : matching determining the values of the kind parameters and using them
3939 : : in the name of the instance. If the instance exists, it is used, otherwise
3940 : : a new derived type is created. */
3941 : : match
3942 : 1833 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3943 : : gfc_actual_arglist **ext_param_list)
3944 : : {
3945 : : /* The PDT template symbol. */
3946 : 1833 : gfc_symbol *pdt = *sym;
3947 : : /* The symbol for the parameter in the template f2k_namespace. */
3948 : 1833 : gfc_symbol *param;
3949 : : /* The hoped for instance of the PDT. */
3950 : 1833 : gfc_symbol *instance = NULL;
3951 : : /* The list of parameters appearing in the PDT declaration. */
3952 : 1833 : gfc_formal_arglist *type_param_name_list;
3953 : : /* Used to store the parameter specification list during recursive calls. */
3954 : 1833 : gfc_actual_arglist *old_param_spec_list;
3955 : : /* Pointers to the parameter specification being used. */
3956 : 1833 : gfc_actual_arglist *actual_param;
3957 : 1833 : gfc_actual_arglist *tail = NULL;
3958 : : /* Used to build up the name of the PDT instance. The prefix uses 4
3959 : : characters and each KIND parameter 2 more. Allow 8 of the latter. */
3960 : 1833 : char name[GFC_MAX_SYMBOL_LEN + 21];
3961 : :
3962 : 1833 : bool name_seen = (param_list == NULL);
3963 : 1833 : bool assumed_seen = false;
3964 : 1833 : bool deferred_seen = false;
3965 : 1833 : bool spec_error = false;
3966 : 1833 : bool alloc_seen = false;
3967 : 1833 : bool ptr_seen = false;
3968 : 1833 : int kind_value, i;
3969 : 1833 : gfc_expr *kind_expr;
3970 : 1833 : gfc_component *c1, *c2;
3971 : 1833 : match m;
3972 : 1833 : gfc_symtree *s = NULL;
3973 : :
3974 : 1833 : type_param_spec_list = NULL;
3975 : :
3976 : 1833 : type_param_name_list = pdt->formal;
3977 : 1833 : actual_param = param_list;
3978 : 1833 : sprintf (name, "Pdt%s", pdt->name);
3979 : :
3980 : : /* Prevent a PDT component of the same type as the template from being
3981 : : converted into an instance. Doing this results in the component being
3982 : : lost. */
3983 : 1833 : if (gfc_current_state () == COMP_DERIVED
3984 : 70 : && !(gfc_state_stack->previous
3985 : 70 : && gfc_state_stack->previous->state == COMP_DERIVED)
3986 : 70 : && gfc_current_block ()->attr.pdt_template)
3987 : : {
3988 : 69 : if (ext_param_list)
3989 : 69 : *ext_param_list = gfc_copy_actual_arglist (param_list);
3990 : 69 : return MATCH_YES;
3991 : : }
3992 : :
3993 : : /* Run through the parameter name list and pick up the actual
3994 : : parameter values or use the default values in the PDT declaration. */
3995 : 4310 : for (; type_param_name_list;
3996 : 2546 : type_param_name_list = type_param_name_list->next)
3997 : : {
3998 : 2594 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3999 : : {
4000 : 2381 : if (actual_param->spec_type == SPEC_ASSUMED)
4001 : : spec_error = deferred_seen;
4002 : : else
4003 : 2381 : spec_error = assumed_seen;
4004 : :
4005 : 2381 : if (spec_error)
4006 : : {
4007 : : gfc_error ("The type parameter spec list at %C cannot contain "
4008 : : "both ASSUMED and DEFERRED parameters");
4009 : : goto error_return;
4010 : : }
4011 : : }
4012 : :
4013 : 2381 : if (actual_param && actual_param->name)
4014 : 2594 : name_seen = true;
4015 : 2594 : param = type_param_name_list->sym;
4016 : :
4017 : 2594 : if (!param || !param->name)
4018 : 2 : continue;
4019 : :
4020 : 2592 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
4021 : : /* An error should already have been thrown in resolve.cc
4022 : : (resolve_fl_derived0). */
4023 : 2592 : if (!pdt->attr.use_assoc && !c1)
4024 : 8 : goto error_return;
4025 : :
4026 : 2584 : kind_expr = NULL;
4027 : 2584 : if (!name_seen)
4028 : : {
4029 : 1568 : if (!actual_param && !(c1 && c1->initializer))
4030 : : {
4031 : 2 : gfc_error ("The type parameter spec list at %C does not contain "
4032 : : "enough parameter expressions");
4033 : 2 : goto error_return;
4034 : : }
4035 : 1566 : else if (!actual_param && c1 && c1->initializer)
4036 : 5 : kind_expr = gfc_copy_expr (c1->initializer);
4037 : 1561 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4038 : 1406 : kind_expr = gfc_copy_expr (actual_param->expr);
4039 : : }
4040 : : else
4041 : : {
4042 : : actual_param = param_list;
4043 : 1394 : for (;actual_param; actual_param = actual_param->next)
4044 : 1180 : if (actual_param->name
4045 : 1176 : && strcmp (actual_param->name, param->name) == 0)
4046 : : break;
4047 : 1016 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
4048 : 652 : kind_expr = gfc_copy_expr (actual_param->expr);
4049 : : else
4050 : : {
4051 : 364 : if (c1->initializer)
4052 : 307 : kind_expr = gfc_copy_expr (c1->initializer);
4053 : 57 : else if (!(actual_param && param->attr.pdt_len))
4054 : : {
4055 : 10 : gfc_error ("The derived parameter %qs at %C does not "
4056 : : "have a default value", param->name);
4057 : 10 : goto error_return;
4058 : : }
4059 : : }
4060 : : }
4061 : :
4062 : 2370 : if (kind_expr && kind_expr->expr_type == EXPR_VARIABLE
4063 : 211 : && kind_expr->ts.type != BT_INTEGER
4064 : 98 : && kind_expr->symtree->n.sym->ts.type != BT_INTEGER)
4065 : : {
4066 : 12 : gfc_error ("The type parameter expression at %L must be of INTEGER "
4067 : : "type and not %s", &kind_expr->where,
4068 : : gfc_basic_typename (kind_expr->symtree->n.sym->ts.type));
4069 : 12 : goto error_return;
4070 : : }
4071 : :
4072 : : /* Store the current parameter expressions in a temporary actual
4073 : : arglist 'list' so that they can be substituted in the corresponding
4074 : : expressions in the PDT instance. */
4075 : 2560 : if (type_param_spec_list == NULL)
4076 : : {
4077 : 1737 : type_param_spec_list = gfc_get_actual_arglist ();
4078 : 1737 : tail = type_param_spec_list;
4079 : : }
4080 : : else
4081 : : {
4082 : 823 : tail->next = gfc_get_actual_arglist ();
4083 : 823 : tail = tail->next;
4084 : : }
4085 : 2560 : tail->name = param->name;
4086 : :
4087 : 2560 : if (kind_expr)
4088 : : {
4089 : : /* Try simplification even for LEN expressions. */
4090 : 2358 : bool ok;
4091 : 2358 : gfc_resolve_expr (kind_expr);
4092 : :
4093 : 2358 : if (c1->attr.pdt_kind
4094 : 1318 : && kind_expr->expr_type != EXPR_CONSTANT
4095 : 10 : && type_param_spec_list)
4096 : 10 : gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
4097 : :
4098 : 2358 : ok = gfc_simplify_expr (kind_expr, 1);
4099 : : /* Variable expressions default to BT_PROCEDURE in the absence of an
4100 : : initializer so allow for this. */
4101 : 2358 : if (kind_expr->ts.type != BT_INTEGER
4102 : 94 : && kind_expr->ts.type != BT_PROCEDURE)
4103 : : {
4104 : 8 : gfc_error ("The parameter expression at %C must be of "
4105 : : "INTEGER type and not %s type",
4106 : : gfc_basic_typename (kind_expr->ts.type));
4107 : 8 : goto error_return;
4108 : : }
4109 : 2350 : if (kind_expr->ts.type == BT_INTEGER && !ok)
4110 : : {
4111 : 4 : gfc_error ("The parameter expression at %C does not "
4112 : : "simplify to an INTEGER constant");
4113 : 4 : goto error_return;
4114 : : }
4115 : :
4116 : 2346 : tail->expr = gfc_copy_expr (kind_expr);
4117 : : }
4118 : :
4119 : 2548 : if (actual_param)
4120 : 2339 : tail->spec_type = actual_param->spec_type;
4121 : :
4122 : 2548 : if (!param->attr.pdt_kind)
4123 : : {
4124 : 1234 : if (!name_seen && actual_param)
4125 : 741 : actual_param = actual_param->next;
4126 : 1234 : if (kind_expr)
4127 : : {
4128 : 1034 : gfc_free_expr (kind_expr);
4129 : 1034 : kind_expr = NULL;
4130 : : }
4131 : 1234 : continue;
4132 : : }
4133 : :
4134 : 1314 : if (actual_param
4135 : 1138 : && (actual_param->spec_type == SPEC_ASSUMED
4136 : 1138 : || actual_param->spec_type == SPEC_DEFERRED))
4137 : : {
4138 : 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
4139 : : "ASSUMED or DEFERRED", param->name);
4140 : 2 : goto error_return;
4141 : : }
4142 : :
4143 : 1312 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
4144 : : {
4145 : 2 : gfc_error ("The value for the KIND parameter %qs at %C does not "
4146 : : "reduce to a constant expression", param->name);
4147 : 2 : goto error_return;
4148 : : }
4149 : :
4150 : 1310 : kind_value = 0;
4151 : : /* This can come about during the parsing of nested pdt_templates. An
4152 : : error arises because the KIND parameter expression has not been
4153 : : provided. Use the template instead of an incorrect instance. */
4154 : 1310 : if (gfc_extract_int (kind_expr, &kind_value))
4155 : : {
4156 : 0 : gfc_free_actual_arglist (type_param_spec_list);
4157 : 0 : return MATCH_YES;
4158 : : }
4159 : :
4160 : 1310 : sprintf (name + strlen (name), "_%d", kind_value);
4161 : :
4162 : 1310 : if (!name_seen && actual_param)
4163 : 792 : actual_param = actual_param->next;
4164 : 1310 : gfc_free_expr (kind_expr);
4165 : : }
4166 : :
4167 : 1716 : if (!name_seen && actual_param)
4168 : : {
4169 : 2 : gfc_error ("The type parameter spec list at %C contains too many "
4170 : : "parameter expressions");
4171 : 2 : goto error_return;
4172 : : }
4173 : :
4174 : : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
4175 : : build it, using 'pdt' as a template. */
4176 : 1714 : if (gfc_get_symbol (name, pdt->ns, &instance))
4177 : : {
4178 : 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
4179 : 0 : goto error_return;
4180 : : }
4181 : :
4182 : : /* If we are in an interface body, the instance will not have been imported.
4183 : : Make sure that it is imported implicitly. */
4184 : 1714 : s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
4185 : 1714 : if (gfc_current_ns->proc_name
4186 : 1709 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
4187 : 79 : && s && s->import_only && pdt->attr.imported)
4188 : : {
4189 : 2 : s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
4190 : 2 : if (!s)
4191 : : {
4192 : 1 : gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
4193 : : &gfc_current_locus);
4194 : 1 : s->n.sym = instance;
4195 : : }
4196 : 2 : s->n.sym->attr.imported = 1;
4197 : 2 : s->import_only = 1;
4198 : : }
4199 : :
4200 : 1714 : m = MATCH_YES;
4201 : :
4202 : 1714 : if (instance->attr.flavor == FL_DERIVED
4203 : 1310 : && instance->attr.pdt_type
4204 : 1310 : && instance->components)
4205 : : {
4206 : 1310 : instance->refs++;
4207 : 1310 : if (ext_param_list)
4208 : 597 : *ext_param_list = type_param_spec_list;
4209 : 1310 : *sym = instance;
4210 : 1310 : gfc_commit_symbols ();
4211 : 1310 : return m;
4212 : : }
4213 : :
4214 : : /* Start building the new instance of the parameterized type. */
4215 : 404 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4216 : 404 : if (pdt->attr.use_assoc)
4217 : 27 : instance->module = pdt->module;
4218 : 404 : instance->attr.pdt_template = 0;
4219 : 404 : instance->attr.pdt_type = 1;
4220 : 404 : instance->declared_at = gfc_current_locus;
4221 : :
4222 : : /* In resolution, the finalizers are copied, according to the type of the
4223 : : argument, to the instance finalizers. However, they are retained by the
4224 : : template and procedures are freed there. */
4225 : 404 : if (pdt->f2k_derived && pdt->f2k_derived->finalizers)
4226 : : {
4227 : 12 : instance->f2k_derived = gfc_get_namespace (NULL, 0);
4228 : 12 : instance->template_sym = pdt;
4229 : 12 : *instance->f2k_derived = *pdt->f2k_derived;
4230 : : }
4231 : :
4232 : : /* Add the components, replacing the parameters in all expressions
4233 : : with the expressions for their values in 'type_param_spec_list'. */
4234 : 404 : c1 = pdt->components;
4235 : 404 : tail = type_param_spec_list;
4236 : 1541 : for (; c1; c1 = c1->next)
4237 : : {
4238 : 1139 : gfc_add_component (instance, c1->name, &c2);
4239 : :
4240 : 1139 : c2->ts = c1->ts;
4241 : 1139 : c2->attr = c1->attr;
4242 : 1139 : if (c1->tb)
4243 : : {
4244 : 6 : c2->tb = gfc_get_tbp ();
4245 : 6 : *c2->tb = *c1->tb;
4246 : : }
4247 : :
4248 : : /* The order of declaration of the type_specs might not be the
4249 : : same as that of the components. */
4250 : 1139 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4251 : : {
4252 : 862 : for (tail = type_param_spec_list; tail; tail = tail->next)
4253 : 862 : if (strcmp (c1->name, tail->name) == 0)
4254 : : break;
4255 : : }
4256 : :
4257 : : /* Deal with type extension by recursively calling this function
4258 : : to obtain the instance of the extended type. */
4259 : 1139 : if (gfc_current_state () != COMP_DERIVED
4260 : 1137 : && c1 == pdt->components
4261 : 403 : && c1->ts.type == BT_DERIVED
4262 : 30 : && c1->ts.u.derived
4263 : 1169 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4264 : : {
4265 : 30 : if (c1->ts.u.derived->attr.pdt_template)
4266 : : {
4267 : 29 : gfc_formal_arglist *f;
4268 : :
4269 : 29 : old_param_spec_list = type_param_spec_list;
4270 : :
4271 : : /* Obtain a spec list appropriate to the extended type..*/
4272 : 29 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4273 : 29 : type_param_spec_list = actual_param;
4274 : 61 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4275 : 32 : actual_param = actual_param->next;
4276 : 29 : if (actual_param)
4277 : : {
4278 : 29 : gfc_free_actual_arglist (actual_param->next);
4279 : 29 : actual_param->next = NULL;
4280 : : }
4281 : :
4282 : : /* Now obtain the PDT instance for the extended type. */
4283 : 29 : c2->param_list = type_param_spec_list;
4284 : 29 : m = gfc_get_pdt_instance (type_param_spec_list,
4285 : : &c2->ts.u.derived,
4286 : : &c2->param_list);
4287 : 29 : type_param_spec_list = old_param_spec_list;
4288 : : }
4289 : : else
4290 : 1 : c2->ts = c1->ts;
4291 : :
4292 : 30 : c2->ts.u.derived->refs++;
4293 : 30 : gfc_set_sym_referenced (c2->ts.u.derived);
4294 : :
4295 : : /* Set extension level. */
4296 : 30 : if (c2->ts.u.derived->attr.extension == 255)
4297 : : {
4298 : : /* Since the extension field is 8 bit wide, we can only have
4299 : : up to 255 extension levels. */
4300 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4301 : : c2->ts.u.derived->name,
4302 : : &c2->ts.u.derived->declared_at);
4303 : 0 : goto error_return;
4304 : : }
4305 : 30 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4306 : :
4307 : 30 : continue;
4308 : 30 : }
4309 : :
4310 : : /* Addressing PR82943, this will fix the issue where a function or
4311 : : subroutine is declared as not a member of the PDT instance.
4312 : : The reason for this is because the PDT instance did not have access
4313 : : to its template's f2k_derived namespace in order to find the
4314 : : typebound procedures.
4315 : :
4316 : : The number of references to the PDT template's f2k_derived will
4317 : : ensure that f2k_derived is properly freed later on. */
4318 : :
4319 : 1109 : if (!instance->f2k_derived && pdt->f2k_derived)
4320 : : {
4321 : 385 : instance->f2k_derived = pdt->f2k_derived;
4322 : 385 : instance->f2k_derived->refs++;
4323 : : }
4324 : :
4325 : : /* Set the component kind using the parameterized expression. */
4326 : 1109 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4327 : 390 : && c1->kind_expr != NULL)
4328 : : {
4329 : 254 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4330 : 254 : gfc_insert_kind_parameter_exprs (e);
4331 : 254 : gfc_simplify_expr (e, 1);
4332 : 254 : gfc_extract_int (e, &c2->ts.kind);
4333 : 254 : gfc_free_expr (e);
4334 : 254 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4335 : : {
4336 : 2 : gfc_error ("Kind %d not supported for type %s at %C",
4337 : : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4338 : 2 : goto error_return;
4339 : : }
4340 : 252 : if (c2->attr.proc_pointer && c2->attr.function
4341 : 0 : && c1->ts.interface && c1->ts.interface->ts.kind == 0)
4342 : : {
4343 : 0 : c2->ts.interface = gfc_new_symbol ("", gfc_current_ns);
4344 : 0 : c2->ts.interface->result = c2->ts.interface;
4345 : 0 : c2->ts.interface->ts = c2->ts;
4346 : 0 : c2->ts.interface->attr.flavor = FL_PROCEDURE;
4347 : 0 : c2->ts.interface->attr.function = 1;
4348 : 0 : c2->attr.function = 1;
4349 : 0 : c2->attr.if_source = IFSRC_UNKNOWN;
4350 : : }
4351 : : }
4352 : :
4353 : : /* Set up either the KIND/LEN initializer, if constant,
4354 : : or the parameterized expression. Use the template
4355 : : initializer if one is not already set in this instance. */
4356 : 1107 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4357 : : {
4358 : 584 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4359 : 495 : c2->initializer = gfc_copy_expr (tail->expr);
4360 : 89 : else if (tail && tail->expr)
4361 : : {
4362 : 10 : c2->param_list = gfc_get_actual_arglist ();
4363 : 10 : c2->param_list->name = tail->name;
4364 : 10 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4365 : 10 : c2->param_list->next = NULL;
4366 : : }
4367 : :
4368 : 584 : if (!c2->initializer && c1->initializer)
4369 : 23 : c2->initializer = gfc_copy_expr (c1->initializer);
4370 : :
4371 : 584 : if (c2->initializer)
4372 : 518 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4373 : : }
4374 : :
4375 : : /* Copy the array spec. */
4376 : 1107 : c2->as = gfc_copy_array_spec (c1->as);
4377 : 1107 : if (c1->ts.type == BT_CLASS)
4378 : 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4379 : :
4380 : 1107 : if (c1->attr.allocatable)
4381 : 33 : alloc_seen = true;
4382 : :
4383 : 1107 : if (c1->attr.pointer)
4384 : 19 : ptr_seen = true;
4385 : :
4386 : : /* Determine if an array spec is parameterized. If so, substitute
4387 : : in the parameter expressions for the bounds and set the pdt_array
4388 : : attribute. Notice that this attribute must be unconditionally set
4389 : : if this is an array of parameterized character length. */
4390 : 1107 : if (c1->as && c1->as->type == AS_EXPLICIT)
4391 : : {
4392 : : bool pdt_array = false;
4393 : :
4394 : : /* Are the bounds of the array parameterized? */
4395 : 439 : for (i = 0; i < c1->as->rank; i++)
4396 : : {
4397 : 267 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4398 : 6 : pdt_array = true;
4399 : 267 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4400 : 253 : pdt_array = true;
4401 : : }
4402 : :
4403 : : /* If they are, free the expressions for the bounds and
4404 : : replace them with the template expressions with substitute
4405 : : values. */
4406 : 425 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4407 : : {
4408 : 253 : gfc_expr *e;
4409 : 253 : e = gfc_copy_expr (c1->as->lower[i]);
4410 : 253 : gfc_insert_kind_parameter_exprs (e);
4411 : 253 : gfc_simplify_expr (e, 1);
4412 : 253 : gfc_free_expr (c2->as->lower[i]);
4413 : 253 : c2->as->lower[i] = e;
4414 : 253 : e = gfc_copy_expr (c1->as->upper[i]);
4415 : 253 : gfc_insert_kind_parameter_exprs (e);
4416 : 253 : gfc_simplify_expr (e, 1);
4417 : 253 : gfc_free_expr (c2->as->upper[i]);
4418 : 253 : c2->as->upper[i] = e;
4419 : : }
4420 : :
4421 : 172 : c2->attr.pdt_array = 1;
4422 : 172 : if (c1->initializer)
4423 : : {
4424 : 6 : c2->initializer = gfc_copy_expr (c1->initializer);
4425 : 6 : gfc_insert_kind_parameter_exprs (c2->initializer);
4426 : 6 : gfc_simplify_expr (c2->initializer, 1);
4427 : : }
4428 : : }
4429 : :
4430 : : /* Similarly, set the string length if parameterized. */
4431 : 1107 : if (c1->ts.type == BT_CHARACTER
4432 : 81 : && c1->ts.u.cl->length
4433 : 1188 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4434 : : {
4435 : 81 : gfc_expr *e;
4436 : 81 : e = gfc_copy_expr (c1->ts.u.cl->length);
4437 : 81 : gfc_insert_kind_parameter_exprs (e);
4438 : 81 : gfc_simplify_expr (e, 1);
4439 : 81 : gfc_free_expr (c2->ts.u.cl->length);
4440 : 81 : c2->ts.u.cl->length = e;
4441 : 81 : c2->attr.pdt_string = 1;
4442 : : }
4443 : :
4444 : : /* Recurse into this function for PDT components. */
4445 : 1107 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4446 : 80 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4447 : : {
4448 : 73 : gfc_actual_arglist *params;
4449 : : /* The component in the template has a list of specification
4450 : : expressions derived from its declaration. */
4451 : 73 : params = gfc_copy_actual_arglist (c1->param_list);
4452 : 73 : actual_param = params;
4453 : : /* Substitute the template parameters with the expressions
4454 : : from the specification list. */
4455 : 232 : for (;actual_param; actual_param = actual_param->next)
4456 : : {
4457 : 86 : gfc_correct_parm_expr (pdt, &actual_param->expr);
4458 : 86 : gfc_insert_parameter_exprs (actual_param->expr,
4459 : : type_param_spec_list);
4460 : : }
4461 : :
4462 : : /* Now obtain the PDT instance for the component. */
4463 : 73 : old_param_spec_list = type_param_spec_list;
4464 : 146 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
4465 : 73 : &c2->param_list);
4466 : 73 : type_param_spec_list = old_param_spec_list;
4467 : :
4468 : 73 : if (!(c2->attr.pointer || c2->attr.allocatable))
4469 : : {
4470 : 46 : if (!c1->initializer
4471 : 27 : || c1->initializer->expr_type != EXPR_FUNCTION)
4472 : 45 : c2->initializer = gfc_default_initializer (&c2->ts);
4473 : : else
4474 : : {
4475 : 1 : gfc_symtree *s;
4476 : 1 : c2->initializer = gfc_copy_expr (c1->initializer);
4477 : 1 : s = gfc_find_symtree (pdt->ns->sym_root,
4478 : 1 : gfc_dt_lower_string (c2->ts.u.derived->name));
4479 : 1 : if (s)
4480 : 0 : c2->initializer->symtree = s;
4481 : 1 : c2->initializer->ts = c2->ts;
4482 : 1 : if (!s)
4483 : 1 : gfc_insert_parameter_exprs (c2->initializer,
4484 : : type_param_spec_list);
4485 : 1 : gfc_simplify_expr (params->expr, 1);
4486 : : }
4487 : : }
4488 : :
4489 : 73 : if (c2->attr.allocatable)
4490 : 20 : instance->attr.alloc_comp = 1;
4491 : : }
4492 : 1034 : else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
4493 : 369 : || c2->attr.pdt_array) && c1->initializer)
4494 : : {
4495 : 20 : c2->initializer = gfc_copy_expr (c1->initializer);
4496 : 20 : if (c2->initializer->ts.type == BT_UNKNOWN)
4497 : 12 : c2->initializer->ts = c2->ts;
4498 : 20 : gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
4499 : : /* The template initializers are parsed using gfc_match_expr rather
4500 : : than gfc_match_init_expr. Apply the missing reduction to the
4501 : : PDT instance initializers. */
4502 : 20 : if (!gfc_reduce_init_expr (c2->initializer))
4503 : : {
4504 : 0 : gfc_free_expr (c2->initializer);
4505 : 0 : goto error_return;
4506 : : }
4507 : 20 : gfc_simplify_expr (c2->initializer, 1);
4508 : : }
4509 : : }
4510 : :
4511 : 402 : if (alloc_seen)
4512 : 30 : instance->attr.alloc_comp = 1;
4513 : 402 : if (ptr_seen)
4514 : 19 : instance->attr.pointer_comp = 1;
4515 : :
4516 : :
4517 : 402 : gfc_commit_symbol (instance);
4518 : 402 : if (ext_param_list)
4519 : 273 : *ext_param_list = type_param_spec_list;
4520 : 402 : *sym = instance;
4521 : 402 : return m;
4522 : :
4523 : 52 : error_return:
4524 : 52 : gfc_free_actual_arglist (type_param_spec_list);
4525 : 52 : return MATCH_ERROR;
4526 : : }
4527 : :
4528 : :
4529 : : /* Match a legacy nonstandard BYTE type-spec. */
4530 : :
4531 : : static match
4532 : 1148138 : match_byte_typespec (gfc_typespec *ts)
4533 : : {
4534 : 1148138 : if (gfc_match (" byte") == MATCH_YES)
4535 : : {
4536 : 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4537 : : return MATCH_ERROR;
4538 : :
4539 : 31 : if (gfc_current_form == FORM_FREE)
4540 : : {
4541 : 19 : char c = gfc_peek_ascii_char ();
4542 : 19 : if (!gfc_is_whitespace (c) && c != ',')
4543 : : return MATCH_NO;
4544 : : }
4545 : :
4546 : 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4547 : : {
4548 : 0 : gfc_error ("BYTE type used at %C "
4549 : : "is not available on the target machine");
4550 : 0 : return MATCH_ERROR;
4551 : : }
4552 : :
4553 : 29 : ts->type = BT_INTEGER;
4554 : 29 : ts->kind = 1;
4555 : 29 : return MATCH_YES;
4556 : : }
4557 : : return MATCH_NO;
4558 : : }
4559 : :
4560 : :
4561 : : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4562 : : structure to the matched specification. This is necessary for FUNCTION and
4563 : : IMPLICIT statements.
4564 : :
4565 : : If implicit_flag is nonzero, then we don't check for the optional
4566 : : kind specification. Not doing so is needed for matching an IMPLICIT
4567 : : statement correctly. */
4568 : :
4569 : : match
4570 : 1148138 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4571 : : {
4572 : : /* Provide sufficient space to hold "pdtsymbol". */
4573 : 1148138 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4574 : 1148138 : gfc_symbol *sym, *dt_sym;
4575 : 1148138 : match m;
4576 : 1148138 : char c;
4577 : 1148138 : bool seen_deferred_kind, matched_type;
4578 : 1148138 : const char *dt_name;
4579 : :
4580 : 1148138 : decl_type_param_list = NULL;
4581 : :
4582 : : /* A belt and braces check that the typespec is correctly being treated
4583 : : as a deferred characteristic association. */
4584 : 2296276 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4585 : 79747 : && (gfc_current_block ()->result->ts.kind == -1)
4586 : 1159718 : && (ts->kind == -1);
4587 : 1148138 : gfc_clear_ts (ts);
4588 : 1148138 : if (seen_deferred_kind)
4589 : 9400 : ts->kind = -1;
4590 : :
4591 : : /* Clear the current binding label, in case one is given. */
4592 : 1148138 : curr_binding_label = NULL;
4593 : :
4594 : : /* Match BYTE type-spec. */
4595 : 1148138 : m = match_byte_typespec (ts);
4596 : 1148138 : if (m != MATCH_NO)
4597 : : return m;
4598 : :
4599 : 1148107 : m = gfc_match (" type (");
4600 : 1148107 : matched_type = (m == MATCH_YES);
4601 : 1148107 : if (matched_type)
4602 : : {
4603 : 30242 : gfc_gobble_whitespace ();
4604 : 30242 : if (gfc_peek_ascii_char () == '*')
4605 : : {
4606 : 5617 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4607 : : return m;
4608 : 5617 : if (gfc_comp_struct (gfc_current_state ()))
4609 : : {
4610 : 2 : gfc_error ("Assumed type at %C is not allowed for components");
4611 : 2 : return MATCH_ERROR;
4612 : : }
4613 : 5615 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4614 : : return MATCH_ERROR;
4615 : 5613 : ts->type = BT_ASSUMED;
4616 : 5613 : return MATCH_YES;
4617 : : }
4618 : :
4619 : 24625 : m = gfc_match ("%n", name);
4620 : 24625 : matched_type = (m == MATCH_YES);
4621 : : }
4622 : :
4623 : 24625 : if ((matched_type && strcmp ("integer", name) == 0)
4624 : 1142490 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4625 : : {
4626 : 107255 : ts->type = BT_INTEGER;
4627 : 107255 : ts->kind = gfc_default_integer_kind;
4628 : 107255 : goto get_kind;
4629 : : }
4630 : :
4631 : 1035235 : if (flag_unsigned)
4632 : : {
4633 : 0 : if ((matched_type && strcmp ("unsigned", name) == 0)
4634 : 22489 : || (!matched_type && gfc_match (" unsigned") == MATCH_YES))
4635 : : {
4636 : 1036 : ts->type = BT_UNSIGNED;
4637 : 1036 : ts->kind = gfc_default_integer_kind;
4638 : 1036 : goto get_kind;
4639 : : }
4640 : : }
4641 : :
4642 : 24619 : if ((matched_type && strcmp ("character", name) == 0)
4643 : 1034199 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4644 : : {
4645 : 28377 : if (matched_type
4646 : 28377 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4647 : : "intrinsic-type-spec at %C"))
4648 : : return MATCH_ERROR;
4649 : :
4650 : 28376 : ts->type = BT_CHARACTER;
4651 : 28376 : if (implicit_flag == 0)
4652 : 28270 : m = gfc_match_char_spec (ts);
4653 : : else
4654 : : m = MATCH_YES;
4655 : :
4656 : 28376 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4657 : : {
4658 : 1 : gfc_error ("Malformed type-spec at %C");
4659 : 1 : return MATCH_ERROR;
4660 : : }
4661 : :
4662 : 28375 : return m;
4663 : : }
4664 : :
4665 : 24615 : if ((matched_type && strcmp ("real", name) == 0)
4666 : 1005822 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4667 : : {
4668 : 29283 : ts->type = BT_REAL;
4669 : 29283 : ts->kind = gfc_default_real_kind;
4670 : 29283 : goto get_kind;
4671 : : }
4672 : :
4673 : 976539 : if ((matched_type
4674 : 24612 : && (strcmp ("doubleprecision", name) == 0
4675 : 24611 : || (strcmp ("double", name) == 0
4676 : 5 : && gfc_match (" precision") == MATCH_YES)))
4677 : 976539 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4678 : : {
4679 : 2550 : if (matched_type
4680 : 2550 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4681 : : "intrinsic-type-spec at %C"))
4682 : : return MATCH_ERROR;
4683 : :
4684 : 2549 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4685 : : {
4686 : 2 : gfc_error ("Malformed type-spec at %C");
4687 : 2 : return MATCH_ERROR;
4688 : : }
4689 : :
4690 : 2547 : ts->type = BT_REAL;
4691 : 2547 : ts->kind = gfc_default_double_kind;
4692 : 2547 : return MATCH_YES;
4693 : : }
4694 : :
4695 : 24608 : if ((matched_type && strcmp ("complex", name) == 0)
4696 : 973989 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4697 : : {
4698 : 3952 : ts->type = BT_COMPLEX;
4699 : 3952 : ts->kind = gfc_default_complex_kind;
4700 : 3952 : goto get_kind;
4701 : : }
4702 : :
4703 : 970037 : if ((matched_type
4704 : 24608 : && (strcmp ("doublecomplex", name) == 0
4705 : 24607 : || (strcmp ("double", name) == 0
4706 : 2 : && gfc_match (" complex") == MATCH_YES)))
4707 : 970037 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4708 : : {
4709 : 204 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4710 : : return MATCH_ERROR;
4711 : :
4712 : 203 : if (matched_type
4713 : 203 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4714 : : "intrinsic-type-spec at %C"))
4715 : : return MATCH_ERROR;
4716 : :
4717 : 203 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4718 : : {
4719 : 2 : gfc_error ("Malformed type-spec at %C");
4720 : 2 : return MATCH_ERROR;
4721 : : }
4722 : :
4723 : 201 : ts->type = BT_COMPLEX;
4724 : 201 : ts->kind = gfc_default_double_kind;
4725 : 201 : return MATCH_YES;
4726 : : }
4727 : :
4728 : 24605 : if ((matched_type && strcmp ("logical", name) == 0)
4729 : 969833 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4730 : : {
4731 : 11353 : ts->type = BT_LOGICAL;
4732 : 11353 : ts->kind = gfc_default_logical_kind;
4733 : 11353 : goto get_kind;
4734 : : }
4735 : :
4736 : 958480 : if (matched_type)
4737 : : {
4738 : 24602 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4739 : 24602 : if (m == MATCH_ERROR)
4740 : : return m;
4741 : :
4742 : 24602 : gfc_gobble_whitespace ();
4743 : 24602 : if (gfc_peek_ascii_char () != ')')
4744 : : {
4745 : 1 : gfc_error ("Malformed type-spec at %C");
4746 : 1 : return MATCH_ERROR;
4747 : : }
4748 : 24601 : m = gfc_match_char (')'); /* Burn closing ')'. */
4749 : : }
4750 : :
4751 : 958479 : if (m != MATCH_YES)
4752 : 933878 : m = match_record_decl (name);
4753 : :
4754 : 958479 : if (matched_type || m == MATCH_YES)
4755 : : {
4756 : 24945 : ts->type = BT_DERIVED;
4757 : : /* We accept record/s/ or type(s) where s is a structure, but we
4758 : : * don't need all the extra derived-type stuff for structures. */
4759 : 24945 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4760 : : {
4761 : 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4762 : 1 : return MATCH_ERROR;
4763 : : }
4764 : :
4765 : 24944 : if (sym && sym->attr.flavor == FL_DERIVED
4766 : 24191 : && sym->attr.pdt_template
4767 : 751 : && gfc_current_state () != COMP_DERIVED)
4768 : : {
4769 : 674 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4770 : 674 : if (m != MATCH_YES)
4771 : : return m;
4772 : 659 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4773 : 659 : ts->u.derived = sym;
4774 : 659 : const char* lower = gfc_dt_lower_string (sym->name);
4775 : 659 : size_t len = strlen (lower);
4776 : : /* Reallocate with sufficient size. */
4777 : 659 : if (len > GFC_MAX_SYMBOL_LEN)
4778 : 2 : name = XALLOCAVEC (char, len + 1);
4779 : 659 : memcpy (name, lower, len);
4780 : 659 : name[len] = '\0';
4781 : : }
4782 : :
4783 : 24929 : if (sym && sym->attr.flavor == FL_STRUCT)
4784 : : {
4785 : 361 : ts->u.derived = sym;
4786 : 361 : return MATCH_YES;
4787 : : }
4788 : : /* Actually a derived type. */
4789 : : }
4790 : :
4791 : : else
4792 : : {
4793 : : /* Match nested STRUCTURE declarations; only valid within another
4794 : : structure declaration. */
4795 : 933534 : if (flag_dec_structure
4796 : 8032 : && (gfc_current_state () == COMP_STRUCTURE
4797 : 7570 : || gfc_current_state () == COMP_MAP))
4798 : : {
4799 : 732 : m = gfc_match (" structure");
4800 : 732 : if (m == MATCH_YES)
4801 : : {
4802 : 27 : m = gfc_match_structure_decl ();
4803 : 27 : if (m == MATCH_YES)
4804 : : {
4805 : : /* gfc_new_block is updated by match_structure_decl. */
4806 : 26 : ts->type = BT_DERIVED;
4807 : 26 : ts->u.derived = gfc_new_block;
4808 : 26 : return MATCH_YES;
4809 : : }
4810 : : }
4811 : 706 : if (m == MATCH_ERROR)
4812 : : return MATCH_ERROR;
4813 : : }
4814 : :
4815 : : /* Match CLASS declarations. */
4816 : 933507 : m = gfc_match (" class ( * )");
4817 : 933507 : if (m == MATCH_ERROR)
4818 : : return MATCH_ERROR;
4819 : 933507 : else if (m == MATCH_YES)
4820 : : {
4821 : 1902 : gfc_symbol *upe;
4822 : 1902 : gfc_symtree *st;
4823 : 1902 : ts->type = BT_CLASS;
4824 : 1902 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4825 : 1902 : if (upe == NULL)
4826 : : {
4827 : 1163 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4828 : 1163 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4829 : 1163 : st->n.sym = upe;
4830 : 1163 : gfc_set_sym_referenced (upe);
4831 : 1163 : upe->refs++;
4832 : 1163 : upe->ts.type = BT_VOID;
4833 : 1163 : upe->attr.unlimited_polymorphic = 1;
4834 : : /* This is essential to force the construction of
4835 : : unlimited polymorphic component class containers. */
4836 : 1163 : upe->attr.zero_comp = 1;
4837 : 1163 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4838 : : &gfc_current_locus))
4839 : : return MATCH_ERROR;
4840 : : }
4841 : : else
4842 : : {
4843 : 739 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4844 : 739 : st->n.sym = upe;
4845 : 739 : upe->refs++;
4846 : : }
4847 : 1902 : ts->u.derived = upe;
4848 : 1902 : return m;
4849 : : }
4850 : :
4851 : 931605 : m = gfc_match (" class (");
4852 : :
4853 : 931605 : if (m == MATCH_YES)
4854 : 8615 : m = gfc_match ("%n", name);
4855 : : else
4856 : : return m;
4857 : :
4858 : 8615 : if (m != MATCH_YES)
4859 : : return m;
4860 : 8615 : ts->type = BT_CLASS;
4861 : :
4862 : 8615 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4863 : : return MATCH_ERROR;
4864 : :
4865 : 8614 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4866 : 8614 : if (m == MATCH_ERROR)
4867 : : return m;
4868 : :
4869 : 8614 : m = gfc_match_char (')');
4870 : 8614 : if (m != MATCH_YES)
4871 : : return m;
4872 : : }
4873 : :
4874 : : /* This picks up function declarations with a PDT typespec. Since a
4875 : : pdt_type has been generated, there is no more to do. Within the
4876 : : function body, this type must be used for the typespec so that
4877 : : the "being used before it is defined warning" does not arise. */
4878 : 33182 : if (ts->type == BT_DERIVED
4879 : 24568 : && sym && sym->attr.pdt_type
4880 : 33841 : && (gfc_current_state () == COMP_CONTAINS
4881 : 655 : || (gfc_current_state () == COMP_FUNCTION
4882 : 181 : && gfc_current_block ()->ts.type == BT_DERIVED
4883 : 12 : && gfc_current_block ()->ts.u.derived == sym
4884 : 12 : && !gfc_find_symtree (gfc_current_ns->sym_root,
4885 : : sym->name))))
4886 : : {
4887 : 12 : if (gfc_current_state () == COMP_FUNCTION)
4888 : : {
4889 : 8 : gfc_symtree *pdt_st;
4890 : 8 : pdt_st = gfc_new_symtree (&gfc_current_ns->sym_root,
4891 : : sym->name);
4892 : 8 : pdt_st->n.sym = sym;
4893 : 8 : sym->refs++;
4894 : : }
4895 : 12 : ts->u.derived = sym;
4896 : 12 : return MATCH_YES;
4897 : : }
4898 : :
4899 : : /* Defer association of the derived type until the end of the
4900 : : specification block. However, if the derived type can be
4901 : : found, add it to the typespec. */
4902 : 33170 : if (gfc_matching_function)
4903 : : {
4904 : 1022 : ts->u.derived = NULL;
4905 : 1022 : if (gfc_current_state () != COMP_INTERFACE
4906 : 1022 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4907 : : {
4908 : 505 : sym = gfc_find_dt_in_generic (sym);
4909 : 505 : ts->u.derived = sym;
4910 : : }
4911 : 1022 : return MATCH_YES;
4912 : : }
4913 : :
4914 : : /* Search for the name but allow the components to be defined later. If
4915 : : type = -1, this typespec has been seen in a function declaration but
4916 : : the type could not be accessed at that point. The actual derived type is
4917 : : stored in a symtree with the first letter of the name capitalized; the
4918 : : symtree with the all lower-case name contains the associated
4919 : : generic function. */
4920 : 32148 : dt_name = gfc_dt_upper_string (name);
4921 : 32148 : sym = NULL;
4922 : 32148 : dt_sym = NULL;
4923 : 32148 : if (ts->kind != -1)
4924 : : {
4925 : 30964 : gfc_get_ha_symbol (name, &sym);
4926 : 30964 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4927 : : {
4928 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4929 : 0 : return MATCH_ERROR;
4930 : : }
4931 : 30964 : if (sym->generic && !dt_sym)
4932 : 12743 : dt_sym = gfc_find_dt_in_generic (sym);
4933 : :
4934 : : /* Host associated PDTs can get confused with their constructors
4935 : : because they are instantiated in the template's namespace. */
4936 : 30964 : if (!dt_sym)
4937 : : {
4938 : 763 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4939 : : {
4940 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4941 : 0 : return MATCH_ERROR;
4942 : : }
4943 : 763 : if (dt_sym && !dt_sym->attr.pdt_type)
4944 : 0 : dt_sym = NULL;
4945 : : }
4946 : : }
4947 : 1184 : else if (ts->kind == -1)
4948 : : {
4949 : 2368 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4950 : 1184 : || gfc_current_ns->has_import_set;
4951 : 1184 : gfc_find_symbol (name, NULL, iface, &sym);
4952 : 1184 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4953 : : {
4954 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4955 : 0 : return MATCH_ERROR;
4956 : : }
4957 : 1184 : if (sym && sym->generic && !dt_sym)
4958 : 0 : dt_sym = gfc_find_dt_in_generic (sym);
4959 : :
4960 : 1184 : ts->kind = 0;
4961 : 1184 : if (sym == NULL)
4962 : : return MATCH_NO;
4963 : : }
4964 : :
4965 : 32137 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4966 : 31553 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4967 : 32135 : || sym->attr.subroutine)
4968 : : {
4969 : 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
4970 : : "entity at %L, which has the same name", name,
4971 : : &sym->declared_at);
4972 : 2 : return MATCH_ERROR;
4973 : : }
4974 : :
4975 : 32135 : if (dt_sym && decl_type_param_list
4976 : 766 : && dt_sym->attr.flavor == FL_DERIVED
4977 : 766 : && !dt_sym->attr.pdt_type
4978 : 175 : && !dt_sym->attr.pdt_template)
4979 : : {
4980 : 1 : gfc_error ("Type %qs is not parameterized and so the type parameter spec "
4981 : : "list at %C may not appear", dt_sym->name);
4982 : 1 : return MATCH_ERROR;
4983 : : }
4984 : :
4985 : 32134 : if (sym && sym->attr.flavor == FL_DERIVED
4986 : : && sym->attr.pdt_template
4987 : : && gfc_current_state () != COMP_DERIVED)
4988 : : {
4989 : : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4990 : : if (m != MATCH_YES)
4991 : : return m;
4992 : : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4993 : : ts->u.derived = sym;
4994 : : strcpy (name, gfc_dt_lower_string (sym->name));
4995 : : }
4996 : :
4997 : 32134 : gfc_save_symbol_data (sym);
4998 : 32134 : gfc_set_sym_referenced (sym);
4999 : 32134 : if (!sym->attr.generic
5000 : 32134 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
5001 : : return MATCH_ERROR;
5002 : :
5003 : 32134 : if (!sym->attr.function
5004 : 32134 : && !gfc_add_function (&sym->attr, sym->name, NULL))
5005 : : return MATCH_ERROR;
5006 : :
5007 : 32134 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
5008 : 32014 : && dt_sym->attr.pdt_template
5009 : 185 : && gfc_current_state () != COMP_DERIVED)
5010 : : {
5011 : 108 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
5012 : 108 : if (m != MATCH_YES)
5013 : : return m;
5014 : 108 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
5015 : : }
5016 : :
5017 : 32134 : if (!dt_sym)
5018 : : {
5019 : 120 : gfc_interface *intr, *head;
5020 : :
5021 : : /* Use upper case to save the actual derived-type symbol. */
5022 : 120 : gfc_get_symbol (dt_name, NULL, &dt_sym);
5023 : 120 : dt_sym->name = gfc_get_string ("%s", sym->name);
5024 : 120 : head = sym->generic;
5025 : 120 : intr = gfc_get_interface ();
5026 : 120 : intr->sym = dt_sym;
5027 : 120 : intr->where = gfc_current_locus;
5028 : 120 : intr->next = head;
5029 : 120 : sym->generic = intr;
5030 : 120 : sym->attr.if_source = IFSRC_DECL;
5031 : : }
5032 : : else
5033 : 32014 : gfc_save_symbol_data (dt_sym);
5034 : :
5035 : 32134 : gfc_set_sym_referenced (dt_sym);
5036 : :
5037 : 120 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
5038 : 32254 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
5039 : : return MATCH_ERROR;
5040 : :
5041 : 32134 : ts->u.derived = dt_sym;
5042 : :
5043 : 32134 : return MATCH_YES;
5044 : :
5045 : 152879 : get_kind:
5046 : 152879 : if (matched_type
5047 : 152879 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
5048 : : "intrinsic-type-spec at %C"))
5049 : : return MATCH_ERROR;
5050 : :
5051 : : /* For all types except double, derived and character, look for an
5052 : : optional kind specifier. MATCH_NO is actually OK at this point. */
5053 : 152876 : if (implicit_flag == 1)
5054 : : {
5055 : 223 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5056 : : return MATCH_ERROR;
5057 : :
5058 : 223 : return MATCH_YES;
5059 : : }
5060 : :
5061 : 152653 : if (gfc_current_form == FORM_FREE)
5062 : : {
5063 : 138902 : c = gfc_peek_ascii_char ();
5064 : 138902 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
5065 : 69019 : && c != ':' && c != ',')
5066 : : {
5067 : 167 : if (matched_type && c == ')')
5068 : : {
5069 : 3 : gfc_next_ascii_char ();
5070 : 3 : return MATCH_YES;
5071 : : }
5072 : 164 : gfc_error ("Malformed type-spec at %C");
5073 : 164 : return MATCH_NO;
5074 : : }
5075 : : }
5076 : :
5077 : 152486 : m = gfc_match_kind_spec (ts, false);
5078 : 152486 : if (m == MATCH_ERROR)
5079 : : return MATCH_ERROR;
5080 : :
5081 : 152450 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
5082 : : {
5083 : 104928 : m = gfc_match_old_kind_spec (ts);
5084 : 104928 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
5085 : : return MATCH_ERROR;
5086 : : }
5087 : :
5088 : 152442 : if (matched_type && gfc_match_char (')') != MATCH_YES)
5089 : : {
5090 : 0 : gfc_error ("Malformed type-spec at %C");
5091 : 0 : return MATCH_ERROR;
5092 : : }
5093 : :
5094 : : /* Defer association of the KIND expression of function results
5095 : : until after USE and IMPORT statements. */
5096 : 4434 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
5097 : 156849 : || gfc_matching_function)
5098 : 7040 : return MATCH_YES;
5099 : :
5100 : 145402 : if (m == MATCH_NO)
5101 : 147569 : m = MATCH_YES; /* No kind specifier found. */
5102 : :
5103 : : return m;
5104 : : }
5105 : :
5106 : :
5107 : : /* Match an IMPLICIT NONE statement. Actually, this statement is
5108 : : already matched in parse.cc, or we would not end up here in the
5109 : : first place. So the only thing we need to check, is if there is
5110 : : trailing garbage. If not, the match is successful. */
5111 : :
5112 : : match
5113 : 23016 : gfc_match_implicit_none (void)
5114 : : {
5115 : 23016 : char c;
5116 : 23016 : match m;
5117 : 23016 : char name[GFC_MAX_SYMBOL_LEN + 1];
5118 : 23016 : bool type = false;
5119 : 23016 : bool external = false;
5120 : 23016 : locus cur_loc = gfc_current_locus;
5121 : :
5122 : 23016 : if (gfc_current_ns->seen_implicit_none
5123 : 23014 : || gfc_current_ns->has_implicit_none_export)
5124 : : {
5125 : 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
5126 : 4 : return MATCH_ERROR;
5127 : : }
5128 : :
5129 : 23012 : gfc_gobble_whitespace ();
5130 : 23012 : c = gfc_peek_ascii_char ();
5131 : 23012 : if (c == '(')
5132 : : {
5133 : 1059 : (void) gfc_next_ascii_char ();
5134 : 1059 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
5135 : : return MATCH_ERROR;
5136 : :
5137 : 1058 : gfc_gobble_whitespace ();
5138 : 1058 : if (gfc_peek_ascii_char () == ')')
5139 : : {
5140 : 1 : (void) gfc_next_ascii_char ();
5141 : 1 : type = true;
5142 : : }
5143 : : else
5144 : 3151 : for(;;)
5145 : : {
5146 : 2104 : m = gfc_match (" %n", name);
5147 : 2104 : if (m != MATCH_YES)
5148 : : return MATCH_ERROR;
5149 : :
5150 : 2104 : if (strcmp (name, "type") == 0)
5151 : : type = true;
5152 : 1057 : else if (strcmp (name, "external") == 0)
5153 : : external = true;
5154 : : else
5155 : : return MATCH_ERROR;
5156 : :
5157 : 2104 : gfc_gobble_whitespace ();
5158 : 2104 : c = gfc_next_ascii_char ();
5159 : 2104 : if (c == ',')
5160 : 1047 : continue;
5161 : 1057 : if (c == ')')
5162 : : break;
5163 : : return MATCH_ERROR;
5164 : : }
5165 : : }
5166 : : else
5167 : : type = true;
5168 : :
5169 : 23011 : if (gfc_match_eos () != MATCH_YES)
5170 : : return MATCH_ERROR;
5171 : :
5172 : 23011 : gfc_set_implicit_none (type, external, &cur_loc);
5173 : :
5174 : 23011 : return MATCH_YES;
5175 : : }
5176 : :
5177 : :
5178 : : /* Match the letter range(s) of an IMPLICIT statement. */
5179 : :
5180 : : static match
5181 : 600 : match_implicit_range (void)
5182 : : {
5183 : 600 : char c, c1, c2;
5184 : 600 : int inner;
5185 : 600 : locus cur_loc;
5186 : :
5187 : 600 : cur_loc = gfc_current_locus;
5188 : :
5189 : 600 : gfc_gobble_whitespace ();
5190 : 600 : c = gfc_next_ascii_char ();
5191 : 600 : if (c != '(')
5192 : : {
5193 : 59 : gfc_error ("Missing character range in IMPLICIT at %C");
5194 : 59 : goto bad;
5195 : : }
5196 : :
5197 : : inner = 1;
5198 : 1195 : while (inner)
5199 : : {
5200 : 722 : gfc_gobble_whitespace ();
5201 : 722 : c1 = gfc_next_ascii_char ();
5202 : 722 : if (!ISALPHA (c1))
5203 : 33 : goto bad;
5204 : :
5205 : 689 : gfc_gobble_whitespace ();
5206 : 689 : c = gfc_next_ascii_char ();
5207 : :
5208 : 689 : switch (c)
5209 : : {
5210 : 201 : case ')':
5211 : 201 : inner = 0; /* Fall through. */
5212 : :
5213 : : case ',':
5214 : : c2 = c1;
5215 : : break;
5216 : :
5217 : 439 : case '-':
5218 : 439 : gfc_gobble_whitespace ();
5219 : 439 : c2 = gfc_next_ascii_char ();
5220 : 439 : if (!ISALPHA (c2))
5221 : 0 : goto bad;
5222 : :
5223 : 439 : gfc_gobble_whitespace ();
5224 : 439 : c = gfc_next_ascii_char ();
5225 : :
5226 : 439 : if ((c != ',') && (c != ')'))
5227 : 0 : goto bad;
5228 : 439 : if (c == ')')
5229 : 272 : inner = 0;
5230 : :
5231 : : break;
5232 : :
5233 : 35 : default:
5234 : 35 : goto bad;
5235 : : }
5236 : :
5237 : 654 : if (c1 > c2)
5238 : : {
5239 : 0 : gfc_error ("Letters must be in alphabetic order in "
5240 : : "IMPLICIT statement at %C");
5241 : 0 : goto bad;
5242 : : }
5243 : :
5244 : : /* See if we can add the newly matched range to the pending
5245 : : implicits from this IMPLICIT statement. We do not check for
5246 : : conflicts with whatever earlier IMPLICIT statements may have
5247 : : set. This is done when we've successfully finished matching
5248 : : the current one. */
5249 : 654 : if (!gfc_add_new_implicit_range (c1, c2))
5250 : 0 : goto bad;
5251 : : }
5252 : :
5253 : : return MATCH_YES;
5254 : :
5255 : 127 : bad:
5256 : 127 : gfc_syntax_error (ST_IMPLICIT);
5257 : :
5258 : 127 : gfc_current_locus = cur_loc;
5259 : 127 : return MATCH_ERROR;
5260 : : }
5261 : :
5262 : :
5263 : : /* Match an IMPLICIT statement, storing the types for
5264 : : gfc_set_implicit() if the statement is accepted by the parser.
5265 : : There is a strange looking, but legal syntactic construction
5266 : : possible. It looks like:
5267 : :
5268 : : IMPLICIT INTEGER (a-b) (c-d)
5269 : :
5270 : : This is legal if "a-b" is a constant expression that happens to
5271 : : equal one of the legal kinds for integers. The real problem
5272 : : happens with an implicit specification that looks like:
5273 : :
5274 : : IMPLICIT INTEGER (a-b)
5275 : :
5276 : : In this case, a typespec matcher that is "greedy" (as most of the
5277 : : matchers are) gobbles the character range as a kindspec, leaving
5278 : : nothing left. We therefore have to go a bit more slowly in the
5279 : : matching process by inhibiting the kindspec checking during
5280 : : typespec matching and checking for a kind later. */
5281 : :
5282 : : match
5283 : 23442 : gfc_match_implicit (void)
5284 : : {
5285 : 23442 : gfc_typespec ts;
5286 : 23442 : locus cur_loc;
5287 : 23442 : char c;
5288 : 23442 : match m;
5289 : :
5290 : 23442 : if (gfc_current_ns->seen_implicit_none)
5291 : : {
5292 : 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
5293 : : "statement");
5294 : 4 : return MATCH_ERROR;
5295 : : }
5296 : :
5297 : 23438 : gfc_clear_ts (&ts);
5298 : :
5299 : : /* We don't allow empty implicit statements. */
5300 : 23438 : if (gfc_match_eos () == MATCH_YES)
5301 : : {
5302 : 0 : gfc_error ("Empty IMPLICIT statement at %C");
5303 : 0 : return MATCH_ERROR;
5304 : : }
5305 : :
5306 : 23467 : do
5307 : : {
5308 : : /* First cleanup. */
5309 : 23467 : gfc_clear_new_implicit ();
5310 : :
5311 : : /* A basic type is mandatory here. */
5312 : 23467 : m = gfc_match_decl_type_spec (&ts, 1);
5313 : 23467 : if (m == MATCH_ERROR)
5314 : 0 : goto error;
5315 : 23467 : if (m == MATCH_NO)
5316 : 23014 : goto syntax;
5317 : :
5318 : 453 : cur_loc = gfc_current_locus;
5319 : 453 : m = match_implicit_range ();
5320 : :
5321 : 453 : if (m == MATCH_YES)
5322 : : {
5323 : : /* We may have <TYPE> (<RANGE>). */
5324 : 326 : gfc_gobble_whitespace ();
5325 : 326 : c = gfc_peek_ascii_char ();
5326 : 326 : if (c == ',' || c == '\n' || c == ';' || c == '!')
5327 : : {
5328 : : /* Check for CHARACTER with no length parameter. */
5329 : 299 : if (ts.type == BT_CHARACTER && !ts.u.cl)
5330 : : {
5331 : 32 : ts.kind = gfc_default_character_kind;
5332 : 32 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
5333 : 32 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
5334 : : NULL, 1);
5335 : : }
5336 : :
5337 : : /* Record the Successful match. */
5338 : 299 : if (!gfc_merge_new_implicit (&ts))
5339 : : return MATCH_ERROR;
5340 : 297 : if (c == ',')
5341 : 28 : c = gfc_next_ascii_char ();
5342 : 269 : else if (gfc_match_eos () == MATCH_ERROR)
5343 : 0 : goto error;
5344 : 297 : continue;
5345 : : }
5346 : :
5347 : 27 : gfc_current_locus = cur_loc;
5348 : : }
5349 : :
5350 : : /* Discard the (incorrectly) matched range. */
5351 : 154 : gfc_clear_new_implicit ();
5352 : :
5353 : : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5354 : 154 : if (ts.type == BT_CHARACTER)
5355 : 74 : m = gfc_match_char_spec (&ts);
5356 : 80 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5357 : : {
5358 : 76 : m = gfc_match_kind_spec (&ts, false);
5359 : 76 : if (m == MATCH_NO)
5360 : : {
5361 : 40 : m = gfc_match_old_kind_spec (&ts);
5362 : 40 : if (m == MATCH_ERROR)
5363 : 0 : goto error;
5364 : 40 : if (m == MATCH_NO)
5365 : 0 : goto syntax;
5366 : : }
5367 : : }
5368 : 154 : if (m == MATCH_ERROR)
5369 : 7 : goto error;
5370 : :
5371 : 147 : m = match_implicit_range ();
5372 : 147 : if (m == MATCH_ERROR)
5373 : 0 : goto error;
5374 : 147 : if (m == MATCH_NO)
5375 : : goto syntax;
5376 : :
5377 : 147 : gfc_gobble_whitespace ();
5378 : 147 : c = gfc_next_ascii_char ();
5379 : 147 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5380 : 0 : goto syntax;
5381 : :
5382 : 147 : if (!gfc_merge_new_implicit (&ts))
5383 : : return MATCH_ERROR;
5384 : : }
5385 : 444 : while (c == ',');
5386 : :
5387 : : return MATCH_YES;
5388 : :
5389 : 23014 : syntax:
5390 : 23014 : gfc_syntax_error (ST_IMPLICIT);
5391 : :
5392 : : error:
5393 : : return MATCH_ERROR;
5394 : : }
5395 : :
5396 : :
5397 : : /* Match the IMPORT statement. IMPORT was added to F2003 as
5398 : :
5399 : : R1209 import-stmt is IMPORT [[ :: ] import-name-list ]
5400 : :
5401 : : C1210 (R1209) The IMPORT statement is allowed only in an interface-body.
5402 : :
5403 : : C1211 (R1209) Each import-name shall be the name of an entity in the
5404 : : host scoping unit.
5405 : :
5406 : : under the description of an interface block. Under F2008, IMPORT was
5407 : : split out of the interface block description to 12.4.3.3 and C1210
5408 : : became
5409 : :
5410 : : C1210 (R1209) The IMPORT statement is allowed only in an interface-body
5411 : : that is not a module procedure interface body.
5412 : :
5413 : : Finally, F2018, section 8.8, has changed the IMPORT statement to
5414 : :
5415 : : R867 import-stmt is IMPORT [[ :: ] import-name-list ]
5416 : : or IMPORT, ONLY : import-name-list
5417 : : or IMPORT, NONE
5418 : : or IMPORT, ALL
5419 : :
5420 : : C896 (R867) An IMPORT statement shall not appear in the scoping unit of
5421 : : a main-program, external-subprogram, module, or block-data.
5422 : :
5423 : : C897 (R867) Each import-name shall be the name of an entity in the host
5424 : : scoping unit.
5425 : :
5426 : : C898 If any IMPORT statement in a scoping unit has an ONLY specifier,
5427 : : all IMPORT statements in that scoping unit shall have an ONLY
5428 : : specifier.
5429 : :
5430 : : C899 IMPORT, NONE shall not appear in the scoping unit of a submodule.
5431 : :
5432 : : C8100 If an IMPORT, NONE or IMPORT, ALL statement appears in a scoping
5433 : : unit, no other IMPORT statement shall appear in that scoping unit.
5434 : :
5435 : : C8101 Within an interface body, an entity that is accessed by host
5436 : : association shall be accessible by host or use association within
5437 : : the host scoping unit, or explicitly declared prior to the interface
5438 : : body.
5439 : :
5440 : : C8102 An entity whose name appears as an import-name or which is made
5441 : : accessible by an IMPORT, ALL statement shall not appear in any
5442 : : context described in 19.5.1.4 that would cause the host entity
5443 : : of that name to be inaccessible. */
5444 : :
5445 : : match
5446 : 3914 : gfc_match_import (void)
5447 : : {
5448 : 3914 : char name[GFC_MAX_SYMBOL_LEN + 1];
5449 : 3914 : match m;
5450 : 3914 : gfc_symbol *sym;
5451 : 3914 : gfc_symtree *st;
5452 : 3914 : bool f2018_allowed = gfc_option.allow_std & ~GFC_STD_OPT_F08;;
5453 : 3914 : importstate current_import_state = gfc_current_ns->import_state;
5454 : :
5455 : 3914 : if (!f2018_allowed
5456 : 13 : && (gfc_current_ns->proc_name == NULL
5457 : 12 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY))
5458 : : {
5459 : 3 : gfc_error ("IMPORT statement at %C only permitted in "
5460 : : "an INTERFACE body");
5461 : 3 : return MATCH_ERROR;
5462 : : }
5463 : : else if (f2018_allowed
5464 : 3901 : && (!gfc_current_ns->parent || gfc_current_ns->is_block_data))
5465 : 4 : goto C897;
5466 : :
5467 : 3897 : if (f2018_allowed
5468 : 3897 : && (current_import_state == IMPORT_ALL
5469 : 3897 : || current_import_state == IMPORT_NONE))
5470 : 2 : goto C8100;
5471 : :
5472 : 3905 : if (gfc_current_ns->proc_name
5473 : 3904 : && gfc_current_ns->proc_name->attr.module_procedure)
5474 : : {
5475 : 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5476 : : "in a module procedure interface body");
5477 : 1 : return MATCH_ERROR;
5478 : : }
5479 : :
5480 : 3904 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5481 : : return MATCH_ERROR;
5482 : :
5483 : 3900 : gfc_current_ns->import_state = IMPORT_NOT_SET;
5484 : 3900 : if (f2018_allowed)
5485 : : {
5486 : 3894 : if (gfc_match (" , none") == MATCH_YES)
5487 : : {
5488 : 8 : if (current_import_state == IMPORT_ONLY)
5489 : 0 : goto C898;
5490 : 8 : if (gfc_current_state () == COMP_SUBMODULE)
5491 : 0 : goto C899;
5492 : 8 : gfc_current_ns->import_state = IMPORT_NONE;
5493 : : }
5494 : 3886 : else if (gfc_match (" , only :") == MATCH_YES)
5495 : : {
5496 : 19 : if (current_import_state != IMPORT_NOT_SET
5497 : 19 : && current_import_state != IMPORT_ONLY)
5498 : 0 : goto C898;
5499 : 19 : gfc_current_ns->import_state = IMPORT_ONLY;
5500 : : }
5501 : 3867 : else if (gfc_match (" , all") == MATCH_YES)
5502 : : {
5503 : 1 : if (current_import_state == IMPORT_ONLY)
5504 : 0 : goto C898;
5505 : 1 : gfc_current_ns->import_state = IMPORT_ALL;
5506 : : }
5507 : :
5508 : 3894 : if (current_import_state != IMPORT_NOT_SET
5509 : 12 : && (gfc_current_ns->import_state == IMPORT_NONE
5510 : 12 : || gfc_current_ns->import_state == IMPORT_ALL))
5511 : 0 : goto C8100;
5512 : : }
5513 : :
5514 : : /* F2008 IMPORT<eos> is distinct from F2018 IMPORT, ALL. */
5515 : 3900 : if (gfc_match_eos () == MATCH_YES)
5516 : : {
5517 : : /* This is the F2008 variant. */
5518 : 225 : if (gfc_current_ns->import_state == IMPORT_NOT_SET)
5519 : : {
5520 : 216 : if (current_import_state == IMPORT_ONLY)
5521 : 0 : goto C898;
5522 : 216 : gfc_current_ns->import_state = IMPORT_F2008;
5523 : : }
5524 : :
5525 : : /* Host variables should be imported. */
5526 : 225 : if (gfc_current_ns->import_state != IMPORT_NONE)
5527 : 217 : gfc_current_ns->has_import_set = 1;
5528 : 225 : return MATCH_YES;
5529 : : }
5530 : :
5531 : 3675 : if (gfc_match (" ::") == MATCH_YES
5532 : 3675 : && gfc_current_ns->import_state != IMPORT_ONLY)
5533 : : {
5534 : 1164 : if (gfc_match_eos () == MATCH_YES)
5535 : 1 : goto expecting_list;
5536 : 1163 : gfc_current_ns->import_state = IMPORT_F2008;
5537 : : }
5538 : 2511 : else if (gfc_current_ns->import_state == IMPORT_ONLY)
5539 : : {
5540 : 19 : if (gfc_match_eos () == MATCH_YES)
5541 : 0 : goto expecting_list;
5542 : : }
5543 : :
5544 : 4358 : for(;;)
5545 : : {
5546 : 4358 : sym = NULL;
5547 : 4358 : m = gfc_match (" %n", name);
5548 : 4358 : switch (m)
5549 : : {
5550 : 4358 : case MATCH_YES:
5551 : 4358 : if (gfc_current_ns->parent != NULL
5552 : 4358 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5553 : : {
5554 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5555 : 0 : return MATCH_ERROR;
5556 : : }
5557 : 4358 : else if (!sym
5558 : 5 : && gfc_current_ns->proc_name
5559 : 4 : && gfc_current_ns->proc_name->ns->parent
5560 : 4359 : && gfc_find_symbol (name,
5561 : : gfc_current_ns->proc_name->ns->parent,
5562 : : 1, &sym))
5563 : : {
5564 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5565 : 0 : return MATCH_ERROR;
5566 : : }
5567 : :
5568 : 4358 : if (sym == NULL)
5569 : : {
5570 : 5 : if (gfc_current_ns->proc_name
5571 : 4 : && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
5572 : : {
5573 : 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5574 : : "at %C - does not exist.", name);
5575 : 1 : return MATCH_ERROR;
5576 : : }
5577 : : else
5578 : : {
5579 : : /* This might be a procedure that has not yet been parsed. If
5580 : : so gfc_fixup_sibling_symbols will replace this symbol with
5581 : : that of the procedure. */
5582 : 4 : gfc_get_sym_tree (name, gfc_current_ns, &st, false,
5583 : : &gfc_current_locus);
5584 : 4 : st->n.sym->refs++;
5585 : 4 : st->n.sym->attr.imported = 1;
5586 : 4 : st->import_only = 1;
5587 : 4 : goto next_item;
5588 : : }
5589 : : }
5590 : :
5591 : 4353 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
5592 : 4353 : if (st && st->n.sym && st->n.sym->attr.imported)
5593 : : {
5594 : 6 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5595 : : "at %C", name);
5596 : 6 : goto next_item;
5597 : : }
5598 : :
5599 : 4347 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5600 : 4347 : st->n.sym = sym;
5601 : 4347 : sym->refs++;
5602 : 4347 : sym->attr.imported = 1;
5603 : 4347 : st->import_only = 1;
5604 : :
5605 : 4347 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5606 : : {
5607 : : /* The actual derived type is stored in a symtree with the first
5608 : : letter of the name capitalized; the symtree with the all
5609 : : lower-case name contains the associated generic function. */
5610 : 602 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5611 : : gfc_dt_upper_string (name));
5612 : 602 : st->n.sym = sym;
5613 : 602 : sym->refs++;
5614 : 602 : sym->attr.imported = 1;
5615 : 602 : st->import_only = 1;
5616 : : }
5617 : :
5618 : 4347 : goto next_item;
5619 : :
5620 : : case MATCH_NO:
5621 : : break;
5622 : :
5623 : : case MATCH_ERROR:
5624 : : return MATCH_ERROR;
5625 : : }
5626 : :
5627 : 4357 : next_item:
5628 : 4357 : if (gfc_match_eos () == MATCH_YES)
5629 : : break;
5630 : 684 : if (gfc_match_char (',') != MATCH_YES)
5631 : 0 : goto syntax;
5632 : : }
5633 : :
5634 : : return MATCH_YES;
5635 : :
5636 : 0 : syntax:
5637 : 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5638 : 0 : return MATCH_ERROR;
5639 : :
5640 : 4 : C897:
5641 : 4 : gfc_error ("F2018: C897 IMPORT statement at %C cannot appear in a main "
5642 : : "program, an external subprogram, a module or block data");
5643 : 4 : return MATCH_ERROR;
5644 : :
5645 : 0 : C898:
5646 : 0 : gfc_error ("F2018: C898 IMPORT statement at %C is not permitted because "
5647 : : "a scoping unit has an ONLY specifier, can only have IMPORT "
5648 : : "with an ONLY specifier");
5649 : 0 : return MATCH_ERROR;
5650 : :
5651 : 0 : C899:
5652 : 0 : gfc_error ("F2018: C899 IMPORT, NONE shall not appear in the scoping unit"
5653 : : " of a submodule as at %C");
5654 : 0 : return MATCH_ERROR;
5655 : :
5656 : 2 : C8100:
5657 : 4 : gfc_error ("F2018: C8100 IMPORT statement at %C is not permitted because "
5658 : : "%s has already been declared, which must be unique in the "
5659 : : "scoping unit",
5660 : 2 : gfc_current_ns->import_state == IMPORT_ALL ? "IMPORT, ALL" :
5661 : : "IMPORT, NONE");
5662 : 2 : return MATCH_ERROR;
5663 : :
5664 : 1 : expecting_list:
5665 : 1 : gfc_error ("Expecting list of named entities at %C");
5666 : 1 : return MATCH_ERROR;
5667 : : }
5668 : :
5669 : :
5670 : : /* A minimal implementation of gfc_match without whitespace, escape
5671 : : characters or variable arguments. Returns true if the next
5672 : : characters match the TARGET template exactly. */
5673 : :
5674 : : static bool
5675 : 141124 : match_string_p (const char *target)
5676 : : {
5677 : 141124 : const char *p;
5678 : :
5679 : 892540 : for (p = target; *p; p++)
5680 : 751417 : if ((char) gfc_next_ascii_char () != *p)
5681 : : return false;
5682 : : return true;
5683 : : }
5684 : :
5685 : : /* Matches an attribute specification including array specs. If
5686 : : successful, leaves the variables current_attr and current_as
5687 : : holding the specification. Also sets the colon_seen variable for
5688 : : later use by matchers associated with initializations.
5689 : :
5690 : : This subroutine is a little tricky in the sense that we don't know
5691 : : if we really have an attr-spec until we hit the double colon.
5692 : : Until that time, we can only return MATCH_NO. This forces us to
5693 : : check for duplicate specification at this level. */
5694 : :
5695 : : static match
5696 : 209200 : match_attr_spec (void)
5697 : : {
5698 : : /* Modifiers that can exist in a type statement. */
5699 : 209200 : enum
5700 : : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5701 : : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5702 : : DECL_DIMENSION, DECL_EXTERNAL,
5703 : : DECL_INTRINSIC, DECL_OPTIONAL,
5704 : : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5705 : : DECL_STATIC, DECL_AUTOMATIC,
5706 : : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5707 : : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5708 : : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5709 : : };
5710 : :
5711 : : /* GFC_DECL_END is the sentinel, index starts at 0. */
5712 : : #define NUM_DECL GFC_DECL_END
5713 : :
5714 : : /* Make sure that values from sym_intent are safe to be used here. */
5715 : 209200 : gcc_assert (INTENT_IN > 0);
5716 : :
5717 : 209200 : locus start, seen_at[NUM_DECL];
5718 : 209200 : int seen[NUM_DECL];
5719 : 209200 : unsigned int d;
5720 : 209200 : const char *attr;
5721 : 209200 : match m;
5722 : 209200 : bool t;
5723 : :
5724 : 209200 : gfc_clear_attr (¤t_attr);
5725 : 209200 : start = gfc_current_locus;
5726 : :
5727 : 209200 : current_as = NULL;
5728 : 209200 : colon_seen = 0;
5729 : 209200 : attr_seen = 0;
5730 : :
5731 : : /* See if we get all of the keywords up to the final double colon. */
5732 : 5648400 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5733 : 5439200 : seen[d] = 0;
5734 : :
5735 : 324123 : for (;;)
5736 : : {
5737 : 324123 : char ch;
5738 : :
5739 : 324123 : d = DECL_NONE;
5740 : 324123 : gfc_gobble_whitespace ();
5741 : :
5742 : 324123 : ch = gfc_next_ascii_char ();
5743 : 324123 : if (ch == ':')
5744 : : {
5745 : : /* This is the successful exit condition for the loop. */
5746 : 176708 : if (gfc_next_ascii_char () == ':')
5747 : : break;
5748 : : }
5749 : 147415 : else if (ch == ',')
5750 : : {
5751 : 114935 : gfc_gobble_whitespace ();
5752 : 114935 : switch (gfc_peek_ascii_char ())
5753 : : {
5754 : 17647 : case 'a':
5755 : 17647 : gfc_next_ascii_char ();
5756 : 17647 : switch (gfc_next_ascii_char ())
5757 : : {
5758 : 17582 : case 'l':
5759 : 17582 : if (match_string_p ("locatable"))
5760 : : {
5761 : : /* Matched "allocatable". */
5762 : : d = DECL_ALLOCATABLE;
5763 : : }
5764 : : break;
5765 : :
5766 : 24 : case 's':
5767 : 24 : if (match_string_p ("ynchronous"))
5768 : : {
5769 : : /* Matched "asynchronous". */
5770 : : d = DECL_ASYNCHRONOUS;
5771 : : }
5772 : : break;
5773 : :
5774 : 41 : case 'u':
5775 : 41 : if (match_string_p ("tomatic"))
5776 : : {
5777 : : /* Matched "automatic". */
5778 : : d = DECL_AUTOMATIC;
5779 : : }
5780 : : break;
5781 : : }
5782 : : break;
5783 : :
5784 : 163 : case 'b':
5785 : : /* Try and match the bind(c). */
5786 : 163 : m = gfc_match_bind_c (NULL, true);
5787 : 163 : if (m == MATCH_YES)
5788 : : d = DECL_IS_BIND_C;
5789 : 0 : else if (m == MATCH_ERROR)
5790 : 0 : goto cleanup;
5791 : : break;
5792 : :
5793 : 2086 : case 'c':
5794 : 2086 : gfc_next_ascii_char ();
5795 : 2086 : if ('o' != gfc_next_ascii_char ())
5796 : : break;
5797 : 2085 : switch (gfc_next_ascii_char ())
5798 : : {
5799 : 46 : case 'd':
5800 : 46 : if (match_string_p ("imension"))
5801 : : {
5802 : : d = DECL_CODIMENSION;
5803 : : break;
5804 : : }
5805 : : /* FALLTHRU */
5806 : 2039 : case 'n':
5807 : 2039 : if (match_string_p ("tiguous"))
5808 : : {
5809 : : d = DECL_CONTIGUOUS;
5810 : : break;
5811 : : }
5812 : : }
5813 : : break;
5814 : :
5815 : 19539 : case 'd':
5816 : 19539 : if (match_string_p ("dimension"))
5817 : : d = DECL_DIMENSION;
5818 : : break;
5819 : :
5820 : 177 : case 'e':
5821 : 177 : if (match_string_p ("external"))
5822 : : d = DECL_EXTERNAL;
5823 : : break;
5824 : :
5825 : 26353 : case 'i':
5826 : 26353 : if (match_string_p ("int"))
5827 : : {
5828 : 26353 : ch = gfc_next_ascii_char ();
5829 : 26353 : if (ch == 'e')
5830 : : {
5831 : 26347 : if (match_string_p ("nt"))
5832 : : {
5833 : : /* Matched "intent". */
5834 : 26346 : d = match_intent_spec ();
5835 : 26346 : if (d == INTENT_UNKNOWN)
5836 : : {
5837 : 2 : m = MATCH_ERROR;
5838 : 2 : goto cleanup;
5839 : : }
5840 : : }
5841 : : }
5842 : 6 : else if (ch == 'r')
5843 : : {
5844 : 6 : if (match_string_p ("insic"))
5845 : : {
5846 : : /* Matched "intrinsic". */
5847 : : d = DECL_INTRINSIC;
5848 : : }
5849 : : }
5850 : : }
5851 : : break;
5852 : :
5853 : 234 : case 'k':
5854 : 234 : if (match_string_p ("kind"))
5855 : : d = DECL_KIND;
5856 : : break;
5857 : :
5858 : 262 : case 'l':
5859 : 262 : if (match_string_p ("len"))
5860 : : d = DECL_LEN;
5861 : : break;
5862 : :
5863 : 5040 : case 'o':
5864 : 5040 : if (match_string_p ("optional"))
5865 : : d = DECL_OPTIONAL;
5866 : : break;
5867 : :
5868 : 26522 : case 'p':
5869 : 26522 : gfc_next_ascii_char ();
5870 : 26522 : switch (gfc_next_ascii_char ())
5871 : : {
5872 : 13944 : case 'a':
5873 : 13944 : if (match_string_p ("rameter"))
5874 : : {
5875 : : /* Matched "parameter". */
5876 : : d = DECL_PARAMETER;
5877 : : }
5878 : : break;
5879 : :
5880 : 12059 : case 'o':
5881 : 12059 : if (match_string_p ("inter"))
5882 : : {
5883 : : /* Matched "pointer". */
5884 : : d = DECL_POINTER;
5885 : : }
5886 : : break;
5887 : :
5888 : 267 : case 'r':
5889 : 267 : ch = gfc_next_ascii_char ();
5890 : 267 : if (ch == 'i')
5891 : : {
5892 : 216 : if (match_string_p ("vate"))
5893 : : {
5894 : : /* Matched "private". */
5895 : : d = DECL_PRIVATE;
5896 : : }
5897 : : }
5898 : 51 : else if (ch == 'o')
5899 : : {
5900 : 51 : if (match_string_p ("tected"))
5901 : : {
5902 : : /* Matched "protected". */
5903 : : d = DECL_PROTECTED;
5904 : : }
5905 : : }
5906 : : break;
5907 : :
5908 : 252 : case 'u':
5909 : 252 : if (match_string_p ("blic"))
5910 : : {
5911 : : /* Matched "public". */
5912 : : d = DECL_PUBLIC;
5913 : : }
5914 : : break;
5915 : : }
5916 : : break;
5917 : :
5918 : 1162 : case 's':
5919 : 1162 : gfc_next_ascii_char ();
5920 : 1162 : switch (gfc_next_ascii_char ())
5921 : : {
5922 : 1149 : case 'a':
5923 : 1149 : if (match_string_p ("ve"))
5924 : : {
5925 : : /* Matched "save". */
5926 : : d = DECL_SAVE;
5927 : : }
5928 : : break;
5929 : :
5930 : 13 : case 't':
5931 : 13 : if (match_string_p ("atic"))
5932 : : {
5933 : : /* Matched "static". */
5934 : : d = DECL_STATIC;
5935 : : }
5936 : : break;
5937 : : }
5938 : : break;
5939 : :
5940 : 5244 : case 't':
5941 : 5244 : if (match_string_p ("target"))
5942 : : d = DECL_TARGET;
5943 : : break;
5944 : :
5945 : 10506 : case 'v':
5946 : 10506 : gfc_next_ascii_char ();
5947 : 10506 : ch = gfc_next_ascii_char ();
5948 : 10506 : if (ch == 'a')
5949 : : {
5950 : 10004 : if (match_string_p ("lue"))
5951 : : {
5952 : : /* Matched "value". */
5953 : : d = DECL_VALUE;
5954 : : }
5955 : : }
5956 : 502 : else if (ch == 'o')
5957 : : {
5958 : 502 : if (match_string_p ("latile"))
5959 : : {
5960 : : /* Matched "volatile". */
5961 : : d = DECL_VOLATILE;
5962 : : }
5963 : : }
5964 : : break;
5965 : : }
5966 : : }
5967 : :
5968 : : /* No double colon and no recognizable decl_type, so assume that
5969 : : we've been looking at something else the whole time. */
5970 : : if (d == DECL_NONE)
5971 : : {
5972 : 32483 : m = MATCH_NO;
5973 : 32483 : goto cleanup;
5974 : : }
5975 : :
5976 : : /* Check to make sure any parens are paired up correctly. */
5977 : 114931 : if (gfc_match_parens () == MATCH_ERROR)
5978 : : {
5979 : 1 : m = MATCH_ERROR;
5980 : 1 : goto cleanup;
5981 : : }
5982 : :
5983 : 114930 : seen[d]++;
5984 : 114930 : seen_at[d] = gfc_current_locus;
5985 : :
5986 : 114930 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5987 : : {
5988 : 19584 : gfc_array_spec *as = NULL;
5989 : :
5990 : 19584 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5991 : : d == DECL_CODIMENSION);
5992 : :
5993 : 19584 : if (current_as == NULL)
5994 : 19566 : current_as = as;
5995 : 18 : else if (m == MATCH_YES)
5996 : : {
5997 : 18 : if (!merge_array_spec (as, current_as, false))
5998 : 2 : m = MATCH_ERROR;
5999 : 18 : free (as);
6000 : : }
6001 : :
6002 : 19584 : if (m == MATCH_NO)
6003 : : {
6004 : 0 : if (d == DECL_CODIMENSION)
6005 : 0 : gfc_error ("Missing codimension specification at %C");
6006 : : else
6007 : 0 : gfc_error ("Missing dimension specification at %C");
6008 : : m = MATCH_ERROR;
6009 : : }
6010 : :
6011 : 19584 : if (m == MATCH_ERROR)
6012 : 7 : goto cleanup;
6013 : : }
6014 : : }
6015 : :
6016 : : /* Since we've seen a double colon, we have to be looking at an
6017 : : attr-spec. This means that we can now issue errors. */
6018 : 4771068 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6019 : 4594363 : if (seen[d] > 1)
6020 : : {
6021 : 2 : switch (d)
6022 : : {
6023 : : case DECL_ALLOCATABLE:
6024 : : attr = "ALLOCATABLE";
6025 : : break;
6026 : 0 : case DECL_ASYNCHRONOUS:
6027 : 0 : attr = "ASYNCHRONOUS";
6028 : 0 : break;
6029 : 0 : case DECL_CODIMENSION:
6030 : 0 : attr = "CODIMENSION";
6031 : 0 : break;
6032 : 0 : case DECL_CONTIGUOUS:
6033 : 0 : attr = "CONTIGUOUS";
6034 : 0 : break;
6035 : 0 : case DECL_DIMENSION:
6036 : 0 : attr = "DIMENSION";
6037 : 0 : break;
6038 : 0 : case DECL_EXTERNAL:
6039 : 0 : attr = "EXTERNAL";
6040 : 0 : break;
6041 : 0 : case DECL_IN:
6042 : 0 : attr = "INTENT (IN)";
6043 : 0 : break;
6044 : 0 : case DECL_OUT:
6045 : 0 : attr = "INTENT (OUT)";
6046 : 0 : break;
6047 : 0 : case DECL_INOUT:
6048 : 0 : attr = "INTENT (IN OUT)";
6049 : 0 : break;
6050 : 0 : case DECL_INTRINSIC:
6051 : 0 : attr = "INTRINSIC";
6052 : 0 : break;
6053 : 0 : case DECL_OPTIONAL:
6054 : 0 : attr = "OPTIONAL";
6055 : 0 : break;
6056 : 0 : case DECL_KIND:
6057 : 0 : attr = "KIND";
6058 : 0 : break;
6059 : 0 : case DECL_LEN:
6060 : 0 : attr = "LEN";
6061 : 0 : break;
6062 : 0 : case DECL_PARAMETER:
6063 : 0 : attr = "PARAMETER";
6064 : 0 : break;
6065 : 0 : case DECL_POINTER:
6066 : 0 : attr = "POINTER";
6067 : 0 : break;
6068 : 0 : case DECL_PROTECTED:
6069 : 0 : attr = "PROTECTED";
6070 : 0 : break;
6071 : 0 : case DECL_PRIVATE:
6072 : 0 : attr = "PRIVATE";
6073 : 0 : break;
6074 : 0 : case DECL_PUBLIC:
6075 : 0 : attr = "PUBLIC";
6076 : 0 : break;
6077 : 0 : case DECL_SAVE:
6078 : 0 : attr = "SAVE";
6079 : 0 : break;
6080 : 0 : case DECL_STATIC:
6081 : 0 : attr = "STATIC";
6082 : 0 : break;
6083 : 1 : case DECL_AUTOMATIC:
6084 : 1 : attr = "AUTOMATIC";
6085 : 1 : break;
6086 : 0 : case DECL_TARGET:
6087 : 0 : attr = "TARGET";
6088 : 0 : break;
6089 : 0 : case DECL_IS_BIND_C:
6090 : 0 : attr = "IS_BIND_C";
6091 : 0 : break;
6092 : 0 : case DECL_VALUE:
6093 : 0 : attr = "VALUE";
6094 : 0 : break;
6095 : 1 : case DECL_VOLATILE:
6096 : 1 : attr = "VOLATILE";
6097 : 1 : break;
6098 : 0 : default:
6099 : 0 : attr = NULL; /* This shouldn't happen. */
6100 : : }
6101 : :
6102 : 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
6103 : 2 : m = MATCH_ERROR;
6104 : 2 : goto cleanup;
6105 : : }
6106 : :
6107 : : /* Now that we've dealt with duplicate attributes, add the attributes
6108 : : to the current attribute. */
6109 : 4770248 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
6110 : : {
6111 : 4593616 : if (seen[d] == 0)
6112 : 4478702 : continue;
6113 : : else
6114 : 114914 : attr_seen = 1;
6115 : :
6116 : 114914 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
6117 : 52 : && !flag_dec_static)
6118 : : {
6119 : 3 : gfc_error ("%s at %L is a DEC extension, enable with "
6120 : : "%<-fdec-static%>",
6121 : : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
6122 : 2 : m = MATCH_ERROR;
6123 : 2 : goto cleanup;
6124 : : }
6125 : : /* Allow SAVE with STATIC, but don't complain. */
6126 : 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
6127 : 0 : continue;
6128 : :
6129 : 114912 : if (gfc_comp_struct (gfc_current_state ())
6130 : 6286 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
6131 : 5343 : && d != DECL_POINTER && d != DECL_PRIVATE
6132 : 3727 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
6133 : : {
6134 : 3670 : bool is_derived = gfc_current_state () == COMP_DERIVED;
6135 : 3670 : if (d == DECL_ALLOCATABLE)
6136 : : {
6137 : 3161 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6138 : : ? G_("ALLOCATABLE attribute at %C in a "
6139 : : "TYPE definition")
6140 : : : G_("ALLOCATABLE attribute at %C in a "
6141 : : "STRUCTURE definition")))
6142 : : {
6143 : 2 : m = MATCH_ERROR;
6144 : 2 : goto cleanup;
6145 : : }
6146 : : }
6147 : 509 : else if (d == DECL_KIND)
6148 : : {
6149 : 232 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6150 : : ? G_("KIND attribute at %C in a "
6151 : : "TYPE definition")
6152 : : : G_("KIND attribute at %C in a "
6153 : : "STRUCTURE definition")))
6154 : : {
6155 : 1 : m = MATCH_ERROR;
6156 : 1 : goto cleanup;
6157 : : }
6158 : 231 : if (current_ts.type != BT_INTEGER)
6159 : : {
6160 : 2 : gfc_error ("Component with KIND attribute at %C must be "
6161 : : "INTEGER");
6162 : 2 : m = MATCH_ERROR;
6163 : 2 : goto cleanup;
6164 : : }
6165 : : }
6166 : 277 : else if (d == DECL_LEN)
6167 : : {
6168 : 261 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
6169 : : ? G_("LEN attribute at %C in a "
6170 : : "TYPE definition")
6171 : : : G_("LEN attribute at %C in a "
6172 : : "STRUCTURE definition")))
6173 : : {
6174 : 0 : m = MATCH_ERROR;
6175 : 0 : goto cleanup;
6176 : : }
6177 : 261 : if (current_ts.type != BT_INTEGER)
6178 : : {
6179 : 1 : gfc_error ("Component with LEN attribute at %C must be "
6180 : : "INTEGER");
6181 : 1 : m = MATCH_ERROR;
6182 : 1 : goto cleanup;
6183 : : }
6184 : : }
6185 : : else
6186 : : {
6187 : 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
6188 : : "TYPE definition")
6189 : : : G_("Attribute at %L is not allowed in a "
6190 : : "STRUCTURE definition"), &seen_at[d]);
6191 : 16 : m = MATCH_ERROR;
6192 : 16 : goto cleanup;
6193 : : }
6194 : : }
6195 : :
6196 : 114890 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
6197 : 468 : && gfc_current_state () != COMP_MODULE)
6198 : : {
6199 : 147 : if (d == DECL_PRIVATE)
6200 : : attr = "PRIVATE";
6201 : : else
6202 : 43 : attr = "PUBLIC";
6203 : 147 : if (gfc_current_state () == COMP_DERIVED
6204 : 141 : && gfc_state_stack->previous
6205 : 141 : && gfc_state_stack->previous->state == COMP_MODULE)
6206 : : {
6207 : 138 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
6208 : : "at %L in a TYPE definition", attr,
6209 : : &seen_at[d]))
6210 : : {
6211 : 2 : m = MATCH_ERROR;
6212 : 2 : goto cleanup;
6213 : : }
6214 : : }
6215 : : else
6216 : : {
6217 : 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
6218 : : "specification part of a module", attr, &seen_at[d]);
6219 : 9 : m = MATCH_ERROR;
6220 : 9 : goto cleanup;
6221 : : }
6222 : : }
6223 : :
6224 : 114879 : if (gfc_current_state () != COMP_DERIVED
6225 : 108624 : && (d == DECL_KIND || d == DECL_LEN))
6226 : : {
6227 : 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
6228 : : "definition", &seen_at[d]);
6229 : 3 : m = MATCH_ERROR;
6230 : 3 : goto cleanup;
6231 : : }
6232 : :
6233 : 114876 : switch (d)
6234 : : {
6235 : 17580 : case DECL_ALLOCATABLE:
6236 : 17580 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
6237 : 17580 : break;
6238 : :
6239 : 23 : case DECL_ASYNCHRONOUS:
6240 : 23 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
6241 : : t = false;
6242 : : else
6243 : 23 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
6244 : : break;
6245 : :
6246 : 44 : case DECL_CODIMENSION:
6247 : 44 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
6248 : 44 : break;
6249 : :
6250 : 2039 : case DECL_CONTIGUOUS:
6251 : 2039 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
6252 : : t = false;
6253 : : else
6254 : 2038 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
6255 : : break;
6256 : :
6257 : 19531 : case DECL_DIMENSION:
6258 : 19531 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
6259 : 19531 : break;
6260 : :
6261 : 176 : case DECL_EXTERNAL:
6262 : 176 : t = gfc_add_external (¤t_attr, &seen_at[d]);
6263 : 176 : break;
6264 : :
6265 : 19873 : case DECL_IN:
6266 : 19873 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
6267 : 19873 : break;
6268 : :
6269 : 3540 : case DECL_OUT:
6270 : 3540 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
6271 : 3540 : break;
6272 : :
6273 : 2927 : case DECL_INOUT:
6274 : 2927 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
6275 : 2927 : break;
6276 : :
6277 : 5 : case DECL_INTRINSIC:
6278 : 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
6279 : 5 : break;
6280 : :
6281 : 5039 : case DECL_OPTIONAL:
6282 : 5039 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
6283 : 5039 : break;
6284 : :
6285 : 229 : case DECL_KIND:
6286 : 229 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
6287 : 229 : break;
6288 : :
6289 : 260 : case DECL_LEN:
6290 : 260 : t = gfc_add_len (¤t_attr, &seen_at[d]);
6291 : 260 : break;
6292 : :
6293 : 13943 : case DECL_PARAMETER:
6294 : 13943 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
6295 : 13943 : break;
6296 : :
6297 : 12058 : case DECL_POINTER:
6298 : 12058 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
6299 : 12058 : break;
6300 : :
6301 : 50 : case DECL_PROTECTED:
6302 : 50 : if (gfc_current_state () != COMP_MODULE
6303 : 48 : || (gfc_current_ns->proc_name
6304 : 48 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
6305 : : {
6306 : 2 : gfc_error ("PROTECTED at %C only allowed in specification "
6307 : : "part of a module");
6308 : 2 : t = false;
6309 : 2 : break;
6310 : : }
6311 : :
6312 : 48 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
6313 : : t = false;
6314 : : else
6315 : 44 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
6316 : : break;
6317 : :
6318 : 213 : case DECL_PRIVATE:
6319 : 213 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
6320 : : &seen_at[d]);
6321 : 213 : break;
6322 : :
6323 : 244 : case DECL_PUBLIC:
6324 : 244 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
6325 : : &seen_at[d]);
6326 : 244 : break;
6327 : :
6328 : 1159 : case DECL_STATIC:
6329 : 1159 : case DECL_SAVE:
6330 : 1159 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
6331 : 1159 : break;
6332 : :
6333 : 37 : case DECL_AUTOMATIC:
6334 : 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
6335 : 37 : break;
6336 : :
6337 : 5242 : case DECL_TARGET:
6338 : 5242 : t = gfc_add_target (¤t_attr, &seen_at[d]);
6339 : 5242 : break;
6340 : :
6341 : 162 : case DECL_IS_BIND_C:
6342 : 162 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
6343 : 162 : break;
6344 : :
6345 : 10003 : case DECL_VALUE:
6346 : 10003 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
6347 : : t = false;
6348 : : else
6349 : 10003 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
6350 : : break;
6351 : :
6352 : 499 : case DECL_VOLATILE:
6353 : 499 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
6354 : : t = false;
6355 : : else
6356 : 498 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
6357 : : break;
6358 : :
6359 : 0 : default:
6360 : 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
6361 : : }
6362 : :
6363 : 114870 : if (!t)
6364 : : {
6365 : 35 : m = MATCH_ERROR;
6366 : 35 : goto cleanup;
6367 : : }
6368 : : }
6369 : :
6370 : : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
6371 : 176632 : if ((gfc_current_state () == COMP_MODULE
6372 : 176632 : || gfc_current_state () == COMP_SUBMODULE)
6373 : 5555 : && !current_attr.save
6374 : 5373 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
6375 : 5281 : current_attr.save = SAVE_IMPLICIT;
6376 : :
6377 : 176632 : colon_seen = 1;
6378 : 176632 : return MATCH_YES;
6379 : :
6380 : 32568 : cleanup:
6381 : 32568 : gfc_current_locus = start;
6382 : 32568 : gfc_free_array_spec (current_as);
6383 : 32568 : current_as = NULL;
6384 : 32568 : attr_seen = 0;
6385 : 32568 : return m;
6386 : : }
6387 : :
6388 : :
6389 : : /* Set the binding label, dest_label, either with the binding label
6390 : : stored in the given gfc_typespec, ts, or if none was provided, it
6391 : : will be the symbol name in all lower case, as required by the draft
6392 : : (J3/04-007, section 15.4.1). If a binding label was given and
6393 : : there is more than one argument (num_idents), it is an error. */
6394 : :
6395 : : static bool
6396 : 310 : set_binding_label (const char **dest_label, const char *sym_name,
6397 : : int num_idents)
6398 : : {
6399 : 310 : if (num_idents > 1 && has_name_equals)
6400 : : {
6401 : 4 : gfc_error ("Multiple identifiers provided with "
6402 : : "single NAME= specifier at %C");
6403 : 4 : return false;
6404 : : }
6405 : :
6406 : 306 : if (curr_binding_label)
6407 : : /* Binding label given; store in temp holder till have sym. */
6408 : 107 : *dest_label = curr_binding_label;
6409 : : else
6410 : : {
6411 : : /* No binding label given, and the NAME= specifier did not exist,
6412 : : which means there was no NAME="". */
6413 : 199 : if (sym_name != NULL && has_name_equals == 0)
6414 : 169 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
6415 : : }
6416 : :
6417 : : return true;
6418 : : }
6419 : :
6420 : :
6421 : : /* Set the status of the given common block as being BIND(C) or not,
6422 : : depending on the given parameter, is_bind_c. */
6423 : :
6424 : : static void
6425 : 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
6426 : : {
6427 : 76 : com_block->is_bind_c = is_bind_c;
6428 : 76 : return;
6429 : : }
6430 : :
6431 : :
6432 : : /* Verify that the given gfc_typespec is for a C interoperable type. */
6433 : :
6434 : : bool
6435 : 19896 : gfc_verify_c_interop (gfc_typespec *ts)
6436 : : {
6437 : 19896 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
6438 : 4276 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
6439 : 8509 : ? true : false;
6440 : 15636 : else if (ts->type == BT_CLASS)
6441 : : return false;
6442 : 15628 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
6443 : 3897 : return false;
6444 : :
6445 : : return true;
6446 : : }
6447 : :
6448 : :
6449 : : /* Verify that the variables of a given common block, which has been
6450 : : defined with the attribute specifier bind(c), to be of a C
6451 : : interoperable type. Errors will be reported here, if
6452 : : encountered. */
6453 : :
6454 : : bool
6455 : 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
6456 : : {
6457 : 1 : gfc_symbol *curr_sym = NULL;
6458 : 1 : bool retval = true;
6459 : :
6460 : 1 : curr_sym = com_block->head;
6461 : :
6462 : : /* Make sure we have at least one symbol. */
6463 : 1 : if (curr_sym == NULL)
6464 : : return retval;
6465 : :
6466 : : /* Here we know we have a symbol, so we'll execute this loop
6467 : : at least once. */
6468 : 1 : do
6469 : : {
6470 : : /* The second to last param, 1, says this is in a common block. */
6471 : 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
6472 : 1 : curr_sym = curr_sym->common_next;
6473 : 1 : } while (curr_sym != NULL);
6474 : :
6475 : : return retval;
6476 : : }
6477 : :
6478 : :
6479 : : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
6480 : : an appropriate error message is reported. */
6481 : :
6482 : : bool
6483 : 6745 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
6484 : : int is_in_common, gfc_common_head *com_block)
6485 : : {
6486 : 6745 : bool bind_c_function = false;
6487 : 6745 : bool retval = true;
6488 : :
6489 : 6745 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6490 : 6745 : bind_c_function = true;
6491 : :
6492 : 6745 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6493 : : {
6494 : 2583 : tmp_sym = tmp_sym->result;
6495 : : /* Make sure it wasn't an implicitly typed result. */
6496 : 2583 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6497 : : {
6498 : 1 : gfc_warning (OPT_Wc_binding_type,
6499 : : "Implicitly declared BIND(C) function %qs at "
6500 : : "%L may not be C interoperable", tmp_sym->name,
6501 : : &tmp_sym->declared_at);
6502 : 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6503 : : /* Mark it as C interoperable to prevent duplicate warnings. */
6504 : 1 : tmp_sym->ts.is_c_interop = 1;
6505 : 1 : tmp_sym->attr.is_c_interop = 1;
6506 : : }
6507 : : }
6508 : :
6509 : : /* Here, we know we have the bind(c) attribute, so if we have
6510 : : enough type info, then verify that it's a C interop kind.
6511 : : The info could be in the symbol already, or possibly still in
6512 : : the given ts (current_ts), so look in both. */
6513 : 6745 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6514 : : {
6515 : 2741 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6516 : : {
6517 : : /* See if we're dealing with a sym in a common block or not. */
6518 : 162 : if (is_in_common == 1 && warn_c_binding_type)
6519 : : {
6520 : 0 : gfc_warning (OPT_Wc_binding_type,
6521 : : "Variable %qs in common block %qs at %L "
6522 : : "may not be a C interoperable "
6523 : : "kind though common block %qs is BIND(C)",
6524 : : tmp_sym->name, com_block->name,
6525 : 0 : &(tmp_sym->declared_at), com_block->name);
6526 : : }
6527 : : else
6528 : : {
6529 : 162 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6530 : 160 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6531 : : {
6532 : 3 : gfc_error ("Type declaration %qs at %L is not C "
6533 : : "interoperable but it is BIND(C)",
6534 : : tmp_sym->name, &(tmp_sym->declared_at));
6535 : 3 : retval = false;
6536 : : }
6537 : 159 : else if (warn_c_binding_type)
6538 : 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6539 : : "may not be a C interoperable "
6540 : : "kind but it is BIND(C)",
6541 : : tmp_sym->name, &(tmp_sym->declared_at));
6542 : : }
6543 : : }
6544 : :
6545 : : /* Variables declared w/in a common block can't be bind(c)
6546 : : since there's no way for C to see these variables, so there's
6547 : : semantically no reason for the attribute. */
6548 : 2741 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6549 : : {
6550 : 1 : gfc_error ("Variable %qs in common block %qs at "
6551 : : "%L cannot be declared with BIND(C) "
6552 : : "since it is not a global",
6553 : 1 : tmp_sym->name, com_block->name,
6554 : : &(tmp_sym->declared_at));
6555 : 1 : retval = false;
6556 : : }
6557 : :
6558 : : /* Scalar variables that are bind(c) cannot have the pointer
6559 : : or allocatable attributes. */
6560 : 2741 : if (tmp_sym->attr.is_bind_c == 1)
6561 : : {
6562 : 2221 : if (tmp_sym->attr.pointer == 1)
6563 : : {
6564 : 1 : gfc_error ("Variable %qs at %L cannot have both the "
6565 : : "POINTER and BIND(C) attributes",
6566 : : tmp_sym->name, &(tmp_sym->declared_at));
6567 : 1 : retval = false;
6568 : : }
6569 : :
6570 : 2221 : if (tmp_sym->attr.allocatable == 1)
6571 : : {
6572 : 0 : gfc_error ("Variable %qs at %L cannot have both the "
6573 : : "ALLOCATABLE and BIND(C) attributes",
6574 : : tmp_sym->name, &(tmp_sym->declared_at));
6575 : 0 : retval = false;
6576 : : }
6577 : :
6578 : : }
6579 : :
6580 : : /* If it is a BIND(C) function, make sure the return value is a
6581 : : scalar value. The previous tests in this function made sure
6582 : : the type is interoperable. */
6583 : 2741 : if (bind_c_function && tmp_sym->as != NULL)
6584 : 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6585 : : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6586 : :
6587 : : /* BIND(C) functions cannot return a character string. */
6588 : 2583 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6589 : 68 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6590 : 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6591 : : "type at %L must have length 1", tmp_sym->name,
6592 : : &(tmp_sym->declared_at));
6593 : : }
6594 : :
6595 : : /* See if the symbol has been marked as private. If it has, warn if
6596 : : there is a binding label with default binding name. */
6597 : 6745 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6598 : 11 : && tmp_sym->binding_label
6599 : 8 : && strcmp (tmp_sym->name, tmp_sym->binding_label) == 0
6600 : 5 : && (tmp_sym->attr.flavor == FL_VARIABLE
6601 : 4 : || tmp_sym->attr.if_source == IFSRC_DECL))
6602 : 4 : gfc_warning (OPT_Wsurprising,
6603 : : "Symbol %qs at %L is marked PRIVATE but is accessible "
6604 : : "via its default binding name %qs", tmp_sym->name,
6605 : : &(tmp_sym->declared_at), tmp_sym->binding_label);
6606 : :
6607 : 6745 : return retval;
6608 : : }
6609 : :
6610 : :
6611 : : /* Set the appropriate fields for a symbol that's been declared as
6612 : : BIND(C) (the is_bind_c flag and the binding label), and verify that
6613 : : the type is C interoperable. Errors are reported by the functions
6614 : : used to set/test these fields. */
6615 : :
6616 : : static bool
6617 : 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6618 : : {
6619 : 47 : bool retval = true;
6620 : :
6621 : : /* TODO: Do we need to make sure the vars aren't marked private? */
6622 : :
6623 : : /* Set the is_bind_c bit in symbol_attribute. */
6624 : 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6625 : :
6626 : 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6627 : : return false;
6628 : :
6629 : : return retval;
6630 : : }
6631 : :
6632 : :
6633 : : /* Set the fields marking the given common block as BIND(C), including
6634 : : a binding label, and report any errors encountered. */
6635 : :
6636 : : static bool
6637 : 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6638 : : {
6639 : 76 : bool retval = true;
6640 : :
6641 : : /* destLabel, common name, typespec (which may have binding label). */
6642 : 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6643 : : num_idents))
6644 : : return false;
6645 : :
6646 : : /* Set the given common block (com_block) to being bind(c) (1). */
6647 : 76 : set_com_block_bind_c (com_block, 1);
6648 : :
6649 : 76 : return retval;
6650 : : }
6651 : :
6652 : :
6653 : : /* Retrieve the list of one or more identifiers that the given bind(c)
6654 : : attribute applies to. */
6655 : :
6656 : : static bool
6657 : 102 : get_bind_c_idents (void)
6658 : : {
6659 : 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6660 : 102 : int num_idents = 0;
6661 : 102 : gfc_symbol *tmp_sym = NULL;
6662 : 102 : match found_id;
6663 : 102 : gfc_common_head *com_block = NULL;
6664 : :
6665 : 102 : if (gfc_match_name (name) == MATCH_YES)
6666 : : {
6667 : 38 : found_id = MATCH_YES;
6668 : 38 : gfc_get_ha_symbol (name, &tmp_sym);
6669 : : }
6670 : 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6671 : : {
6672 : 64 : found_id = MATCH_YES;
6673 : 64 : com_block = gfc_get_common (name, 0);
6674 : : }
6675 : : else
6676 : : {
6677 : 0 : gfc_error ("Need either entity or common block name for "
6678 : : "attribute specification statement at %C");
6679 : 0 : return false;
6680 : : }
6681 : :
6682 : : /* Save the current identifier and look for more. */
6683 : 123 : do
6684 : : {
6685 : : /* Increment the number of identifiers found for this spec stmt. */
6686 : 123 : num_idents++;
6687 : :
6688 : : /* Make sure we have a sym or com block, and verify that it can
6689 : : be bind(c). Set the appropriate field(s) and look for more
6690 : : identifiers. */
6691 : 123 : if (tmp_sym != NULL || com_block != NULL)
6692 : : {
6693 : 123 : if (tmp_sym != NULL)
6694 : : {
6695 : 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6696 : : return false;
6697 : : }
6698 : : else
6699 : : {
6700 : 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6701 : : return false;
6702 : : }
6703 : :
6704 : : /* Look to see if we have another identifier. */
6705 : 122 : tmp_sym = NULL;
6706 : 122 : if (gfc_match_eos () == MATCH_YES)
6707 : : found_id = MATCH_NO;
6708 : 21 : else if (gfc_match_char (',') != MATCH_YES)
6709 : : found_id = MATCH_NO;
6710 : 21 : else if (gfc_match_name (name) == MATCH_YES)
6711 : : {
6712 : 9 : found_id = MATCH_YES;
6713 : 9 : gfc_get_ha_symbol (name, &tmp_sym);
6714 : : }
6715 : 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6716 : : {
6717 : 12 : found_id = MATCH_YES;
6718 : 12 : com_block = gfc_get_common (name, 0);
6719 : : }
6720 : : else
6721 : : {
6722 : 0 : gfc_error ("Missing entity or common block name for "
6723 : : "attribute specification statement at %C");
6724 : 0 : return false;
6725 : : }
6726 : : }
6727 : : else
6728 : : {
6729 : 0 : gfc_internal_error ("Missing symbol");
6730 : : }
6731 : 122 : } while (found_id == MATCH_YES);
6732 : :
6733 : : /* if we get here we were successful */
6734 : : return true;
6735 : : }
6736 : :
6737 : :
6738 : : /* Try and match a BIND(C) attribute specification statement. */
6739 : :
6740 : : match
6741 : 140 : gfc_match_bind_c_stmt (void)
6742 : : {
6743 : 140 : match found_match = MATCH_NO;
6744 : 140 : gfc_typespec *ts;
6745 : :
6746 : 140 : ts = ¤t_ts;
6747 : :
6748 : : /* This may not be necessary. */
6749 : 140 : gfc_clear_ts (ts);
6750 : : /* Clear the temporary binding label holder. */
6751 : 140 : curr_binding_label = NULL;
6752 : :
6753 : : /* Look for the bind(c). */
6754 : 140 : found_match = gfc_match_bind_c (NULL, true);
6755 : :
6756 : 140 : if (found_match == MATCH_YES)
6757 : : {
6758 : 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6759 : : return MATCH_ERROR;
6760 : :
6761 : : /* Look for the :: now, but it is not required. */
6762 : 102 : gfc_match (" :: ");
6763 : :
6764 : : /* Get the identifier(s) that needs to be updated. This may need to
6765 : : change to hand the flag(s) for the attr specified so all identifiers
6766 : : found can have all appropriate parts updated (assuming that the same
6767 : : spec stmt can have multiple attrs, such as both bind(c) and
6768 : : allocatable...). */
6769 : 102 : if (!get_bind_c_idents ())
6770 : : /* Error message should have printed already. */
6771 : : return MATCH_ERROR;
6772 : : }
6773 : :
6774 : : return found_match;
6775 : : }
6776 : :
6777 : :
6778 : : /* Match a data declaration statement. */
6779 : :
6780 : : match
6781 : 992590 : gfc_match_data_decl (void)
6782 : : {
6783 : 992590 : gfc_symbol *sym;
6784 : 992590 : match m;
6785 : 992590 : int elem;
6786 : :
6787 : 992590 : type_param_spec_list = NULL;
6788 : 992590 : decl_type_param_list = NULL;
6789 : :
6790 : 992590 : num_idents_on_line = 0;
6791 : :
6792 : 992590 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6793 : 992590 : if (m != MATCH_YES)
6794 : : return m;
6795 : :
6796 : 208091 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6797 : 33366 : && !gfc_comp_struct (gfc_current_state ()))
6798 : : {
6799 : 30260 : sym = gfc_use_derived (current_ts.u.derived);
6800 : :
6801 : 30260 : if (sym == NULL)
6802 : : {
6803 : 15 : m = MATCH_ERROR;
6804 : 15 : goto cleanup;
6805 : : }
6806 : :
6807 : 30245 : current_ts.u.derived = sym;
6808 : : }
6809 : :
6810 : 208076 : m = match_attr_spec ();
6811 : 208076 : if (m == MATCH_ERROR)
6812 : : {
6813 : 84 : m = MATCH_NO;
6814 : 84 : goto cleanup;
6815 : : }
6816 : :
6817 : : /* F2018:C708. */
6818 : 207992 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6819 : : {
6820 : 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6821 : 6 : m = MATCH_ERROR;
6822 : 6 : goto cleanup;
6823 : : }
6824 : :
6825 : 207986 : if (current_ts.type == BT_CLASS
6826 : 10443 : && current_ts.u.derived->attr.unlimited_polymorphic)
6827 : 1874 : goto ok;
6828 : :
6829 : 206112 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6830 : 31470 : && current_ts.u.derived->components == NULL
6831 : 2694 : && !current_ts.u.derived->attr.zero_comp)
6832 : : {
6833 : :
6834 : 202 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6835 : 135 : goto ok;
6836 : :
6837 : 67 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6838 : 40 : goto ok;
6839 : :
6840 : 27 : gfc_find_symbol (current_ts.u.derived->name,
6841 : 27 : current_ts.u.derived->ns, 1, &sym);
6842 : :
6843 : : /* Any symbol that we find had better be a type definition
6844 : : which has its components defined, or be a structure definition
6845 : : actively being parsed. */
6846 : 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6847 : 26 : && (current_ts.u.derived->components != NULL
6848 : 26 : || current_ts.u.derived->attr.zero_comp
6849 : 26 : || current_ts.u.derived == gfc_new_block))
6850 : 26 : goto ok;
6851 : :
6852 : 1 : gfc_error ("Derived type at %C has not been previously defined "
6853 : : "and so cannot appear in a derived type definition");
6854 : 1 : m = MATCH_ERROR;
6855 : 1 : goto cleanup;
6856 : : }
6857 : :
6858 : 205910 : ok:
6859 : : /* If we have an old-style character declaration, and no new-style
6860 : : attribute specifications, then there a comma is optional between
6861 : : the type specification and the variable list. */
6862 : 207985 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6863 : 1407 : gfc_match_char (',');
6864 : :
6865 : : /* Give the types/attributes to symbols that follow. Give the element
6866 : : a number so that repeat character length expressions can be copied. */
6867 : : elem = 1;
6868 : 271873 : for (;;)
6869 : : {
6870 : 271873 : num_idents_on_line++;
6871 : 271873 : m = variable_decl (elem++);
6872 : 271871 : if (m == MATCH_ERROR)
6873 : 406 : goto cleanup;
6874 : 271465 : if (m == MATCH_NO)
6875 : : break;
6876 : :
6877 : 271454 : if (gfc_match_eos () == MATCH_YES)
6878 : 207545 : goto cleanup;
6879 : 63909 : if (gfc_match_char (',') != MATCH_YES)
6880 : : break;
6881 : : }
6882 : :
6883 : 32 : if (!gfc_error_flag_test ())
6884 : : {
6885 : : /* An anonymous structure declaration is unambiguous; if we matched one
6886 : : according to gfc_match_structure_decl, we need to return MATCH_YES
6887 : : here to avoid confusing the remaining matchers, even if there was an
6888 : : error during variable_decl. We must flush any such errors. Note this
6889 : : causes the parser to gracefully continue parsing the remaining input
6890 : : as a structure body, which likely follows. */
6891 : 8 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
6892 : 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6893 : : {
6894 : 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
6895 : : " at %C");
6896 : : /* Skip the bad variable_decl and line up for the start of the
6897 : : structure body. */
6898 : 1 : gfc_error_recovery ();
6899 : 1 : m = MATCH_YES;
6900 : 1 : goto cleanup;
6901 : : }
6902 : :
6903 : 7 : gfc_error ("Syntax error in data declaration at %C");
6904 : : }
6905 : :
6906 : 31 : m = MATCH_ERROR;
6907 : :
6908 : 31 : gfc_free_data_all (gfc_current_ns);
6909 : :
6910 : 208089 : cleanup:
6911 : 208089 : if (saved_kind_expr)
6912 : 156 : gfc_free_expr (saved_kind_expr);
6913 : 208089 : if (type_param_spec_list)
6914 : 757 : gfc_free_actual_arglist (type_param_spec_list);
6915 : 208089 : if (decl_type_param_list)
6916 : 768 : gfc_free_actual_arglist (decl_type_param_list);
6917 : 208089 : saved_kind_expr = NULL;
6918 : 208089 : gfc_free_array_spec (current_as);
6919 : 208089 : current_as = NULL;
6920 : 208089 : return m;
6921 : : }
6922 : :
6923 : : static bool
6924 : 23091 : in_module_or_interface(void)
6925 : : {
6926 : 23091 : if (gfc_current_state () == COMP_MODULE
6927 : 23091 : || gfc_current_state () == COMP_SUBMODULE
6928 : 23091 : || gfc_current_state () == COMP_INTERFACE)
6929 : : return true;
6930 : :
6931 : 19506 : if (gfc_state_stack->state == COMP_CONTAINS
6932 : 18721 : || gfc_state_stack->state == COMP_FUNCTION
6933 : 18624 : || gfc_state_stack->state == COMP_SUBROUTINE)
6934 : : {
6935 : 882 : gfc_state_data *p;
6936 : 925 : for (p = gfc_state_stack->previous; p ; p = p->previous)
6937 : : {
6938 : 921 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
6939 : 109 : || p->state == COMP_INTERFACE)
6940 : : return true;
6941 : : }
6942 : : }
6943 : : return false;
6944 : : }
6945 : :
6946 : : /* Match a prefix associated with a function or subroutine
6947 : : declaration. If the typespec pointer is nonnull, then a typespec
6948 : : can be matched. Note that if nothing matches, MATCH_YES is
6949 : : returned (the null string was matched). */
6950 : :
6951 : : match
6952 : 233209 : gfc_match_prefix (gfc_typespec *ts)
6953 : : {
6954 : 233209 : bool seen_type;
6955 : 233209 : bool seen_impure;
6956 : 233209 : bool found_prefix;
6957 : :
6958 : 233209 : gfc_clear_attr (¤t_attr);
6959 : 233209 : seen_type = false;
6960 : 233209 : seen_impure = false;
6961 : :
6962 : 233209 : gcc_assert (!gfc_matching_prefix);
6963 : 233209 : gfc_matching_prefix = true;
6964 : :
6965 : 242666 : do
6966 : : {
6967 : 261594 : found_prefix = false;
6968 : :
6969 : : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6970 : : corresponding attribute seems natural and distinguishes these
6971 : : procedures from procedure types of PROC_MODULE, which these are
6972 : : as well. */
6973 : 261594 : if (gfc_match ("module% ") == MATCH_YES)
6974 : : {
6975 : 23366 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6976 : 275 : goto error;
6977 : :
6978 : 23091 : if (!in_module_or_interface ())
6979 : : {
6980 : 18628 : gfc_error ("MODULE prefix at %C found outside of a module, "
6981 : : "submodule, or interface");
6982 : 18628 : goto error;
6983 : : }
6984 : :
6985 : 4463 : current_attr.module_procedure = 1;
6986 : 4463 : found_prefix = true;
6987 : : }
6988 : :
6989 : 242691 : if (!seen_type && ts != NULL)
6990 : : {
6991 : 130533 : match m;
6992 : 130533 : m = gfc_match_decl_type_spec (ts, 0);
6993 : 130533 : if (m == MATCH_ERROR)
6994 : 15 : goto error;
6995 : 130518 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
6996 : : {
6997 : : seen_type = true;
6998 : : found_prefix = true;
6999 : : }
7000 : : }
7001 : :
7002 : 242676 : if (gfc_match ("elemental% ") == MATCH_YES)
7003 : : {
7004 : 5139 : if (!gfc_add_elemental (¤t_attr, NULL))
7005 : 2 : goto error;
7006 : :
7007 : : found_prefix = true;
7008 : : }
7009 : :
7010 : 242674 : if (gfc_match ("pure% ") == MATCH_YES)
7011 : : {
7012 : 2347 : if (!gfc_add_pure (¤t_attr, NULL))
7013 : 2 : goto error;
7014 : :
7015 : : found_prefix = true;
7016 : : }
7017 : :
7018 : 242672 : if (gfc_match ("recursive% ") == MATCH_YES)
7019 : : {
7020 : 463 : if (!gfc_add_recursive (¤t_attr, NULL))
7021 : 2 : goto error;
7022 : :
7023 : : found_prefix = true;
7024 : : }
7025 : :
7026 : : /* IMPURE is a somewhat special case, as it needs not set an actual
7027 : : attribute but rather only prevents ELEMENTAL routines from being
7028 : : automatically PURE. */
7029 : 242670 : if (gfc_match ("impure% ") == MATCH_YES)
7030 : : {
7031 : 663 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
7032 : 4 : goto error;
7033 : :
7034 : : seen_impure = true;
7035 : : found_prefix = true;
7036 : : }
7037 : : }
7038 : : while (found_prefix);
7039 : :
7040 : : /* IMPURE and PURE must not both appear, of course. */
7041 : 214281 : if (seen_impure && current_attr.pure)
7042 : : {
7043 : 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
7044 : 4 : goto error;
7045 : : }
7046 : :
7047 : : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
7048 : 213622 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
7049 : : {
7050 : 4498 : if (!gfc_add_pure (¤t_attr, NULL))
7051 : 0 : goto error;
7052 : : }
7053 : :
7054 : : /* At this point, the next item is not a prefix. */
7055 : 214277 : gcc_assert (gfc_matching_prefix);
7056 : :
7057 : 214277 : gfc_matching_prefix = false;
7058 : 214277 : return MATCH_YES;
7059 : :
7060 : 18932 : error:
7061 : 18932 : gcc_assert (gfc_matching_prefix);
7062 : 18932 : gfc_matching_prefix = false;
7063 : 18932 : return MATCH_ERROR;
7064 : : }
7065 : :
7066 : :
7067 : : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
7068 : :
7069 : : static bool
7070 : 60850 : copy_prefix (symbol_attribute *dest, locus *where)
7071 : : {
7072 : 60850 : if (dest->module_procedure)
7073 : : {
7074 : 659 : if (current_attr.elemental)
7075 : 7 : dest->elemental = 1;
7076 : :
7077 : 659 : if (current_attr.pure)
7078 : 55 : dest->pure = 1;
7079 : :
7080 : 659 : if (current_attr.recursive)
7081 : 8 : dest->recursive = 1;
7082 : :
7083 : : /* Module procedures are unusual in that the 'dest' is copied from
7084 : : the interface declaration. However, this is an oportunity to
7085 : : check that the submodule declaration is compliant with the
7086 : : interface. */
7087 : 659 : if (dest->elemental && !current_attr.elemental)
7088 : : {
7089 : 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
7090 : : "missing at %L", where);
7091 : 1 : return false;
7092 : : }
7093 : :
7094 : 658 : if (dest->pure && !current_attr.pure)
7095 : : {
7096 : 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
7097 : : "missing at %L", where);
7098 : 1 : return false;
7099 : : }
7100 : :
7101 : 657 : if (dest->recursive && !current_attr.recursive)
7102 : : {
7103 : 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
7104 : : "missing at %L", where);
7105 : 1 : return false;
7106 : : }
7107 : :
7108 : : return true;
7109 : : }
7110 : :
7111 : 60191 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
7112 : : return false;
7113 : :
7114 : 60189 : if (current_attr.pure && !gfc_add_pure (dest, where))
7115 : : return false;
7116 : :
7117 : 60189 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
7118 : : return false;
7119 : :
7120 : : return true;
7121 : : }
7122 : :
7123 : :
7124 : : /* Match a formal argument list or, if typeparam is true, a
7125 : : type_param_name_list. */
7126 : :
7127 : : match
7128 : 468613 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
7129 : : int null_flag, bool typeparam)
7130 : : {
7131 : 468613 : gfc_formal_arglist *head, *tail, *p, *q;
7132 : 468613 : char name[GFC_MAX_SYMBOL_LEN + 1];
7133 : 468613 : gfc_symbol *sym;
7134 : 468613 : match m;
7135 : 468613 : gfc_formal_arglist *formal = NULL;
7136 : :
7137 : 468613 : head = tail = NULL;
7138 : :
7139 : : /* Keep the interface formal argument list and null it so that the
7140 : : matching for the new declaration can be done. The numbers and
7141 : : names of the arguments are checked here. The interface formal
7142 : : arguments are retained in formal_arglist and the characteristics
7143 : : are compared in resolve.cc(resolve_fl_procedure). See the remark
7144 : : in get_proc_name about the eventual need to copy the formal_arglist
7145 : : and populate the formal namespace of the interface symbol. */
7146 : 468613 : if (progname->attr.module_procedure
7147 : 663 : && progname->attr.host_assoc)
7148 : : {
7149 : 179 : formal = progname->formal;
7150 : 179 : progname->formal = NULL;
7151 : : }
7152 : :
7153 : 468613 : if (gfc_match_char ('(') != MATCH_YES)
7154 : : {
7155 : 277536 : if (null_flag)
7156 : 6289 : goto ok;
7157 : : return MATCH_NO;
7158 : : }
7159 : :
7160 : 191077 : if (gfc_match_char (')') == MATCH_YES)
7161 : : {
7162 : 10141 : if (typeparam)
7163 : : {
7164 : 1 : gfc_error_now ("A type parameter list is required at %C");
7165 : 1 : m = MATCH_ERROR;
7166 : 1 : goto cleanup;
7167 : : }
7168 : : else
7169 : 10140 : goto ok;
7170 : : }
7171 : :
7172 : 241854 : for (;;)
7173 : : {
7174 : 241854 : gfc_gobble_whitespace ();
7175 : 241854 : if (gfc_match_char ('*') == MATCH_YES)
7176 : : {
7177 : 10233 : sym = NULL;
7178 : 10233 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
7179 : : "Alternate-return argument at %C"))
7180 : : {
7181 : 1 : m = MATCH_ERROR;
7182 : 1 : goto cleanup;
7183 : : }
7184 : 10232 : else if (typeparam)
7185 : 2 : gfc_error_now ("A parameter name is required at %C");
7186 : : }
7187 : : else
7188 : : {
7189 : 231621 : locus loc = gfc_current_locus;
7190 : 231621 : m = gfc_match_name (name);
7191 : 231621 : if (m != MATCH_YES)
7192 : : {
7193 : 15768 : if(typeparam)
7194 : 1 : gfc_error_now ("A parameter name is required at %C");
7195 : 15784 : goto cleanup;
7196 : : }
7197 : 215853 : loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
7198 : :
7199 : 215853 : if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
7200 : 16 : goto cleanup;
7201 : 215837 : else if (typeparam
7202 : 215837 : && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
7203 : 0 : goto cleanup;
7204 : : }
7205 : :
7206 : 226069 : p = gfc_get_formal_arglist ();
7207 : :
7208 : 226069 : if (head == NULL)
7209 : : head = tail = p;
7210 : : else
7211 : : {
7212 : 60215 : tail->next = p;
7213 : 60215 : tail = p;
7214 : : }
7215 : :
7216 : 226069 : tail->sym = sym;
7217 : :
7218 : : /* We don't add the VARIABLE flavor because the name could be a
7219 : : dummy procedure. We don't apply these attributes to formal
7220 : : arguments of statement functions. */
7221 : 215837 : if (sym != NULL && !st_flag
7222 : 324019 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
7223 : 97950 : || !gfc_missing_attr (&sym->attr, NULL)))
7224 : : {
7225 : 0 : m = MATCH_ERROR;
7226 : 0 : goto cleanup;
7227 : : }
7228 : :
7229 : : /* The name of a program unit can be in a different namespace,
7230 : : so check for it explicitly. After the statement is accepted,
7231 : : the name is checked for especially in gfc_get_symbol(). */
7232 : 226069 : if (gfc_new_block != NULL && sym != NULL && !typeparam
7233 : 96804 : && strcmp (sym->name, gfc_new_block->name) == 0)
7234 : : {
7235 : 0 : gfc_error ("Name %qs at %C is the name of the procedure",
7236 : : sym->name);
7237 : 0 : m = MATCH_ERROR;
7238 : 0 : goto cleanup;
7239 : : }
7240 : :
7241 : 226069 : if (gfc_match_char (')') == MATCH_YES)
7242 : 118880 : goto ok;
7243 : :
7244 : 107189 : m = gfc_match_char (',');
7245 : 107189 : if (m != MATCH_YES)
7246 : : {
7247 : 46271 : if (typeparam)
7248 : 1 : gfc_error_now ("Expected parameter list in type declaration "
7249 : : "at %C");
7250 : : else
7251 : 46270 : gfc_error ("Unexpected junk in formal argument list at %C");
7252 : 46271 : goto cleanup;
7253 : : }
7254 : : }
7255 : :
7256 : 135309 : ok:
7257 : : /* Check for duplicate symbols in the formal argument list. */
7258 : 135309 : if (head != NULL)
7259 : : {
7260 : 177531 : for (p = head; p->next; p = p->next)
7261 : : {
7262 : 58699 : if (p->sym == NULL)
7263 : 327 : continue;
7264 : :
7265 : 233367 : for (q = p->next; q; q = q->next)
7266 : 175043 : if (p->sym == q->sym)
7267 : : {
7268 : 48 : if (typeparam)
7269 : 1 : gfc_error_now ("Duplicate name %qs in parameter "
7270 : : "list at %C", p->sym->name);
7271 : : else
7272 : 47 : gfc_error ("Duplicate symbol %qs in formal argument "
7273 : : "list at %C", p->sym->name);
7274 : :
7275 : 48 : m = MATCH_ERROR;
7276 : 48 : goto cleanup;
7277 : : }
7278 : : }
7279 : : }
7280 : :
7281 : 135261 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
7282 : : {
7283 : 0 : m = MATCH_ERROR;
7284 : 0 : goto cleanup;
7285 : : }
7286 : :
7287 : : /* gfc_error_now used in following and return with MATCH_YES because
7288 : : doing otherwise results in a cascade of extraneous errors and in
7289 : : some cases an ICE in symbol.cc(gfc_release_symbol). */
7290 : 135261 : if (progname->attr.module_procedure && progname->attr.host_assoc)
7291 : : {
7292 : 178 : bool arg_count_mismatch = false;
7293 : :
7294 : 178 : if (!formal && head)
7295 : : arg_count_mismatch = true;
7296 : :
7297 : : /* Abbreviated module procedure declaration is not meant to have any
7298 : : formal arguments! */
7299 : 178 : if (!progname->abr_modproc_decl && formal && !head)
7300 : 1 : arg_count_mismatch = true;
7301 : :
7302 : 348 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
7303 : : {
7304 : 170 : if ((p->next != NULL && q->next == NULL)
7305 : 169 : || (p->next == NULL && q->next != NULL))
7306 : : arg_count_mismatch = true;
7307 : 168 : else if ((p->sym == NULL && q->sym == NULL)
7308 : 168 : || (p->sym && q->sym
7309 : 166 : && strcmp (p->sym->name, q->sym->name) == 0))
7310 : 164 : continue;
7311 : : else
7312 : : {
7313 : 4 : if (q->sym == NULL)
7314 : 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
7315 : : "conflicts with alternate return at %C",
7316 : : p->sym->name);
7317 : 3 : else if (p->sym == NULL)
7318 : 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
7319 : : "alternate return and conflicts with "
7320 : : "%qs in the separate declaration at %C",
7321 : : q->sym->name);
7322 : : else
7323 : 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
7324 : : "argument names (%s/%s) at %C",
7325 : : p->sym->name, q->sym->name);
7326 : : }
7327 : : }
7328 : :
7329 : 178 : if (arg_count_mismatch)
7330 : 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
7331 : : "formal arguments at %C");
7332 : : }
7333 : :
7334 : : return MATCH_YES;
7335 : :
7336 : 62105 : cleanup:
7337 : 62105 : gfc_free_formal_arglist (head);
7338 : 62105 : return m;
7339 : : }
7340 : :
7341 : :
7342 : : /* Match a RESULT specification following a function declaration or
7343 : : ENTRY statement. Also matches the end-of-statement. */
7344 : :
7345 : : static match
7346 : 7831 : match_result (gfc_symbol *function, gfc_symbol **result)
7347 : : {
7348 : 7831 : char name[GFC_MAX_SYMBOL_LEN + 1];
7349 : 7831 : gfc_symbol *r;
7350 : 7831 : match m;
7351 : :
7352 : 7831 : if (gfc_match (" result (") != MATCH_YES)
7353 : : return MATCH_NO;
7354 : :
7355 : 5788 : m = gfc_match_name (name);
7356 : 5788 : if (m != MATCH_YES)
7357 : : return m;
7358 : :
7359 : : /* Get the right paren, and that's it because there could be the
7360 : : bind(c) attribute after the result clause. */
7361 : 5788 : if (gfc_match_char (')') != MATCH_YES)
7362 : : {
7363 : : /* TODO: should report the missing right paren here. */
7364 : : return MATCH_ERROR;
7365 : : }
7366 : :
7367 : 5788 : if (strcmp (function->name, name) == 0)
7368 : : {
7369 : 1 : gfc_error ("RESULT variable at %C must be different than function name");
7370 : 1 : return MATCH_ERROR;
7371 : : }
7372 : :
7373 : 5787 : if (gfc_get_symbol (name, NULL, &r))
7374 : : return MATCH_ERROR;
7375 : :
7376 : 5787 : if (!gfc_add_result (&r->attr, r->name, NULL))
7377 : : return MATCH_ERROR;
7378 : :
7379 : 5787 : *result = r;
7380 : :
7381 : 5787 : return MATCH_YES;
7382 : : }
7383 : :
7384 : :
7385 : : /* Match a function suffix, which could be a combination of a result
7386 : : clause and BIND(C), either one, or neither. The draft does not
7387 : : require them to come in a specific order. */
7388 : :
7389 : : static match
7390 : 7835 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
7391 : : {
7392 : 7835 : match is_bind_c; /* Found bind(c). */
7393 : 7835 : match is_result; /* Found result clause. */
7394 : 7835 : match found_match; /* Status of whether we've found a good match. */
7395 : 7835 : char peek_char; /* Character we're going to peek at. */
7396 : 7835 : bool allow_binding_name;
7397 : :
7398 : : /* Initialize to having found nothing. */
7399 : 7835 : found_match = MATCH_NO;
7400 : 7835 : is_bind_c = MATCH_NO;
7401 : 7835 : is_result = MATCH_NO;
7402 : :
7403 : : /* Get the next char to narrow between result and bind(c). */
7404 : 7835 : gfc_gobble_whitespace ();
7405 : 7835 : peek_char = gfc_peek_ascii_char ();
7406 : :
7407 : : /* C binding names are not allowed for internal procedures. */
7408 : 7835 : if (gfc_current_state () == COMP_CONTAINS
7409 : 4561 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
7410 : : allow_binding_name = false;
7411 : : else
7412 : 6199 : allow_binding_name = true;
7413 : :
7414 : 7835 : switch (peek_char)
7415 : : {
7416 : 5417 : case 'r':
7417 : : /* Look for result clause. */
7418 : 5417 : is_result = match_result (sym, result);
7419 : 5417 : if (is_result == MATCH_YES)
7420 : : {
7421 : : /* Now see if there is a bind(c) after it. */
7422 : 5416 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7423 : : /* We've found the result clause and possibly bind(c). */
7424 : 5416 : found_match = MATCH_YES;
7425 : : }
7426 : : else
7427 : : /* This should only be MATCH_ERROR. */
7428 : : found_match = is_result;
7429 : : break;
7430 : 2418 : case 'b':
7431 : : /* Look for bind(c) first. */
7432 : 2418 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
7433 : 2418 : if (is_bind_c == MATCH_YES)
7434 : : {
7435 : : /* Now see if a result clause followed it. */
7436 : 2414 : is_result = match_result (sym, result);
7437 : 2414 : found_match = MATCH_YES;
7438 : : }
7439 : : else
7440 : : {
7441 : : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
7442 : : found_match = MATCH_ERROR;
7443 : : }
7444 : : break;
7445 : 0 : default:
7446 : 0 : gfc_error ("Unexpected junk after function declaration at %C");
7447 : 0 : found_match = MATCH_ERROR;
7448 : 0 : break;
7449 : : }
7450 : :
7451 : 7830 : if (is_bind_c == MATCH_YES)
7452 : : {
7453 : : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
7454 : 2563 : if (gfc_current_state () == COMP_CONTAINS
7455 : 416 : && sym->ns->proc_name->attr.flavor != FL_MODULE
7456 : 2575 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
7457 : : "at %L may not be specified for an internal "
7458 : : "procedure", &gfc_current_locus))
7459 : : return MATCH_ERROR;
7460 : :
7461 : 2560 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
7462 : : return MATCH_ERROR;
7463 : : }
7464 : :
7465 : : return found_match;
7466 : : }
7467 : :
7468 : :
7469 : : /* Procedure pointer return value without RESULT statement:
7470 : : Add "hidden" result variable named "ppr@". */
7471 : :
7472 : : static bool
7473 : 72261 : add_hidden_procptr_result (gfc_symbol *sym)
7474 : : {
7475 : 72261 : bool case1,case2;
7476 : :
7477 : 72261 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
7478 : : return false;
7479 : :
7480 : : /* First usage case: PROCEDURE and EXTERNAL statements. */
7481 : 1519 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
7482 : 1519 : && strcmp (gfc_current_block ()->name, sym->name) == 0
7483 : 72647 : && sym->attr.external;
7484 : : /* Second usage case: INTERFACE statements. */
7485 : 13935 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
7486 : 13935 : && gfc_state_stack->previous->state == COMP_FUNCTION
7487 : 72308 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
7488 : :
7489 : 72077 : if (case1 || case2)
7490 : : {
7491 : 124 : gfc_symtree *stree;
7492 : 124 : if (case1)
7493 : 94 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7494 : : else
7495 : : {
7496 : 30 : gfc_symtree *st2;
7497 : 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7498 : 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7499 : 30 : st2->n.sym = stree->n.sym;
7500 : 30 : stree->n.sym->refs++;
7501 : : }
7502 : 124 : sym->result = stree->n.sym;
7503 : :
7504 : 124 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7505 : 124 : sym->result->attr.pointer = sym->attr.pointer;
7506 : 124 : sym->result->attr.external = sym->attr.external;
7507 : 124 : sym->result->attr.referenced = sym->attr.referenced;
7508 : 124 : sym->result->ts = sym->ts;
7509 : 124 : sym->attr.proc_pointer = 0;
7510 : 124 : sym->attr.pointer = 0;
7511 : 124 : sym->attr.external = 0;
7512 : 124 : if (sym->result->attr.external && sym->result->attr.pointer)
7513 : : {
7514 : 4 : sym->result->attr.pointer = 0;
7515 : 4 : sym->result->attr.proc_pointer = 1;
7516 : : }
7517 : :
7518 : 124 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7519 : : }
7520 : : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7521 : 71983 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7522 : 399 : && sym->result && sym->result != sym && sym->result->attr.external
7523 : 28 : && sym == gfc_current_ns->proc_name
7524 : 28 : && sym == sym->result->ns->proc_name
7525 : 28 : && strcmp ("ppr@", sym->result->name) == 0)
7526 : : {
7527 : 28 : sym->result->attr.proc_pointer = 1;
7528 : 28 : sym->attr.pointer = 0;
7529 : 28 : return true;
7530 : : }
7531 : : else
7532 : : return false;
7533 : : }
7534 : :
7535 : :
7536 : : /* Match the interface for a PROCEDURE declaration,
7537 : : including brackets (R1212). */
7538 : :
7539 : : static match
7540 : 1549 : match_procedure_interface (gfc_symbol **proc_if)
7541 : : {
7542 : 1549 : match m;
7543 : 1549 : gfc_symtree *st;
7544 : 1549 : locus old_loc, entry_loc;
7545 : 1549 : gfc_namespace *old_ns = gfc_current_ns;
7546 : 1549 : char name[GFC_MAX_SYMBOL_LEN + 1];
7547 : :
7548 : 1549 : old_loc = entry_loc = gfc_current_locus;
7549 : 1549 : gfc_clear_ts (¤t_ts);
7550 : :
7551 : 1549 : if (gfc_match (" (") != MATCH_YES)
7552 : : {
7553 : 1 : gfc_current_locus = entry_loc;
7554 : 1 : return MATCH_NO;
7555 : : }
7556 : :
7557 : : /* Get the type spec. for the procedure interface. */
7558 : 1548 : old_loc = gfc_current_locus;
7559 : 1548 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7560 : 1548 : gfc_gobble_whitespace ();
7561 : 1548 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7562 : 390 : goto got_ts;
7563 : :
7564 : 1158 : if (m == MATCH_ERROR)
7565 : : return m;
7566 : :
7567 : : /* Procedure interface is itself a procedure. */
7568 : 1158 : gfc_current_locus = old_loc;
7569 : 1158 : m = gfc_match_name (name);
7570 : :
7571 : : /* First look to see if it is already accessible in the current
7572 : : namespace because it is use associated or contained. */
7573 : 1158 : st = NULL;
7574 : 1158 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7575 : : return MATCH_ERROR;
7576 : :
7577 : : /* If it is still not found, then try the parent namespace, if it
7578 : : exists and create the symbol there if it is still not found. */
7579 : 1158 : if (gfc_current_ns->parent)
7580 : 385 : gfc_current_ns = gfc_current_ns->parent;
7581 : 1158 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7582 : : return MATCH_ERROR;
7583 : :
7584 : 1158 : gfc_current_ns = old_ns;
7585 : 1158 : *proc_if = st->n.sym;
7586 : :
7587 : 1158 : if (*proc_if)
7588 : : {
7589 : 1158 : (*proc_if)->refs++;
7590 : : /* Resolve interface if possible. That way, attr.procedure is only set
7591 : : if it is declared by a later procedure-declaration-stmt, which is
7592 : : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7593 : 1158 : while ((*proc_if)->ts.interface
7594 : 1165 : && *proc_if != (*proc_if)->ts.interface)
7595 : 7 : *proc_if = (*proc_if)->ts.interface;
7596 : :
7597 : 1158 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7598 : 387 : && (*proc_if)->ts.type == BT_UNKNOWN
7599 : 1545 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7600 : : (*proc_if)->name, NULL))
7601 : : return MATCH_ERROR;
7602 : : }
7603 : :
7604 : 0 : got_ts:
7605 : 1548 : if (gfc_match (" )") != MATCH_YES)
7606 : : {
7607 : 0 : gfc_current_locus = entry_loc;
7608 : 0 : return MATCH_NO;
7609 : : }
7610 : :
7611 : : return MATCH_YES;
7612 : : }
7613 : :
7614 : :
7615 : : /* Match a PROCEDURE declaration (R1211). */
7616 : :
7617 : : static match
7618 : 1124 : match_procedure_decl (void)
7619 : : {
7620 : 1124 : match m;
7621 : 1124 : gfc_symbol *sym, *proc_if = NULL;
7622 : 1124 : int num;
7623 : 1124 : gfc_expr *initializer = NULL;
7624 : :
7625 : : /* Parse interface (with brackets). */
7626 : 1124 : m = match_procedure_interface (&proc_if);
7627 : 1124 : if (m != MATCH_YES)
7628 : : return m;
7629 : :
7630 : : /* Parse attributes (with colons). */
7631 : 1124 : m = match_attr_spec();
7632 : 1124 : if (m == MATCH_ERROR)
7633 : : return MATCH_ERROR;
7634 : :
7635 : 1123 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7636 : : {
7637 : 17 : current_attr.is_bind_c = 1;
7638 : 17 : has_name_equals = 0;
7639 : 17 : curr_binding_label = NULL;
7640 : : }
7641 : :
7642 : : /* Get procedure symbols. */
7643 : 79 : for(num=1;;num++)
7644 : : {
7645 : 1202 : m = gfc_match_symbol (&sym, 0);
7646 : 1202 : if (m == MATCH_NO)
7647 : 1 : goto syntax;
7648 : 1201 : else if (m == MATCH_ERROR)
7649 : : return m;
7650 : :
7651 : : /* Add current_attr to the symbol attributes. */
7652 : 1201 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7653 : : return MATCH_ERROR;
7654 : :
7655 : 1199 : if (sym->attr.is_bind_c)
7656 : : {
7657 : : /* Check for C1218. */
7658 : 54 : if (!proc_if || !proc_if->attr.is_bind_c)
7659 : : {
7660 : 1 : gfc_error ("BIND(C) attribute at %C requires "
7661 : : "an interface with BIND(C)");
7662 : 1 : return MATCH_ERROR;
7663 : : }
7664 : : /* Check for C1217. */
7665 : 53 : if (has_name_equals && sym->attr.pointer)
7666 : : {
7667 : 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7668 : : "POINTER attribute at %C");
7669 : 1 : return MATCH_ERROR;
7670 : : }
7671 : 52 : if (has_name_equals && sym->attr.dummy)
7672 : : {
7673 : 1 : gfc_error ("Dummy procedure at %C may not have "
7674 : : "BIND(C) attribute with NAME");
7675 : 1 : return MATCH_ERROR;
7676 : : }
7677 : : /* Set binding label for BIND(C). */
7678 : 51 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7679 : : return MATCH_ERROR;
7680 : : }
7681 : :
7682 : 1195 : if (!gfc_add_external (&sym->attr, NULL))
7683 : : return MATCH_ERROR;
7684 : :
7685 : 1191 : if (add_hidden_procptr_result (sym))
7686 : 67 : sym = sym->result;
7687 : :
7688 : 1191 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7689 : : return MATCH_ERROR;
7690 : :
7691 : : /* Set interface. */
7692 : 1190 : if (proc_if != NULL)
7693 : : {
7694 : 851 : if (sym->ts.type != BT_UNKNOWN)
7695 : : {
7696 : 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7697 : : sym->name, &gfc_current_locus,
7698 : : gfc_basic_typename (sym->ts.type));
7699 : 1 : return MATCH_ERROR;
7700 : : }
7701 : 850 : sym->ts.interface = proc_if;
7702 : 850 : sym->attr.untyped = 1;
7703 : 850 : sym->attr.if_source = IFSRC_IFBODY;
7704 : : }
7705 : 339 : else if (current_ts.type != BT_UNKNOWN)
7706 : : {
7707 : 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7708 : : return MATCH_ERROR;
7709 : 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7710 : 198 : sym->ts.interface->ts = current_ts;
7711 : 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7712 : 198 : sym->ts.interface->attr.function = 1;
7713 : 198 : sym->attr.function = 1;
7714 : 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7715 : : }
7716 : :
7717 : 1188 : if (gfc_match (" =>") == MATCH_YES)
7718 : : {
7719 : 87 : if (!current_attr.pointer)
7720 : : {
7721 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7722 : 0 : m = MATCH_ERROR;
7723 : 0 : goto cleanup;
7724 : : }
7725 : :
7726 : 87 : m = match_pointer_init (&initializer, 1);
7727 : 87 : if (m != MATCH_YES)
7728 : 1 : goto cleanup;
7729 : :
7730 : 86 : if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
7731 : 0 : goto cleanup;
7732 : :
7733 : : }
7734 : :
7735 : 1187 : if (gfc_match_eos () == MATCH_YES)
7736 : : return MATCH_YES;
7737 : 79 : if (gfc_match_char (',') != MATCH_YES)
7738 : 0 : goto syntax;
7739 : : }
7740 : :
7741 : 1 : syntax:
7742 : 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7743 : 1 : return MATCH_ERROR;
7744 : :
7745 : 1 : cleanup:
7746 : : /* Free stuff up and return. */
7747 : 1 : gfc_free_expr (initializer);
7748 : 1 : return m;
7749 : : }
7750 : :
7751 : :
7752 : : static match
7753 : : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7754 : :
7755 : :
7756 : : /* Match a procedure pointer component declaration (R445). */
7757 : :
7758 : : static match
7759 : 425 : match_ppc_decl (void)
7760 : : {
7761 : 425 : match m;
7762 : 425 : gfc_symbol *proc_if = NULL;
7763 : 425 : gfc_typespec ts;
7764 : 425 : int num;
7765 : 425 : gfc_component *c;
7766 : 425 : gfc_expr *initializer = NULL;
7767 : 425 : gfc_typebound_proc* tb;
7768 : 425 : char name[GFC_MAX_SYMBOL_LEN + 1];
7769 : :
7770 : : /* Parse interface (with brackets). */
7771 : 425 : m = match_procedure_interface (&proc_if);
7772 : 425 : if (m != MATCH_YES)
7773 : 1 : goto syntax;
7774 : :
7775 : : /* Parse attributes. */
7776 : 424 : tb = XCNEW (gfc_typebound_proc);
7777 : 424 : tb->where = gfc_current_locus;
7778 : 424 : m = match_binding_attributes (tb, false, true);
7779 : 424 : if (m == MATCH_ERROR)
7780 : : return m;
7781 : :
7782 : 421 : gfc_clear_attr (¤t_attr);
7783 : 421 : current_attr.procedure = 1;
7784 : 421 : current_attr.proc_pointer = 1;
7785 : 421 : current_attr.access = tb->access;
7786 : 421 : current_attr.flavor = FL_PROCEDURE;
7787 : :
7788 : : /* Match the colons (required). */
7789 : 421 : if (gfc_match (" ::") != MATCH_YES)
7790 : : {
7791 : 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7792 : 1 : return MATCH_ERROR;
7793 : : }
7794 : :
7795 : : /* Check for C450. */
7796 : 420 : if (!tb->nopass && proc_if == NULL)
7797 : : {
7798 : 2 : gfc_error("NOPASS or explicit interface required at %C");
7799 : 2 : return MATCH_ERROR;
7800 : : }
7801 : :
7802 : 418 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7803 : : return MATCH_ERROR;
7804 : :
7805 : : /* Match PPC names. */
7806 : 417 : ts = current_ts;
7807 : 417 : for(num=1;;num++)
7808 : : {
7809 : 418 : m = gfc_match_name (name);
7810 : 418 : if (m == MATCH_NO)
7811 : 0 : goto syntax;
7812 : 418 : else if (m == MATCH_ERROR)
7813 : : return m;
7814 : :
7815 : 418 : if (!gfc_add_component (gfc_current_block(), name, &c))
7816 : : return MATCH_ERROR;
7817 : :
7818 : : /* Add current_attr to the symbol attributes. */
7819 : 418 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
7820 : : return MATCH_ERROR;
7821 : :
7822 : 418 : if (!gfc_add_external (&c->attr, NULL))
7823 : : return MATCH_ERROR;
7824 : :
7825 : 418 : if (!gfc_add_proc (&c->attr, name, NULL))
7826 : : return MATCH_ERROR;
7827 : :
7828 : 418 : if (num == 1)
7829 : 417 : c->tb = tb;
7830 : : else
7831 : : {
7832 : 1 : c->tb = XCNEW (gfc_typebound_proc);
7833 : 1 : c->tb->where = gfc_current_locus;
7834 : 1 : *c->tb = *tb;
7835 : : }
7836 : :
7837 : 418 : if (saved_kind_expr)
7838 : 0 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
7839 : :
7840 : : /* Set interface. */
7841 : 418 : if (proc_if != NULL)
7842 : : {
7843 : 352 : c->ts.interface = proc_if;
7844 : 352 : c->attr.untyped = 1;
7845 : 352 : c->attr.if_source = IFSRC_IFBODY;
7846 : : }
7847 : 66 : else if (ts.type != BT_UNKNOWN)
7848 : : {
7849 : 29 : c->ts = ts;
7850 : 29 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7851 : 29 : c->ts.interface->result = c->ts.interface;
7852 : 29 : c->ts.interface->ts = ts;
7853 : 29 : c->ts.interface->attr.flavor = FL_PROCEDURE;
7854 : 29 : c->ts.interface->attr.function = 1;
7855 : 29 : c->attr.function = 1;
7856 : 29 : c->attr.if_source = IFSRC_UNKNOWN;
7857 : : }
7858 : :
7859 : 418 : if (gfc_match (" =>") == MATCH_YES)
7860 : : {
7861 : 66 : m = match_pointer_init (&initializer, 1);
7862 : 66 : if (m != MATCH_YES)
7863 : : {
7864 : 0 : gfc_free_expr (initializer);
7865 : 0 : return m;
7866 : : }
7867 : 66 : c->initializer = initializer;
7868 : : }
7869 : :
7870 : 418 : if (gfc_match_eos () == MATCH_YES)
7871 : : return MATCH_YES;
7872 : 1 : if (gfc_match_char (',') != MATCH_YES)
7873 : 0 : goto syntax;
7874 : : }
7875 : :
7876 : 1 : syntax:
7877 : 1 : gfc_error ("Syntax error in procedure pointer component at %C");
7878 : 1 : return MATCH_ERROR;
7879 : : }
7880 : :
7881 : :
7882 : : /* Match a PROCEDURE declaration inside an interface (R1206). */
7883 : :
7884 : : static match
7885 : 1561 : match_procedure_in_interface (void)
7886 : : {
7887 : 1561 : match m;
7888 : 1561 : gfc_symbol *sym;
7889 : 1561 : char name[GFC_MAX_SYMBOL_LEN + 1];
7890 : 1561 : locus old_locus;
7891 : :
7892 : 1561 : if (current_interface.type == INTERFACE_NAMELESS
7893 : 1561 : || current_interface.type == INTERFACE_ABSTRACT)
7894 : : {
7895 : 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
7896 : 1 : return MATCH_ERROR;
7897 : : }
7898 : :
7899 : : /* Check if the F2008 optional double colon appears. */
7900 : 1560 : gfc_gobble_whitespace ();
7901 : 1560 : old_locus = gfc_current_locus;
7902 : 1560 : if (gfc_match ("::") == MATCH_YES)
7903 : : {
7904 : 875 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
7905 : : "MODULE PROCEDURE statement at %L", &old_locus))
7906 : : return MATCH_ERROR;
7907 : : }
7908 : : else
7909 : 685 : gfc_current_locus = old_locus;
7910 : :
7911 : 2214 : for(;;)
7912 : : {
7913 : 2214 : m = gfc_match_name (name);
7914 : 2214 : if (m == MATCH_NO)
7915 : 0 : goto syntax;
7916 : 2214 : else if (m == MATCH_ERROR)
7917 : : return m;
7918 : 2214 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
7919 : : return MATCH_ERROR;
7920 : :
7921 : 2214 : if (!gfc_add_interface (sym))
7922 : : return MATCH_ERROR;
7923 : :
7924 : 2213 : if (gfc_match_eos () == MATCH_YES)
7925 : : break;
7926 : 655 : if (gfc_match_char (',') != MATCH_YES)
7927 : 0 : goto syntax;
7928 : : }
7929 : :
7930 : : return MATCH_YES;
7931 : :
7932 : 0 : syntax:
7933 : 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7934 : 0 : return MATCH_ERROR;
7935 : : }
7936 : :
7937 : :
7938 : : /* General matcher for PROCEDURE declarations. */
7939 : :
7940 : : static match match_procedure_in_type (void);
7941 : :
7942 : : match
7943 : 6209 : gfc_match_procedure (void)
7944 : : {
7945 : 6209 : match m;
7946 : :
7947 : 6209 : switch (gfc_current_state ())
7948 : : {
7949 : 1124 : case COMP_NONE:
7950 : 1124 : case COMP_PROGRAM:
7951 : 1124 : case COMP_MODULE:
7952 : 1124 : case COMP_SUBMODULE:
7953 : 1124 : case COMP_SUBROUTINE:
7954 : 1124 : case COMP_FUNCTION:
7955 : 1124 : case COMP_BLOCK:
7956 : 1124 : m = match_procedure_decl ();
7957 : 1124 : break;
7958 : 1561 : case COMP_INTERFACE:
7959 : 1561 : m = match_procedure_in_interface ();
7960 : 1561 : break;
7961 : 425 : case COMP_DERIVED:
7962 : 425 : m = match_ppc_decl ();
7963 : 425 : break;
7964 : 3099 : case COMP_DERIVED_CONTAINS:
7965 : 3099 : m = match_procedure_in_type ();
7966 : 3099 : break;
7967 : : default:
7968 : : return MATCH_NO;
7969 : : }
7970 : :
7971 : 6209 : if (m != MATCH_YES)
7972 : : return m;
7973 : :
7974 : 6153 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7975 : 4 : return MATCH_ERROR;
7976 : :
7977 : : return m;
7978 : : }
7979 : :
7980 : :
7981 : : /* Warn if a matched procedure has the same name as an intrinsic; this is
7982 : : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7983 : : parser-state-stack to find out whether we're in a module. */
7984 : :
7985 : : static void
7986 : 60847 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7987 : : {
7988 : 60847 : bool in_module;
7989 : :
7990 : 121694 : in_module = (gfc_state_stack->previous
7991 : 60847 : && (gfc_state_stack->previous->state == COMP_MODULE
7992 : 49477 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
7993 : :
7994 : 60847 : gfc_warn_intrinsic_shadow (sym, in_module, func);
7995 : 60847 : }
7996 : :
7997 : :
7998 : : /* Match a function declaration. */
7999 : :
8000 : : match
8001 : 124115 : gfc_match_function_decl (void)
8002 : : {
8003 : 124115 : char name[GFC_MAX_SYMBOL_LEN + 1];
8004 : 124115 : gfc_symbol *sym, *result;
8005 : 124115 : locus old_loc;
8006 : 124115 : match m;
8007 : 124115 : match suffix_match;
8008 : 124115 : match found_match; /* Status returned by match func. */
8009 : :
8010 : 124115 : if (gfc_current_state () != COMP_NONE
8011 : 77857 : && gfc_current_state () != COMP_INTERFACE
8012 : 50441 : && gfc_current_state () != COMP_CONTAINS)
8013 : : return MATCH_NO;
8014 : :
8015 : 124115 : gfc_clear_ts (¤t_ts);
8016 : :
8017 : 124115 : old_loc = gfc_current_locus;
8018 : :
8019 : 124115 : m = gfc_match_prefix (¤t_ts);
8020 : 124115 : if (m != MATCH_YES)
8021 : : {
8022 : 9468 : gfc_current_locus = old_loc;
8023 : 9468 : return m;
8024 : : }
8025 : :
8026 : 114647 : if (gfc_match ("function% %n", name) != MATCH_YES)
8027 : : {
8028 : 95825 : gfc_current_locus = old_loc;
8029 : 95825 : return MATCH_NO;
8030 : : }
8031 : :
8032 : 18822 : if (get_proc_name (name, &sym, false))
8033 : : return MATCH_ERROR;
8034 : :
8035 : 18817 : if (add_hidden_procptr_result (sym))
8036 : 20 : sym = sym->result;
8037 : :
8038 : 18817 : if (current_attr.module_procedure)
8039 : 287 : sym->attr.module_procedure = 1;
8040 : :
8041 : 18817 : gfc_new_block = sym;
8042 : :
8043 : 18817 : m = gfc_match_formal_arglist (sym, 0, 0);
8044 : 18817 : if (m == MATCH_NO)
8045 : : {
8046 : 6 : gfc_error ("Expected formal argument list in function "
8047 : : "definition at %C");
8048 : 6 : m = MATCH_ERROR;
8049 : 6 : goto cleanup;
8050 : : }
8051 : 18811 : else if (m == MATCH_ERROR)
8052 : 0 : goto cleanup;
8053 : :
8054 : 18811 : result = NULL;
8055 : :
8056 : : /* According to the draft, the bind(c) and result clause can
8057 : : come in either order after the formal_arg_list (i.e., either
8058 : : can be first, both can exist together or by themselves or neither
8059 : : one). Therefore, the match_result can't match the end of the
8060 : : string, and check for the bind(c) or result clause in either order. */
8061 : 18811 : found_match = gfc_match_eos ();
8062 : :
8063 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
8064 : : must have been marked BIND(C) with a BIND(C) attribute and that is
8065 : : not allowed for procedures. */
8066 : 18811 : if (sym->attr.is_bind_c == 1)
8067 : : {
8068 : 3 : sym->attr.is_bind_c = 0;
8069 : :
8070 : 3 : if (gfc_state_stack->previous
8071 : 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8072 : : {
8073 : 1 : locus loc;
8074 : 1 : loc = sym->old_symbol != NULL
8075 : 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
8076 : 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8077 : : "variables or common blocks", &loc);
8078 : : }
8079 : : }
8080 : :
8081 : 18811 : if (found_match != MATCH_YES)
8082 : : {
8083 : : /* If we haven't found the end-of-statement, look for a suffix. */
8084 : 7604 : suffix_match = gfc_match_suffix (sym, &result);
8085 : 7604 : if (suffix_match == MATCH_YES)
8086 : : /* Need to get the eos now. */
8087 : 7596 : found_match = gfc_match_eos ();
8088 : : else
8089 : : found_match = suffix_match;
8090 : : }
8091 : :
8092 : : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8093 : : subprogram and a binding label is specified, it shall be the
8094 : : same as the binding label specified in the corresponding module
8095 : : procedure interface body. */
8096 : 18811 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
8097 : 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8098 : 3 : && sym->binding_label && sym->old_symbol->binding_label
8099 : 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8100 : : {
8101 : 1 : const char *null = "NULL", *s1, *s2;
8102 : 1 : s1 = sym->binding_label;
8103 : 1 : if (!s1) s1 = null;
8104 : 1 : s2 = sym->old_symbol->binding_label;
8105 : 1 : if (!s2) s2 = null;
8106 : 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8107 : 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8108 : 1 : return MATCH_ERROR;
8109 : : }
8110 : :
8111 : 18810 : if(found_match != MATCH_YES)
8112 : : m = MATCH_ERROR;
8113 : : else
8114 : : {
8115 : : /* Make changes to the symbol. */
8116 : 18802 : m = MATCH_ERROR;
8117 : :
8118 : 18802 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
8119 : 0 : goto cleanup;
8120 : :
8121 : 18802 : if (!gfc_missing_attr (&sym->attr, NULL))
8122 : 0 : goto cleanup;
8123 : :
8124 : 18802 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8125 : : {
8126 : 1 : if(!sym->attr.module_procedure)
8127 : 1 : goto cleanup;
8128 : : else
8129 : 0 : gfc_error_check ();
8130 : : }
8131 : :
8132 : : /* Delay matching the function characteristics until after the
8133 : : specification block by signalling kind=-1. */
8134 : 18801 : sym->declared_at = old_loc;
8135 : 18801 : if (current_ts.type != BT_UNKNOWN)
8136 : 6702 : current_ts.kind = -1;
8137 : : else
8138 : 12099 : current_ts.kind = 0;
8139 : :
8140 : 18801 : if (result == NULL)
8141 : : {
8142 : 13226 : if (current_ts.type != BT_UNKNOWN
8143 : 13226 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
8144 : 1 : goto cleanup;
8145 : 13225 : sym->result = sym;
8146 : : }
8147 : : else
8148 : : {
8149 : 5575 : if (current_ts.type != BT_UNKNOWN
8150 : 5575 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
8151 : 0 : goto cleanup;
8152 : 5575 : sym->result = result;
8153 : : }
8154 : :
8155 : : /* Warn if this procedure has the same name as an intrinsic. */
8156 : 18800 : do_warn_intrinsic_shadow (sym, true);
8157 : :
8158 : 18800 : return MATCH_YES;
8159 : : }
8160 : :
8161 : 16 : cleanup:
8162 : 16 : gfc_current_locus = old_loc;
8163 : 16 : return m;
8164 : : }
8165 : :
8166 : :
8167 : : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
8168 : : pass the name of the entry, rather than the gfc_current_block name, and
8169 : : to return false upon finding an existing global entry. */
8170 : :
8171 : : static bool
8172 : 504 : add_global_entry (const char *name, const char *binding_label, bool sub,
8173 : : locus *where)
8174 : : {
8175 : 504 : gfc_gsymbol *s;
8176 : 504 : enum gfc_symbol_type type;
8177 : :
8178 : 504 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
8179 : :
8180 : : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
8181 : : name is a global identifier. */
8182 : 504 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
8183 : : {
8184 : 499 : s = gfc_get_gsymbol (name, false);
8185 : :
8186 : 499 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8187 : : {
8188 : 2 : gfc_global_used (s, where);
8189 : 2 : return false;
8190 : : }
8191 : : else
8192 : : {
8193 : 497 : s->type = type;
8194 : 497 : s->sym_name = name;
8195 : 497 : s->where = *where;
8196 : 497 : s->defined = 1;
8197 : 497 : s->ns = gfc_current_ns;
8198 : : }
8199 : : }
8200 : :
8201 : : /* Don't add the symbol multiple times. */
8202 : 502 : if (binding_label
8203 : 502 : && (!gfc_notification_std (GFC_STD_F2008)
8204 : 0 : || strcmp (name, binding_label) != 0))
8205 : : {
8206 : 5 : s = gfc_get_gsymbol (binding_label, true);
8207 : :
8208 : 5 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
8209 : : {
8210 : 1 : gfc_global_used (s, where);
8211 : 1 : return false;
8212 : : }
8213 : : else
8214 : : {
8215 : 4 : s->type = type;
8216 : 4 : s->sym_name = name;
8217 : 4 : s->binding_label = binding_label;
8218 : 4 : s->where = *where;
8219 : 4 : s->defined = 1;
8220 : 4 : s->ns = gfc_current_ns;
8221 : : }
8222 : : }
8223 : :
8224 : : return true;
8225 : : }
8226 : :
8227 : :
8228 : : /* Match an ENTRY statement. */
8229 : :
8230 : : match
8231 : 769 : gfc_match_entry (void)
8232 : : {
8233 : 769 : gfc_symbol *proc;
8234 : 769 : gfc_symbol *result;
8235 : 769 : gfc_symbol *entry;
8236 : 769 : char name[GFC_MAX_SYMBOL_LEN + 1];
8237 : 769 : gfc_compile_state state;
8238 : 769 : match m;
8239 : 769 : gfc_entry_list *el;
8240 : 769 : locus old_loc;
8241 : 769 : bool module_procedure;
8242 : 769 : char peek_char;
8243 : 769 : match is_bind_c;
8244 : :
8245 : 769 : m = gfc_match_name (name);
8246 : 769 : if (m != MATCH_YES)
8247 : : return m;
8248 : :
8249 : 769 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
8250 : : return MATCH_ERROR;
8251 : :
8252 : 769 : state = gfc_current_state ();
8253 : 769 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
8254 : : {
8255 : 3 : switch (state)
8256 : : {
8257 : 0 : case COMP_PROGRAM:
8258 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
8259 : 0 : break;
8260 : 0 : case COMP_MODULE:
8261 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
8262 : 0 : break;
8263 : 0 : case COMP_SUBMODULE:
8264 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
8265 : 0 : break;
8266 : 0 : case COMP_BLOCK_DATA:
8267 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8268 : : "a BLOCK DATA");
8269 : 0 : break;
8270 : 0 : case COMP_INTERFACE:
8271 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8272 : : "an INTERFACE");
8273 : 0 : break;
8274 : 1 : case COMP_STRUCTURE:
8275 : 1 : gfc_error ("ENTRY statement at %C cannot appear within "
8276 : : "a STRUCTURE block");
8277 : 1 : break;
8278 : 0 : case COMP_DERIVED:
8279 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8280 : : "a DERIVED TYPE block");
8281 : 0 : break;
8282 : 0 : case COMP_IF:
8283 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8284 : : "an IF-THEN block");
8285 : 0 : break;
8286 : 0 : case COMP_DO:
8287 : 0 : case COMP_DO_CONCURRENT:
8288 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8289 : : "a DO block");
8290 : 0 : break;
8291 : 0 : case COMP_SELECT:
8292 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8293 : : "a SELECT block");
8294 : 0 : break;
8295 : 0 : case COMP_FORALL:
8296 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8297 : : "a FORALL block");
8298 : 0 : break;
8299 : 0 : case COMP_WHERE:
8300 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8301 : : "a WHERE block");
8302 : 0 : break;
8303 : 0 : case COMP_CONTAINS:
8304 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
8305 : : "a contained subprogram");
8306 : 0 : break;
8307 : 2 : default:
8308 : 2 : gfc_error ("Unexpected ENTRY statement at %C");
8309 : : }
8310 : 3 : return MATCH_ERROR;
8311 : : }
8312 : :
8313 : 766 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
8314 : 766 : && gfc_state_stack->previous->state == COMP_INTERFACE)
8315 : : {
8316 : 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
8317 : 1 : return MATCH_ERROR;
8318 : : }
8319 : :
8320 : 1530 : module_procedure = gfc_current_ns->parent != NULL
8321 : 259 : && gfc_current_ns->parent->proc_name
8322 : 765 : && gfc_current_ns->parent->proc_name->attr.flavor
8323 : 259 : == FL_MODULE;
8324 : :
8325 : 765 : if (gfc_current_ns->parent != NULL
8326 : 259 : && gfc_current_ns->parent->proc_name
8327 : 259 : && !module_procedure)
8328 : : {
8329 : 0 : gfc_error("ENTRY statement at %C cannot appear in a "
8330 : : "contained procedure");
8331 : 0 : return MATCH_ERROR;
8332 : : }
8333 : :
8334 : : /* Module function entries need special care in get_proc_name
8335 : : because previous references within the function will have
8336 : : created symbols attached to the current namespace. */
8337 : 765 : if (get_proc_name (name, &entry,
8338 : : gfc_current_ns->parent != NULL
8339 : 765 : && module_procedure))
8340 : : return MATCH_ERROR;
8341 : :
8342 : 763 : proc = gfc_current_block ();
8343 : :
8344 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
8345 : : must have been marked BIND(C) with a BIND(C) attribute and that is
8346 : : not allowed for procedures. */
8347 : 763 : if (entry->attr.is_bind_c == 1)
8348 : : {
8349 : 0 : locus loc;
8350 : :
8351 : 0 : entry->attr.is_bind_c = 0;
8352 : :
8353 : 0 : loc = entry->old_symbol != NULL
8354 : 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
8355 : 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8356 : : "variables or common blocks", &loc);
8357 : : }
8358 : :
8359 : : /* Check what next non-whitespace character is so we can tell if there
8360 : : is the required parens if we have a BIND(C). */
8361 : 763 : old_loc = gfc_current_locus;
8362 : 763 : gfc_gobble_whitespace ();
8363 : 763 : peek_char = gfc_peek_ascii_char ();
8364 : :
8365 : 763 : if (state == COMP_SUBROUTINE)
8366 : : {
8367 : 134 : m = gfc_match_formal_arglist (entry, 0, 1);
8368 : 134 : if (m != MATCH_YES)
8369 : : return MATCH_ERROR;
8370 : :
8371 : : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
8372 : : never be an internal procedure. */
8373 : 134 : is_bind_c = gfc_match_bind_c (entry, true);
8374 : 134 : if (is_bind_c == MATCH_ERROR)
8375 : : return MATCH_ERROR;
8376 : 134 : if (is_bind_c == MATCH_YES)
8377 : : {
8378 : 22 : if (peek_char != '(')
8379 : : {
8380 : 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8381 : 0 : return MATCH_ERROR;
8382 : : }
8383 : :
8384 : 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
8385 : 22 : &(entry->declared_at), 1))
8386 : : return MATCH_ERROR;
8387 : :
8388 : : }
8389 : :
8390 : 134 : if (!gfc_current_ns->parent
8391 : 134 : && !add_global_entry (name, entry->binding_label, true,
8392 : : &old_loc))
8393 : : return MATCH_ERROR;
8394 : :
8395 : : /* An entry in a subroutine. */
8396 : 131 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8397 : 131 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
8398 : 3 : return MATCH_ERROR;
8399 : : }
8400 : : else
8401 : : {
8402 : : /* An entry in a function.
8403 : : We need to take special care because writing
8404 : : ENTRY f()
8405 : : as
8406 : : ENTRY f
8407 : : is allowed, whereas
8408 : : ENTRY f() RESULT (r)
8409 : : can't be written as
8410 : : ENTRY f RESULT (r). */
8411 : 629 : if (gfc_match_eos () == MATCH_YES)
8412 : : {
8413 : 24 : gfc_current_locus = old_loc;
8414 : : /* Match the empty argument list, and add the interface to
8415 : : the symbol. */
8416 : 24 : m = gfc_match_formal_arglist (entry, 0, 1);
8417 : : }
8418 : : else
8419 : 605 : m = gfc_match_formal_arglist (entry, 0, 0);
8420 : :
8421 : 629 : if (m != MATCH_YES)
8422 : : return MATCH_ERROR;
8423 : :
8424 : 628 : result = NULL;
8425 : :
8426 : 628 : if (gfc_match_eos () == MATCH_YES)
8427 : : {
8428 : 397 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8429 : 397 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8430 : 2 : return MATCH_ERROR;
8431 : :
8432 : 395 : entry->result = entry;
8433 : : }
8434 : : else
8435 : : {
8436 : 231 : m = gfc_match_suffix (entry, &result);
8437 : 231 : if (m == MATCH_NO)
8438 : 0 : gfc_syntax_error (ST_ENTRY);
8439 : 231 : if (m != MATCH_YES)
8440 : : return MATCH_ERROR;
8441 : :
8442 : 231 : if (result)
8443 : : {
8444 : 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
8445 : 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
8446 : 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
8447 : 0 : return MATCH_ERROR;
8448 : 212 : entry->result = result;
8449 : : }
8450 : : else
8451 : : {
8452 : 19 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
8453 : 19 : || !gfc_add_function (&entry->attr, entry->name, NULL))
8454 : 0 : return MATCH_ERROR;
8455 : 19 : entry->result = entry;
8456 : : }
8457 : : }
8458 : :
8459 : 626 : if (!gfc_current_ns->parent
8460 : 626 : && !add_global_entry (name, entry->binding_label, false,
8461 : : &old_loc))
8462 : : return MATCH_ERROR;
8463 : : }
8464 : :
8465 : 754 : if (gfc_match_eos () != MATCH_YES)
8466 : : {
8467 : 0 : gfc_syntax_error (ST_ENTRY);
8468 : 0 : return MATCH_ERROR;
8469 : : }
8470 : :
8471 : : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
8472 : 754 : if (proc->attr.elemental && entry->attr.is_bind_c)
8473 : : {
8474 : 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
8475 : : "elemental procedure", &entry->declared_at);
8476 : 2 : return MATCH_ERROR;
8477 : : }
8478 : :
8479 : 752 : entry->attr.recursive = proc->attr.recursive;
8480 : 752 : entry->attr.elemental = proc->attr.elemental;
8481 : 752 : entry->attr.pure = proc->attr.pure;
8482 : :
8483 : 752 : el = gfc_get_entry_list ();
8484 : 752 : el->sym = entry;
8485 : 752 : el->next = gfc_current_ns->entries;
8486 : 752 : gfc_current_ns->entries = el;
8487 : 752 : if (el->next)
8488 : 84 : el->id = el->next->id + 1;
8489 : : else
8490 : 668 : el->id = 1;
8491 : :
8492 : 752 : new_st.op = EXEC_ENTRY;
8493 : 752 : new_st.ext.entry = el;
8494 : :
8495 : 752 : return MATCH_YES;
8496 : : }
8497 : :
8498 : :
8499 : : /* Match a subroutine statement, including optional prefixes. */
8500 : :
8501 : : match
8502 : 783552 : gfc_match_subroutine (void)
8503 : : {
8504 : 783552 : char name[GFC_MAX_SYMBOL_LEN + 1];
8505 : 783552 : gfc_symbol *sym;
8506 : 783552 : match m;
8507 : 783552 : match is_bind_c;
8508 : 783552 : char peek_char;
8509 : 783552 : bool allow_binding_name;
8510 : 783552 : locus loc;
8511 : :
8512 : 783552 : if (gfc_current_state () != COMP_NONE
8513 : 743031 : && gfc_current_state () != COMP_INTERFACE
8514 : 721403 : && gfc_current_state () != COMP_CONTAINS)
8515 : : return MATCH_NO;
8516 : :
8517 : 102394 : m = gfc_match_prefix (NULL);
8518 : 102394 : if (m != MATCH_YES)
8519 : : return m;
8520 : :
8521 : 92936 : loc = gfc_current_locus;
8522 : 92936 : m = gfc_match ("subroutine% %n", name);
8523 : 92936 : if (m != MATCH_YES)
8524 : : return m;
8525 : :
8526 : 42084 : if (get_proc_name (name, &sym, false))
8527 : : return MATCH_ERROR;
8528 : :
8529 : : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8530 : : the symbol existed before. */
8531 : 42072 : sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
8532 : : &gfc_current_locus);
8533 : :
8534 : 42072 : if (current_attr.module_procedure)
8535 : 364 : sym->attr.module_procedure = 1;
8536 : :
8537 : 42072 : if (add_hidden_procptr_result (sym))
8538 : 9 : sym = sym->result;
8539 : :
8540 : 42072 : gfc_new_block = sym;
8541 : :
8542 : : /* Check what next non-whitespace character is so we can tell if there
8543 : : is the required parens if we have a BIND(C). */
8544 : 42072 : gfc_gobble_whitespace ();
8545 : 42072 : peek_char = gfc_peek_ascii_char ();
8546 : :
8547 : 42072 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8548 : : return MATCH_ERROR;
8549 : :
8550 : 42069 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8551 : : return MATCH_ERROR;
8552 : :
8553 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
8554 : : must have been marked BIND(C) with a BIND(C) attribute and that is
8555 : : not allowed for procedures. */
8556 : 42069 : if (sym->attr.is_bind_c == 1)
8557 : : {
8558 : 4 : sym->attr.is_bind_c = 0;
8559 : :
8560 : 4 : if (gfc_state_stack->previous
8561 : 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8562 : : {
8563 : 2 : locus loc;
8564 : 2 : loc = sym->old_symbol != NULL
8565 : 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8566 : 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8567 : : "variables or common blocks", &loc);
8568 : : }
8569 : : }
8570 : :
8571 : : /* C binding names are not allowed for internal procedures. */
8572 : 42069 : if (gfc_current_state () == COMP_CONTAINS
8573 : 25373 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8574 : : allow_binding_name = false;
8575 : : else
8576 : 27491 : allow_binding_name = true;
8577 : :
8578 : : /* Here, we are just checking if it has the bind(c) attribute, and if
8579 : : so, then we need to make sure it's all correct. If it doesn't,
8580 : : we still need to continue matching the rest of the subroutine line. */
8581 : 42069 : gfc_gobble_whitespace ();
8582 : 42069 : loc = gfc_current_locus;
8583 : 42069 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8584 : 42069 : if (is_bind_c == MATCH_ERROR)
8585 : : {
8586 : : /* There was an attempt at the bind(c), but it was wrong. An
8587 : : error message should have been printed w/in the gfc_match_bind_c
8588 : : so here we'll just return the MATCH_ERROR. */
8589 : : return MATCH_ERROR;
8590 : : }
8591 : :
8592 : 42056 : if (is_bind_c == MATCH_YES)
8593 : : {
8594 : 3967 : gfc_formal_arglist *arg;
8595 : :
8596 : : /* The following is allowed in the Fortran 2008 draft. */
8597 : 3967 : if (gfc_current_state () == COMP_CONTAINS
8598 : 1296 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8599 : 4378 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8600 : : "at %L may not be specified for an internal "
8601 : : "procedure", &gfc_current_locus))
8602 : : return MATCH_ERROR;
8603 : :
8604 : 3964 : if (peek_char != '(')
8605 : : {
8606 : 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8607 : 1 : return MATCH_ERROR;
8608 : : }
8609 : :
8610 : : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8611 : : subprogram and a binding label is specified, it shall be the
8612 : : same as the binding label specified in the corresponding module
8613 : : procedure interface body. */
8614 : 3963 : if (sym->attr.module_procedure && sym->old_symbol
8615 : 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8616 : 3 : && sym->binding_label && sym->old_symbol->binding_label
8617 : 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8618 : : {
8619 : 1 : const char *null = "NULL", *s1, *s2;
8620 : 1 : s1 = sym->binding_label;
8621 : 1 : if (!s1) s1 = null;
8622 : 1 : s2 = sym->old_symbol->binding_label;
8623 : 1 : if (!s2) s2 = null;
8624 : 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8625 : 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8626 : 1 : return MATCH_ERROR;
8627 : : }
8628 : :
8629 : : /* Scan the dummy arguments for an alternate return. */
8630 : 12239 : for (arg = sym->formal; arg; arg = arg->next)
8631 : 8278 : if (!arg->sym)
8632 : : {
8633 : 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8634 : : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8635 : 1 : return MATCH_ERROR;
8636 : : }
8637 : :
8638 : 3961 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8639 : : return MATCH_ERROR;
8640 : : }
8641 : :
8642 : 42049 : if (gfc_match_eos () != MATCH_YES)
8643 : : {
8644 : 1 : gfc_syntax_error (ST_SUBROUTINE);
8645 : 1 : return MATCH_ERROR;
8646 : : }
8647 : :
8648 : 42048 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8649 : : {
8650 : 4 : if(!sym->attr.module_procedure)
8651 : : return MATCH_ERROR;
8652 : : else
8653 : 3 : gfc_error_check ();
8654 : : }
8655 : :
8656 : : /* Warn if it has the same name as an intrinsic. */
8657 : 42047 : do_warn_intrinsic_shadow (sym, false);
8658 : :
8659 : 42047 : return MATCH_YES;
8660 : : }
8661 : :
8662 : :
8663 : : /* Check that the NAME identifier in a BIND attribute or statement
8664 : : is conform to C identifier rules. */
8665 : :
8666 : : match
8667 : 1162 : check_bind_name_identifier (char **name)
8668 : : {
8669 : 1162 : char *n = *name, *p;
8670 : :
8671 : : /* Remove leading spaces. */
8672 : 1188 : while (*n == ' ')
8673 : 26 : n++;
8674 : :
8675 : : /* On an empty string, free memory and set name to NULL. */
8676 : 1162 : if (*n == '\0')
8677 : : {
8678 : 42 : free (*name);
8679 : 42 : *name = NULL;
8680 : 42 : return MATCH_YES;
8681 : : }
8682 : :
8683 : : /* Remove trailing spaces. */
8684 : 1120 : p = n + strlen(n) - 1;
8685 : 1136 : while (*p == ' ')
8686 : 16 : *(p--) = '\0';
8687 : :
8688 : : /* Insert the identifier into the symbol table. */
8689 : 1120 : p = xstrdup (n);
8690 : 1120 : free (*name);
8691 : 1120 : *name = p;
8692 : :
8693 : : /* Now check that identifier is valid under C rules. */
8694 : 1120 : if (ISDIGIT (*p))
8695 : : {
8696 : 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8697 : 2 : return MATCH_ERROR;
8698 : : }
8699 : :
8700 : 12355 : for (; *p; p++)
8701 : 11240 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8702 : : {
8703 : 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8704 : 3 : return MATCH_ERROR;
8705 : : }
8706 : :
8707 : : return MATCH_YES;
8708 : : }
8709 : :
8710 : :
8711 : : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8712 : : given, and set the binding label in either the given symbol (if not
8713 : : NULL), or in the current_ts. The symbol may be NULL because we may
8714 : : encounter the BIND(C) before the declaration itself. Return
8715 : : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8716 : : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8717 : : or MATCH_YES if the specifier was correct and the binding label and
8718 : : bind(c) fields were set correctly for the given symbol or the
8719 : : current_ts. If allow_binding_name is false, no binding name may be
8720 : : given. */
8721 : :
8722 : : match
8723 : 50340 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8724 : : {
8725 : 50340 : char *binding_label = NULL;
8726 : 50340 : gfc_expr *e = NULL;
8727 : :
8728 : : /* Initialize the flag that specifies whether we encountered a NAME=
8729 : : specifier or not. */
8730 : 50340 : has_name_equals = 0;
8731 : :
8732 : : /* This much we have to be able to match, in this order, if
8733 : : there is a bind(c) label. */
8734 : 50340 : if (gfc_match (" bind ( c ") != MATCH_YES)
8735 : : return MATCH_NO;
8736 : :
8737 : : /* Now see if there is a binding label, or if we've reached the
8738 : : end of the bind(c) attribute without one. */
8739 : 6840 : if (gfc_match_char (',') == MATCH_YES)
8740 : : {
8741 : 1169 : if (gfc_match (" name = ") != MATCH_YES)
8742 : : {
8743 : 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8744 : : "at %C");
8745 : : /* should give an error message here */
8746 : 1 : return MATCH_ERROR;
8747 : : }
8748 : :
8749 : 1168 : has_name_equals = 1;
8750 : :
8751 : 1168 : if (gfc_match_init_expr (&e) != MATCH_YES)
8752 : : {
8753 : 2 : gfc_free_expr (e);
8754 : 2 : return MATCH_ERROR;
8755 : : }
8756 : :
8757 : 1166 : if (!gfc_simplify_expr(e, 0))
8758 : : {
8759 : 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8760 : 0 : gfc_free_expr (e);
8761 : 0 : return MATCH_ERROR;
8762 : : }
8763 : :
8764 : 1166 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8765 : 1163 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
8766 : : {
8767 : 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
8768 : : "default character kind");
8769 : 4 : gfc_free_expr(e);
8770 : 4 : return MATCH_ERROR;
8771 : : }
8772 : :
8773 : : // Get a C string from the Fortran string constant
8774 : 2324 : binding_label = gfc_widechar_to_char (e->value.character.string,
8775 : 1162 : e->value.character.length);
8776 : 1162 : gfc_free_expr(e);
8777 : :
8778 : : // Check that it is valid (old gfc_match_name_C)
8779 : 1162 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
8780 : : return MATCH_ERROR;
8781 : : }
8782 : :
8783 : : /* Get the required right paren. */
8784 : 6828 : if (gfc_match_char (')') != MATCH_YES)
8785 : : {
8786 : 1 : gfc_error ("Missing closing paren for binding label at %C");
8787 : 1 : return MATCH_ERROR;
8788 : : }
8789 : :
8790 : 6827 : if (has_name_equals && !allow_binding_name)
8791 : : {
8792 : 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
8793 : 6 : return MATCH_ERROR;
8794 : : }
8795 : :
8796 : 6821 : if (has_name_equals && sym != NULL && sym->attr.dummy)
8797 : : {
8798 : 2 : gfc_error ("For dummy procedure %s, no binding name is "
8799 : : "allowed in BIND(C) at %C", sym->name);
8800 : 2 : return MATCH_ERROR;
8801 : : }
8802 : :
8803 : :
8804 : : /* Save the binding label to the symbol. If sym is null, we're
8805 : : probably matching the typespec attributes of a declaration and
8806 : : haven't gotten the name yet, and therefore, no symbol yet. */
8807 : 6819 : if (binding_label)
8808 : : {
8809 : 1108 : if (sym != NULL)
8810 : 999 : sym->binding_label = binding_label;
8811 : : else
8812 : 109 : curr_binding_label = binding_label;
8813 : : }
8814 : 5711 : else if (allow_binding_name)
8815 : : {
8816 : : /* No binding label, but if symbol isn't null, we
8817 : : can set the label for it here.
8818 : : If name="" or allow_binding_name is false, no C binding name is
8819 : : created. */
8820 : 5288 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
8821 : 5121 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
8822 : : }
8823 : :
8824 : 6819 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
8825 : 718 : && current_interface.type == INTERFACE_ABSTRACT)
8826 : : {
8827 : 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8828 : 1 : return MATCH_ERROR;
8829 : : }
8830 : :
8831 : : return MATCH_YES;
8832 : : }
8833 : :
8834 : :
8835 : : /* Return nonzero if we're currently compiling a contained procedure. */
8836 : :
8837 : : static int
8838 : 61149 : contained_procedure (void)
8839 : : {
8840 : 61149 : gfc_state_data *s = gfc_state_stack;
8841 : :
8842 : 61149 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
8843 : 60272 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
8844 : 35476 : return 1;
8845 : :
8846 : : return 0;
8847 : : }
8848 : :
8849 : : /* Set the kind of each enumerator. The kind is selected such that it is
8850 : : interoperable with the corresponding C enumeration type, making
8851 : : sure that -fshort-enums is honored. */
8852 : :
8853 : : static void
8854 : 158 : set_enum_kind(void)
8855 : : {
8856 : 158 : enumerator_history *current_history = NULL;
8857 : 158 : int kind;
8858 : 158 : int i;
8859 : :
8860 : 158 : if (max_enum == NULL || enum_history == NULL)
8861 : : return;
8862 : :
8863 : 150 : if (!flag_short_enums)
8864 : : return;
8865 : :
8866 : : i = 0;
8867 : 48 : do
8868 : : {
8869 : 48 : kind = gfc_integer_kinds[i++].kind;
8870 : : }
8871 : 48 : while (kind < gfc_c_int_kind
8872 : 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
8873 : : kind) != ARITH_OK);
8874 : :
8875 : 24 : current_history = enum_history;
8876 : 96 : while (current_history != NULL)
8877 : : {
8878 : 72 : current_history->sym->ts.kind = kind;
8879 : 72 : current_history = current_history->next;
8880 : : }
8881 : : }
8882 : :
8883 : :
8884 : : /* Match any of the various end-block statements. Returns the type of
8885 : : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8886 : : and END BLOCK statements cannot be replaced by a single END statement. */
8887 : :
8888 : : match
8889 : 179390 : gfc_match_end (gfc_statement *st)
8890 : : {
8891 : 179390 : char name[GFC_MAX_SYMBOL_LEN + 1];
8892 : 179390 : gfc_compile_state state;
8893 : 179390 : locus old_loc;
8894 : 179390 : const char *block_name;
8895 : 179390 : const char *target;
8896 : 179390 : int eos_ok;
8897 : 179390 : match m;
8898 : 179390 : gfc_namespace *parent_ns, *ns, *prev_ns;
8899 : 179390 : gfc_namespace **nsp;
8900 : 179390 : bool abbreviated_modproc_decl = false;
8901 : 179390 : bool got_matching_end = false;
8902 : :
8903 : 179390 : old_loc = gfc_current_locus;
8904 : 179390 : if (gfc_match ("end") != MATCH_YES)
8905 : : return MATCH_NO;
8906 : :
8907 : 174395 : state = gfc_current_state ();
8908 : 95114 : block_name = gfc_current_block () == NULL
8909 : 174395 : ? NULL : gfc_current_block ()->name;
8910 : :
8911 : 174395 : switch (state)
8912 : : {
8913 : 2768 : case COMP_ASSOCIATE:
8914 : 2768 : case COMP_BLOCK:
8915 : 2768 : case COMP_CHANGE_TEAM:
8916 : 2768 : if (startswith (block_name, "block@"))
8917 : : block_name = NULL;
8918 : : break;
8919 : :
8920 : 16785 : case COMP_CONTAINS:
8921 : 16785 : case COMP_DERIVED_CONTAINS:
8922 : 16785 : case COMP_OMP_BEGIN_METADIRECTIVE:
8923 : 16785 : state = gfc_state_stack->previous->state;
8924 : 15270 : block_name = gfc_state_stack->previous->sym == NULL
8925 : 16785 : ? NULL : gfc_state_stack->previous->sym->name;
8926 : 16785 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
8927 : 16785 : && gfc_state_stack->previous->sym->abr_modproc_decl;
8928 : : break;
8929 : :
8930 : : case COMP_OMP_METADIRECTIVE:
8931 : : {
8932 : : /* Metadirectives can be nested, so we need to drill down to the
8933 : : first state that is not COMP_OMP_METADIRECTIVE. */
8934 : : gfc_state_data *state_data = gfc_state_stack;
8935 : :
8936 : 85 : do
8937 : : {
8938 : 85 : state_data = state_data->previous;
8939 : 85 : state = state_data->state;
8940 : 77 : block_name = (state_data->sym == NULL
8941 : 85 : ? NULL : state_data->sym->name);
8942 : 170 : abbreviated_modproc_decl = (state_data->sym
8943 : 85 : && state_data->sym->abr_modproc_decl);
8944 : : }
8945 : 85 : while (state == COMP_OMP_METADIRECTIVE);
8946 : :
8947 : 83 : if (block_name && startswith (block_name, "block@"))
8948 : : block_name = NULL;
8949 : : }
8950 : : break;
8951 : :
8952 : : default:
8953 : : break;
8954 : : }
8955 : :
8956 : 83 : if (!abbreviated_modproc_decl)
8957 : 174394 : abbreviated_modproc_decl = gfc_current_block ()
8958 : 174394 : && gfc_current_block ()->abr_modproc_decl;
8959 : :
8960 : 174395 : switch (state)
8961 : : {
8962 : 27238 : case COMP_NONE:
8963 : 27238 : case COMP_PROGRAM:
8964 : 27238 : *st = ST_END_PROGRAM;
8965 : 27238 : target = " program";
8966 : 27238 : eos_ok = 1;
8967 : 27238 : break;
8968 : :
8969 : 42224 : case COMP_SUBROUTINE:
8970 : 42224 : *st = ST_END_SUBROUTINE;
8971 : 42224 : if (!abbreviated_modproc_decl)
8972 : : target = " subroutine";
8973 : : else
8974 : 134 : target = " procedure";
8975 : 42224 : eos_ok = !contained_procedure ();
8976 : 42224 : break;
8977 : :
8978 : 18925 : case COMP_FUNCTION:
8979 : 18925 : *st = ST_END_FUNCTION;
8980 : 18925 : if (!abbreviated_modproc_decl)
8981 : : target = " function";
8982 : : else
8983 : 108 : target = " procedure";
8984 : 18925 : eos_ok = !contained_procedure ();
8985 : 18925 : break;
8986 : :
8987 : 87 : case COMP_BLOCK_DATA:
8988 : 87 : *st = ST_END_BLOCK_DATA;
8989 : 87 : target = " block data";
8990 : 87 : eos_ok = 1;
8991 : 87 : break;
8992 : :
8993 : 9449 : case COMP_MODULE:
8994 : 9449 : *st = ST_END_MODULE;
8995 : 9449 : target = " module";
8996 : 9449 : eos_ok = 1;
8997 : 9449 : break;
8998 : :
8999 : 228 : case COMP_SUBMODULE:
9000 : 228 : *st = ST_END_SUBMODULE;
9001 : 228 : target = " submodule";
9002 : 228 : eos_ok = 1;
9003 : 228 : break;
9004 : :
9005 : 10450 : case COMP_INTERFACE:
9006 : 10450 : *st = ST_END_INTERFACE;
9007 : 10450 : target = " interface";
9008 : 10450 : eos_ok = 0;
9009 : 10450 : break;
9010 : :
9011 : 257 : case COMP_MAP:
9012 : 257 : *st = ST_END_MAP;
9013 : 257 : target = " map";
9014 : 257 : eos_ok = 0;
9015 : 257 : break;
9016 : :
9017 : 132 : case COMP_UNION:
9018 : 132 : *st = ST_END_UNION;
9019 : 132 : target = " union";
9020 : 132 : eos_ok = 0;
9021 : 132 : break;
9022 : :
9023 : 313 : case COMP_STRUCTURE:
9024 : 313 : *st = ST_END_STRUCTURE;
9025 : 313 : target = " structure";
9026 : 313 : eos_ok = 0;
9027 : 313 : break;
9028 : :
9029 : 12262 : case COMP_DERIVED:
9030 : 12262 : case COMP_DERIVED_CONTAINS:
9031 : 12262 : *st = ST_END_TYPE;
9032 : 12262 : target = " type";
9033 : 12262 : eos_ok = 0;
9034 : 12262 : break;
9035 : :
9036 : 1404 : case COMP_ASSOCIATE:
9037 : 1404 : *st = ST_END_ASSOCIATE;
9038 : 1404 : target = " associate";
9039 : 1404 : eos_ok = 0;
9040 : 1404 : break;
9041 : :
9042 : 1327 : case COMP_BLOCK:
9043 : 1327 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
9044 : 1327 : *st = ST_END_BLOCK;
9045 : 1327 : target = " block";
9046 : 1327 : eos_ok = 0;
9047 : 1327 : break;
9048 : :
9049 : 14348 : case COMP_IF:
9050 : 14348 : *st = ST_ENDIF;
9051 : 14348 : target = " if";
9052 : 14348 : eos_ok = 0;
9053 : 14348 : break;
9054 : :
9055 : 30083 : case COMP_DO:
9056 : 30083 : case COMP_DO_CONCURRENT:
9057 : 30083 : *st = ST_ENDDO;
9058 : 30083 : target = " do";
9059 : 30083 : eos_ok = 0;
9060 : 30083 : break;
9061 : :
9062 : 50 : case COMP_CRITICAL:
9063 : 50 : *st = ST_END_CRITICAL;
9064 : 50 : target = " critical";
9065 : 50 : eos_ok = 0;
9066 : 50 : break;
9067 : :
9068 : 4505 : case COMP_SELECT:
9069 : 4505 : case COMP_SELECT_TYPE:
9070 : 4505 : case COMP_SELECT_RANK:
9071 : 4505 : *st = ST_END_SELECT;
9072 : 4505 : target = " select";
9073 : 4505 : eos_ok = 0;
9074 : 4505 : break;
9075 : :
9076 : 506 : case COMP_FORALL:
9077 : 506 : *st = ST_END_FORALL;
9078 : 506 : target = " forall";
9079 : 506 : eos_ok = 0;
9080 : 506 : break;
9081 : :
9082 : 373 : case COMP_WHERE:
9083 : 373 : *st = ST_END_WHERE;
9084 : 373 : target = " where";
9085 : 373 : eos_ok = 0;
9086 : 373 : break;
9087 : :
9088 : 158 : case COMP_ENUM:
9089 : 158 : *st = ST_END_ENUM;
9090 : 158 : target = " enum";
9091 : 158 : eos_ok = 0;
9092 : 158 : last_initializer = NULL;
9093 : 158 : set_enum_kind ();
9094 : 158 : gfc_free_enum_history ();
9095 : 158 : break;
9096 : :
9097 : 0 : case COMP_OMP_BEGIN_METADIRECTIVE:
9098 : 0 : *st = ST_OMP_END_METADIRECTIVE;
9099 : 0 : target = " metadirective";
9100 : 0 : eos_ok = 0;
9101 : 0 : break;
9102 : :
9103 : 67 : case COMP_CHANGE_TEAM:
9104 : 67 : *st = ST_END_TEAM;
9105 : 67 : target = " team";
9106 : 67 : eos_ok = 0;
9107 : 67 : break;
9108 : :
9109 : 9 : default:
9110 : 9 : gfc_error ("Unexpected END statement at %C");
9111 : 9 : goto cleanup;
9112 : : }
9113 : :
9114 : 174386 : old_loc = gfc_current_locus;
9115 : 174386 : if (gfc_match_eos () == MATCH_YES)
9116 : : {
9117 : 20155 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
9118 : : {
9119 : 7889 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
9120 : : "instead of %s statement at %L",
9121 : : abbreviated_modproc_decl ? "END PROCEDURE"
9122 : 3932 : : gfc_ascii_statement(*st), &old_loc))
9123 : 4 : goto cleanup;
9124 : : }
9125 : 9 : else if (!eos_ok)
9126 : : {
9127 : : /* We would have required END [something]. */
9128 : 9 : gfc_error ("%s statement expected at %L",
9129 : : gfc_ascii_statement (*st), &old_loc);
9130 : 9 : goto cleanup;
9131 : : }
9132 : :
9133 : 20142 : return MATCH_YES;
9134 : : }
9135 : :
9136 : : /* Verify that we've got the sort of end-block that we're expecting. */
9137 : 154231 : if (gfc_match (target) != MATCH_YES)
9138 : : {
9139 : 327 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
9140 : 163 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
9141 : 164 : goto cleanup;
9142 : : }
9143 : : else
9144 : 154067 : got_matching_end = true;
9145 : :
9146 : 154067 : if (*st == ST_END_TEAM && gfc_match_end_team () == MATCH_ERROR)
9147 : : /* Emit errors of stat and errmsg parsing now to finish the block and
9148 : : continue analysis of compilation unit. */
9149 : 2 : gfc_error_check ();
9150 : :
9151 : 154067 : old_loc = gfc_current_locus;
9152 : : /* If we're at the end, make sure a block name wasn't required. */
9153 : 154067 : if (gfc_match_eos () == MATCH_YES)
9154 : : {
9155 : 101890 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
9156 : : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
9157 : : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL
9158 : : && *st != ST_END_TEAM)
9159 : : return MATCH_YES;
9160 : :
9161 : 52169 : if (!block_name)
9162 : : return MATCH_YES;
9163 : :
9164 : 8 : gfc_error ("Expected block name of %qs in %s statement at %L",
9165 : : block_name, gfc_ascii_statement (*st), &old_loc);
9166 : :
9167 : 8 : return MATCH_ERROR;
9168 : : }
9169 : :
9170 : : /* END INTERFACE has a special handler for its several possible endings. */
9171 : 52177 : if (*st == ST_END_INTERFACE)
9172 : 592 : return gfc_match_end_interface ();
9173 : :
9174 : : /* We haven't hit the end of statement, so what is left must be an
9175 : : end-name. */
9176 : 51585 : m = gfc_match_space ();
9177 : 51585 : if (m == MATCH_YES)
9178 : 51585 : m = gfc_match_name (name);
9179 : :
9180 : 51585 : if (m == MATCH_NO)
9181 : 0 : gfc_error ("Expected terminating name at %C");
9182 : 51585 : if (m != MATCH_YES)
9183 : 0 : goto cleanup;
9184 : :
9185 : 51585 : if (block_name == NULL)
9186 : 15 : goto syntax;
9187 : :
9188 : : /* We have to pick out the declared submodule name from the composite
9189 : : required by F2008:11.2.3 para 2, which ends in the declared name. */
9190 : 51570 : if (state == COMP_SUBMODULE)
9191 : 114 : block_name = strchr (block_name, '.') + 1;
9192 : :
9193 : 51570 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
9194 : : {
9195 : 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
9196 : : gfc_ascii_statement (*st));
9197 : 8 : goto cleanup;
9198 : : }
9199 : : /* Procedure pointer as function result. */
9200 : 51562 : else if (strcmp (block_name, "ppr@") == 0
9201 : 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
9202 : : {
9203 : 0 : gfc_error ("Expected label %qs for %s statement at %C",
9204 : 0 : gfc_current_block ()->ns->proc_name->name,
9205 : : gfc_ascii_statement (*st));
9206 : 0 : goto cleanup;
9207 : : }
9208 : :
9209 : 51562 : if (gfc_match_eos () == MATCH_YES)
9210 : : return MATCH_YES;
9211 : :
9212 : 0 : syntax:
9213 : 15 : gfc_syntax_error (*st);
9214 : :
9215 : 209 : cleanup:
9216 : 209 : gfc_current_locus = old_loc;
9217 : :
9218 : : /* If we are missing an END BLOCK, we created a half-ready namespace.
9219 : : Remove it from the parent namespace's sibling list. */
9220 : :
9221 : 209 : if (state == COMP_BLOCK && !got_matching_end)
9222 : : {
9223 : 7 : parent_ns = gfc_current_ns->parent;
9224 : :
9225 : 7 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
9226 : :
9227 : 7 : prev_ns = NULL;
9228 : 7 : ns = *nsp;
9229 : 14 : while (ns)
9230 : : {
9231 : 7 : if (ns == gfc_current_ns)
9232 : : {
9233 : 7 : if (prev_ns == NULL)
9234 : 7 : *nsp = NULL;
9235 : : else
9236 : 0 : prev_ns->sibling = ns->sibling;
9237 : : }
9238 : 7 : prev_ns = ns;
9239 : 7 : ns = ns->sibling;
9240 : : }
9241 : :
9242 : 7 : gfc_free_namespace (gfc_current_ns);
9243 : 7 : gfc_current_ns = parent_ns;
9244 : 7 : gfc_state_stack = gfc_state_stack->previous;
9245 : 7 : state = gfc_current_state ();
9246 : : }
9247 : :
9248 : : return MATCH_ERROR;
9249 : : }
9250 : :
9251 : :
9252 : :
9253 : : /***************** Attribute declaration statements ****************/
9254 : :
9255 : : /* Set the attribute of a single variable. */
9256 : :
9257 : : static match
9258 : 10231 : attr_decl1 (void)
9259 : : {
9260 : 10231 : char name[GFC_MAX_SYMBOL_LEN + 1];
9261 : 10231 : gfc_array_spec *as;
9262 : :
9263 : : /* Workaround -Wmaybe-uninitialized false positive during
9264 : : profiledbootstrap by initializing them. */
9265 : 10231 : gfc_symbol *sym = NULL;
9266 : 10231 : locus var_locus;
9267 : 10231 : match m;
9268 : :
9269 : 10231 : as = NULL;
9270 : :
9271 : 10231 : m = gfc_match_name (name);
9272 : 10231 : if (m != MATCH_YES)
9273 : 0 : goto cleanup;
9274 : :
9275 : 10231 : if (find_special (name, &sym, false))
9276 : : return MATCH_ERROR;
9277 : :
9278 : 10231 : if (!check_function_name (name))
9279 : : {
9280 : 7 : m = MATCH_ERROR;
9281 : 7 : goto cleanup;
9282 : : }
9283 : :
9284 : 10224 : var_locus = gfc_current_locus;
9285 : :
9286 : : /* Deal with possible array specification for certain attributes. */
9287 : 10224 : if (current_attr.dimension
9288 : 8650 : || current_attr.codimension
9289 : 8629 : || current_attr.allocatable
9290 : 8206 : || current_attr.pointer
9291 : 7495 : || current_attr.target)
9292 : : {
9293 : 2955 : m = gfc_match_array_spec (&as, !current_attr.codimension,
9294 : : !current_attr.dimension
9295 : 1381 : && !current_attr.pointer
9296 : 3625 : && !current_attr.target);
9297 : 2955 : if (m == MATCH_ERROR)
9298 : 2 : goto cleanup;
9299 : :
9300 : 2953 : if (current_attr.dimension && m == MATCH_NO)
9301 : : {
9302 : 0 : gfc_error ("Missing array specification at %L in DIMENSION "
9303 : : "statement", &var_locus);
9304 : 0 : m = MATCH_ERROR;
9305 : 0 : goto cleanup;
9306 : : }
9307 : :
9308 : 2953 : if (current_attr.dimension && sym->value)
9309 : : {
9310 : 1 : gfc_error ("Dimensions specified for %s at %L after its "
9311 : : "initialization", sym->name, &var_locus);
9312 : 1 : m = MATCH_ERROR;
9313 : 1 : goto cleanup;
9314 : : }
9315 : :
9316 : 2952 : if (current_attr.codimension && m == MATCH_NO)
9317 : : {
9318 : 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
9319 : : "statement", &var_locus);
9320 : 0 : m = MATCH_ERROR;
9321 : 0 : goto cleanup;
9322 : : }
9323 : :
9324 : 2952 : if ((current_attr.allocatable || current_attr.pointer)
9325 : 1134 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
9326 : : {
9327 : 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
9328 : 0 : m = MATCH_ERROR;
9329 : 0 : goto cleanup;
9330 : : }
9331 : : }
9332 : :
9333 : 10221 : if (sym->ts.type == BT_CLASS
9334 : 200 : && sym->ts.u.derived
9335 : 200 : && sym->ts.u.derived->attr.is_class)
9336 : : {
9337 : 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
9338 : 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
9339 : 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
9340 : 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
9341 : 177 : if (CLASS_DATA (sym)->as)
9342 : 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
9343 : : }
9344 : 8649 : if (current_attr.dimension == 0 && current_attr.codimension == 0
9345 : 18850 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
9346 : : {
9347 : 22 : m = MATCH_ERROR;
9348 : 22 : goto cleanup;
9349 : : }
9350 : 10199 : if (!gfc_set_array_spec (sym, as, &var_locus))
9351 : : {
9352 : 18 : m = MATCH_ERROR;
9353 : 18 : goto cleanup;
9354 : : }
9355 : :
9356 : 10181 : if (sym->attr.cray_pointee && sym->as != NULL)
9357 : : {
9358 : : /* Fix the array spec. */
9359 : 2 : m = gfc_mod_pointee_as (sym->as);
9360 : 2 : if (m == MATCH_ERROR)
9361 : 0 : goto cleanup;
9362 : : }
9363 : :
9364 : 10181 : if (!gfc_add_attribute (&sym->attr, &var_locus))
9365 : : {
9366 : 0 : m = MATCH_ERROR;
9367 : 0 : goto cleanup;
9368 : : }
9369 : :
9370 : 5685 : if ((current_attr.external || current_attr.intrinsic)
9371 : 6112 : && sym->attr.flavor != FL_PROCEDURE
9372 : 16261 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
9373 : : {
9374 : 0 : m = MATCH_ERROR;
9375 : 0 : goto cleanup;
9376 : : }
9377 : :
9378 : 10181 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
9379 : 169 : && !as && !current_attr.pointer && !current_attr.allocatable
9380 : 136 : && !current_attr.external)
9381 : : {
9382 : 136 : sym->attr.pointer = 0;
9383 : 136 : sym->attr.allocatable = 0;
9384 : 136 : sym->attr.dimension = 0;
9385 : 136 : sym->attr.codimension = 0;
9386 : 136 : gfc_free_array_spec (sym->as);
9387 : 136 : sym->as = NULL;
9388 : : }
9389 : 10045 : else if (sym->ts.type == BT_CLASS
9390 : 10045 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
9391 : : {
9392 : 0 : m = MATCH_ERROR;
9393 : 0 : goto cleanup;
9394 : : }
9395 : :
9396 : 10181 : add_hidden_procptr_result (sym);
9397 : :
9398 : 10181 : return MATCH_YES;
9399 : :
9400 : 50 : cleanup:
9401 : 50 : gfc_free_array_spec (as);
9402 : 50 : return m;
9403 : : }
9404 : :
9405 : :
9406 : : /* Generic attribute declaration subroutine. Used for attributes that
9407 : : just have a list of names. */
9408 : :
9409 : : static match
9410 : 6571 : attr_decl (void)
9411 : : {
9412 : 6571 : match m;
9413 : :
9414 : : /* Gobble the optional double colon, by simply ignoring the result
9415 : : of gfc_match(). */
9416 : 6571 : gfc_match (" ::");
9417 : :
9418 : 10231 : for (;;)
9419 : : {
9420 : 10231 : m = attr_decl1 ();
9421 : 10231 : if (m != MATCH_YES)
9422 : : break;
9423 : :
9424 : 10181 : if (gfc_match_eos () == MATCH_YES)
9425 : : {
9426 : : m = MATCH_YES;
9427 : : break;
9428 : : }
9429 : :
9430 : 3660 : if (gfc_match_char (',') != MATCH_YES)
9431 : : {
9432 : 0 : gfc_error ("Unexpected character in variable list at %C");
9433 : 0 : m = MATCH_ERROR;
9434 : 0 : break;
9435 : : }
9436 : : }
9437 : :
9438 : 6571 : return m;
9439 : : }
9440 : :
9441 : :
9442 : : /* This routine matches Cray Pointer declarations of the form:
9443 : : pointer ( <pointer>, <pointee> )
9444 : : or
9445 : : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
9446 : : The pointer, if already declared, should be an integer. Otherwise, we
9447 : : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
9448 : : be either a scalar, or an array declaration. No space is allocated for
9449 : : the pointee. For the statement
9450 : : pointer (ipt, ar(10))
9451 : : any subsequent uses of ar will be translated (in C-notation) as
9452 : : ar(i) => ((<type> *) ipt)(i)
9453 : : After gimplification, pointee variable will disappear in the code. */
9454 : :
9455 : : static match
9456 : 334 : cray_pointer_decl (void)
9457 : : {
9458 : 334 : match m;
9459 : 334 : gfc_array_spec *as = NULL;
9460 : 334 : gfc_symbol *cptr; /* Pointer symbol. */
9461 : 334 : gfc_symbol *cpte; /* Pointee symbol. */
9462 : 334 : locus var_locus;
9463 : 334 : bool done = false;
9464 : :
9465 : 334 : while (!done)
9466 : : {
9467 : 347 : if (gfc_match_char ('(') != MATCH_YES)
9468 : : {
9469 : 1 : gfc_error ("Expected %<(%> at %C");
9470 : 1 : return MATCH_ERROR;
9471 : : }
9472 : :
9473 : : /* Match pointer. */
9474 : 346 : var_locus = gfc_current_locus;
9475 : 346 : gfc_clear_attr (¤t_attr);
9476 : 346 : gfc_add_cray_pointer (¤t_attr, &var_locus);
9477 : 346 : current_ts.type = BT_INTEGER;
9478 : 346 : current_ts.kind = gfc_index_integer_kind;
9479 : :
9480 : 346 : m = gfc_match_symbol (&cptr, 0);
9481 : 346 : if (m != MATCH_YES)
9482 : : {
9483 : 2 : gfc_error ("Expected variable name at %C");
9484 : 2 : return m;
9485 : : }
9486 : :
9487 : 344 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
9488 : : return MATCH_ERROR;
9489 : :
9490 : 341 : gfc_set_sym_referenced (cptr);
9491 : :
9492 : 341 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
9493 : : {
9494 : 327 : cptr->ts.type = BT_INTEGER;
9495 : 327 : cptr->ts.kind = gfc_index_integer_kind;
9496 : : }
9497 : 14 : else if (cptr->ts.type != BT_INTEGER)
9498 : : {
9499 : 1 : gfc_error ("Cray pointer at %C must be an integer");
9500 : 1 : return MATCH_ERROR;
9501 : : }
9502 : 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
9503 : 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
9504 : : " memory addresses require %d bytes",
9505 : : cptr->ts.kind, gfc_index_integer_kind);
9506 : :
9507 : 340 : if (gfc_match_char (',') != MATCH_YES)
9508 : : {
9509 : 2 : gfc_error ("Expected \",\" at %C");
9510 : 2 : return MATCH_ERROR;
9511 : : }
9512 : :
9513 : : /* Match Pointee. */
9514 : 338 : var_locus = gfc_current_locus;
9515 : 338 : gfc_clear_attr (¤t_attr);
9516 : 338 : gfc_add_cray_pointee (¤t_attr, &var_locus);
9517 : 338 : current_ts.type = BT_UNKNOWN;
9518 : 338 : current_ts.kind = 0;
9519 : :
9520 : 338 : m = gfc_match_symbol (&cpte, 0);
9521 : 338 : if (m != MATCH_YES)
9522 : : {
9523 : 2 : gfc_error ("Expected variable name at %C");
9524 : 2 : return m;
9525 : : }
9526 : :
9527 : : /* Check for an optional array spec. */
9528 : 336 : m = gfc_match_array_spec (&as, true, false);
9529 : 336 : if (m == MATCH_ERROR)
9530 : : {
9531 : 0 : gfc_free_array_spec (as);
9532 : 0 : return m;
9533 : : }
9534 : 336 : else if (m == MATCH_NO)
9535 : : {
9536 : 226 : gfc_free_array_spec (as);
9537 : 226 : as = NULL;
9538 : : }
9539 : :
9540 : 336 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9541 : : return MATCH_ERROR;
9542 : :
9543 : 329 : gfc_set_sym_referenced (cpte);
9544 : :
9545 : 329 : if (cpte->as == NULL)
9546 : : {
9547 : 247 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9548 : 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9549 : : }
9550 : 82 : else if (as != NULL)
9551 : : {
9552 : 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9553 : 1 : gfc_free_array_spec (as);
9554 : 1 : return MATCH_ERROR;
9555 : : }
9556 : :
9557 : 328 : as = NULL;
9558 : :
9559 : 328 : if (cpte->as != NULL)
9560 : : {
9561 : : /* Fix array spec. */
9562 : 190 : m = gfc_mod_pointee_as (cpte->as);
9563 : 190 : if (m == MATCH_ERROR)
9564 : : return m;
9565 : : }
9566 : :
9567 : : /* Point the Pointee at the Pointer. */
9568 : 328 : cpte->cp_pointer = cptr;
9569 : :
9570 : 328 : if (gfc_match_char (')') != MATCH_YES)
9571 : : {
9572 : 2 : gfc_error ("Expected \")\" at %C");
9573 : 2 : return MATCH_ERROR;
9574 : : }
9575 : 326 : m = gfc_match_char (',');
9576 : 326 : if (m != MATCH_YES)
9577 : 313 : done = true; /* Stop searching for more declarations. */
9578 : :
9579 : : }
9580 : :
9581 : 313 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9582 : 313 : || gfc_match_eos () != MATCH_YES)
9583 : : {
9584 : 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9585 : 0 : return MATCH_ERROR;
9586 : : }
9587 : : return MATCH_YES;
9588 : : }
9589 : :
9590 : :
9591 : : match
9592 : 3116 : gfc_match_external (void)
9593 : : {
9594 : :
9595 : 3116 : gfc_clear_attr (¤t_attr);
9596 : 3116 : current_attr.external = 1;
9597 : :
9598 : 3116 : return attr_decl ();
9599 : : }
9600 : :
9601 : :
9602 : : match
9603 : 208 : gfc_match_intent (void)
9604 : : {
9605 : 208 : sym_intent intent;
9606 : :
9607 : : /* This is not allowed within a BLOCK construct! */
9608 : 208 : if (gfc_current_state () == COMP_BLOCK)
9609 : : {
9610 : 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9611 : 2 : return MATCH_ERROR;
9612 : : }
9613 : :
9614 : 206 : intent = match_intent_spec ();
9615 : 206 : if (intent == INTENT_UNKNOWN)
9616 : : return MATCH_ERROR;
9617 : :
9618 : 206 : gfc_clear_attr (¤t_attr);
9619 : 206 : current_attr.intent = intent;
9620 : :
9621 : 206 : return attr_decl ();
9622 : : }
9623 : :
9624 : :
9625 : : match
9626 : 1456 : gfc_match_intrinsic (void)
9627 : : {
9628 : :
9629 : 1456 : gfc_clear_attr (¤t_attr);
9630 : 1456 : current_attr.intrinsic = 1;
9631 : :
9632 : 1456 : return attr_decl ();
9633 : : }
9634 : :
9635 : :
9636 : : match
9637 : 220 : gfc_match_optional (void)
9638 : : {
9639 : : /* This is not allowed within a BLOCK construct! */
9640 : 220 : if (gfc_current_state () == COMP_BLOCK)
9641 : : {
9642 : 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9643 : 2 : return MATCH_ERROR;
9644 : : }
9645 : :
9646 : 218 : gfc_clear_attr (¤t_attr);
9647 : 218 : current_attr.optional = 1;
9648 : :
9649 : 218 : return attr_decl ();
9650 : : }
9651 : :
9652 : :
9653 : : match
9654 : 903 : gfc_match_pointer (void)
9655 : : {
9656 : 903 : gfc_gobble_whitespace ();
9657 : 903 : if (gfc_peek_ascii_char () == '(')
9658 : : {
9659 : 335 : if (!flag_cray_pointer)
9660 : : {
9661 : 1 : gfc_error ("Cray pointer declaration at %C requires "
9662 : : "%<-fcray-pointer%> flag");
9663 : 1 : return MATCH_ERROR;
9664 : : }
9665 : 334 : return cray_pointer_decl ();
9666 : : }
9667 : : else
9668 : : {
9669 : 568 : gfc_clear_attr (¤t_attr);
9670 : 568 : current_attr.pointer = 1;
9671 : :
9672 : 568 : return attr_decl ();
9673 : : }
9674 : : }
9675 : :
9676 : :
9677 : : match
9678 : 161 : gfc_match_allocatable (void)
9679 : : {
9680 : 161 : gfc_clear_attr (¤t_attr);
9681 : 161 : current_attr.allocatable = 1;
9682 : :
9683 : 161 : return attr_decl ();
9684 : : }
9685 : :
9686 : :
9687 : : match
9688 : 22 : gfc_match_codimension (void)
9689 : : {
9690 : 22 : gfc_clear_attr (¤t_attr);
9691 : 22 : current_attr.codimension = 1;
9692 : :
9693 : 22 : return attr_decl ();
9694 : : }
9695 : :
9696 : :
9697 : : match
9698 : 80 : gfc_match_contiguous (void)
9699 : : {
9700 : 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9701 : : return MATCH_ERROR;
9702 : :
9703 : 79 : gfc_clear_attr (¤t_attr);
9704 : 79 : current_attr.contiguous = 1;
9705 : :
9706 : 79 : return attr_decl ();
9707 : : }
9708 : :
9709 : :
9710 : : match
9711 : 646 : gfc_match_dimension (void)
9712 : : {
9713 : 646 : gfc_clear_attr (¤t_attr);
9714 : 646 : current_attr.dimension = 1;
9715 : :
9716 : 646 : return attr_decl ();
9717 : : }
9718 : :
9719 : :
9720 : : match
9721 : 99 : gfc_match_target (void)
9722 : : {
9723 : 99 : gfc_clear_attr (¤t_attr);
9724 : 99 : current_attr.target = 1;
9725 : :
9726 : 99 : return attr_decl ();
9727 : : }
9728 : :
9729 : :
9730 : : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9731 : : statement. */
9732 : :
9733 : : static match
9734 : 1678 : access_attr_decl (gfc_statement st)
9735 : : {
9736 : 1678 : char name[GFC_MAX_SYMBOL_LEN + 1];
9737 : 1678 : interface_type type;
9738 : 1678 : gfc_user_op *uop;
9739 : 1678 : gfc_symbol *sym, *dt_sym;
9740 : 1678 : gfc_intrinsic_op op;
9741 : 1678 : match m;
9742 : 1678 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9743 : :
9744 : 1678 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9745 : 0 : goto done;
9746 : :
9747 : 2795 : for (;;)
9748 : : {
9749 : 2795 : m = gfc_match_generic_spec (&type, name, &op);
9750 : 2795 : if (m == MATCH_NO)
9751 : 0 : goto syntax;
9752 : 2795 : if (m == MATCH_ERROR)
9753 : 0 : goto done;
9754 : :
9755 : 2795 : switch (type)
9756 : : {
9757 : 0 : case INTERFACE_NAMELESS:
9758 : 0 : case INTERFACE_ABSTRACT:
9759 : 0 : goto syntax;
9760 : :
9761 : 2721 : case INTERFACE_GENERIC:
9762 : 2721 : case INTERFACE_DTIO:
9763 : :
9764 : 2721 : if (gfc_get_symbol (name, NULL, &sym))
9765 : 0 : goto done;
9766 : :
9767 : 2721 : if (type == INTERFACE_DTIO
9768 : 20 : && gfc_current_ns->proc_name
9769 : 20 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9770 : 20 : && sym->attr.flavor == FL_UNKNOWN)
9771 : 2 : sym->attr.flavor = FL_PROCEDURE;
9772 : :
9773 : 2721 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9774 : 4 : goto done;
9775 : :
9776 : 317 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9777 : 2767 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9778 : 0 : goto done;
9779 : :
9780 : : break;
9781 : :
9782 : 70 : case INTERFACE_INTRINSIC_OP:
9783 : 70 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9784 : : {
9785 : 70 : gfc_intrinsic_op other_op;
9786 : :
9787 : 70 : gfc_current_ns->operator_access[op] = access;
9788 : :
9789 : : /* Handle the case if there is another op with the same
9790 : : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9791 : 70 : other_op = gfc_equivalent_op (op);
9792 : :
9793 : 70 : if (other_op != INTRINSIC_NONE)
9794 : 21 : gfc_current_ns->operator_access[other_op] = access;
9795 : : }
9796 : : else
9797 : : {
9798 : 0 : gfc_error ("Access specification of the %s operator at %C has "
9799 : : "already been specified", gfc_op2string (op));
9800 : 0 : goto done;
9801 : : }
9802 : :
9803 : : break;
9804 : :
9805 : 4 : case INTERFACE_USER_OP:
9806 : 4 : uop = gfc_get_uop (name);
9807 : :
9808 : 4 : if (uop->access == ACCESS_UNKNOWN)
9809 : : {
9810 : 3 : uop->access = access;
9811 : : }
9812 : : else
9813 : : {
9814 : 1 : gfc_error ("Access specification of the .%s. operator at %C "
9815 : : "has already been specified", uop->name);
9816 : 1 : goto done;
9817 : : }
9818 : :
9819 : 3 : break;
9820 : : }
9821 : :
9822 : 2790 : if (gfc_match_char (',') == MATCH_NO)
9823 : : break;
9824 : : }
9825 : :
9826 : 1673 : if (gfc_match_eos () != MATCH_YES)
9827 : 0 : goto syntax;
9828 : : return MATCH_YES;
9829 : :
9830 : 0 : syntax:
9831 : 0 : gfc_syntax_error (st);
9832 : :
9833 : : done:
9834 : : return MATCH_ERROR;
9835 : : }
9836 : :
9837 : :
9838 : : match
9839 : 23 : gfc_match_protected (void)
9840 : : {
9841 : 23 : gfc_symbol *sym;
9842 : 23 : match m;
9843 : 23 : char c;
9844 : :
9845 : : /* PROTECTED has already been seen, but must be followed by whitespace
9846 : : or ::. */
9847 : 23 : c = gfc_peek_ascii_char ();
9848 : 23 : if (!gfc_is_whitespace (c) && c != ':')
9849 : : return MATCH_NO;
9850 : :
9851 : 22 : if (!gfc_current_ns->proc_name
9852 : 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
9853 : : {
9854 : 3 : gfc_error ("PROTECTED at %C only allowed in specification "
9855 : : "part of a module");
9856 : 3 : return MATCH_ERROR;
9857 : :
9858 : : }
9859 : :
9860 : 19 : gfc_match (" ::");
9861 : :
9862 : 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
9863 : : return MATCH_ERROR;
9864 : :
9865 : : /* PROTECTED has an entity-list. */
9866 : 18 : if (gfc_match_eos () == MATCH_YES)
9867 : 0 : goto syntax;
9868 : :
9869 : 26 : for(;;)
9870 : : {
9871 : 26 : m = gfc_match_symbol (&sym, 0);
9872 : 26 : switch (m)
9873 : : {
9874 : 26 : case MATCH_YES:
9875 : 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
9876 : : return MATCH_ERROR;
9877 : 25 : goto next_item;
9878 : :
9879 : : case MATCH_NO:
9880 : : break;
9881 : :
9882 : : case MATCH_ERROR:
9883 : : return MATCH_ERROR;
9884 : : }
9885 : :
9886 : 25 : next_item:
9887 : 25 : if (gfc_match_eos () == MATCH_YES)
9888 : : break;
9889 : 8 : if (gfc_match_char (',') != MATCH_YES)
9890 : 0 : goto syntax;
9891 : : }
9892 : :
9893 : : return MATCH_YES;
9894 : :
9895 : 0 : syntax:
9896 : 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
9897 : 0 : return MATCH_ERROR;
9898 : : }
9899 : :
9900 : :
9901 : : /* The PRIVATE statement is a bit weird in that it can be an attribute
9902 : : declaration, but also works as a standalone statement inside of a
9903 : : type declaration or a module. */
9904 : :
9905 : : match
9906 : 28170 : gfc_match_private (gfc_statement *st)
9907 : : {
9908 : 28170 : gfc_state_data *prev;
9909 : :
9910 : 28170 : if (gfc_match ("private") != MATCH_YES)
9911 : : return MATCH_NO;
9912 : :
9913 : : /* Try matching PRIVATE without an access-list. */
9914 : 1546 : if (gfc_match_eos () == MATCH_YES)
9915 : : {
9916 : 1259 : prev = gfc_state_stack->previous;
9917 : 1259 : if (gfc_current_state () != COMP_MODULE
9918 : 360 : && !(gfc_current_state () == COMP_DERIVED
9919 : 327 : && prev && prev->state == COMP_MODULE)
9920 : 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9921 : 32 : && prev->previous && prev->previous->state == COMP_MODULE))
9922 : : {
9923 : 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9924 : : "specification part of a module");
9925 : 2 : return MATCH_ERROR;
9926 : : }
9927 : :
9928 : 1257 : *st = ST_PRIVATE;
9929 : 1257 : return MATCH_YES;
9930 : : }
9931 : :
9932 : : /* At this point in free-form source code, PRIVATE must be followed
9933 : : by whitespace or ::. */
9934 : 287 : if (gfc_current_form == FORM_FREE)
9935 : : {
9936 : 285 : char c = gfc_peek_ascii_char ();
9937 : 285 : if (!gfc_is_whitespace (c) && c != ':')
9938 : : return MATCH_NO;
9939 : : }
9940 : :
9941 : 286 : prev = gfc_state_stack->previous;
9942 : 286 : if (gfc_current_state () != COMP_MODULE
9943 : 1 : && !(gfc_current_state () == COMP_DERIVED
9944 : 0 : && prev && prev->state == COMP_MODULE)
9945 : 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9946 : 0 : && prev->previous && prev->previous->state == COMP_MODULE))
9947 : : {
9948 : 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9949 : : "specification part of a module");
9950 : 1 : return MATCH_ERROR;
9951 : : }
9952 : :
9953 : 285 : *st = ST_ATTR_DECL;
9954 : 285 : return access_attr_decl (ST_PRIVATE);
9955 : : }
9956 : :
9957 : :
9958 : : match
9959 : 1779 : gfc_match_public (gfc_statement *st)
9960 : : {
9961 : 1779 : if (gfc_match ("public") != MATCH_YES)
9962 : : return MATCH_NO;
9963 : :
9964 : : /* Try matching PUBLIC without an access-list. */
9965 : 1440 : if (gfc_match_eos () == MATCH_YES)
9966 : : {
9967 : 45 : if (gfc_current_state () != COMP_MODULE)
9968 : : {
9969 : 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
9970 : : "specification part of a module");
9971 : 2 : return MATCH_ERROR;
9972 : : }
9973 : :
9974 : 43 : *st = ST_PUBLIC;
9975 : 43 : return MATCH_YES;
9976 : : }
9977 : :
9978 : : /* At this point in free-form source code, PUBLIC must be followed
9979 : : by whitespace or ::. */
9980 : 1395 : if (gfc_current_form == FORM_FREE)
9981 : : {
9982 : 1393 : char c = gfc_peek_ascii_char ();
9983 : 1393 : if (!gfc_is_whitespace (c) && c != ':')
9984 : : return MATCH_NO;
9985 : : }
9986 : :
9987 : 1394 : if (gfc_current_state () != COMP_MODULE)
9988 : : {
9989 : 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
9990 : : "specification part of a module");
9991 : 1 : return MATCH_ERROR;
9992 : : }
9993 : :
9994 : 1393 : *st = ST_ATTR_DECL;
9995 : 1393 : return access_attr_decl (ST_PUBLIC);
9996 : : }
9997 : :
9998 : :
9999 : : /* Workhorse for gfc_match_parameter. */
10000 : :
10001 : : static match
10002 : 7639 : do_parm (void)
10003 : : {
10004 : 7639 : gfc_symbol *sym;
10005 : 7639 : gfc_expr *init;
10006 : 7639 : match m;
10007 : 7639 : bool t;
10008 : :
10009 : 7639 : m = gfc_match_symbol (&sym, 0);
10010 : 7639 : if (m == MATCH_NO)
10011 : 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
10012 : :
10013 : 7639 : if (m != MATCH_YES)
10014 : : return m;
10015 : :
10016 : 7639 : if (gfc_match_char ('=') == MATCH_NO)
10017 : : {
10018 : 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
10019 : 0 : return MATCH_ERROR;
10020 : : }
10021 : :
10022 : 7639 : m = gfc_match_init_expr (&init);
10023 : 7639 : if (m == MATCH_NO)
10024 : 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
10025 : 7639 : if (m != MATCH_YES)
10026 : : return m;
10027 : :
10028 : 7638 : if (sym->ts.type == BT_UNKNOWN
10029 : 7638 : && !gfc_set_default_type (sym, 1, NULL))
10030 : : {
10031 : 1 : m = MATCH_ERROR;
10032 : 1 : goto cleanup;
10033 : : }
10034 : :
10035 : 7637 : if (!gfc_check_assign_symbol (sym, NULL, init)
10036 : 7637 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
10037 : : {
10038 : 1 : m = MATCH_ERROR;
10039 : 1 : goto cleanup;
10040 : : }
10041 : :
10042 : 7636 : if (sym->value)
10043 : : {
10044 : 1 : gfc_error ("Initializing already initialized variable at %C");
10045 : 1 : m = MATCH_ERROR;
10046 : 1 : goto cleanup;
10047 : : }
10048 : :
10049 : 7635 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
10050 : 7635 : return (t) ? MATCH_YES : MATCH_ERROR;
10051 : :
10052 : 3 : cleanup:
10053 : 3 : gfc_free_expr (init);
10054 : 3 : return m;
10055 : : }
10056 : :
10057 : :
10058 : : /* Match a parameter statement, with the weird syntax that these have. */
10059 : :
10060 : : match
10061 : 6929 : gfc_match_parameter (void)
10062 : : {
10063 : 6929 : const char *term = " )%t";
10064 : 6929 : match m;
10065 : :
10066 : 6929 : if (gfc_match_char ('(') == MATCH_NO)
10067 : : {
10068 : : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
10069 : 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
10070 : : return MATCH_NO;
10071 : 6928 : term = " %t";
10072 : : }
10073 : :
10074 : 7639 : for (;;)
10075 : : {
10076 : 7639 : m = do_parm ();
10077 : 7639 : if (m != MATCH_YES)
10078 : : break;
10079 : :
10080 : 7635 : if (gfc_match (term) == MATCH_YES)
10081 : : break;
10082 : :
10083 : 711 : if (gfc_match_char (',') != MATCH_YES)
10084 : : {
10085 : 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
10086 : 0 : m = MATCH_ERROR;
10087 : 0 : break;
10088 : : }
10089 : : }
10090 : :
10091 : : return m;
10092 : : }
10093 : :
10094 : :
10095 : : match
10096 : 8 : gfc_match_automatic (void)
10097 : : {
10098 : 8 : gfc_symbol *sym;
10099 : 8 : match m;
10100 : 8 : bool seen_symbol = false;
10101 : :
10102 : 8 : if (!flag_dec_static)
10103 : : {
10104 : 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10105 : : "%<-fdec-static%>",
10106 : : "AUTOMATIC"
10107 : : );
10108 : 2 : return MATCH_ERROR;
10109 : : }
10110 : :
10111 : 6 : gfc_match (" ::");
10112 : :
10113 : 6 : for (;;)
10114 : : {
10115 : 6 : m = gfc_match_symbol (&sym, 0);
10116 : 6 : switch (m)
10117 : : {
10118 : : case MATCH_NO:
10119 : : break;
10120 : :
10121 : : case MATCH_ERROR:
10122 : : return MATCH_ERROR;
10123 : :
10124 : 4 : case MATCH_YES:
10125 : 4 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
10126 : : return MATCH_ERROR;
10127 : : seen_symbol = true;
10128 : : break;
10129 : : }
10130 : :
10131 : 4 : if (gfc_match_eos () == MATCH_YES)
10132 : : break;
10133 : 0 : if (gfc_match_char (',') != MATCH_YES)
10134 : 0 : goto syntax;
10135 : : }
10136 : :
10137 : 4 : if (!seen_symbol)
10138 : : {
10139 : 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
10140 : 2 : return MATCH_ERROR;
10141 : : }
10142 : :
10143 : : return MATCH_YES;
10144 : :
10145 : 0 : syntax:
10146 : 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
10147 : 0 : return MATCH_ERROR;
10148 : : }
10149 : :
10150 : :
10151 : : match
10152 : 7 : gfc_match_static (void)
10153 : : {
10154 : 7 : gfc_symbol *sym;
10155 : 7 : match m;
10156 : 7 : bool seen_symbol = false;
10157 : :
10158 : 7 : if (!flag_dec_static)
10159 : : {
10160 : 2 : gfc_error ("%s at %C is a DEC extension, enable with "
10161 : : "%<-fdec-static%>",
10162 : : "STATIC");
10163 : 2 : return MATCH_ERROR;
10164 : : }
10165 : :
10166 : 5 : gfc_match (" ::");
10167 : :
10168 : 5 : for (;;)
10169 : : {
10170 : 5 : m = gfc_match_symbol (&sym, 0);
10171 : 5 : switch (m)
10172 : : {
10173 : : case MATCH_NO:
10174 : : break;
10175 : :
10176 : : case MATCH_ERROR:
10177 : : return MATCH_ERROR;
10178 : :
10179 : 3 : case MATCH_YES:
10180 : 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10181 : : &gfc_current_locus))
10182 : : return MATCH_ERROR;
10183 : : seen_symbol = true;
10184 : : break;
10185 : : }
10186 : :
10187 : 3 : if (gfc_match_eos () == MATCH_YES)
10188 : : break;
10189 : 0 : if (gfc_match_char (',') != MATCH_YES)
10190 : 0 : goto syntax;
10191 : : }
10192 : :
10193 : 3 : if (!seen_symbol)
10194 : : {
10195 : 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
10196 : 2 : return MATCH_ERROR;
10197 : : }
10198 : :
10199 : : return MATCH_YES;
10200 : :
10201 : 0 : syntax:
10202 : 0 : gfc_error ("Syntax error in STATIC statement at %C");
10203 : 0 : return MATCH_ERROR;
10204 : : }
10205 : :
10206 : :
10207 : : /* Save statements have a special syntax. */
10208 : :
10209 : : match
10210 : 271 : gfc_match_save (void)
10211 : : {
10212 : 271 : char n[GFC_MAX_SYMBOL_LEN+1];
10213 : 271 : gfc_common_head *c;
10214 : 271 : gfc_symbol *sym;
10215 : 271 : match m;
10216 : :
10217 : 271 : if (gfc_match_eos () == MATCH_YES)
10218 : : {
10219 : 150 : if (gfc_current_ns->seen_save)
10220 : : {
10221 : 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
10222 : : "follows previous SAVE statement"))
10223 : : return MATCH_ERROR;
10224 : : }
10225 : :
10226 : 149 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
10227 : 149 : return MATCH_YES;
10228 : : }
10229 : :
10230 : 121 : if (gfc_current_ns->save_all)
10231 : : {
10232 : 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
10233 : : "blanket SAVE statement"))
10234 : : return MATCH_ERROR;
10235 : : }
10236 : :
10237 : 120 : gfc_match (" ::");
10238 : :
10239 : 180 : for (;;)
10240 : : {
10241 : 180 : m = gfc_match_symbol (&sym, 0);
10242 : 180 : switch (m)
10243 : : {
10244 : 178 : case MATCH_YES:
10245 : 178 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
10246 : : &gfc_current_locus))
10247 : : return MATCH_ERROR;
10248 : 176 : goto next_item;
10249 : :
10250 : : case MATCH_NO:
10251 : : break;
10252 : :
10253 : : case MATCH_ERROR:
10254 : : return MATCH_ERROR;
10255 : : }
10256 : :
10257 : 2 : m = gfc_match (" / %n /", &n);
10258 : 2 : if (m == MATCH_ERROR)
10259 : : return MATCH_ERROR;
10260 : 2 : if (m == MATCH_NO)
10261 : 0 : goto syntax;
10262 : :
10263 : : /* F2023:C1108: A SAVE statement in a BLOCK construct shall contain a
10264 : : saved-entity-list that does not specify a common-block-name. */
10265 : 2 : if (gfc_current_state () == COMP_BLOCK)
10266 : : {
10267 : 1 : gfc_error ("SAVE of COMMON block %qs at %C is not allowed "
10268 : : "in a BLOCK construct", n);
10269 : 1 : return MATCH_ERROR;
10270 : : }
10271 : :
10272 : 1 : c = gfc_get_common (n, 0);
10273 : 1 : c->saved = 1;
10274 : :
10275 : 1 : gfc_current_ns->seen_save = 1;
10276 : :
10277 : 177 : next_item:
10278 : 177 : if (gfc_match_eos () == MATCH_YES)
10279 : : break;
10280 : 60 : if (gfc_match_char (',') != MATCH_YES)
10281 : 0 : goto syntax;
10282 : : }
10283 : :
10284 : : return MATCH_YES;
10285 : :
10286 : 0 : syntax:
10287 : 0 : if (gfc_current_ns->seen_save)
10288 : : {
10289 : 0 : gfc_error ("Syntax error in SAVE statement at %C");
10290 : 0 : return MATCH_ERROR;
10291 : : }
10292 : : else
10293 : : return MATCH_NO;
10294 : : }
10295 : :
10296 : :
10297 : : match
10298 : 93 : gfc_match_value (void)
10299 : : {
10300 : 93 : gfc_symbol *sym;
10301 : 93 : match m;
10302 : :
10303 : : /* This is not allowed within a BLOCK construct! */
10304 : 93 : if (gfc_current_state () == COMP_BLOCK)
10305 : : {
10306 : 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
10307 : 2 : return MATCH_ERROR;
10308 : : }
10309 : :
10310 : 91 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
10311 : : return MATCH_ERROR;
10312 : :
10313 : 90 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10314 : : {
10315 : : return MATCH_ERROR;
10316 : : }
10317 : :
10318 : 90 : if (gfc_match_eos () == MATCH_YES)
10319 : 0 : goto syntax;
10320 : :
10321 : 116 : for(;;)
10322 : : {
10323 : 116 : m = gfc_match_symbol (&sym, 0);
10324 : 116 : switch (m)
10325 : : {
10326 : 116 : case MATCH_YES:
10327 : 116 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
10328 : : return MATCH_ERROR;
10329 : 109 : goto next_item;
10330 : :
10331 : : case MATCH_NO:
10332 : : break;
10333 : :
10334 : : case MATCH_ERROR:
10335 : : return MATCH_ERROR;
10336 : : }
10337 : :
10338 : 109 : next_item:
10339 : 109 : if (gfc_match_eos () == MATCH_YES)
10340 : : break;
10341 : 26 : if (gfc_match_char (',') != MATCH_YES)
10342 : 0 : goto syntax;
10343 : : }
10344 : :
10345 : : return MATCH_YES;
10346 : :
10347 : 0 : syntax:
10348 : 0 : gfc_error ("Syntax error in VALUE statement at %C");
10349 : 0 : return MATCH_ERROR;
10350 : : }
10351 : :
10352 : :
10353 : : match
10354 : 45 : gfc_match_volatile (void)
10355 : : {
10356 : 45 : gfc_symbol *sym;
10357 : 45 : char *name;
10358 : 45 : match m;
10359 : :
10360 : 45 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
10361 : : return MATCH_ERROR;
10362 : :
10363 : 44 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10364 : : {
10365 : : return MATCH_ERROR;
10366 : : }
10367 : :
10368 : 44 : if (gfc_match_eos () == MATCH_YES)
10369 : 1 : goto syntax;
10370 : :
10371 : 48 : for(;;)
10372 : : {
10373 : : /* VOLATILE is special because it can be added to host-associated
10374 : : symbols locally. Except for coarrays. */
10375 : 48 : m = gfc_match_symbol (&sym, 1);
10376 : 48 : switch (m)
10377 : : {
10378 : 48 : case MATCH_YES:
10379 : 48 : name = XCNEWVAR (char, strlen (sym->name) + 1);
10380 : 48 : strcpy (name, sym->name);
10381 : 48 : if (!check_function_name (name))
10382 : : return MATCH_ERROR;
10383 : : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
10384 : : for variable in a BLOCK which is defined outside of the BLOCK. */
10385 : 47 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
10386 : : {
10387 : 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
10388 : : "%C, which is use-/host-associated", sym->name);
10389 : 2 : return MATCH_ERROR;
10390 : : }
10391 : 45 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
10392 : : return MATCH_ERROR;
10393 : 42 : goto next_item;
10394 : :
10395 : : case MATCH_NO:
10396 : : break;
10397 : :
10398 : : case MATCH_ERROR:
10399 : : return MATCH_ERROR;
10400 : : }
10401 : :
10402 : 42 : next_item:
10403 : 42 : if (gfc_match_eos () == MATCH_YES)
10404 : : break;
10405 : 5 : if (gfc_match_char (',') != MATCH_YES)
10406 : 0 : goto syntax;
10407 : : }
10408 : :
10409 : : return MATCH_YES;
10410 : :
10411 : 1 : syntax:
10412 : 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
10413 : 1 : return MATCH_ERROR;
10414 : : }
10415 : :
10416 : :
10417 : : match
10418 : 11 : gfc_match_asynchronous (void)
10419 : : {
10420 : 11 : gfc_symbol *sym;
10421 : 11 : char *name;
10422 : 11 : match m;
10423 : :
10424 : 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
10425 : : return MATCH_ERROR;
10426 : :
10427 : 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
10428 : : {
10429 : : return MATCH_ERROR;
10430 : : }
10431 : :
10432 : 10 : if (gfc_match_eos () == MATCH_YES)
10433 : 0 : goto syntax;
10434 : :
10435 : 10 : for(;;)
10436 : : {
10437 : : /* ASYNCHRONOUS is special because it can be added to host-associated
10438 : : symbols locally. */
10439 : 10 : m = gfc_match_symbol (&sym, 1);
10440 : 10 : switch (m)
10441 : : {
10442 : 10 : case MATCH_YES:
10443 : 10 : name = XCNEWVAR (char, strlen (sym->name) + 1);
10444 : 10 : strcpy (name, sym->name);
10445 : 10 : if (!check_function_name (name))
10446 : : return MATCH_ERROR;
10447 : 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
10448 : : return MATCH_ERROR;
10449 : 7 : goto next_item;
10450 : :
10451 : : case MATCH_NO:
10452 : : break;
10453 : :
10454 : : case MATCH_ERROR:
10455 : : return MATCH_ERROR;
10456 : : }
10457 : :
10458 : 7 : next_item:
10459 : 7 : if (gfc_match_eos () == MATCH_YES)
10460 : : break;
10461 : 0 : if (gfc_match_char (',') != MATCH_YES)
10462 : 0 : goto syntax;
10463 : : }
10464 : :
10465 : : return MATCH_YES;
10466 : :
10467 : 0 : syntax:
10468 : 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
10469 : 0 : return MATCH_ERROR;
10470 : : }
10471 : :
10472 : :
10473 : : /* Match a module procedure statement in a submodule. */
10474 : :
10475 : : match
10476 : 741505 : gfc_match_submod_proc (void)
10477 : : {
10478 : 741505 : char name[GFC_MAX_SYMBOL_LEN + 1];
10479 : 741505 : gfc_symbol *sym, *fsym;
10480 : 741505 : match m;
10481 : 741505 : gfc_formal_arglist *formal, *head, *tail;
10482 : :
10483 : 741505 : if (gfc_current_state () != COMP_CONTAINS
10484 : 14887 : || !(gfc_state_stack->previous
10485 : 14887 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
10486 : 14887 : || gfc_state_stack->previous->state == COMP_MODULE)))
10487 : : return MATCH_NO;
10488 : :
10489 : 7424 : m = gfc_match (" module% procedure% %n", name);
10490 : 7424 : if (m != MATCH_YES)
10491 : : return m;
10492 : :
10493 : 244 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
10494 : : "at %C"))
10495 : : return MATCH_ERROR;
10496 : :
10497 : 244 : if (get_proc_name (name, &sym, false))
10498 : : return MATCH_ERROR;
10499 : :
10500 : : /* Make sure that the result field is appropriately filled. */
10501 : 244 : if (sym->tlink && sym->tlink->attr.function)
10502 : : {
10503 : 108 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
10504 : : {
10505 : 65 : sym->result = sym->tlink->result;
10506 : 65 : if (!sym->result->attr.use_assoc)
10507 : : {
10508 : 20 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
10509 : : sym->result->name);
10510 : 20 : st->n.sym = sym->result;
10511 : 20 : sym->result->refs++;
10512 : : }
10513 : : }
10514 : : else
10515 : 43 : sym->result = sym;
10516 : : }
10517 : :
10518 : : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
10519 : : the symbol existed before. */
10520 : 244 : sym->declared_at = gfc_current_locus;
10521 : :
10522 : 244 : if (!sym->attr.module_procedure)
10523 : : return MATCH_ERROR;
10524 : :
10525 : : /* Signal match_end to expect "end procedure". */
10526 : 242 : sym->abr_modproc_decl = 1;
10527 : :
10528 : : /* Change from IFSRC_IFBODY coming from the interface declaration. */
10529 : 242 : sym->attr.if_source = IFSRC_DECL;
10530 : :
10531 : 242 : gfc_new_block = sym;
10532 : :
10533 : : /* Make a new formal arglist with the symbols in the procedure
10534 : : namespace. */
10535 : 242 : head = tail = NULL;
10536 : 548 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
10537 : : {
10538 : 306 : if (formal == sym->formal)
10539 : 216 : head = tail = gfc_get_formal_arglist ();
10540 : : else
10541 : : {
10542 : 90 : tail->next = gfc_get_formal_arglist ();
10543 : 90 : tail = tail->next;
10544 : : }
10545 : :
10546 : 306 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
10547 : 0 : goto cleanup;
10548 : :
10549 : 306 : tail->sym = fsym;
10550 : 306 : gfc_set_sym_referenced (fsym);
10551 : : }
10552 : :
10553 : : /* The dummy symbols get cleaned up, when the formal_namespace of the
10554 : : interface declaration is cleared. This allows us to add the
10555 : : explicit interface as is done for other type of procedure. */
10556 : 242 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10557 : : &gfc_current_locus))
10558 : : return MATCH_ERROR;
10559 : :
10560 : 242 : if (gfc_match_eos () != MATCH_YES)
10561 : : {
10562 : : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10563 : : undone, such that the st->n.sym->formal points to the original symbol;
10564 : : if now this namespace is finalized, the formal namespace is freed,
10565 : : but it might be still needed in the parent namespace. */
10566 : 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10567 : 1 : st->n.sym = NULL;
10568 : 1 : gfc_free_symbol (sym->tlink);
10569 : 1 : sym->tlink = NULL;
10570 : 1 : sym->refs--;
10571 : 1 : gfc_syntax_error (ST_MODULE_PROC);
10572 : 1 : return MATCH_ERROR;
10573 : : }
10574 : :
10575 : : return MATCH_YES;
10576 : :
10577 : 0 : cleanup:
10578 : 0 : gfc_free_formal_arglist (head);
10579 : 0 : return MATCH_ERROR;
10580 : : }
10581 : :
10582 : :
10583 : : /* Match a module procedure statement. Note that we have to modify
10584 : : symbols in the parent's namespace because the current one was there
10585 : : to receive symbols that are in an interface's formal argument list. */
10586 : :
10587 : : match
10588 : 1456 : gfc_match_modproc (void)
10589 : : {
10590 : 1456 : char name[GFC_MAX_SYMBOL_LEN + 1];
10591 : 1456 : gfc_symbol *sym;
10592 : 1456 : match m;
10593 : 1456 : locus old_locus;
10594 : 1456 : gfc_namespace *module_ns;
10595 : 1456 : gfc_interface *old_interface_head, *interface;
10596 : :
10597 : 1456 : if (gfc_state_stack->previous == NULL
10598 : 1454 : || (gfc_state_stack->state != COMP_INTERFACE
10599 : 4 : && (gfc_state_stack->state != COMP_CONTAINS
10600 : 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10601 : 1450 : || current_interface.type == INTERFACE_NAMELESS
10602 : 1450 : || current_interface.type == INTERFACE_ABSTRACT)
10603 : : {
10604 : 7 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10605 : : "interface");
10606 : 7 : return MATCH_ERROR;
10607 : : }
10608 : :
10609 : 1449 : module_ns = gfc_current_ns->parent;
10610 : 1455 : for (; module_ns; module_ns = module_ns->parent)
10611 : 1455 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10612 : 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10613 : 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10614 : 12 : && !module_ns->proc_name->attr.contained))
10615 : : break;
10616 : :
10617 : 1449 : if (module_ns == NULL)
10618 : : return MATCH_ERROR;
10619 : :
10620 : : /* Store the current state of the interface. We will need it if we
10621 : : end up with a syntax error and need to recover. */
10622 : 1449 : old_interface_head = gfc_current_interface_head ();
10623 : :
10624 : : /* Check if the F2008 optional double colon appears. */
10625 : 1449 : gfc_gobble_whitespace ();
10626 : 1449 : old_locus = gfc_current_locus;
10627 : 1449 : if (gfc_match ("::") == MATCH_YES)
10628 : : {
10629 : 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10630 : : "MODULE PROCEDURE statement at %L", &old_locus))
10631 : : return MATCH_ERROR;
10632 : : }
10633 : : else
10634 : 1424 : gfc_current_locus = old_locus;
10635 : :
10636 : 1803 : for (;;)
10637 : : {
10638 : 1803 : bool last = false;
10639 : 1803 : old_locus = gfc_current_locus;
10640 : :
10641 : 1803 : m = gfc_match_name (name);
10642 : 1803 : if (m == MATCH_NO)
10643 : 1 : goto syntax;
10644 : 1802 : if (m != MATCH_YES)
10645 : : return MATCH_ERROR;
10646 : :
10647 : : /* Check for syntax error before starting to add symbols to the
10648 : : current namespace. */
10649 : 1802 : if (gfc_match_eos () == MATCH_YES)
10650 : : last = true;
10651 : :
10652 : 359 : if (!last && gfc_match_char (',') != MATCH_YES)
10653 : 2 : goto syntax;
10654 : :
10655 : : /* Now we're sure the syntax is valid, we process this item
10656 : : further. */
10657 : 1800 : if (gfc_get_symbol (name, module_ns, &sym))
10658 : : return MATCH_ERROR;
10659 : :
10660 : 1800 : if (sym->attr.intrinsic)
10661 : : {
10662 : 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10663 : : "PROCEDURE", &old_locus);
10664 : 1 : return MATCH_ERROR;
10665 : : }
10666 : :
10667 : 1799 : if (sym->attr.proc != PROC_MODULE
10668 : 1799 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10669 : : return MATCH_ERROR;
10670 : :
10671 : 1796 : if (!gfc_add_interface (sym))
10672 : : return MATCH_ERROR;
10673 : :
10674 : 1793 : sym->attr.mod_proc = 1;
10675 : 1793 : sym->declared_at = old_locus;
10676 : :
10677 : 1793 : if (last)
10678 : : break;
10679 : : }
10680 : :
10681 : : return MATCH_YES;
10682 : :
10683 : 3 : syntax:
10684 : : /* Restore the previous state of the interface. */
10685 : 3 : interface = gfc_current_interface_head ();
10686 : 3 : gfc_set_current_interface_head (old_interface_head);
10687 : :
10688 : : /* Free the new interfaces. */
10689 : 10 : while (interface != old_interface_head)
10690 : : {
10691 : 4 : gfc_interface *i = interface->next;
10692 : 4 : free (interface);
10693 : 4 : interface = i;
10694 : : }
10695 : :
10696 : : /* And issue a syntax error. */
10697 : 3 : gfc_syntax_error (ST_MODULE_PROC);
10698 : 3 : return MATCH_ERROR;
10699 : : }
10700 : :
10701 : :
10702 : : /* Check a derived type that is being extended. */
10703 : :
10704 : : static gfc_symbol*
10705 : 1443 : check_extended_derived_type (char *name)
10706 : : {
10707 : 1443 : gfc_symbol *extended;
10708 : :
10709 : 1443 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10710 : : {
10711 : 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10712 : 0 : return NULL;
10713 : : }
10714 : :
10715 : 1443 : extended = gfc_find_dt_in_generic (extended);
10716 : :
10717 : : /* F08:C428. */
10718 : 1443 : if (!extended)
10719 : : {
10720 : 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10721 : 2 : return NULL;
10722 : : }
10723 : :
10724 : 1441 : if (extended->attr.flavor != FL_DERIVED)
10725 : : {
10726 : 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10727 : : "derived type", name);
10728 : 0 : return NULL;
10729 : : }
10730 : :
10731 : 1441 : if (extended->attr.is_bind_c)
10732 : : {
10733 : 1 : gfc_error ("%qs cannot be extended at %C because it "
10734 : : "is BIND(C)", extended->name);
10735 : 1 : return NULL;
10736 : : }
10737 : :
10738 : 1440 : if (extended->attr.sequence)
10739 : : {
10740 : 1 : gfc_error ("%qs cannot be extended at %C because it "
10741 : : "is a SEQUENCE type", extended->name);
10742 : 1 : return NULL;
10743 : : }
10744 : :
10745 : : return extended;
10746 : : }
10747 : :
10748 : :
10749 : : /* Match the optional attribute specifiers for a type declaration.
10750 : : Return MATCH_ERROR if an error is encountered in one of the handled
10751 : : attributes (public, private, bind(c)), MATCH_NO if what's found is
10752 : : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10753 : : checking on attribute conflicts needs to be done. */
10754 : :
10755 : : static match
10756 : 18500 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10757 : : {
10758 : : /* See if the derived type is marked as private. */
10759 : 18500 : if (gfc_match (" , private") == MATCH_YES)
10760 : : {
10761 : 15 : if (gfc_current_state () != COMP_MODULE)
10762 : : {
10763 : 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
10764 : : "specification part of a module");
10765 : 1 : return MATCH_ERROR;
10766 : : }
10767 : :
10768 : 14 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10769 : : return MATCH_ERROR;
10770 : : }
10771 : 18485 : else if (gfc_match (" , public") == MATCH_YES)
10772 : : {
10773 : 545 : if (gfc_current_state () != COMP_MODULE)
10774 : : {
10775 : 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
10776 : : "specification part of a module");
10777 : 0 : return MATCH_ERROR;
10778 : : }
10779 : :
10780 : 545 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10781 : : return MATCH_ERROR;
10782 : : }
10783 : 17940 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
10784 : : {
10785 : : /* If the type is defined to be bind(c) it then needs to make
10786 : : sure that all fields are interoperable. This will
10787 : : need to be a semantic check on the finished derived type.
10788 : : See 15.2.3 (lines 9-12) of F2003 draft. */
10789 : 407 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10790 : : return MATCH_ERROR;
10791 : :
10792 : : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10793 : : }
10794 : 17533 : else if (gfc_match (" , abstract") == MATCH_YES)
10795 : : {
10796 : 320 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
10797 : : return MATCH_ERROR;
10798 : :
10799 : 319 : if (!gfc_add_abstract (attr, &gfc_current_locus))
10800 : : return MATCH_ERROR;
10801 : : }
10802 : 17213 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
10803 : : {
10804 : 1444 : if (!gfc_add_extension (attr, &gfc_current_locus))
10805 : : return MATCH_ERROR;
10806 : : }
10807 : : else
10808 : 15769 : return MATCH_NO;
10809 : :
10810 : : /* If we get here, something matched. */
10811 : : return MATCH_YES;
10812 : : }
10813 : :
10814 : :
10815 : : /* Common function for type declaration blocks similar to derived types, such
10816 : : as STRUCTURES and MAPs. Unlike derived types, a structure type
10817 : : does NOT have a generic symbol matching the name given by the user.
10818 : : STRUCTUREs can share names with variables and PARAMETERs so we must allow
10819 : : for the creation of an independent symbol.
10820 : : Other parameters are a message to prefix errors with, the name of the new
10821 : : type to be created, and the flavor to add to the resulting symbol. */
10822 : :
10823 : : static bool
10824 : 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
10825 : : gfc_symbol **result)
10826 : : {
10827 : 717 : gfc_symbol *sym;
10828 : 717 : locus where;
10829 : :
10830 : 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
10831 : :
10832 : 717 : if (decl)
10833 : 717 : where = *decl;
10834 : : else
10835 : 0 : where = gfc_current_locus;
10836 : :
10837 : 717 : if (gfc_get_symbol (name, NULL, &sym))
10838 : : return false;
10839 : :
10840 : 717 : if (!sym)
10841 : : {
10842 : 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
10843 : : return false;
10844 : : }
10845 : :
10846 : 717 : if (sym->components != NULL || sym->attr.zero_comp)
10847 : : {
10848 : 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
10849 : : sym->name, &sym->declared_at);
10850 : 3 : return false;
10851 : : }
10852 : :
10853 : 714 : sym->declared_at = where;
10854 : :
10855 : 714 : if (sym->attr.flavor != fl
10856 : 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
10857 : : return false;
10858 : :
10859 : 714 : if (!sym->hash_value)
10860 : : /* Set the hash for the compound name for this type. */
10861 : 713 : sym->hash_value = gfc_hash_value (sym);
10862 : :
10863 : : /* Normally the type is expected to have been completely parsed by the time
10864 : : a field declaration with this type is seen. For unions, maps, and nested
10865 : : structure declarations, we need to indicate that it is okay that we
10866 : : haven't seen any components yet. This will be updated after the structure
10867 : : is fully parsed. */
10868 : 714 : sym->attr.zero_comp = 0;
10869 : :
10870 : : /* Structures always act like derived-types with the SEQUENCE attribute */
10871 : 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
10872 : :
10873 : 714 : if (result) *result = sym;
10874 : :
10875 : : return true;
10876 : : }
10877 : :
10878 : :
10879 : : /* Match the opening of a MAP block. Like a struct within a union in C;
10880 : : behaves identical to STRUCTURE blocks. */
10881 : :
10882 : : match
10883 : 259 : gfc_match_map (void)
10884 : : {
10885 : : /* Counter used to give unique internal names to map structures. */
10886 : 259 : static unsigned int gfc_map_id = 0;
10887 : 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
10888 : 259 : gfc_symbol *sym;
10889 : 259 : locus old_loc;
10890 : :
10891 : 259 : old_loc = gfc_current_locus;
10892 : :
10893 : 259 : if (gfc_match_eos () != MATCH_YES)
10894 : : {
10895 : 1 : gfc_error ("Junk after MAP statement at %C");
10896 : 1 : gfc_current_locus = old_loc;
10897 : 1 : return MATCH_ERROR;
10898 : : }
10899 : :
10900 : : /* Map blocks are anonymous so we make up unique names for the symbol table
10901 : : which are invalid Fortran identifiers. */
10902 : 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
10903 : :
10904 : 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
10905 : : return MATCH_ERROR;
10906 : :
10907 : 258 : gfc_new_block = sym;
10908 : :
10909 : 258 : return MATCH_YES;
10910 : : }
10911 : :
10912 : :
10913 : : /* Match the opening of a UNION block. */
10914 : :
10915 : : match
10916 : 133 : gfc_match_union (void)
10917 : : {
10918 : : /* Counter used to give unique internal names to union types. */
10919 : 133 : static unsigned int gfc_union_id = 0;
10920 : 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
10921 : 133 : gfc_symbol *sym;
10922 : 133 : locus old_loc;
10923 : :
10924 : 133 : old_loc = gfc_current_locus;
10925 : :
10926 : 133 : if (gfc_match_eos () != MATCH_YES)
10927 : : {
10928 : 1 : gfc_error ("Junk after UNION statement at %C");
10929 : 1 : gfc_current_locus = old_loc;
10930 : 1 : return MATCH_ERROR;
10931 : : }
10932 : :
10933 : : /* Unions are anonymous so we make up unique names for the symbol table
10934 : : which are invalid Fortran identifiers. */
10935 : 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
10936 : :
10937 : 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
10938 : : return MATCH_ERROR;
10939 : :
10940 : 132 : gfc_new_block = sym;
10941 : :
10942 : 132 : return MATCH_YES;
10943 : : }
10944 : :
10945 : :
10946 : : /* Match the beginning of a STRUCTURE declaration. This is similar to
10947 : : matching the beginning of a derived type declaration with a few
10948 : : twists. The resulting type symbol has no access control or other
10949 : : interesting attributes. */
10950 : :
10951 : : match
10952 : 336 : gfc_match_structure_decl (void)
10953 : : {
10954 : : /* Counter used to give unique internal names to anonymous structures. */
10955 : 336 : static unsigned int gfc_structure_id = 0;
10956 : 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
10957 : 336 : gfc_symbol *sym;
10958 : 336 : match m;
10959 : 336 : locus where;
10960 : :
10961 : 336 : if (!flag_dec_structure)
10962 : : {
10963 : 3 : gfc_error ("%s at %C is a DEC extension, enable with "
10964 : : "%<-fdec-structure%>",
10965 : : "STRUCTURE");
10966 : 3 : return MATCH_ERROR;
10967 : : }
10968 : :
10969 : 333 : name[0] = '\0';
10970 : :
10971 : 333 : m = gfc_match (" /%n/", name);
10972 : 333 : if (m != MATCH_YES)
10973 : : {
10974 : : /* Non-nested structure declarations require a structure name. */
10975 : 24 : if (!gfc_comp_struct (gfc_current_state ()))
10976 : : {
10977 : 4 : gfc_error ("Structure name expected in non-nested structure "
10978 : : "declaration at %C");
10979 : 4 : return MATCH_ERROR;
10980 : : }
10981 : : /* This is an anonymous structure; make up a unique name for it
10982 : : (upper-case letters never make it to symbol names from the source).
10983 : : The important thing is initializing the type variable
10984 : : and setting gfc_new_symbol, which is immediately used by
10985 : : parse_structure () and variable_decl () to add components of
10986 : : this type. */
10987 : 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
10988 : : }
10989 : :
10990 : 329 : where = gfc_current_locus;
10991 : : /* No field list allowed after non-nested structure declaration. */
10992 : 329 : if (!gfc_comp_struct (gfc_current_state ())
10993 : 296 : && gfc_match_eos () != MATCH_YES)
10994 : : {
10995 : 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10996 : 1 : return MATCH_ERROR;
10997 : : }
10998 : :
10999 : : /* Make sure the name is not the name of an intrinsic type. */
11000 : 328 : if (gfc_is_intrinsic_typename (name))
11001 : : {
11002 : 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
11003 : : " intrinsic type", name);
11004 : 1 : return MATCH_ERROR;
11005 : : }
11006 : :
11007 : : /* Store the actual type symbol for the structure with an upper-case first
11008 : : letter (an invalid Fortran identifier). */
11009 : :
11010 : 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
11011 : : return MATCH_ERROR;
11012 : :
11013 : 324 : gfc_new_block = sym;
11014 : 324 : return MATCH_YES;
11015 : : }
11016 : :
11017 : :
11018 : : /* This function does some work to determine which matcher should be used to
11019 : : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
11020 : : * as an alias for PRINT from derived type declarations, TYPE IS statements,
11021 : : * and [parameterized] derived type declarations. */
11022 : :
11023 : : match
11024 : 511748 : gfc_match_type (gfc_statement *st)
11025 : : {
11026 : 511748 : char name[GFC_MAX_SYMBOL_LEN + 1];
11027 : 511748 : match m;
11028 : 511748 : locus old_loc;
11029 : :
11030 : : /* Requires -fdec. */
11031 : 511748 : if (!flag_dec)
11032 : : return MATCH_NO;
11033 : :
11034 : 2483 : m = gfc_match ("type");
11035 : 2483 : if (m != MATCH_YES)
11036 : : return m;
11037 : : /* If we already have an error in the buffer, it is probably from failing to
11038 : : * match a derived type data declaration. Let it happen. */
11039 : 20 : else if (gfc_error_flag_test ())
11040 : : return MATCH_NO;
11041 : :
11042 : 20 : old_loc = gfc_current_locus;
11043 : 20 : *st = ST_NONE;
11044 : :
11045 : : /* If we see an attribute list before anything else it's definitely a derived
11046 : : * type declaration. */
11047 : 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
11048 : 8 : goto derived;
11049 : :
11050 : : /* By now "TYPE" has already been matched. If we do not see a name, this may
11051 : : * be something like "TYPE *" or "TYPE <fmt>". */
11052 : 12 : m = gfc_match_name (name);
11053 : 12 : if (m != MATCH_YES)
11054 : : {
11055 : : /* Let print match if it can, otherwise throw an error from
11056 : : * gfc_match_derived_decl. */
11057 : 7 : gfc_current_locus = old_loc;
11058 : 7 : if (gfc_match_print () == MATCH_YES)
11059 : : {
11060 : 7 : *st = ST_WRITE;
11061 : 7 : return MATCH_YES;
11062 : : }
11063 : 0 : goto derived;
11064 : : }
11065 : :
11066 : : /* Check for EOS. */
11067 : 5 : if (gfc_match_eos () == MATCH_YES)
11068 : : {
11069 : : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
11070 : : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
11071 : : * Otherwise if gfc_match_derived_decl fails it's probably an existing
11072 : : * symbol which can be printed. */
11073 : 3 : gfc_current_locus = old_loc;
11074 : 3 : m = gfc_match_derived_decl ();
11075 : 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
11076 : : {
11077 : 2 : *st = ST_DERIVED_DECL;
11078 : 2 : return m;
11079 : : }
11080 : : }
11081 : : else
11082 : : {
11083 : : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
11084 : : like <type name(parameter)>. */
11085 : 2 : gfc_gobble_whitespace ();
11086 : 2 : bool paren = gfc_peek_ascii_char () == '(';
11087 : 2 : if (paren)
11088 : : {
11089 : 1 : if (strcmp ("is", name) == 0)
11090 : 1 : goto typeis;
11091 : : else
11092 : 0 : goto derived;
11093 : : }
11094 : : }
11095 : :
11096 : : /* Treat TYPE... like PRINT... */
11097 : 2 : gfc_current_locus = old_loc;
11098 : 2 : *st = ST_WRITE;
11099 : 2 : return gfc_match_print ();
11100 : :
11101 : 8 : derived:
11102 : 8 : gfc_current_locus = old_loc;
11103 : 8 : *st = ST_DERIVED_DECL;
11104 : 8 : return gfc_match_derived_decl ();
11105 : :
11106 : 1 : typeis:
11107 : 1 : gfc_current_locus = old_loc;
11108 : 1 : *st = ST_TYPE_IS;
11109 : 1 : return gfc_match_type_is ();
11110 : : }
11111 : :
11112 : :
11113 : : /* Match the beginning of a derived type declaration. If a type name
11114 : : was the result of a function, then it is possible to have a symbol
11115 : : already to be known as a derived type yet have no components. */
11116 : :
11117 : : match
11118 : 15776 : gfc_match_derived_decl (void)
11119 : : {
11120 : 15776 : char name[GFC_MAX_SYMBOL_LEN + 1];
11121 : 15776 : char parent[GFC_MAX_SYMBOL_LEN + 1];
11122 : 15776 : symbol_attribute attr;
11123 : 15776 : gfc_symbol *sym, *gensym;
11124 : 15776 : gfc_symbol *extended;
11125 : 15776 : match m;
11126 : 15776 : match is_type_attr_spec = MATCH_NO;
11127 : 15776 : bool seen_attr = false;
11128 : 15776 : gfc_interface *intr = NULL, *head;
11129 : 15776 : bool parameterized_type = false;
11130 : 15776 : bool seen_colons = false;
11131 : :
11132 : 15776 : if (gfc_comp_struct (gfc_current_state ()))
11133 : : return MATCH_NO;
11134 : :
11135 : 15772 : name[0] = '\0';
11136 : 15772 : parent[0] = '\0';
11137 : 15772 : gfc_clear_attr (&attr);
11138 : 15772 : extended = NULL;
11139 : :
11140 : 18500 : do
11141 : : {
11142 : 18500 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
11143 : 18500 : if (is_type_attr_spec == MATCH_ERROR)
11144 : : return MATCH_ERROR;
11145 : 18497 : if (is_type_attr_spec == MATCH_YES)
11146 : 2728 : seen_attr = true;
11147 : 18497 : } while (is_type_attr_spec == MATCH_YES);
11148 : :
11149 : : /* Deal with derived type extensions. The extension attribute has
11150 : : been added to 'attr' but now the parent type must be found and
11151 : : checked. */
11152 : 15769 : if (parent[0])
11153 : 1443 : extended = check_extended_derived_type (parent);
11154 : :
11155 : 15769 : if (parent[0] && !extended)
11156 : : return MATCH_ERROR;
11157 : :
11158 : 15765 : m = gfc_match (" ::");
11159 : 15765 : if (m == MATCH_YES)
11160 : : {
11161 : : seen_colons = true;
11162 : : }
11163 : 9952 : else if (seen_attr)
11164 : : {
11165 : 5 : gfc_error ("Expected :: in TYPE definition at %C");
11166 : 5 : return MATCH_ERROR;
11167 : : }
11168 : :
11169 : : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
11170 : : But, we need to simply return for TYPE(. */
11171 : 9947 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
11172 : : {
11173 : 9899 : char c = gfc_peek_ascii_char ();
11174 : 9899 : if (c == '(')
11175 : : return m;
11176 : 9835 : if (!gfc_is_whitespace (c))
11177 : : {
11178 : 4 : gfc_error ("Mangled derived type definition at %C");
11179 : 4 : return MATCH_NO;
11180 : : }
11181 : : }
11182 : :
11183 : 15692 : m = gfc_match (" %n ", name);
11184 : 15692 : if (m != MATCH_YES)
11185 : : return m;
11186 : :
11187 : : /* Make sure that we don't identify TYPE IS (...) as a parameterized
11188 : : derived type named 'is'.
11189 : : TODO Expand the check, when 'name' = "is" by matching " (tname) "
11190 : : and checking if this is a(n intrinsic) typename. This picks up
11191 : : misplaced TYPE IS statements such as in select_type_1.f03. */
11192 : 15681 : if (gfc_peek_ascii_char () == '(')
11193 : : {
11194 : 3735 : if (gfc_current_state () == COMP_SELECT_TYPE
11195 : 353 : || (!seen_colons && !strcmp (name, "is")))
11196 : : return MATCH_NO;
11197 : : parameterized_type = true;
11198 : : }
11199 : :
11200 : 12297 : m = gfc_match_eos ();
11201 : 12297 : if (m != MATCH_YES && !parameterized_type)
11202 : : return m;
11203 : :
11204 : : /* Make sure the name is not the name of an intrinsic type. */
11205 : 12294 : if (gfc_is_intrinsic_typename (name))
11206 : : {
11207 : 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
11208 : : "type", name);
11209 : 18 : return MATCH_ERROR;
11210 : : }
11211 : :
11212 : 12276 : if (gfc_get_symbol (name, NULL, &gensym))
11213 : : return MATCH_ERROR;
11214 : :
11215 : 12276 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
11216 : : {
11217 : 5 : if (gensym->ts.u.derived)
11218 : 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
11219 : : "of %s", gensym->name, gfc_typename (&gensym->ts));
11220 : : else
11221 : 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
11222 : : gensym->name);
11223 : 5 : return MATCH_ERROR;
11224 : : }
11225 : :
11226 : 12271 : if (!gensym->attr.generic
11227 : 12271 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
11228 : : return MATCH_ERROR;
11229 : :
11230 : 12267 : if (!gensym->attr.function
11231 : 12267 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
11232 : : return MATCH_ERROR;
11233 : :
11234 : 12266 : if (gensym->attr.dummy)
11235 : : {
11236 : 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
11237 : : name, &gensym->declared_at);
11238 : 1 : return MATCH_ERROR;
11239 : : }
11240 : :
11241 : 12265 : sym = gfc_find_dt_in_generic (gensym);
11242 : :
11243 : 12265 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
11244 : : {
11245 : 1 : gfc_error ("Derived type definition of %qs at %C has already been "
11246 : : "defined", sym->name);
11247 : 1 : return MATCH_ERROR;
11248 : : }
11249 : :
11250 : 12264 : if (!sym)
11251 : : {
11252 : : /* Use upper case to save the actual derived-type symbol. */
11253 : 12179 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
11254 : 12179 : sym->name = gfc_get_string ("%s", gensym->name);
11255 : 12179 : head = gensym->generic;
11256 : 12179 : intr = gfc_get_interface ();
11257 : 12179 : intr->sym = sym;
11258 : 12179 : intr->where = gfc_current_locus;
11259 : 12179 : intr->sym->declared_at = gfc_current_locus;
11260 : 12179 : intr->next = head;
11261 : 12179 : gensym->generic = intr;
11262 : 12179 : gensym->attr.if_source = IFSRC_DECL;
11263 : : }
11264 : :
11265 : : /* The symbol may already have the derived attribute without the
11266 : : components. The ways this can happen is via a function
11267 : : definition, an INTRINSIC statement or a subtype in another
11268 : : derived type that is a pointer. The first part of the AND clause
11269 : : is true if the symbol is not the return value of a function. */
11270 : 12264 : if (sym->attr.flavor != FL_DERIVED
11271 : 12264 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
11272 : : return MATCH_ERROR;
11273 : :
11274 : 12264 : if (attr.access != ACCESS_UNKNOWN
11275 : 12264 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
11276 : : return MATCH_ERROR;
11277 : 12264 : else if (sym->attr.access == ACCESS_UNKNOWN
11278 : 11709 : && gensym->attr.access != ACCESS_UNKNOWN
11279 : 12578 : && !gfc_add_access (&sym->attr, gensym->attr.access,
11280 : : sym->name, NULL))
11281 : : return MATCH_ERROR;
11282 : :
11283 : 12264 : if (sym->attr.access != ACCESS_UNKNOWN
11284 : 869 : && gensym->attr.access == ACCESS_UNKNOWN)
11285 : 555 : gensym->attr.access = sym->attr.access;
11286 : :
11287 : : /* See if the derived type was labeled as bind(c). */
11288 : 12264 : if (attr.is_bind_c != 0)
11289 : 404 : sym->attr.is_bind_c = attr.is_bind_c;
11290 : :
11291 : : /* Construct the f2k_derived namespace if it is not yet there. */
11292 : 12264 : if (!sym->f2k_derived)
11293 : 12264 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
11294 : :
11295 : 12264 : if (parameterized_type)
11296 : : {
11297 : : /* Ignore error or mismatches by going to the end of the statement
11298 : : in order to avoid the component declarations causing problems. */
11299 : 351 : m = gfc_match_formal_arglist (sym, 0, 0, true);
11300 : 351 : if (m != MATCH_YES)
11301 : 4 : gfc_error_recovery ();
11302 : : else
11303 : 347 : sym->attr.pdt_template = 1;
11304 : 351 : m = gfc_match_eos ();
11305 : 351 : if (m != MATCH_YES)
11306 : : {
11307 : 1 : gfc_error_recovery ();
11308 : 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
11309 : : }
11310 : : }
11311 : :
11312 : 12264 : if (extended && !sym->components)
11313 : : {
11314 : 1439 : gfc_component *p;
11315 : 1439 : gfc_formal_arglist *f, *g, *h;
11316 : :
11317 : : /* Add the extended derived type as the first component. */
11318 : 1439 : gfc_add_component (sym, parent, &p);
11319 : 1439 : extended->refs++;
11320 : 1439 : gfc_set_sym_referenced (extended);
11321 : :
11322 : 1439 : p->ts.type = BT_DERIVED;
11323 : 1439 : p->ts.u.derived = extended;
11324 : 1439 : p->initializer = gfc_default_initializer (&p->ts);
11325 : :
11326 : : /* Set extension level. */
11327 : 1439 : if (extended->attr.extension == 255)
11328 : : {
11329 : : /* Since the extension field is 8 bit wide, we can only have
11330 : : up to 255 extension levels. */
11331 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
11332 : : extended->name, &extended->declared_at);
11333 : 0 : return MATCH_ERROR;
11334 : : }
11335 : 1439 : sym->attr.extension = extended->attr.extension + 1;
11336 : :
11337 : : /* Provide the links between the extended type and its extension. */
11338 : 1439 : if (!extended->f2k_derived)
11339 : 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
11340 : :
11341 : : /* Copy the extended type-param-name-list from the extended type,
11342 : : append those of the extension and add the whole lot to the
11343 : : extension. */
11344 : 1439 : if (extended->attr.pdt_template)
11345 : : {
11346 : 28 : g = h = NULL;
11347 : 28 : sym->attr.pdt_template = 1;
11348 : 87 : for (f = extended->formal; f; f = f->next)
11349 : : {
11350 : 59 : if (f == extended->formal)
11351 : : {
11352 : 28 : g = gfc_get_formal_arglist ();
11353 : 28 : h = g;
11354 : : }
11355 : : else
11356 : : {
11357 : 31 : g->next = gfc_get_formal_arglist ();
11358 : 31 : g = g->next;
11359 : : }
11360 : 59 : g->sym = f->sym;
11361 : : }
11362 : 28 : g->next = sym->formal;
11363 : 28 : sym->formal = h;
11364 : : }
11365 : : }
11366 : :
11367 : 12264 : if (!sym->hash_value)
11368 : : /* Set the hash for the compound name for this type. */
11369 : 12264 : sym->hash_value = gfc_hash_value (sym);
11370 : :
11371 : : /* Take over the ABSTRACT attribute. */
11372 : 12264 : sym->attr.abstract = attr.abstract;
11373 : :
11374 : 12264 : gfc_new_block = sym;
11375 : :
11376 : 12264 : return MATCH_YES;
11377 : : }
11378 : :
11379 : :
11380 : : /* Cray Pointees can be declared as:
11381 : : pointer (ipt, a (n,m,...,*)) */
11382 : :
11383 : : match
11384 : 240 : gfc_mod_pointee_as (gfc_array_spec *as)
11385 : : {
11386 : 240 : as->cray_pointee = true; /* This will be useful to know later. */
11387 : 240 : if (as->type == AS_ASSUMED_SIZE)
11388 : 72 : as->cp_was_assumed = true;
11389 : 168 : else if (as->type == AS_ASSUMED_SHAPE)
11390 : : {
11391 : 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
11392 : 0 : return MATCH_ERROR;
11393 : : }
11394 : : return MATCH_YES;
11395 : : }
11396 : :
11397 : :
11398 : : /* Match the enum definition statement, here we are trying to match
11399 : : the first line of enum definition statement.
11400 : : Returns MATCH_YES if match is found. */
11401 : :
11402 : : match
11403 : 158 : gfc_match_enum (void)
11404 : : {
11405 : 158 : match m;
11406 : :
11407 : 158 : m = gfc_match_eos ();
11408 : 158 : if (m != MATCH_YES)
11409 : : return m;
11410 : :
11411 : 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
11412 : 0 : return MATCH_ERROR;
11413 : :
11414 : : return MATCH_YES;
11415 : : }
11416 : :
11417 : :
11418 : : /* Returns an initializer whose value is one higher than the value of the
11419 : : LAST_INITIALIZER argument. If the argument is NULL, the
11420 : : initializers value will be set to zero. The initializer's kind
11421 : : will be set to gfc_c_int_kind.
11422 : :
11423 : : If -fshort-enums is given, the appropriate kind will be selected
11424 : : later after all enumerators have been parsed. A warning is issued
11425 : : here if an initializer exceeds gfc_c_int_kind. */
11426 : :
11427 : : static gfc_expr *
11428 : 377 : enum_initializer (gfc_expr *last_initializer, locus where)
11429 : : {
11430 : 377 : gfc_expr *result;
11431 : 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
11432 : :
11433 : 377 : mpz_init (result->value.integer);
11434 : :
11435 : 377 : if (last_initializer != NULL)
11436 : : {
11437 : 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
11438 : 266 : result->where = last_initializer->where;
11439 : :
11440 : 266 : if (gfc_check_integer_range (result->value.integer,
11441 : : gfc_c_int_kind) != ARITH_OK)
11442 : : {
11443 : 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
11444 : 0 : return NULL;
11445 : : }
11446 : : }
11447 : : else
11448 : : {
11449 : : /* Control comes here, if it's the very first enumerator and no
11450 : : initializer has been given. It will be initialized to zero. */
11451 : 111 : mpz_set_si (result->value.integer, 0);
11452 : : }
11453 : :
11454 : : return result;
11455 : : }
11456 : :
11457 : :
11458 : : /* Match a variable name with an optional initializer. When this
11459 : : subroutine is called, a variable is expected to be parsed next.
11460 : : Depending on what is happening at the moment, updates either the
11461 : : symbol table or the current interface. */
11462 : :
11463 : : static match
11464 : 549 : enumerator_decl (void)
11465 : : {
11466 : 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
11467 : 549 : gfc_expr *initializer;
11468 : 549 : gfc_array_spec *as = NULL;
11469 : 549 : gfc_symbol *sym;
11470 : 549 : locus var_locus;
11471 : 549 : match m;
11472 : 549 : bool t;
11473 : 549 : locus old_locus;
11474 : :
11475 : 549 : initializer = NULL;
11476 : 549 : old_locus = gfc_current_locus;
11477 : :
11478 : : /* When we get here, we've just matched a list of attributes and
11479 : : maybe a type and a double colon. The next thing we expect to see
11480 : : is the name of the symbol. */
11481 : 549 : m = gfc_match_name (name);
11482 : 549 : if (m != MATCH_YES)
11483 : 1 : goto cleanup;
11484 : :
11485 : 548 : var_locus = gfc_current_locus;
11486 : :
11487 : : /* OK, we've successfully matched the declaration. Now put the
11488 : : symbol in the current namespace. If we fail to create the symbol,
11489 : : bail out. */
11490 : 548 : if (!build_sym (name, 1, NULL, false, &as, &var_locus))
11491 : : {
11492 : 1 : m = MATCH_ERROR;
11493 : 1 : goto cleanup;
11494 : : }
11495 : :
11496 : : /* The double colon must be present in order to have initializers.
11497 : : Otherwise the statement is ambiguous with an assignment statement. */
11498 : 547 : if (colon_seen)
11499 : : {
11500 : 471 : if (gfc_match_char ('=') == MATCH_YES)
11501 : : {
11502 : 170 : m = gfc_match_init_expr (&initializer);
11503 : 170 : if (m == MATCH_NO)
11504 : : {
11505 : 0 : gfc_error ("Expected an initialization expression at %C");
11506 : 0 : m = MATCH_ERROR;
11507 : : }
11508 : :
11509 : 170 : if (m != MATCH_YES)
11510 : 2 : goto cleanup;
11511 : : }
11512 : : }
11513 : :
11514 : : /* If we do not have an initializer, the initialization value of the
11515 : : previous enumerator (stored in last_initializer) is incremented
11516 : : by 1 and is used to initialize the current enumerator. */
11517 : 545 : if (initializer == NULL)
11518 : 377 : initializer = enum_initializer (last_initializer, old_locus);
11519 : :
11520 : 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
11521 : : {
11522 : 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
11523 : : &var_locus);
11524 : 2 : m = MATCH_ERROR;
11525 : 2 : goto cleanup;
11526 : : }
11527 : :
11528 : : /* Store this current initializer, for the next enumerator variable
11529 : : to be parsed. add_init_expr_to_sym() zeros initializer, so we
11530 : : use last_initializer below. */
11531 : 543 : last_initializer = initializer;
11532 : 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
11533 : :
11534 : : /* Maintain enumerator history. */
11535 : 543 : gfc_find_symbol (name, NULL, 0, &sym);
11536 : 543 : create_enum_history (sym, last_initializer);
11537 : :
11538 : 543 : return (t) ? MATCH_YES : MATCH_ERROR;
11539 : :
11540 : 6 : cleanup:
11541 : : /* Free stuff up and return. */
11542 : 6 : gfc_free_expr (initializer);
11543 : :
11544 : 6 : return m;
11545 : : }
11546 : :
11547 : :
11548 : : /* Match the enumerator definition statement. */
11549 : :
11550 : : match
11551 : 785042 : gfc_match_enumerator_def (void)
11552 : : {
11553 : 785042 : match m;
11554 : 785042 : bool t;
11555 : :
11556 : 785042 : gfc_clear_ts (¤t_ts);
11557 : :
11558 : 785042 : m = gfc_match (" enumerator");
11559 : 785042 : if (m != MATCH_YES)
11560 : : return m;
11561 : :
11562 : 269 : m = gfc_match (" :: ");
11563 : 269 : if (m == MATCH_ERROR)
11564 : : return m;
11565 : :
11566 : 269 : colon_seen = (m == MATCH_YES);
11567 : :
11568 : 269 : if (gfc_current_state () != COMP_ENUM)
11569 : : {
11570 : 4 : gfc_error ("ENUM definition statement expected before %C");
11571 : 4 : gfc_free_enum_history ();
11572 : 4 : return MATCH_ERROR;
11573 : : }
11574 : :
11575 : 265 : (¤t_ts)->type = BT_INTEGER;
11576 : 265 : (¤t_ts)->kind = gfc_c_int_kind;
11577 : :
11578 : 265 : gfc_clear_attr (¤t_attr);
11579 : 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11580 : 265 : if (!t)
11581 : : {
11582 : 0 : m = MATCH_ERROR;
11583 : 0 : goto cleanup;
11584 : : }
11585 : :
11586 : 549 : for (;;)
11587 : : {
11588 : 549 : m = enumerator_decl ();
11589 : 549 : if (m == MATCH_ERROR)
11590 : : {
11591 : 6 : gfc_free_enum_history ();
11592 : 6 : goto cleanup;
11593 : : }
11594 : 543 : if (m == MATCH_NO)
11595 : : break;
11596 : :
11597 : 542 : if (gfc_match_eos () == MATCH_YES)
11598 : 256 : goto cleanup;
11599 : 286 : if (gfc_match_char (',') != MATCH_YES)
11600 : : break;
11601 : : }
11602 : :
11603 : 3 : if (gfc_current_state () == COMP_ENUM)
11604 : : {
11605 : 3 : gfc_free_enum_history ();
11606 : 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11607 : 3 : m = MATCH_ERROR;
11608 : : }
11609 : :
11610 : 0 : cleanup:
11611 : 265 : gfc_free_array_spec (current_as);
11612 : 265 : current_as = NULL;
11613 : 265 : return m;
11614 : :
11615 : : }
11616 : :
11617 : :
11618 : : /* Match binding attributes. */
11619 : :
11620 : : static match
11621 : 4509 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11622 : : {
11623 : 4509 : bool found_passing = false;
11624 : 4509 : bool seen_ptr = false;
11625 : 4509 : match m = MATCH_YES;
11626 : :
11627 : : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11628 : : this case the defaults are in there. */
11629 : 4509 : ba->access = ACCESS_UNKNOWN;
11630 : 4509 : ba->pass_arg = NULL;
11631 : 4509 : ba->pass_arg_num = 0;
11632 : 4509 : ba->nopass = 0;
11633 : 4509 : ba->non_overridable = 0;
11634 : 4509 : ba->deferred = 0;
11635 : 4509 : ba->ppc = ppc;
11636 : :
11637 : : /* If we find a comma, we believe there are binding attributes. */
11638 : 4509 : m = gfc_match_char (',');
11639 : 4509 : if (m == MATCH_NO)
11640 : 2302 : goto done;
11641 : :
11642 : 2747 : do
11643 : : {
11644 : : /* Access specifier. */
11645 : :
11646 : 2747 : m = gfc_match (" public");
11647 : 2747 : if (m == MATCH_ERROR)
11648 : 0 : goto error;
11649 : 2747 : if (m == MATCH_YES)
11650 : : {
11651 : 250 : if (ba->access != ACCESS_UNKNOWN)
11652 : : {
11653 : 0 : gfc_error ("Duplicate access-specifier at %C");
11654 : 0 : goto error;
11655 : : }
11656 : :
11657 : 250 : ba->access = ACCESS_PUBLIC;
11658 : 250 : continue;
11659 : : }
11660 : :
11661 : 2497 : m = gfc_match (" private");
11662 : 2497 : if (m == MATCH_ERROR)
11663 : 0 : goto error;
11664 : 2497 : if (m == MATCH_YES)
11665 : : {
11666 : 163 : if (ba->access != ACCESS_UNKNOWN)
11667 : : {
11668 : 1 : gfc_error ("Duplicate access-specifier at %C");
11669 : 1 : goto error;
11670 : : }
11671 : :
11672 : 162 : ba->access = ACCESS_PRIVATE;
11673 : 162 : continue;
11674 : : }
11675 : :
11676 : : /* If inside GENERIC, the following is not allowed. */
11677 : 2334 : if (!generic)
11678 : : {
11679 : :
11680 : : /* NOPASS flag. */
11681 : 2333 : m = gfc_match (" nopass");
11682 : 2333 : if (m == MATCH_ERROR)
11683 : 0 : goto error;
11684 : 2333 : if (m == MATCH_YES)
11685 : : {
11686 : 700 : if (found_passing)
11687 : : {
11688 : 1 : gfc_error ("Binding attributes already specify passing,"
11689 : : " illegal NOPASS at %C");
11690 : 1 : goto error;
11691 : : }
11692 : :
11693 : 699 : found_passing = true;
11694 : 699 : ba->nopass = 1;
11695 : 699 : continue;
11696 : : }
11697 : :
11698 : : /* PASS possibly including argument. */
11699 : 1633 : m = gfc_match (" pass");
11700 : 1633 : if (m == MATCH_ERROR)
11701 : 0 : goto error;
11702 : 1633 : if (m == MATCH_YES)
11703 : : {
11704 : 890 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11705 : :
11706 : 890 : if (found_passing)
11707 : : {
11708 : 2 : gfc_error ("Binding attributes already specify passing,"
11709 : : " illegal PASS at %C");
11710 : 2 : goto error;
11711 : : }
11712 : :
11713 : 888 : m = gfc_match (" ( %n )", arg);
11714 : 888 : if (m == MATCH_ERROR)
11715 : 0 : goto error;
11716 : 888 : if (m == MATCH_YES)
11717 : 480 : ba->pass_arg = gfc_get_string ("%s", arg);
11718 : 888 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11719 : :
11720 : 888 : found_passing = true;
11721 : 888 : ba->nopass = 0;
11722 : 888 : continue;
11723 : 888 : }
11724 : :
11725 : 743 : if (ppc)
11726 : : {
11727 : : /* POINTER flag. */
11728 : 423 : m = gfc_match (" pointer");
11729 : 423 : if (m == MATCH_ERROR)
11730 : 0 : goto error;
11731 : 423 : if (m == MATCH_YES)
11732 : : {
11733 : 423 : if (seen_ptr)
11734 : : {
11735 : 1 : gfc_error ("Duplicate POINTER attribute at %C");
11736 : 1 : goto error;
11737 : : }
11738 : :
11739 : 422 : seen_ptr = true;
11740 : 422 : continue;
11741 : : }
11742 : : }
11743 : : else
11744 : : {
11745 : : /* NON_OVERRIDABLE flag. */
11746 : 320 : m = gfc_match (" non_overridable");
11747 : 320 : if (m == MATCH_ERROR)
11748 : 0 : goto error;
11749 : 320 : if (m == MATCH_YES)
11750 : : {
11751 : 62 : if (ba->non_overridable)
11752 : : {
11753 : 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11754 : 1 : goto error;
11755 : : }
11756 : :
11757 : 61 : ba->non_overridable = 1;
11758 : 61 : continue;
11759 : : }
11760 : :
11761 : : /* DEFERRED flag. */
11762 : 258 : m = gfc_match (" deferred");
11763 : 258 : if (m == MATCH_ERROR)
11764 : 0 : goto error;
11765 : 258 : if (m == MATCH_YES)
11766 : : {
11767 : 258 : if (ba->deferred)
11768 : : {
11769 : 1 : gfc_error ("Duplicate DEFERRED at %C");
11770 : 1 : goto error;
11771 : : }
11772 : :
11773 : 257 : ba->deferred = 1;
11774 : 257 : continue;
11775 : : }
11776 : : }
11777 : :
11778 : : }
11779 : :
11780 : : /* Nothing matching found. */
11781 : 1 : if (generic)
11782 : 1 : gfc_error ("Expected access-specifier at %C");
11783 : : else
11784 : 0 : gfc_error ("Expected binding attribute at %C");
11785 : 1 : goto error;
11786 : : }
11787 : 2739 : while (gfc_match_char (',') == MATCH_YES);
11788 : :
11789 : : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11790 : 2199 : if (ba->non_overridable && ba->deferred)
11791 : : {
11792 : 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11793 : 1 : goto error;
11794 : : }
11795 : :
11796 : : m = MATCH_YES;
11797 : :
11798 : 4500 : done:
11799 : 4500 : if (ba->access == ACCESS_UNKNOWN)
11800 : 4089 : ba->access = ppc ? gfc_current_block()->component_access
11801 : : : gfc_typebound_default_access;
11802 : :
11803 : 4500 : if (ppc && !seen_ptr)
11804 : : {
11805 : 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
11806 : : " at %C");
11807 : 2 : goto error;
11808 : : }
11809 : :
11810 : : return m;
11811 : :
11812 : : error:
11813 : : return MATCH_ERROR;
11814 : : }
11815 : :
11816 : :
11817 : : /* Match a PROCEDURE specific binding inside a derived type. */
11818 : :
11819 : : static match
11820 : 3099 : match_procedure_in_type (void)
11821 : : {
11822 : 3099 : char name[GFC_MAX_SYMBOL_LEN + 1];
11823 : 3099 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
11824 : 3099 : char* target = NULL, *ifc = NULL;
11825 : 3099 : gfc_typebound_proc tb;
11826 : 3099 : bool seen_colons;
11827 : 3099 : bool seen_attrs;
11828 : 3099 : match m;
11829 : 3099 : gfc_symtree* stree;
11830 : 3099 : gfc_namespace* ns;
11831 : 3099 : gfc_symbol* block;
11832 : 3099 : int num;
11833 : :
11834 : : /* Check current state. */
11835 : 3099 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
11836 : 3099 : block = gfc_state_stack->previous->sym;
11837 : 3099 : gcc_assert (block);
11838 : :
11839 : : /* Try to match PROCEDURE(interface). */
11840 : 3099 : if (gfc_match (" (") == MATCH_YES)
11841 : : {
11842 : 259 : m = gfc_match_name (target_buf);
11843 : 259 : if (m == MATCH_ERROR)
11844 : : return m;
11845 : 259 : if (m != MATCH_YES)
11846 : : {
11847 : 1 : gfc_error ("Interface-name expected after %<(%> at %C");
11848 : 1 : return MATCH_ERROR;
11849 : : }
11850 : :
11851 : 258 : if (gfc_match (" )") != MATCH_YES)
11852 : : {
11853 : 1 : gfc_error ("%<)%> expected at %C");
11854 : 1 : return MATCH_ERROR;
11855 : : }
11856 : :
11857 : : ifc = target_buf;
11858 : : }
11859 : :
11860 : : /* Construct the data structure. */
11861 : 3097 : memset (&tb, 0, sizeof (tb));
11862 : 3097 : tb.where = gfc_current_locus;
11863 : :
11864 : : /* Match binding attributes. */
11865 : 3097 : m = match_binding_attributes (&tb, false, false);
11866 : 3097 : if (m == MATCH_ERROR)
11867 : : return m;
11868 : 3090 : seen_attrs = (m == MATCH_YES);
11869 : :
11870 : : /* Check that attribute DEFERRED is given if an interface is specified. */
11871 : 3090 : if (tb.deferred && !ifc)
11872 : : {
11873 : 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
11874 : 1 : return MATCH_ERROR;
11875 : : }
11876 : 3089 : if (ifc && !tb.deferred)
11877 : : {
11878 : 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11879 : 1 : return MATCH_ERROR;
11880 : : }
11881 : :
11882 : : /* Match the colons. */
11883 : 3088 : m = gfc_match (" ::");
11884 : 3088 : if (m == MATCH_ERROR)
11885 : : return m;
11886 : 3088 : seen_colons = (m == MATCH_YES);
11887 : 3088 : if (seen_attrs && !seen_colons)
11888 : : {
11889 : 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
11890 : 4 : return MATCH_ERROR;
11891 : : }
11892 : :
11893 : : /* Match the binding names. */
11894 : 19 : for(num=1;;num++)
11895 : : {
11896 : 3103 : m = gfc_match_name (name);
11897 : 3103 : if (m == MATCH_ERROR)
11898 : : return m;
11899 : 3103 : if (m == MATCH_NO)
11900 : : {
11901 : 5 : gfc_error ("Expected binding name at %C");
11902 : 5 : return MATCH_ERROR;
11903 : : }
11904 : :
11905 : 3098 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
11906 : : return MATCH_ERROR;
11907 : :
11908 : : /* Try to match the '=> target', if it's there. */
11909 : 3097 : target = ifc;
11910 : 3097 : m = gfc_match (" =>");
11911 : 3097 : if (m == MATCH_ERROR)
11912 : : return m;
11913 : 3097 : if (m == MATCH_YES)
11914 : : {
11915 : 1231 : if (tb.deferred)
11916 : : {
11917 : 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11918 : 1 : return MATCH_ERROR;
11919 : : }
11920 : :
11921 : 1230 : if (!seen_colons)
11922 : : {
11923 : 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11924 : : " at %C");
11925 : 1 : return MATCH_ERROR;
11926 : : }
11927 : :
11928 : 1229 : m = gfc_match_name (target_buf);
11929 : 1229 : if (m == MATCH_ERROR)
11930 : : return m;
11931 : 1229 : if (m == MATCH_NO)
11932 : : {
11933 : 2 : gfc_error ("Expected binding target after %<=>%> at %C");
11934 : 2 : return MATCH_ERROR;
11935 : : }
11936 : : target = target_buf;
11937 : : }
11938 : :
11939 : : /* If no target was found, it has the same name as the binding. */
11940 : 1866 : if (!target)
11941 : 1613 : target = name;
11942 : :
11943 : : /* Get the namespace to insert the symbols into. */
11944 : 3093 : ns = block->f2k_derived;
11945 : 3093 : gcc_assert (ns);
11946 : :
11947 : : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11948 : 3093 : if (tb.deferred && !block->attr.abstract)
11949 : : {
11950 : 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
11951 : : "is not ABSTRACT", block->name);
11952 : 1 : return MATCH_ERROR;
11953 : : }
11954 : :
11955 : : /* See if we already have a binding with this name in the symtree which
11956 : : would be an error. If a GENERIC already targeted this binding, it may
11957 : : be already there but then typebound is still NULL. */
11958 : 3092 : stree = gfc_find_symtree (ns->tb_sym_root, name);
11959 : 3092 : if (stree && stree->n.tb)
11960 : : {
11961 : 2 : gfc_error ("There is already a procedure with binding name %qs for "
11962 : : "the derived type %qs at %C", name, block->name);
11963 : 2 : return MATCH_ERROR;
11964 : : }
11965 : :
11966 : : /* Insert it and set attributes. */
11967 : :
11968 : 2997 : if (!stree)
11969 : : {
11970 : 2997 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
11971 : 2997 : gcc_assert (stree);
11972 : : }
11973 : 3090 : stree->n.tb = gfc_get_typebound_proc (&tb);
11974 : :
11975 : 3090 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
11976 : : false))
11977 : : return MATCH_ERROR;
11978 : 3090 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
11979 : 3090 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
11980 : 3090 : target, &stree->n.tb->u.specific->n.sym->declared_at);
11981 : :
11982 : 3090 : if (gfc_match_eos () == MATCH_YES)
11983 : : return MATCH_YES;
11984 : 20 : if (gfc_match_char (',') != MATCH_YES)
11985 : 1 : goto syntax;
11986 : : }
11987 : :
11988 : 1 : syntax:
11989 : 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
11990 : 1 : return MATCH_ERROR;
11991 : : }
11992 : :
11993 : :
11994 : : /* Match a GENERIC statement.
11995 : : F2018 15.4.3.3 GENERIC statement
11996 : :
11997 : : A GENERIC statement specifies a generic identifier for one or more specific
11998 : : procedures, in the same way as a generic interface block that does not contain
11999 : : interface bodies.
12000 : :
12001 : : R1510 generic-stmt is:
12002 : : GENERIC [ , access-spec ] :: generic-spec => specific-procedure-list
12003 : :
12004 : : C1510 (R1510) A specific-procedure in a GENERIC statement shall not specify a
12005 : : procedure that was specified previously in any accessible interface with the
12006 : : same generic identifier.
12007 : :
12008 : : If access-spec appears, it specifies the accessibility (8.5.2) of generic-spec.
12009 : :
12010 : : For GENERIC statements outside of a derived type, use is made of the existing,
12011 : : typebound matching functions to obtain access-spec and generic-spec. After
12012 : : this the standard INTERFACE machinery is used. */
12013 : :
12014 : : static match
12015 : 100 : match_generic_stmt (void)
12016 : : {
12017 : 100 : char name[GFC_MAX_SYMBOL_LEN + 1];
12018 : : /* Allow space for OPERATOR(...). */
12019 : 100 : char generic_spec_name[GFC_MAX_SYMBOL_LEN + 16];
12020 : : /* Generics other than uops */
12021 : 100 : gfc_symbol* generic_spec = NULL;
12022 : : /* Generic uops */
12023 : 100 : gfc_user_op *generic_uop = NULL;
12024 : : /* For the matching calls */
12025 : 100 : gfc_typebound_proc tbattr;
12026 : 100 : gfc_namespace* ns = gfc_current_ns;
12027 : 100 : interface_type op_type;
12028 : 100 : gfc_intrinsic_op op;
12029 : 100 : match m;
12030 : 100 : gfc_symtree* st;
12031 : : /* The specific-procedure-list */
12032 : 100 : gfc_interface *generic = NULL;
12033 : : /* The head of the specific-procedure-list */
12034 : 100 : gfc_interface **generic_tail = NULL;
12035 : :
12036 : 100 : memset (&tbattr, 0, sizeof (tbattr));
12037 : 100 : tbattr.where = gfc_current_locus;
12038 : :
12039 : : /* See if we get an access-specifier. */
12040 : 100 : m = match_binding_attributes (&tbattr, true, false);
12041 : 100 : tbattr.where = gfc_current_locus;
12042 : 100 : if (m == MATCH_ERROR)
12043 : 0 : goto error;
12044 : :
12045 : : /* Now the colons, those are required. */
12046 : 100 : if (gfc_match (" ::") != MATCH_YES)
12047 : : {
12048 : 0 : gfc_error ("Expected %<::%> at %C");
12049 : 0 : goto error;
12050 : : }
12051 : :
12052 : : /* Match the generic-spec name; depending on type (operator / generic) format
12053 : : it for future error messages in 'generic_spec_name'. */
12054 : 100 : m = gfc_match_generic_spec (&op_type, name, &op);
12055 : 100 : if (m == MATCH_ERROR)
12056 : : return MATCH_ERROR;
12057 : 100 : if (m == MATCH_NO)
12058 : : {
12059 : 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12060 : 0 : goto error;
12061 : : }
12062 : :
12063 : 100 : switch (op_type)
12064 : : {
12065 : 63 : case INTERFACE_GENERIC:
12066 : 63 : case INTERFACE_DTIO:
12067 : 63 : snprintf (generic_spec_name, sizeof (generic_spec_name), "%s", name);
12068 : 63 : break;
12069 : :
12070 : 22 : case INTERFACE_USER_OP:
12071 : 22 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(.%s.)", name);
12072 : 22 : break;
12073 : :
12074 : 13 : case INTERFACE_INTRINSIC_OP:
12075 : 13 : snprintf (generic_spec_name, sizeof (generic_spec_name), "OPERATOR(%s)",
12076 : : gfc_op2string (op));
12077 : 13 : break;
12078 : :
12079 : 2 : case INTERFACE_NAMELESS:
12080 : 2 : gfc_error ("Malformed GENERIC statement at %C");
12081 : 2 : goto error;
12082 : 0 : break;
12083 : :
12084 : 0 : default:
12085 : 0 : gcc_unreachable ();
12086 : : }
12087 : :
12088 : : /* Match the required =>. */
12089 : 98 : if (gfc_match (" =>") != MATCH_YES)
12090 : : {
12091 : 1 : gfc_error ("Expected %<=>%> at %C");
12092 : 1 : goto error;
12093 : : }
12094 : :
12095 : :
12096 : 97 : if (gfc_current_state () != COMP_MODULE && tbattr.access != ACCESS_UNKNOWN)
12097 : : {
12098 : 1 : gfc_error ("The access specification at %L not in a module",
12099 : : &tbattr.where);
12100 : 1 : goto error;
12101 : : }
12102 : :
12103 : : /* Try to find existing generic-spec with this name for this operator;
12104 : : if there is something, check that it is another generic-spec and then
12105 : : extend it rather than building a new symbol. Otherwise, create a new
12106 : : one with the right attributes. */
12107 : :
12108 : 96 : switch (op_type)
12109 : : {
12110 : 61 : case INTERFACE_DTIO:
12111 : 61 : case INTERFACE_GENERIC:
12112 : 61 : st = gfc_find_symtree (ns->sym_root, name);
12113 : 61 : generic_spec = st ? st->n.sym : NULL;
12114 : 61 : if (generic_spec)
12115 : : {
12116 : 25 : if (generic_spec->attr.flavor != FL_PROCEDURE
12117 : 11 : && generic_spec->attr.flavor != FL_UNKNOWN)
12118 : : {
12119 : 1 : gfc_error ("The generic-spec name %qs at %C clashes with the "
12120 : : "name of an entity declared at %L that is not a "
12121 : : "procedure", name, &generic_spec->declared_at);
12122 : 1 : goto error;
12123 : : }
12124 : :
12125 : 24 : if (op_type == INTERFACE_GENERIC && !generic_spec->attr.generic
12126 : 10 : && generic_spec->attr.flavor != FL_UNKNOWN)
12127 : : {
12128 : 0 : gfc_error ("There's already a non-generic procedure with "
12129 : : "name %qs at %C", generic_spec->name);
12130 : 0 : goto error;
12131 : : }
12132 : :
12133 : 24 : if (tbattr.access != ACCESS_UNKNOWN)
12134 : : {
12135 : 2 : if (generic_spec->attr.access != tbattr.access)
12136 : : {
12137 : 1 : gfc_error ("The access specification at %L conflicts with "
12138 : : "that already given to %qs", &tbattr.where,
12139 : : generic_spec->name);
12140 : 1 : goto error;
12141 : : }
12142 : : else
12143 : : {
12144 : 1 : gfc_error ("The access specification at %L repeats that "
12145 : : "already given to %qs", &tbattr.where,
12146 : : generic_spec->name);
12147 : 1 : goto error;
12148 : : }
12149 : : }
12150 : :
12151 : 22 : if (generic_spec->ts.type != BT_UNKNOWN)
12152 : : {
12153 : 1 : gfc_error ("The generic-spec in the generic statement at %C "
12154 : : "has a type from the declaration at %L",
12155 : : &generic_spec->declared_at);
12156 : 1 : goto error;
12157 : : }
12158 : : }
12159 : :
12160 : : /* Now create the generic_spec if it doesn't already exist and provide
12161 : : is with the appropriate attributes. */
12162 : 57 : if (!generic_spec || generic_spec->attr.flavor != FL_PROCEDURE)
12163 : : {
12164 : 45 : if (!generic_spec)
12165 : : {
12166 : 36 : gfc_get_symbol (name, ns, &generic_spec, &gfc_current_locus);
12167 : 36 : gfc_set_sym_referenced (generic_spec);
12168 : 36 : generic_spec->attr.access = tbattr.access;
12169 : : }
12170 : 9 : else if (generic_spec->attr.access == ACCESS_UNKNOWN)
12171 : 0 : generic_spec->attr.access = tbattr.access;
12172 : 45 : generic_spec->refs++;
12173 : 45 : generic_spec->attr.generic = 1;
12174 : 45 : generic_spec->attr.flavor = FL_PROCEDURE;
12175 : :
12176 : 45 : generic_spec->declared_at = gfc_current_locus;
12177 : : }
12178 : :
12179 : : /* Prepare to add the specific procedures. */
12180 : 57 : generic = generic_spec->generic;
12181 : 57 : generic_tail = &generic_spec->generic;
12182 : 57 : break;
12183 : :
12184 : 22 : case INTERFACE_USER_OP:
12185 : 22 : st = gfc_find_symtree (ns->uop_root, name);
12186 : 22 : generic_uop = st ? st->n.uop : NULL;
12187 : 2 : if (generic_uop)
12188 : : {
12189 : 2 : if (generic_uop->access != ACCESS_UNKNOWN
12190 : 2 : && tbattr.access != ACCESS_UNKNOWN)
12191 : : {
12192 : 2 : if (generic_uop->access != tbattr.access)
12193 : : {
12194 : 1 : gfc_error ("The user operator at %L must have the same "
12195 : : "access specification as already defined user "
12196 : : "operator %qs", &tbattr.where, generic_spec_name);
12197 : 1 : goto error;
12198 : : }
12199 : : else
12200 : : {
12201 : 1 : gfc_error ("The user operator at %L repeats the access "
12202 : : "specification of already defined user operator " "%qs", &tbattr.where, generic_spec_name);
12203 : 1 : goto error;
12204 : : }
12205 : : }
12206 : 0 : else if (generic_uop->access == ACCESS_UNKNOWN)
12207 : 0 : generic_uop->access = tbattr.access;
12208 : : }
12209 : : else
12210 : : {
12211 : 20 : generic_uop = gfc_get_uop (name);
12212 : 20 : generic_uop->access = tbattr.access;
12213 : : }
12214 : :
12215 : : /* Prepare to add the specific procedures. */
12216 : 20 : generic = generic_uop->op;
12217 : 20 : generic_tail = &generic_uop->op;
12218 : 20 : break;
12219 : :
12220 : 13 : case INTERFACE_INTRINSIC_OP:
12221 : 13 : generic = ns->op[op];
12222 : 13 : generic_tail = &ns->op[op];
12223 : 13 : break;
12224 : :
12225 : 0 : default:
12226 : 0 : gcc_unreachable ();
12227 : : }
12228 : :
12229 : : /* Now, match all following names in the specific-procedure-list. */
12230 : 154 : do
12231 : : {
12232 : 154 : m = gfc_match_name (name);
12233 : 154 : if (m == MATCH_ERROR)
12234 : 0 : goto error;
12235 : 154 : if (m == MATCH_NO)
12236 : : {
12237 : 0 : gfc_error ("Expected specific procedure name at %C");
12238 : 0 : goto error;
12239 : : }
12240 : :
12241 : 154 : if (op_type == INTERFACE_GENERIC
12242 : 95 : && !strcmp (generic_spec->name, name))
12243 : : {
12244 : 2 : gfc_error ("The name %qs of the specific procedure at %C conflicts "
12245 : : "with that of the generic-spec", name);
12246 : 2 : goto error;
12247 : : }
12248 : :
12249 : 152 : generic = *generic_tail;
12250 : 242 : for (; generic; generic = generic->next)
12251 : : {
12252 : 90 : if (!strcmp (generic->sym->name, name))
12253 : : {
12254 : 0 : gfc_error ("%qs already defined as a specific procedure for the"
12255 : : " generic %qs at %C", name, generic_spec->name);
12256 : 0 : goto error;
12257 : : }
12258 : : }
12259 : :
12260 : 152 : gfc_find_sym_tree (name, ns, 1, &st);
12261 : 152 : if (!st)
12262 : : {
12263 : : /* This might be a procedure that has not yet been parsed. If
12264 : : so gfc_fixup_sibling_symbols will replace this symbol with
12265 : : that of the procedure. */
12266 : 75 : gfc_get_sym_tree (name, ns, &st, false);
12267 : 75 : st->n.sym->refs++;
12268 : : }
12269 : :
12270 : 152 : generic = gfc_get_interface();
12271 : 152 : generic->next = *generic_tail;
12272 : 152 : *generic_tail = generic;
12273 : 152 : generic->where = gfc_current_locus;
12274 : 152 : generic->sym = st->n.sym;
12275 : : }
12276 : 152 : while (gfc_match (" ,") == MATCH_YES);
12277 : :
12278 : 88 : if (gfc_match_eos () != MATCH_YES)
12279 : : {
12280 : 0 : gfc_error ("Junk after GENERIC statement at %C");
12281 : 0 : goto error;
12282 : : }
12283 : :
12284 : 88 : gfc_commit_symbols ();
12285 : 88 : return MATCH_YES;
12286 : :
12287 : : error:
12288 : : return MATCH_ERROR;
12289 : : }
12290 : :
12291 : :
12292 : : /* Match a GENERIC procedure binding inside a derived type. */
12293 : :
12294 : : static match
12295 : 888 : match_typebound_generic (void)
12296 : : {
12297 : 888 : char name[GFC_MAX_SYMBOL_LEN + 1];
12298 : 888 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
12299 : 888 : gfc_symbol* block;
12300 : 888 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
12301 : 888 : gfc_typebound_proc* tb;
12302 : 888 : gfc_namespace* ns;
12303 : 888 : interface_type op_type;
12304 : 888 : gfc_intrinsic_op op;
12305 : 888 : match m;
12306 : :
12307 : : /* Check current state. */
12308 : 888 : if (gfc_current_state () == COMP_DERIVED)
12309 : : {
12310 : 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
12311 : 0 : return MATCH_ERROR;
12312 : : }
12313 : 888 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
12314 : : return MATCH_NO;
12315 : 888 : block = gfc_state_stack->previous->sym;
12316 : 888 : ns = block->f2k_derived;
12317 : 888 : gcc_assert (block && ns);
12318 : :
12319 : 888 : memset (&tbattr, 0, sizeof (tbattr));
12320 : 888 : tbattr.where = gfc_current_locus;
12321 : :
12322 : : /* See if we get an access-specifier. */
12323 : 888 : m = match_binding_attributes (&tbattr, true, false);
12324 : 888 : if (m == MATCH_ERROR)
12325 : 1 : goto error;
12326 : :
12327 : : /* Now the colons, those are required. */
12328 : 887 : if (gfc_match (" ::") != MATCH_YES)
12329 : : {
12330 : 0 : gfc_error ("Expected %<::%> at %C");
12331 : 0 : goto error;
12332 : : }
12333 : :
12334 : : /* Match the binding name; depending on type (operator / generic) format
12335 : : it for future error messages into bind_name. */
12336 : :
12337 : 887 : m = gfc_match_generic_spec (&op_type, name, &op);
12338 : 887 : if (m == MATCH_ERROR)
12339 : : return MATCH_ERROR;
12340 : 887 : if (m == MATCH_NO)
12341 : : {
12342 : 0 : gfc_error ("Expected generic name or operator descriptor at %C");
12343 : 0 : goto error;
12344 : : }
12345 : :
12346 : 887 : switch (op_type)
12347 : : {
12348 : 456 : case INTERFACE_GENERIC:
12349 : 456 : case INTERFACE_DTIO:
12350 : 456 : snprintf (bind_name, sizeof (bind_name), "%s", name);
12351 : 456 : break;
12352 : :
12353 : 27 : case INTERFACE_USER_OP:
12354 : 27 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
12355 : 27 : break;
12356 : :
12357 : 403 : case INTERFACE_INTRINSIC_OP:
12358 : 403 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
12359 : : gfc_op2string (op));
12360 : 403 : break;
12361 : :
12362 : 1 : case INTERFACE_NAMELESS:
12363 : 1 : gfc_error ("Malformed GENERIC statement at %C");
12364 : 1 : goto error;
12365 : 0 : break;
12366 : :
12367 : 0 : default:
12368 : 0 : gcc_unreachable ();
12369 : : }
12370 : :
12371 : : /* Match the required =>. */
12372 : 886 : if (gfc_match (" =>") != MATCH_YES)
12373 : : {
12374 : 0 : gfc_error ("Expected %<=>%> at %C");
12375 : 0 : goto error;
12376 : : }
12377 : :
12378 : : /* Try to find existing GENERIC binding with this name / for this operator;
12379 : : if there is something, check that it is another GENERIC and then extend
12380 : : it rather than building a new node. Otherwise, create it and put it
12381 : : at the right position. */
12382 : :
12383 : 886 : switch (op_type)
12384 : : {
12385 : 483 : case INTERFACE_DTIO:
12386 : 483 : case INTERFACE_USER_OP:
12387 : 483 : case INTERFACE_GENERIC:
12388 : 483 : {
12389 : 483 : const bool is_op = (op_type == INTERFACE_USER_OP);
12390 : 483 : gfc_symtree* st;
12391 : :
12392 : 483 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
12393 : 483 : tb = st ? st->n.tb : NULL;
12394 : : break;
12395 : : }
12396 : :
12397 : 403 : case INTERFACE_INTRINSIC_OP:
12398 : 403 : tb = ns->tb_op[op];
12399 : 403 : break;
12400 : :
12401 : 0 : default:
12402 : 0 : gcc_unreachable ();
12403 : : }
12404 : :
12405 : 414 : if (tb)
12406 : : {
12407 : 9 : if (!tb->is_generic)
12408 : : {
12409 : 1 : gcc_assert (op_type == INTERFACE_GENERIC);
12410 : 1 : gfc_error ("There's already a non-generic procedure with binding name"
12411 : : " %qs for the derived type %qs at %C",
12412 : : bind_name, block->name);
12413 : 1 : goto error;
12414 : : }
12415 : :
12416 : 8 : if (tb->access != tbattr.access)
12417 : : {
12418 : 2 : gfc_error ("Binding at %C must have the same access as already"
12419 : : " defined binding %qs", bind_name);
12420 : 2 : goto error;
12421 : : }
12422 : : }
12423 : : else
12424 : : {
12425 : 877 : tb = gfc_get_typebound_proc (NULL);
12426 : 877 : tb->where = gfc_current_locus;
12427 : 877 : tb->access = tbattr.access;
12428 : 877 : tb->is_generic = 1;
12429 : 877 : tb->u.generic = NULL;
12430 : :
12431 : 877 : switch (op_type)
12432 : : {
12433 : 474 : case INTERFACE_DTIO:
12434 : 474 : case INTERFACE_GENERIC:
12435 : 474 : case INTERFACE_USER_OP:
12436 : 474 : {
12437 : 474 : const bool is_op = (op_type == INTERFACE_USER_OP);
12438 : 474 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
12439 : : &ns->tb_sym_root, name);
12440 : 474 : gcc_assert (st);
12441 : 474 : st->n.tb = tb;
12442 : :
12443 : 474 : break;
12444 : : }
12445 : :
12446 : 403 : case INTERFACE_INTRINSIC_OP:
12447 : 403 : ns->tb_op[op] = tb;
12448 : 403 : break;
12449 : :
12450 : 0 : default:
12451 : 0 : gcc_unreachable ();
12452 : : }
12453 : : }
12454 : :
12455 : : /* Now, match all following names as specific targets. */
12456 : 1034 : do
12457 : : {
12458 : 1034 : gfc_symtree* target_st;
12459 : 1034 : gfc_tbp_generic* target;
12460 : :
12461 : 1034 : m = gfc_match_name (name);
12462 : 1034 : if (m == MATCH_ERROR)
12463 : 0 : goto error;
12464 : 1034 : if (m == MATCH_NO)
12465 : : {
12466 : 1 : gfc_error ("Expected specific binding name at %C");
12467 : 1 : goto error;
12468 : : }
12469 : :
12470 : 1033 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
12471 : :
12472 : : /* See if this is a duplicate specification. */
12473 : 1262 : for (target = tb->u.generic; target; target = target->next)
12474 : 230 : if (target_st == target->specific_st)
12475 : : {
12476 : 1 : gfc_error ("%qs already defined as specific binding for the"
12477 : : " generic %qs at %C", name, bind_name);
12478 : 1 : goto error;
12479 : : }
12480 : :
12481 : 1032 : target = gfc_get_tbp_generic ();
12482 : 1032 : target->specific_st = target_st;
12483 : 1032 : target->specific = NULL;
12484 : 1032 : target->next = tb->u.generic;
12485 : 1032 : target->is_operator = ((op_type == INTERFACE_USER_OP)
12486 : 1032 : || (op_type == INTERFACE_INTRINSIC_OP));
12487 : 1032 : tb->u.generic = target;
12488 : : }
12489 : 1032 : while (gfc_match (" ,") == MATCH_YES);
12490 : :
12491 : : /* Here should be the end. */
12492 : 881 : if (gfc_match_eos () != MATCH_YES)
12493 : : {
12494 : 1 : gfc_error ("Junk after GENERIC binding at %C");
12495 : 1 : goto error;
12496 : : }
12497 : :
12498 : : return MATCH_YES;
12499 : :
12500 : : error:
12501 : : return MATCH_ERROR;
12502 : : }
12503 : :
12504 : :
12505 : : match
12506 : 988 : gfc_match_generic ()
12507 : : {
12508 : 988 : if (gfc_option.allow_std & ~GFC_STD_OPT_F08
12509 : 986 : && gfc_current_state () != COMP_DERIVED_CONTAINS)
12510 : 100 : return match_generic_stmt ();
12511 : : else
12512 : 888 : return match_typebound_generic ();
12513 : : }
12514 : :
12515 : :
12516 : : /* Match a FINAL declaration inside a derived type. */
12517 : :
12518 : : match
12519 : 427 : gfc_match_final_decl (void)
12520 : : {
12521 : 427 : char name[GFC_MAX_SYMBOL_LEN + 1];
12522 : 427 : gfc_symbol* sym;
12523 : 427 : match m;
12524 : 427 : gfc_namespace* module_ns;
12525 : 427 : bool first, last;
12526 : 427 : gfc_symbol* block;
12527 : :
12528 : 427 : if (gfc_current_form == FORM_FREE)
12529 : : {
12530 : 427 : char c = gfc_peek_ascii_char ();
12531 : 427 : if (!gfc_is_whitespace (c) && c != ':')
12532 : : return MATCH_NO;
12533 : : }
12534 : :
12535 : 426 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
12536 : : {
12537 : 1 : if (gfc_current_form == FORM_FIXED)
12538 : : return MATCH_NO;
12539 : :
12540 : 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
12541 : : "CONTAINS section");
12542 : 1 : return MATCH_ERROR;
12543 : : }
12544 : :
12545 : 425 : block = gfc_state_stack->previous->sym;
12546 : 425 : gcc_assert (block);
12547 : :
12548 : 425 : if (gfc_state_stack->previous->previous
12549 : 425 : && gfc_state_stack->previous->previous->state != COMP_MODULE
12550 : 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
12551 : : {
12552 : 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
12553 : : " specification part of a MODULE");
12554 : 0 : return MATCH_ERROR;
12555 : : }
12556 : :
12557 : 425 : module_ns = gfc_current_ns;
12558 : 425 : gcc_assert (module_ns);
12559 : 425 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
12560 : :
12561 : : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
12562 : 425 : if (gfc_match (" ::") == MATCH_ERROR)
12563 : : return MATCH_ERROR;
12564 : :
12565 : : /* Match the sequence of procedure names. */
12566 : : first = true;
12567 : : last = false;
12568 : 511 : do
12569 : : {
12570 : 511 : gfc_finalizer* f;
12571 : :
12572 : 511 : if (first && gfc_match_eos () == MATCH_YES)
12573 : : {
12574 : 2 : gfc_error ("Empty FINAL at %C");
12575 : 2 : return MATCH_ERROR;
12576 : : }
12577 : :
12578 : 509 : m = gfc_match_name (name);
12579 : 509 : if (m == MATCH_NO)
12580 : : {
12581 : 1 : gfc_error ("Expected module procedure name at %C");
12582 : 1 : return MATCH_ERROR;
12583 : : }
12584 : 508 : else if (m != MATCH_YES)
12585 : : return MATCH_ERROR;
12586 : :
12587 : 508 : if (gfc_match_eos () == MATCH_YES)
12588 : : last = true;
12589 : 87 : if (!last && gfc_match_char (',') != MATCH_YES)
12590 : : {
12591 : 1 : gfc_error ("Expected %<,%> at %C");
12592 : 1 : return MATCH_ERROR;
12593 : : }
12594 : :
12595 : 507 : if (gfc_get_symbol (name, module_ns, &sym))
12596 : : {
12597 : 0 : gfc_error ("Unknown procedure name %qs at %C", name);
12598 : 0 : return MATCH_ERROR;
12599 : : }
12600 : :
12601 : : /* Mark the symbol as module procedure. */
12602 : 507 : if (sym->attr.proc != PROC_MODULE
12603 : 507 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
12604 : : return MATCH_ERROR;
12605 : :
12606 : : /* Check if we already have this symbol in the list, this is an error. */
12607 : 688 : for (f = block->f2k_derived->finalizers; f; f = f->next)
12608 : 182 : if (f->proc_sym == sym)
12609 : : {
12610 : 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
12611 : : name);
12612 : 1 : return MATCH_ERROR;
12613 : : }
12614 : :
12615 : : /* Add this symbol to the list of finalizers. */
12616 : 506 : gcc_assert (block->f2k_derived);
12617 : 506 : sym->refs++;
12618 : 506 : f = XCNEW (gfc_finalizer);
12619 : 506 : f->proc_sym = sym;
12620 : 506 : f->proc_tree = NULL;
12621 : 506 : f->where = gfc_current_locus;
12622 : 506 : f->next = block->f2k_derived->finalizers;
12623 : 506 : block->f2k_derived->finalizers = f;
12624 : :
12625 : 506 : first = false;
12626 : : }
12627 : 506 : while (!last);
12628 : :
12629 : : return MATCH_YES;
12630 : : }
12631 : :
12632 : :
12633 : : const ext_attr_t ext_attr_list[] = {
12634 : : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
12635 : : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
12636 : : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
12637 : : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
12638 : : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
12639 : : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
12640 : : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
12641 : : { "noinline", EXT_ATTR_NOINLINE, NULL },
12642 : : { "noreturn", EXT_ATTR_NORETURN, NULL },
12643 : : { "weak", EXT_ATTR_WEAK, NULL },
12644 : : { NULL, EXT_ATTR_LAST, NULL }
12645 : : };
12646 : :
12647 : : /* Match a !GCC$ ATTRIBUTES statement of the form:
12648 : : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
12649 : : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
12650 : :
12651 : : TODO: We should support all GCC attributes using the same syntax for
12652 : : the attribute list, i.e. the list in C
12653 : : __attributes(( attribute-list ))
12654 : : matches then
12655 : : !GCC$ ATTRIBUTES attribute-list ::
12656 : : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
12657 : : saved into a TREE.
12658 : :
12659 : : As there is absolutely no risk of confusion, we should never return
12660 : : MATCH_NO. */
12661 : : match
12662 : 2964 : gfc_match_gcc_attributes (void)
12663 : : {
12664 : 2964 : symbol_attribute attr;
12665 : 2964 : char name[GFC_MAX_SYMBOL_LEN + 1];
12666 : 2964 : unsigned id;
12667 : 2964 : gfc_symbol *sym;
12668 : 2964 : match m;
12669 : :
12670 : 2964 : gfc_clear_attr (&attr);
12671 : 2964 : for(;;)
12672 : : {
12673 : 2964 : char ch;
12674 : :
12675 : 2964 : if (gfc_match_name (name) != MATCH_YES)
12676 : : return MATCH_ERROR;
12677 : :
12678 : 17857 : for (id = 0; id < EXT_ATTR_LAST; id++)
12679 : 17857 : if (strcmp (name, ext_attr_list[id].name) == 0)
12680 : : break;
12681 : :
12682 : 2964 : if (id == EXT_ATTR_LAST)
12683 : : {
12684 : 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
12685 : 0 : return MATCH_ERROR;
12686 : : }
12687 : :
12688 : 2964 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
12689 : : return MATCH_ERROR;
12690 : :
12691 : 2964 : gfc_gobble_whitespace ();
12692 : 2964 : ch = gfc_next_ascii_char ();
12693 : 2964 : if (ch == ':')
12694 : : {
12695 : : /* This is the successful exit condition for the loop. */
12696 : 2964 : if (gfc_next_ascii_char () == ':')
12697 : : break;
12698 : : }
12699 : :
12700 : 0 : if (ch == ',')
12701 : 0 : continue;
12702 : :
12703 : 0 : goto syntax;
12704 : 0 : }
12705 : :
12706 : 2964 : if (gfc_match_eos () == MATCH_YES)
12707 : 0 : goto syntax;
12708 : :
12709 : 2971 : for(;;)
12710 : : {
12711 : 2971 : m = gfc_match_name (name);
12712 : 2971 : if (m != MATCH_YES)
12713 : : return m;
12714 : :
12715 : 2971 : if (find_special (name, &sym, true))
12716 : : return MATCH_ERROR;
12717 : :
12718 : 2971 : sym->attr.ext_attr |= attr.ext_attr;
12719 : :
12720 : 2971 : if (gfc_match_eos () == MATCH_YES)
12721 : : break;
12722 : :
12723 : 7 : if (gfc_match_char (',') != MATCH_YES)
12724 : 0 : goto syntax;
12725 : : }
12726 : :
12727 : : return MATCH_YES;
12728 : :
12729 : 0 : syntax:
12730 : 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
12731 : 0 : return MATCH_ERROR;
12732 : : }
12733 : :
12734 : :
12735 : : /* Match a !GCC$ UNROLL statement of the form:
12736 : : !GCC$ UNROLL n
12737 : :
12738 : : The parameter n is the number of times we are supposed to unroll.
12739 : :
12740 : : When we come here, we have already matched the !GCC$ UNROLL string. */
12741 : : match
12742 : 19 : gfc_match_gcc_unroll (void)
12743 : : {
12744 : 19 : int value;
12745 : :
12746 : : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
12747 : 19 : if (gfc_match_small_int (&value) == MATCH_YES)
12748 : : {
12749 : 19 : if (value < 0 || value > USHRT_MAX)
12750 : : {
12751 : 2 : gfc_error ("%<GCC unroll%> directive requires a"
12752 : : " non-negative integral constant"
12753 : : " less than or equal to %u at %C",
12754 : : USHRT_MAX
12755 : : );
12756 : 2 : return MATCH_ERROR;
12757 : : }
12758 : 17 : if (gfc_match_eos () == MATCH_YES)
12759 : : {
12760 : 17 : directive_unroll = value == 0 ? 1 : value;
12761 : 17 : return MATCH_YES;
12762 : : }
12763 : : }
12764 : :
12765 : 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
12766 : 0 : return MATCH_ERROR;
12767 : : }
12768 : :
12769 : : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
12770 : :
12771 : : The parameter b is name of a middle-end built-in.
12772 : : FLAGS is optional and must be one of:
12773 : : - (inbranch)
12774 : : - (notinbranch)
12775 : :
12776 : : IF('target') is optional and TARGET is a name of a multilib ABI.
12777 : :
12778 : : When we come here, we have already matched the !GCC$ builtin string. */
12779 : :
12780 : : match
12781 : 3342848 : gfc_match_gcc_builtin (void)
12782 : : {
12783 : 3342848 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
12784 : 3342848 : char target[GFC_MAX_SYMBOL_LEN + 1];
12785 : :
12786 : 3342848 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
12787 : : return MATCH_ERROR;
12788 : :
12789 : 3342848 : gfc_simd_clause clause = SIMD_NONE;
12790 : 3342848 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
12791 : : clause = SIMD_NOTINBRANCH;
12792 : 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
12793 : 15 : clause = SIMD_INBRANCH;
12794 : :
12795 : 3342848 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
12796 : : {
12797 : 3342819 : const char *abi = targetm.get_multilib_abi_name ();
12798 : 3342819 : if (abi == NULL || strcmp (abi, target) != 0)
12799 : : return MATCH_YES;
12800 : : }
12801 : :
12802 : 1649461 : if (gfc_vectorized_builtins == NULL)
12803 : 30551 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
12804 : :
12805 : 1649461 : char *r = XNEWVEC (char, strlen (builtin) + 32);
12806 : 1649461 : sprintf (r, "__builtin_%s", builtin);
12807 : :
12808 : 1649461 : bool existed;
12809 : 1649461 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
12810 : 1649461 : value |= clause;
12811 : 1649461 : if (existed)
12812 : 22 : free (r);
12813 : :
12814 : : return MATCH_YES;
12815 : : }
12816 : :
12817 : : /* Match an !GCC$ IVDEP statement.
12818 : : When we come here, we have already matched the !GCC$ IVDEP string. */
12819 : :
12820 : : match
12821 : 3 : gfc_match_gcc_ivdep (void)
12822 : : {
12823 : 3 : if (gfc_match_eos () == MATCH_YES)
12824 : : {
12825 : 3 : directive_ivdep = true;
12826 : 3 : return MATCH_YES;
12827 : : }
12828 : :
12829 : 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
12830 : 0 : return MATCH_ERROR;
12831 : : }
12832 : :
12833 : : /* Match an !GCC$ VECTOR statement.
12834 : : When we come here, we have already matched the !GCC$ VECTOR string. */
12835 : :
12836 : : match
12837 : 3 : gfc_match_gcc_vector (void)
12838 : : {
12839 : 3 : if (gfc_match_eos () == MATCH_YES)
12840 : : {
12841 : 3 : directive_vector = true;
12842 : 3 : directive_novector = false;
12843 : 3 : return MATCH_YES;
12844 : : }
12845 : :
12846 : 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
12847 : 0 : return MATCH_ERROR;
12848 : : }
12849 : :
12850 : : /* Match an !GCC$ NOVECTOR statement.
12851 : : When we come here, we have already matched the !GCC$ NOVECTOR string. */
12852 : :
12853 : : match
12854 : 3 : gfc_match_gcc_novector (void)
12855 : : {
12856 : 3 : if (gfc_match_eos () == MATCH_YES)
12857 : : {
12858 : 3 : directive_novector = true;
12859 : 3 : directive_vector = false;
12860 : 3 : return MATCH_YES;
12861 : : }
12862 : :
12863 : 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
12864 : 0 : return MATCH_ERROR;
12865 : : }
|
