Branch data Line data Source code
1 : : /* Declaration statement matcher
2 : : Copyright (C) 2002-2023 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 : 7079 : gfc_in_match_data (void)
125 : : {
126 : 7079 : return in_match_data;
127 : : }
128 : :
129 : : static void
130 : 4960 : set_in_match_data (bool set_value)
131 : : {
132 : 4960 : in_match_data = set_value;
133 : 2480 : }
134 : :
135 : : /* Free a gfc_data_variable structure and everything beneath it. */
136 : :
137 : : static void
138 : 5802 : free_variable (gfc_data_variable *p)
139 : : {
140 : 5802 : gfc_data_variable *q;
141 : :
142 : 8970 : for (; p; p = q)
143 : : {
144 : 3168 : q = p->next;
145 : 3168 : gfc_free_expr (p->expr);
146 : 3168 : gfc_free_iterator (&p->iter, 0);
147 : 3168 : free_variable (p->list);
148 : 3168 : free (p);
149 : : }
150 : 5802 : }
151 : :
152 : :
153 : : /* Free a gfc_data_value structure and everything beneath it. */
154 : :
155 : : static void
156 : 2634 : free_value (gfc_data_value *p)
157 : : {
158 : 2634 : gfc_data_value *q;
159 : :
160 : 11523 : for (; p; p = q)
161 : : {
162 : 8889 : q = p->next;
163 : 8889 : mpz_clear (p->repeat);
164 : 8889 : gfc_free_expr (p->expr);
165 : 8889 : free (p);
166 : : }
167 : 2634 : }
168 : :
169 : :
170 : : /* Free a list of gfc_data structures. */
171 : :
172 : : void
173 : 414372 : gfc_free_data (gfc_data *p)
174 : : {
175 : 414372 : gfc_data *q;
176 : :
177 : 417006 : for (; p; p = q)
178 : : {
179 : 2634 : q = p->next;
180 : 2634 : free_variable (p->var);
181 : 2634 : free_value (p->value);
182 : 2634 : free (p);
183 : : }
184 : 414372 : }
185 : :
186 : :
187 : : /* Free all data in a namespace. */
188 : :
189 : : static void
190 : 37 : gfc_free_data_all (gfc_namespace *ns)
191 : : {
192 : 37 : gfc_data *d;
193 : :
194 : 43 : for (;ns->data;)
195 : : {
196 : 6 : d = ns->data->next;
197 : 6 : free (ns->data);
198 : 6 : ns->data = d;
199 : : }
200 : 37 : }
201 : :
202 : : /* Reject data parsed since the last restore point was marked. */
203 : :
204 : : void
205 : 7245473 : gfc_reject_data (gfc_namespace *ns)
206 : : {
207 : 7245473 : gfc_data *d;
208 : :
209 : 7245475 : 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 : 7245473 : }
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 : 163 : var_list (gfc_data_variable *parent)
224 : : {
225 : 163 : gfc_data_variable *tail, var;
226 : 163 : match m;
227 : :
228 : 163 : m = var_element (&var);
229 : 163 : if (m == MATCH_ERROR)
230 : : return MATCH_ERROR;
231 : 163 : if (m == MATCH_NO)
232 : 0 : goto syntax;
233 : :
234 : 163 : tail = gfc_get_data_variable ();
235 : 163 : *tail = var;
236 : :
237 : 163 : parent->list = tail;
238 : :
239 : 165 : for (;;)
240 : : {
241 : 164 : if (gfc_match_char (',') != MATCH_YES)
242 : 0 : goto syntax;
243 : :
244 : 164 : m = gfc_match_iterator (&parent->iter, 1);
245 : 164 : 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 : 163 : 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 : 3126 : var_element (gfc_data_variable *new_var)
277 : : {
278 : 3126 : match m;
279 : 3126 : gfc_symbol *sym;
280 : :
281 : 3126 : memset (new_var, 0, sizeof (gfc_data_variable));
282 : :
283 : 3126 : if (gfc_match_char ('(') == MATCH_YES)
284 : 163 : return var_list (new_var);
285 : :
286 : 2963 : m = gfc_match_variable (&new_var->expr, 0);
287 : 2963 : if (m != MATCH_YES)
288 : : return m;
289 : :
290 : 2959 : 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 : 2957 : sym = new_var->expr->symtree->n.sym;
299 : :
300 : : /* Symbol should already have an associated type. */
301 : 2957 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
302 : : return MATCH_ERROR;
303 : :
304 : 2956 : if (!sym->attr.function && gfc_current_ns->parent
305 : 213 : && 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 : 2955 : if (gfc_current_state () != COMP_BLOCK_DATA
313 : 2819 : && sym->attr.in_common
314 : 2984 : && !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 : 2953 : 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 : 2577 : top_var_list (gfc_data *d)
330 : : {
331 : 2577 : gfc_data_variable var, *tail, *new_var;
332 : 2577 : match m;
333 : :
334 : 2577 : tail = NULL;
335 : :
336 : 2962 : for (;;)
337 : : {
338 : 2962 : m = var_element (&var);
339 : 2962 : if (m == MATCH_NO)
340 : 0 : goto syntax;
341 : 2962 : if (m == MATCH_ERROR)
342 : : return MATCH_ERROR;
343 : :
344 : 2947 : new_var = gfc_get_data_variable ();
345 : 2947 : *new_var = var;
346 : 2947 : if (new_var->expr)
347 : 2817 : new_var->expr->where = gfc_current_locus;
348 : :
349 : 2947 : if (tail == NULL)
350 : 2562 : d->var = new_var;
351 : : else
352 : 385 : tail->next = new_var;
353 : :
354 : 2947 : tail = new_var;
355 : :
356 : 2947 : if (gfc_match_char ('/') == MATCH_YES)
357 : : break;
358 : 388 : 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 : 9315 : match_data_constant (gfc_expr **result)
373 : : {
374 : 9315 : char name[GFC_MAX_SYMBOL_LEN + 1];
375 : 9315 : gfc_symbol *sym, *dt_sym = NULL;
376 : 9315 : gfc_expr *expr;
377 : 9315 : match m;
378 : 9315 : locus old_loc;
379 : :
380 : 9315 : m = gfc_match_literal_constant (&expr, 1);
381 : 9315 : if (m == MATCH_YES)
382 : : {
383 : 8982 : *result = expr;
384 : 8982 : return MATCH_YES;
385 : : }
386 : :
387 : 333 : if (m == MATCH_ERROR)
388 : : return MATCH_ERROR;
389 : :
390 : 325 : m = gfc_match_null (result);
391 : 325 : if (m != MATCH_NO)
392 : : return m;
393 : :
394 : 317 : old_loc = gfc_current_locus;
395 : :
396 : : /* Should this be a structure component, try to match it
397 : : before matching a name. */
398 : 317 : m = gfc_match_rvalue (result);
399 : 317 : if (m == MATCH_ERROR)
400 : : return m;
401 : :
402 : 317 : if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
403 : : {
404 : 3 : if (!gfc_simplify_expr (*result, 0))
405 : 0 : m = MATCH_ERROR;
406 : 3 : return m;
407 : : }
408 : 308 : else if (m == MATCH_YES)
409 : : {
410 : : /* If a parameter inquiry ends up here, symtree is NULL but **result
411 : : contains the right constant expression. Check here. */
412 : 308 : if ((*result)->symtree == NULL
413 : 37 : && (*result)->expr_type == EXPR_CONSTANT
414 : 37 : && ((*result)->ts.type == BT_INTEGER
415 : 1 : || (*result)->ts.type == BT_REAL))
416 : : return m;
417 : :
418 : : /* F2018:R845 data-stmt-constant is initial-data-target.
419 : : A data-stmt-constant shall be ... initial-data-target if and
420 : : only if the corresponding data-stmt-object has the POINTER
421 : : attribute. ... If data-stmt-constant is initial-data-target
422 : : the corresponding data statement object shall be
423 : : data-pointer-initialization compatible (7.5.4.6) with the initial
424 : : data target; the data statement object is initially associated
425 : : with the target. */
426 : 272 : if ((*result)->symtree
427 : 271 : && (*result)->symtree->n.sym->attr.save
428 : 218 : && (*result)->symtree->n.sym->attr.target)
429 : : return m;
430 : 239 : gfc_free_expr (*result);
431 : : }
432 : :
433 : 245 : gfc_current_locus = old_loc;
434 : :
435 : 245 : m = gfc_match_name (name);
436 : 245 : if (m != MATCH_YES)
437 : : return m;
438 : :
439 : 239 : if (gfc_find_symbol (name, NULL, 1, &sym))
440 : : return MATCH_ERROR;
441 : :
442 : 239 : if (sym && sym->attr.generic)
443 : 49 : dt_sym = gfc_find_dt_in_generic (sym);
444 : :
445 : 239 : if (sym == NULL
446 : 239 : || (sym->attr.flavor != FL_PARAMETER
447 : 54 : && (!dt_sym || !gfc_fl_struct (dt_sym->attr.flavor))))
448 : : {
449 : 5 : gfc_error ("Symbol %qs must be a PARAMETER in DATA statement at %C",
450 : : name);
451 : 5 : *result = NULL;
452 : 5 : return MATCH_ERROR;
453 : : }
454 : 234 : else if (dt_sym && gfc_fl_struct (dt_sym->attr.flavor))
455 : 49 : return gfc_match_structure_constructor (dt_sym, result);
456 : :
457 : : /* Check to see if the value is an initialization array expression. */
458 : 185 : if (sym->value->expr_type == EXPR_ARRAY)
459 : : {
460 : 67 : gfc_current_locus = old_loc;
461 : :
462 : 67 : m = gfc_match_init_expr (result);
463 : 67 : if (m == MATCH_ERROR)
464 : : return m;
465 : :
466 : 66 : if (m == MATCH_YES)
467 : : {
468 : 66 : if (!gfc_simplify_expr (*result, 0))
469 : 0 : m = MATCH_ERROR;
470 : :
471 : 66 : if ((*result)->expr_type == EXPR_CONSTANT)
472 : : return m;
473 : : else
474 : : {
475 : 2 : gfc_error ("Invalid initializer %s in Data statement at %C", name);
476 : 2 : return MATCH_ERROR;
477 : : }
478 : : }
479 : : }
480 : :
481 : 118 : *result = gfc_copy_expr (sym->value);
482 : 118 : return MATCH_YES;
483 : : }
484 : :
485 : :
486 : : /* Match a list of values in a DATA statement. The leading '/' has
487 : : already been seen at this point. */
488 : :
489 : : static match
490 : 2620 : top_val_list (gfc_data *data)
491 : : {
492 : 2620 : gfc_data_value *new_val, *tail;
493 : 2620 : gfc_expr *expr;
494 : 2620 : match m;
495 : :
496 : 2620 : tail = NULL;
497 : :
498 : 8926 : for (;;)
499 : : {
500 : 8926 : m = match_data_constant (&expr);
501 : 8926 : if (m == MATCH_NO)
502 : 3 : goto syntax;
503 : 8923 : if (m == MATCH_ERROR)
504 : : return MATCH_ERROR;
505 : :
506 : 8901 : new_val = gfc_get_data_value ();
507 : 8901 : mpz_init (new_val->repeat);
508 : :
509 : 8901 : if (tail == NULL)
510 : 2595 : data->value = new_val;
511 : : else
512 : 6306 : tail->next = new_val;
513 : :
514 : 8901 : tail = new_val;
515 : :
516 : 8901 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
517 : : {
518 : 8671 : tail->expr = expr;
519 : 8671 : mpz_set_ui (tail->repeat, 1);
520 : : }
521 : : else
522 : : {
523 : 230 : mpz_set (tail->repeat, expr->value.integer);
524 : 230 : gfc_free_expr (expr);
525 : :
526 : 230 : m = match_data_constant (&tail->expr);
527 : 230 : if (m == MATCH_NO)
528 : 0 : goto syntax;
529 : 230 : if (m == MATCH_ERROR)
530 : : return MATCH_ERROR;
531 : : }
532 : :
533 : 8897 : if (gfc_match_char ('/') == MATCH_YES)
534 : : break;
535 : 6307 : if (gfc_match_char (',') == MATCH_NO)
536 : 1 : goto syntax;
537 : : }
538 : :
539 : : return MATCH_YES;
540 : :
541 : 4 : syntax:
542 : 4 : gfc_syntax_error (ST_DATA);
543 : 4 : gfc_free_data_all (gfc_current_ns);
544 : 4 : return MATCH_ERROR;
545 : : }
546 : :
547 : :
548 : : /* Matches an old style initialization. */
549 : :
550 : : static match
551 : 70 : match_old_style_init (const char *name)
552 : : {
553 : 70 : match m;
554 : 70 : gfc_symtree *st;
555 : 70 : gfc_symbol *sym;
556 : 70 : gfc_data *newdata, *nd;
557 : :
558 : : /* Set up data structure to hold initializers. */
559 : 70 : gfc_find_sym_tree (name, NULL, 0, &st);
560 : 70 : sym = st->n.sym;
561 : :
562 : 70 : newdata = gfc_get_data ();
563 : 70 : newdata->var = gfc_get_data_variable ();
564 : 70 : newdata->var->expr = gfc_get_variable_expr (st);
565 : 70 : newdata->var->expr->where = sym->declared_at;
566 : 70 : newdata->where = gfc_current_locus;
567 : :
568 : : /* Match initial value list. This also eats the terminal '/'. */
569 : 70 : m = top_val_list (newdata);
570 : 70 : if (m != MATCH_YES)
571 : : {
572 : 1 : free (newdata);
573 : 1 : return m;
574 : : }
575 : :
576 : : /* Check that a BOZ did not creep into an old-style initialization. */
577 : 137 : for (nd = newdata; nd; nd = nd->next)
578 : : {
579 : 69 : if (nd->value->expr->ts.type == BT_BOZ
580 : 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
581 : : "initialization"), &nd->value->expr->where))
582 : : return MATCH_ERROR;
583 : :
584 : 68 : if (nd->var->expr->ts.type != BT_INTEGER
585 : 27 : && nd->var->expr->ts.type != BT_REAL
586 : 21 : && nd->value->expr->ts.type == BT_BOZ)
587 : : {
588 : 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
589 : : "a %qs variable in an old-style initialization"),
590 : 0 : &nd->value->expr->where,
591 : : gfc_typename (&nd->value->expr->ts));
592 : 0 : return MATCH_ERROR;
593 : : }
594 : : }
595 : :
596 : 68 : if (gfc_pure (NULL))
597 : : {
598 : 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
599 : 1 : free (newdata);
600 : 1 : return MATCH_ERROR;
601 : : }
602 : 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
603 : :
604 : : /* Mark the variable as having appeared in a data statement. */
605 : 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
606 : : {
607 : 2 : free (newdata);
608 : 2 : return MATCH_ERROR;
609 : : }
610 : :
611 : : /* Chain in namespace list of DATA initializers. */
612 : 65 : newdata->next = gfc_current_ns->data;
613 : 65 : gfc_current_ns->data = newdata;
614 : :
615 : 65 : return m;
616 : : }
617 : :
618 : :
619 : : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
620 : : we are matching a DATA statement and are therefore issuing an error
621 : : if we encounter something unexpected, if not, we're trying to match
622 : : an old-style initialization expression of the form INTEGER I /2/. */
623 : :
624 : : match
625 : 2482 : gfc_match_data (void)
626 : : {
627 : 2482 : gfc_data *new_data;
628 : 2482 : gfc_expr *e;
629 : 2482 : gfc_ref *ref;
630 : 2482 : match m;
631 : 2482 : char c;
632 : :
633 : : /* DATA has been matched. In free form source code, the next character
634 : : needs to be whitespace or '(' from an implied do-loop. Check that
635 : : here. */
636 : 2482 : c = gfc_peek_ascii_char ();
637 : 2482 : if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '(')
638 : : return MATCH_NO;
639 : :
640 : : /* Before parsing the rest of a DATA statement, check F2008:c1206. */
641 : 2481 : if ((gfc_current_state () == COMP_FUNCTION
642 : 2481 : || gfc_current_state () == COMP_SUBROUTINE)
643 : 1216 : && gfc_state_stack->previous->state == COMP_INTERFACE)
644 : : {
645 : 1 : gfc_error ("DATA statement at %C cannot appear within an INTERFACE");
646 : 1 : return MATCH_ERROR;
647 : : }
648 : :
649 : 2480 : set_in_match_data (true);
650 : :
651 : 2674 : for (;;)
652 : : {
653 : 2577 : new_data = gfc_get_data ();
654 : 2577 : new_data->where = gfc_current_locus;
655 : :
656 : 2577 : m = top_var_list (new_data);
657 : 2577 : if (m != MATCH_YES)
658 : 18 : goto cleanup;
659 : :
660 : 2559 : if (new_data->var->iter.var
661 : 121 : && new_data->var->iter.var->ts.type == BT_INTEGER
662 : 73 : && new_data->var->iter.var->symtree->n.sym->attr.implied_index == 1
663 : 67 : && new_data->var->list
664 : 67 : && new_data->var->list->expr
665 : 54 : && new_data->var->list->expr->ts.type == BT_CHARACTER
666 : 3 : && new_data->var->list->expr->ref
667 : 3 : && new_data->var->list->expr->ref->type == REF_SUBSTRING)
668 : : {
669 : 1 : gfc_error ("Invalid substring in data-implied-do at %L in DATA "
670 : : "statement", &new_data->var->list->expr->where);
671 : 1 : goto cleanup;
672 : : }
673 : :
674 : : /* Check for an entity with an allocatable component, which is not
675 : : allowed. */
676 : 2558 : e = new_data->var->expr;
677 : 2558 : if (e)
678 : : {
679 : 2438 : bool invalid;
680 : :
681 : 2438 : invalid = false;
682 : 3743 : for (ref = e->ref; ref; ref = ref->next)
683 : 1305 : if ((ref->type == REF_COMPONENT
684 : 138 : && ref->u.c.component->attr.allocatable)
685 : 1303 : || (ref->type == REF_ARRAY
686 : 1117 : && e->symtree->n.sym->attr.pointer != 1
687 : 1114 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
688 : 1305 : invalid = true;
689 : :
690 : 2438 : if (invalid)
691 : : {
692 : 2 : gfc_error ("Allocatable component or deferred-shaped array "
693 : : "near %C in DATA statement");
694 : 2 : goto cleanup;
695 : : }
696 : :
697 : : /* F2008:C567 (R536) A data-i-do-object or a variable that appears
698 : : as a data-stmt-object shall not be an object designator in which
699 : : a pointer appears other than as the entire rightmost part-ref. */
700 : 2436 : if (!e->ref && e->ts.type == BT_DERIVED
701 : 33 : && e->symtree->n.sym->attr.pointer)
702 : 4 : goto partref;
703 : :
704 : 2432 : ref = e->ref;
705 : 2432 : if (e->symtree->n.sym->ts.type == BT_DERIVED
706 : 112 : && e->symtree->n.sym->attr.pointer
707 : 1 : && ref->type == REF_COMPONENT)
708 : 1 : goto partref;
709 : :
710 : 3728 : for (; ref; ref = ref->next)
711 : 1298 : if (ref->type == REF_COMPONENT
712 : 133 : && ref->u.c.component->attr.pointer
713 : 27 : && ref->next)
714 : 1 : goto partref;
715 : : }
716 : :
717 : 2550 : m = top_val_list (new_data);
718 : 2550 : if (m != MATCH_YES)
719 : 29 : goto cleanup;
720 : :
721 : 2521 : new_data->next = gfc_current_ns->data;
722 : 2521 : gfc_current_ns->data = new_data;
723 : :
724 : : /* A BOZ literal constant cannot appear in a structure constructor.
725 : : Check for that here for a data statement value. */
726 : 2521 : if (new_data->value->expr->ts.type == BT_DERIVED
727 : 26 : && new_data->value->expr->value.constructor)
728 : : {
729 : 24 : gfc_constructor *c;
730 : 24 : c = gfc_constructor_first (new_data->value->expr->value.constructor);
731 : 73 : for (; c; c = gfc_constructor_next (c))
732 : 25 : if (c->expr && c->expr->ts.type == BT_BOZ)
733 : : {
734 : 0 : gfc_error ("BOZ literal constant at %L cannot appear in a "
735 : : "structure constructor", &c->expr->where);
736 : 0 : return MATCH_ERROR;
737 : : }
738 : : }
739 : :
740 : 2521 : if (gfc_match_eos () == MATCH_YES)
741 : : break;
742 : :
743 : 97 : gfc_match_char (','); /* Optional comma */
744 : 97 : }
745 : :
746 : 2424 : set_in_match_data (false);
747 : :
748 : 2424 : if (gfc_pure (NULL))
749 : : {
750 : 0 : gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
751 : 0 : return MATCH_ERROR;
752 : : }
753 : 2424 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
754 : :
755 : 2424 : return MATCH_YES;
756 : :
757 : 6 : partref:
758 : :
759 : 6 : gfc_error ("part-ref with pointer attribute near %L is not "
760 : : "rightmost part-ref of data-stmt-object",
761 : : &e->where);
762 : :
763 : 56 : cleanup:
764 : 56 : set_in_match_data (false);
765 : 56 : gfc_free_data (new_data);
766 : 56 : return MATCH_ERROR;
767 : : }
768 : :
769 : :
770 : : /************************ Declaration statements *********************/
771 : :
772 : :
773 : : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
774 : : list). The difference here is the expression is a list of constants
775 : : and is surrounded by '/'.
776 : : The typespec ts must match the typespec of the variable which the
777 : : clist is initializing.
778 : : The arrayspec tells whether this should match a list of constants
779 : : corresponding to array elements or a scalar (as == NULL). */
780 : :
781 : : static match
782 : 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
783 : : {
784 : 74 : gfc_constructor_base array_head = NULL;
785 : 74 : gfc_expr *expr = NULL;
786 : 74 : match m = MATCH_ERROR;
787 : 74 : locus where;
788 : 74 : mpz_t repeat, cons_size, as_size;
789 : 74 : bool scalar;
790 : 74 : int cmp;
791 : :
792 : 74 : gcc_assert (ts);
793 : :
794 : : /* We have already matched '/' - now look for a constant list, as with
795 : : top_val_list from decl.cc, but append the result to an array. */
796 : 74 : if (gfc_match ("/") == MATCH_YES)
797 : : {
798 : 1 : gfc_error ("Empty old style initializer list at %C");
799 : 1 : return MATCH_ERROR;
800 : : }
801 : :
802 : 73 : where = gfc_current_locus;
803 : 73 : scalar = !as || !as->rank;
804 : :
805 : 42 : if (!scalar && !spec_size (as, &as_size))
806 : : {
807 : 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
808 : 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
809 : : /* Nothing to cleanup yet. */
810 : 1 : return MATCH_ERROR;
811 : : }
812 : :
813 : 72 : mpz_init_set_ui (repeat, 0);
814 : :
815 : 143 : for (;;)
816 : : {
817 : 143 : m = match_data_constant (&expr);
818 : 143 : if (m != MATCH_YES)
819 : 3 : expr = NULL; /* match_data_constant may set expr to garbage */
820 : 3 : if (m == MATCH_NO)
821 : 2 : goto syntax;
822 : 141 : if (m == MATCH_ERROR)
823 : 1 : goto cleanup;
824 : :
825 : : /* Found r in repeat spec r*c; look for the constant to repeat. */
826 : 140 : if ( gfc_match_char ('*') == MATCH_YES)
827 : : {
828 : 18 : if (scalar)
829 : : {
830 : 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
831 : 1 : goto cleanup;
832 : : }
833 : 17 : if (expr->ts.type != BT_INTEGER)
834 : : {
835 : 1 : gfc_error ("Repeat spec must be an integer at %C");
836 : 1 : goto cleanup;
837 : : }
838 : 16 : mpz_set (repeat, expr->value.integer);
839 : 16 : gfc_free_expr (expr);
840 : 16 : expr = NULL;
841 : :
842 : 16 : m = match_data_constant (&expr);
843 : 16 : if (m == MATCH_NO)
844 : : {
845 : 1 : m = MATCH_ERROR;
846 : 1 : gfc_error ("Expected data constant after repeat spec at %C");
847 : : }
848 : 16 : if (m != MATCH_YES)
849 : 1 : goto cleanup;
850 : : }
851 : : /* No repeat spec, we matched the data constant itself. */
852 : : else
853 : 122 : mpz_set_ui (repeat, 1);
854 : :
855 : 137 : if (!scalar)
856 : : {
857 : : /* Add the constant initializer as many times as repeated. */
858 : 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
859 : : {
860 : : /* Make sure types of elements match */
861 : 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
862 : 12 : && !gfc_convert_type (expr, ts, 1))
863 : 0 : goto cleanup;
864 : :
865 : 144 : gfc_constructor_append_expr (&array_head,
866 : : gfc_copy_expr (expr), &gfc_current_locus);
867 : : }
868 : :
869 : 107 : gfc_free_expr (expr);
870 : 107 : expr = NULL;
871 : : }
872 : :
873 : : /* For scalar initializers quit after one element. */
874 : : else
875 : : {
876 : 30 : if(gfc_match_char ('/') != MATCH_YES)
877 : : {
878 : 1 : gfc_error ("End of scalar initializer expected at %C");
879 : 1 : goto cleanup;
880 : : }
881 : : break;
882 : : }
883 : :
884 : 107 : if (gfc_match_char ('/') == MATCH_YES)
885 : : break;
886 : 72 : if (gfc_match_char (',') == MATCH_NO)
887 : 1 : goto syntax;
888 : : }
889 : :
890 : : /* If we break early from here out, we encountered an error. */
891 : 64 : m = MATCH_ERROR;
892 : :
893 : : /* Set up expr as an array constructor. */
894 : 64 : if (!scalar)
895 : : {
896 : 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
897 : 35 : expr->ts = *ts;
898 : 35 : expr->value.constructor = array_head;
899 : :
900 : : /* Validate sizes. We built expr ourselves, so cons_size will be
901 : : constant (we fail above for non-constant expressions).
902 : : We still need to verify that the sizes match. */
903 : 35 : gcc_assert (gfc_array_size (expr, &cons_size));
904 : 35 : cmp = mpz_cmp (cons_size, as_size);
905 : 35 : if (cmp < 0)
906 : 2 : gfc_error ("Not enough elements in array initializer at %C");
907 : 33 : else if (cmp > 0)
908 : 3 : gfc_error ("Too many elements in array initializer at %C");
909 : 35 : mpz_clear (cons_size);
910 : 35 : if (cmp)
911 : 5 : goto cleanup;
912 : :
913 : : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
914 : 30 : expr->rank = as->rank;
915 : 30 : expr->shape = gfc_get_shape (as->rank);
916 : 66 : for (int i = 0; i < as->rank; ++i)
917 : 36 : spec_dimen_size (as, i, &expr->shape[i]);
918 : : }
919 : :
920 : : /* Make sure scalar types match. */
921 : 29 : else if (!gfc_compare_types (&expr->ts, ts)
922 : 29 : && !gfc_convert_type (expr, ts, 1))
923 : 2 : goto cleanup;
924 : :
925 : 57 : if (expr->ts.u.cl)
926 : 1 : expr->ts.u.cl->length_from_typespec = 1;
927 : :
928 : 57 : *result = expr;
929 : 57 : m = MATCH_YES;
930 : 57 : goto done;
931 : :
932 : 3 : syntax:
933 : 3 : m = MATCH_ERROR;
934 : 3 : gfc_error ("Syntax error in old style initializer list at %C");
935 : :
936 : 15 : cleanup:
937 : 15 : if (expr)
938 : 10 : expr->value.constructor = NULL;
939 : 15 : gfc_free_expr (expr);
940 : 15 : gfc_constructor_free (array_head);
941 : :
942 : 72 : done:
943 : 72 : mpz_clear (repeat);
944 : 72 : if (!scalar)
945 : 41 : mpz_clear (as_size);
946 : : return m;
947 : : }
948 : :
949 : :
950 : : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
951 : :
952 : : static bool
953 : 84 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
954 : : {
955 : 84 : if ((from->type == AS_ASSUMED_RANK && to->corank)
956 : 82 : || (to->type == AS_ASSUMED_RANK && from->corank))
957 : : {
958 : 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
959 : 5 : return false;
960 : : }
961 : :
962 : 79 : if (to->rank == 0 && from->rank > 0)
963 : : {
964 : 32 : to->rank = from->rank;
965 : 32 : to->type = from->type;
966 : 32 : to->cray_pointee = from->cray_pointee;
967 : 32 : to->cp_was_assumed = from->cp_was_assumed;
968 : :
969 : 102 : for (int i = to->corank - 1; i >= 0; i--)
970 : : {
971 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
972 : : cleans up elsewhere. */
973 : 70 : int j = from->rank + i;
974 : 70 : if (j >= GFC_MAX_DIMENSIONS)
975 : : break;
976 : :
977 : 70 : to->lower[j] = to->lower[i];
978 : 70 : to->upper[j] = to->upper[i];
979 : : }
980 : 77 : for (int i = 0; i < from->rank; i++)
981 : : {
982 : 45 : if (copy)
983 : : {
984 : 29 : to->lower[i] = gfc_copy_expr (from->lower[i]);
985 : 29 : to->upper[i] = gfc_copy_expr (from->upper[i]);
986 : : }
987 : : else
988 : : {
989 : 16 : to->lower[i] = from->lower[i];
990 : 16 : to->upper[i] = from->upper[i];
991 : : }
992 : : }
993 : : }
994 : 47 : else if (to->corank == 0 && from->corank > 0)
995 : : {
996 : 22 : to->corank = from->corank;
997 : 22 : to->cotype = from->cotype;
998 : :
999 : 75 : for (int i = 0; i < from->corank; i++)
1000 : : {
1001 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
1002 : : cleans up elsewhere. */
1003 : 54 : int k = from->rank + i;
1004 : 54 : int j = to->rank + i;
1005 : 54 : if (j >= GFC_MAX_DIMENSIONS)
1006 : : break;
1007 : :
1008 : 53 : if (copy)
1009 : : {
1010 : 24 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1011 : 24 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1012 : : }
1013 : : else
1014 : : {
1015 : 29 : to->lower[j] = from->lower[k];
1016 : 29 : to->upper[j] = from->upper[k];
1017 : : }
1018 : : }
1019 : : }
1020 : :
1021 : 79 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1022 : : {
1023 : 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1024 : : "allowed dimensions of %d",
1025 : : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1026 : 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1027 : 1 : return false;
1028 : : }
1029 : : return true;
1030 : : }
1031 : :
1032 : :
1033 : : /* Match an intent specification. Since this can only happen after an
1034 : : INTENT word, a legal intent-spec must follow. */
1035 : :
1036 : : static sym_intent
1037 : 22546 : match_intent_spec (void)
1038 : : {
1039 : :
1040 : 22546 : if (gfc_match (" ( in out )") == MATCH_YES)
1041 : : return INTENT_INOUT;
1042 : 20028 : if (gfc_match (" ( in )") == MATCH_YES)
1043 : : return INTENT_IN;
1044 : 3052 : if (gfc_match (" ( out )") == MATCH_YES)
1045 : : return INTENT_OUT;
1046 : :
1047 : 2 : gfc_error ("Bad INTENT specification at %C");
1048 : 2 : return INTENT_UNKNOWN;
1049 : : }
1050 : :
1051 : :
1052 : : /* Matches a character length specification, which is either a
1053 : : specification expression, '*', or ':'. */
1054 : :
1055 : : static match
1056 : 23370 : char_len_param_value (gfc_expr **expr, bool *deferred)
1057 : : {
1058 : 23370 : match m;
1059 : 23370 : gfc_expr *p;
1060 : :
1061 : 23370 : *expr = NULL;
1062 : 23370 : *deferred = false;
1063 : :
1064 : 23370 : if (gfc_match_char ('*') == MATCH_YES)
1065 : : return MATCH_YES;
1066 : :
1067 : 17525 : if (gfc_match_char (':') == MATCH_YES)
1068 : : {
1069 : 2066 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1070 : : return MATCH_ERROR;
1071 : :
1072 : 2064 : *deferred = true;
1073 : :
1074 : 2064 : return MATCH_YES;
1075 : : }
1076 : :
1077 : 15459 : m = gfc_match_expr (expr);
1078 : :
1079 : 15459 : if (m == MATCH_NO || m == MATCH_ERROR)
1080 : : return m;
1081 : :
1082 : 15454 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1083 : : return MATCH_ERROR;
1084 : :
1085 : : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1086 : 15448 : p = gfc_copy_expr (*expr);
1087 : 15448 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1088 : 13069 : gfc_replace_expr (*expr, p);
1089 : : else
1090 : 2379 : gfc_free_expr (p);
1091 : :
1092 : 15448 : if ((*expr)->expr_type == EXPR_FUNCTION)
1093 : : {
1094 : 968 : if ((*expr)->ts.type == BT_INTEGER
1095 : 967 : || ((*expr)->ts.type == BT_UNKNOWN
1096 : 967 : && strcmp((*expr)->symtree->name, "null") != 0))
1097 : : return MATCH_YES;
1098 : :
1099 : 2 : goto syntax;
1100 : : }
1101 : 14480 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1102 : : {
1103 : : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1104 : : processor dependent and its value is greater than or equal to zero.
1105 : : F2008, 4.4.3.2: If the character length parameter value evaluates
1106 : : to a negative value, the length of character entities declared
1107 : : is zero. */
1108 : :
1109 : 13016 : if ((*expr)->ts.type == BT_INTEGER)
1110 : : {
1111 : 12998 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1112 : 4 : mpz_set_si ((*expr)->value.integer, 0);
1113 : : }
1114 : : else
1115 : 18 : goto syntax;
1116 : : }
1117 : 1464 : else if ((*expr)->expr_type == EXPR_ARRAY)
1118 : 8 : goto syntax;
1119 : 1456 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1120 : : {
1121 : 1112 : bool t;
1122 : 1112 : gfc_expr *e;
1123 : :
1124 : 1112 : e = gfc_copy_expr (*expr);
1125 : :
1126 : : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1127 : : which causes an ICE if gfc_reduce_init_expr() is called. */
1128 : 1112 : if (e->ref && e->ref->type == REF_ARRAY
1129 : 8 : && e->ref->u.ar.type == AR_UNKNOWN
1130 : 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1131 : 2 : goto syntax;
1132 : :
1133 : 1110 : t = gfc_reduce_init_expr (e);
1134 : :
1135 : 1110 : if (!t && e->ts.type == BT_UNKNOWN
1136 : 7 : && e->symtree->n.sym->attr.untyped == 1
1137 : 7 : && (flag_implicit_none
1138 : 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1139 : 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1140 : : {
1141 : 7 : gfc_free_expr (e);
1142 : 7 : goto syntax;
1143 : : }
1144 : :
1145 : 1103 : if ((e->ref && e->ref->type == REF_ARRAY
1146 : 4 : && e->ref->u.ar.type != AR_ELEMENT)
1147 : 1102 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1148 : : {
1149 : 2 : gfc_free_expr (e);
1150 : 2 : goto syntax;
1151 : : }
1152 : :
1153 : 1101 : gfc_free_expr (e);
1154 : : }
1155 : :
1156 : 14443 : if (gfc_seen_div0)
1157 : 52 : m = MATCH_ERROR;
1158 : :
1159 : : return m;
1160 : :
1161 : 39 : syntax:
1162 : 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1163 : 39 : return MATCH_ERROR;
1164 : : }
1165 : :
1166 : :
1167 : : /* A character length is a '*' followed by a literal integer or a
1168 : : char_len_param_value in parenthesis. */
1169 : :
1170 : : static match
1171 : 54234 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1172 : : {
1173 : 54234 : int length;
1174 : 54234 : match m;
1175 : :
1176 : 54234 : *deferred = false;
1177 : 54234 : m = gfc_match_char ('*');
1178 : 54234 : if (m != MATCH_YES)
1179 : : return m;
1180 : :
1181 : 2698 : m = gfc_match_small_literal_int (&length, NULL);
1182 : 2698 : if (m == MATCH_ERROR)
1183 : : return m;
1184 : :
1185 : 2698 : if (m == MATCH_YES)
1186 : : {
1187 : 2194 : if (obsolescent_check
1188 : 2194 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1189 : : return MATCH_ERROR;
1190 : 2194 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1191 : 2194 : return m;
1192 : : }
1193 : :
1194 : 504 : if (gfc_match_char ('(') == MATCH_NO)
1195 : 0 : goto syntax;
1196 : :
1197 : 504 : m = char_len_param_value (expr, deferred);
1198 : 504 : if (m != MATCH_YES && gfc_matching_function)
1199 : : {
1200 : 0 : gfc_undo_symbols ();
1201 : 0 : m = MATCH_YES;
1202 : : }
1203 : :
1204 : 1 : if (m == MATCH_ERROR)
1205 : : return m;
1206 : 503 : if (m == MATCH_NO)
1207 : 0 : goto syntax;
1208 : :
1209 : 503 : if (gfc_match_char (')') == MATCH_NO)
1210 : : {
1211 : 0 : gfc_free_expr (*expr);
1212 : 0 : *expr = NULL;
1213 : 0 : goto syntax;
1214 : : }
1215 : :
1216 : : return MATCH_YES;
1217 : :
1218 : 0 : syntax:
1219 : 0 : gfc_error ("Syntax error in character length specification at %C");
1220 : 0 : return MATCH_ERROR;
1221 : : }
1222 : :
1223 : :
1224 : : /* Special subroutine for finding a symbol. Check if the name is found
1225 : : in the current name space. If not, and we're compiling a function or
1226 : : subroutine and the parent compilation unit is an interface, then check
1227 : : to see if the name we've been given is the name of the interface
1228 : : (located in another namespace). */
1229 : :
1230 : : static int
1231 : 237759 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1232 : : {
1233 : 237759 : gfc_state_data *s;
1234 : 237759 : gfc_symtree *st;
1235 : 237759 : int i;
1236 : :
1237 : 237759 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1238 : 237759 : if (i == 0)
1239 : : {
1240 : 237759 : *result = st ? st->n.sym : NULL;
1241 : 237759 : goto end;
1242 : : }
1243 : :
1244 : 0 : if (gfc_current_state () != COMP_SUBROUTINE
1245 : 0 : && gfc_current_state () != COMP_FUNCTION)
1246 : 0 : goto end;
1247 : :
1248 : 0 : s = gfc_state_stack->previous;
1249 : 0 : if (s == NULL)
1250 : 0 : goto end;
1251 : :
1252 : 0 : if (s->state != COMP_INTERFACE)
1253 : 0 : goto end;
1254 : 0 : if (s->sym == NULL)
1255 : 0 : goto end; /* Nameless interface. */
1256 : :
1257 : 0 : if (strcmp (name, s->sym->name) == 0)
1258 : : {
1259 : 0 : *result = s->sym;
1260 : 0 : return 0;
1261 : : }
1262 : :
1263 : 0 : end:
1264 : : return i;
1265 : : }
1266 : :
1267 : :
1268 : : /* Special subroutine for getting a symbol node associated with a
1269 : : procedure name, used in SUBROUTINE and FUNCTION statements. The
1270 : : symbol is created in the parent using with symtree node in the
1271 : : child unit pointing to the symbol. If the current namespace has no
1272 : : parent, then the symbol is just created in the current unit. */
1273 : :
1274 : : static int
1275 : 51033 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1276 : : {
1277 : 51033 : gfc_symtree *st;
1278 : 51033 : gfc_symbol *sym;
1279 : 51033 : int rc = 0;
1280 : :
1281 : : /* Module functions have to be left in their own namespace because
1282 : : they have potentially (almost certainly!) already been referenced.
1283 : : In this sense, they are rather like external functions. This is
1284 : : fixed up in resolve.cc(resolve_entries), where the symbol name-
1285 : : space is set to point to the master function, so that the fake
1286 : : result mechanism can work. */
1287 : 51033 : if (module_fcn_entry)
1288 : : {
1289 : : /* Present if entry is declared to be a module procedure. */
1290 : 259 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1291 : :
1292 : 259 : if (*result == NULL)
1293 : 216 : rc = gfc_get_symbol (name, NULL, result);
1294 : 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1295 : 43 : && (*result)->ts.type == BT_UNKNOWN
1296 : 86 : && sym->attr.flavor == FL_UNKNOWN)
1297 : : /* Pick up the typespec for the entry, if declared in the function
1298 : : body. Note that this symbol is FL_UNKNOWN because it will
1299 : : only have appeared in a type declaration. The local symtree
1300 : : is set to point to the module symbol and a unique symtree
1301 : : to the local version. This latter ensures a correct clearing
1302 : : of the symbols. */
1303 : : {
1304 : : /* If the ENTRY proceeds its specification, we need to ensure
1305 : : that this does not raise a "has no IMPLICIT type" error. */
1306 : 43 : if (sym->ts.type == BT_UNKNOWN)
1307 : 23 : sym->attr.untyped = 1;
1308 : :
1309 : 43 : (*result)->ts = sym->ts;
1310 : :
1311 : : /* Put the symbol in the procedure namespace so that, should
1312 : : the ENTRY precede its specification, the specification
1313 : : can be applied. */
1314 : 43 : (*result)->ns = gfc_current_ns;
1315 : :
1316 : 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1317 : 43 : st->n.sym = *result;
1318 : 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1319 : 43 : sym->refs++;
1320 : 43 : st->n.sym = sym;
1321 : : }
1322 : : }
1323 : : else
1324 : 50774 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1325 : :
1326 : 51033 : if (rc)
1327 : : return rc;
1328 : :
1329 : 51032 : sym = *result;
1330 : 51032 : if (sym->attr.proc == PROC_ST_FUNCTION)
1331 : : return rc;
1332 : :
1333 : 51032 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1334 : : {
1335 : : /* Create a partially populated interface symbol to carry the
1336 : : characteristics of the procedure and the result. */
1337 : 338 : sym->tlink = gfc_new_symbol (name, sym->ns);
1338 : 338 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1339 : 338 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1340 : 338 : if (sym->attr.dimension)
1341 : 15 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1342 : :
1343 : : /* Ideally, at this point, a copy would be made of the formal
1344 : : arguments and their namespace. However, this does not appear
1345 : : to be necessary, albeit at the expense of not being able to
1346 : : use gfc_compare_interfaces directly. */
1347 : :
1348 : 338 : if (sym->result && sym->result != sym)
1349 : : {
1350 : 54 : sym->tlink->result = sym->result;
1351 : 54 : sym->result = NULL;
1352 : : }
1353 : 284 : else if (sym->result)
1354 : : {
1355 : 60 : sym->tlink->result = sym->tlink;
1356 : : }
1357 : : }
1358 : 50694 : else if (sym && !sym->gfc_new
1359 : 18610 : && gfc_current_state () != COMP_INTERFACE)
1360 : : {
1361 : : /* Trap another encompassed procedure with the same name. All
1362 : : these conditions are necessary to avoid picking up an entry
1363 : : whose name clashes with that of the encompassing procedure;
1364 : : this is handled using gsymbols to register unique, globally
1365 : : accessible names. */
1366 : 17815 : if (sym->attr.flavor != 0
1367 : 16025 : && sym->attr.proc != 0
1368 : 1987 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1369 : 6 : && sym->attr.if_source != IFSRC_UNKNOWN)
1370 : : {
1371 : 6 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1372 : : name, &sym->declared_at);
1373 : 6 : return true;
1374 : : }
1375 : 17809 : if (sym->attr.flavor != 0
1376 : 16019 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1377 : : {
1378 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1379 : : name, &sym->declared_at);
1380 : 1 : return true;
1381 : : }
1382 : :
1383 : 17808 : if (sym->attr.external && sym->attr.procedure
1384 : 2 : && gfc_current_state () == COMP_CONTAINS)
1385 : : {
1386 : 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1387 : : "procedure defined at %L",
1388 : : name, &sym->declared_at);
1389 : 1 : return true;
1390 : : }
1391 : :
1392 : : /* Trap a procedure with a name the same as interface in the
1393 : : encompassing scope. */
1394 : 17807 : if (sym->attr.generic != 0
1395 : 59 : && (sym->attr.subroutine || sym->attr.function)
1396 : 1 : && !sym->attr.mod_proc)
1397 : : {
1398 : 1 : gfc_error_now ("Name %qs at %C is already defined"
1399 : : " as a generic interface at %L",
1400 : : name, &sym->declared_at);
1401 : 1 : return true;
1402 : : }
1403 : :
1404 : : /* Trap declarations of attributes in encompassing scope. The
1405 : : signature for this is that ts.kind is nonzero for no-CLASS
1406 : : entity. For a CLASS entity, ts.kind is zero. */
1407 : 17806 : if ((sym->ts.kind != 0 || sym->ts.type == BT_CLASS)
1408 : 341 : && !sym->attr.implicit_type
1409 : 340 : && sym->attr.proc == 0
1410 : 334 : && gfc_current_ns->parent != NULL
1411 : 135 : && sym->attr.access == 0
1412 : 133 : && !module_fcn_entry)
1413 : : {
1414 : 3 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1415 : : "from a previous declaration", name);
1416 : 3 : return true;
1417 : : }
1418 : : }
1419 : :
1420 : : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1421 : : subroutine-stmt of a module subprogram or of a nonabstract interface
1422 : : body that is declared in the scoping unit of a module or submodule. */
1423 : 51020 : if (sym->attr.external
1424 : 68 : && (sym->attr.subroutine || sym->attr.function)
1425 : 67 : && sym->attr.if_source == IFSRC_IFBODY
1426 : 67 : && !current_attr.module_procedure
1427 : 4 : && sym->attr.proc == PROC_MODULE
1428 : 3 : && gfc_state_stack->state == COMP_CONTAINS)
1429 : : {
1430 : 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1431 : : "clashes with internal procedure defined at %C",
1432 : : name, &sym->declared_at);
1433 : 1 : return true;
1434 : : }
1435 : :
1436 : 51019 : if (sym && !sym->gfc_new
1437 : 18935 : && sym->attr.flavor != FL_UNKNOWN
1438 : 16842 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1439 : 193 : && gfc_state_stack->state == COMP_CONTAINS
1440 : 188 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1441 : : {
1442 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1443 : : name, &sym->declared_at);
1444 : 1 : return true;
1445 : : }
1446 : :
1447 : 51018 : if (gfc_current_ns->parent == NULL || *result == NULL)
1448 : : return rc;
1449 : :
1450 : : /* Module function entries will already have a symtree in
1451 : : the current namespace but will need one at module level. */
1452 : 39631 : if (module_fcn_entry)
1453 : : {
1454 : : /* Present if entry is declared to be a module procedure. */
1455 : 257 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1456 : 257 : if (st == NULL)
1457 : 216 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1458 : : }
1459 : : else
1460 : 39374 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1461 : :
1462 : 39631 : st->n.sym = sym;
1463 : 39631 : sym->refs++;
1464 : :
1465 : : /* See if the procedure should be a module procedure. */
1466 : :
1467 : 39631 : if (((sym->ns->proc_name != NULL
1468 : 39631 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1469 : 17436 : && sym->attr.proc != PROC_MODULE)
1470 : 39631 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1471 : 54771 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1472 : : rc = 2;
1473 : :
1474 : : return rc;
1475 : : }
1476 : :
1477 : :
1478 : : /* Verify that the given symbol representing a parameter is C
1479 : : interoperable, by checking to see if it was marked as such after
1480 : : its declaration. If the given symbol is not interoperable, a
1481 : : warning is reported, thus removing the need to return the status to
1482 : : the calling function. The standard does not require the user use
1483 : : one of the iso_c_binding named constants to declare an
1484 : : interoperable parameter, but we can't be sure if the param is C
1485 : : interop or not if the user doesn't. For example, integer(4) may be
1486 : : legal Fortran, but doesn't have meaning in C. It may interop with
1487 : : a number of the C types, which causes a problem because the
1488 : : compiler can't know which one. This code is almost certainly not
1489 : : portable, and the user will get what they deserve if the C type
1490 : : across platforms isn't always interoperable with integer(4). If
1491 : : the user had used something like integer(c_int) or integer(c_long),
1492 : : the compiler could have automatically handled the varying sizes
1493 : : across platforms. */
1494 : :
1495 : : bool
1496 : 12265 : gfc_verify_c_interop_param (gfc_symbol *sym)
1497 : : {
1498 : 12265 : int is_c_interop = 0;
1499 : 12265 : bool retval = true;
1500 : :
1501 : : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1502 : : Don't repeat the checks here. */
1503 : 12265 : if (sym->attr.implicit_type)
1504 : : return true;
1505 : :
1506 : : /* For subroutines or functions that are passed to a BIND(C) procedure,
1507 : : they're interoperable if they're BIND(C) and their params are all
1508 : : interoperable. */
1509 : 12265 : if (sym->attr.flavor == FL_PROCEDURE)
1510 : : {
1511 : 2 : if (sym->attr.is_bind_c == 0)
1512 : : {
1513 : 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1514 : : "attribute to be C interoperable", sym->name,
1515 : : &(sym->declared_at));
1516 : 0 : return false;
1517 : : }
1518 : : else
1519 : : {
1520 : 2 : if (sym->attr.is_c_interop == 1)
1521 : : /* We've already checked this procedure; don't check it again. */
1522 : : return true;
1523 : : else
1524 : 2 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1525 : 2 : sym->common_block);
1526 : : }
1527 : : }
1528 : :
1529 : : /* See if we've stored a reference to a procedure that owns sym. */
1530 : 12263 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1531 : : {
1532 : 12263 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1533 : : {
1534 : 12223 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1535 : :
1536 : 3105 : if (is_c_interop != 1)
1537 : : {
1538 : : /* Make personalized messages to give better feedback. */
1539 : 3105 : if (sym->ts.type == BT_DERIVED)
1540 : 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1541 : : "BIND(C) procedure %qs but is not C interoperable "
1542 : : "because derived type %qs is not C interoperable",
1543 : : sym->name, &(sym->declared_at),
1544 : 1 : sym->ns->proc_name->name,
1545 : 1 : sym->ts.u.derived->name);
1546 : 3104 : else if (sym->ts.type == BT_CLASS)
1547 : 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1548 : : "BIND(C) procedure %qs but is not C interoperable "
1549 : : "because it is polymorphic",
1550 : : sym->name, &(sym->declared_at),
1551 : 6 : sym->ns->proc_name->name);
1552 : 3098 : else if (warn_c_binding_type)
1553 : 19 : gfc_warning (OPT_Wc_binding_type,
1554 : : "Variable %qs at %L is a dummy argument of the "
1555 : : "BIND(C) procedure %qs but may not be C "
1556 : : "interoperable",
1557 : : sym->name, &(sym->declared_at),
1558 : 19 : sym->ns->proc_name->name);
1559 : : }
1560 : :
1561 : : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1562 : 12223 : if (sym->attr.pointer && sym->attr.contiguous)
1563 : 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1564 : : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1565 : 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1566 : :
1567 : : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1568 : : procedure that are default-initialized are not permitted. */
1569 : 12223 : if ((sym->attr.pointer || sym->attr.allocatable)
1570 : 1029 : && sym->ts.type == BT_DERIVED
1571 : 12593 : && gfc_has_default_initializer (sym->ts.u.derived))
1572 : : {
1573 : 8 : gfc_error ("Default-initialized %s dummy argument %qs "
1574 : : "at %L is not permitted in BIND(C) procedure %qs",
1575 : 4 : (sym->attr.pointer ? "pointer" : "allocatable"),
1576 : : sym->name, &sym->declared_at,
1577 : 4 : sym->ns->proc_name->name);
1578 : 4 : retval = false;
1579 : : }
1580 : :
1581 : : /* Character strings are only C interoperable if they have a
1582 : : length of 1. However, as an argument they are also interoperable
1583 : : when passed as descriptor (which requires len=: or len=*). */
1584 : 12223 : if (sym->ts.type == BT_CHARACTER)
1585 : : {
1586 : 2239 : gfc_charlen *cl = sym->ts.u.cl;
1587 : :
1588 : 2239 : if (sym->attr.allocatable || sym->attr.pointer)
1589 : : {
1590 : : /* F2018, 18.3.6 (6). */
1591 : 193 : if (!sym->ts.deferred)
1592 : : {
1593 : 64 : if (sym->attr.allocatable)
1594 : 32 : gfc_error ("Allocatable character dummy argument %qs "
1595 : : "at %L must have deferred length as "
1596 : : "procedure %qs is BIND(C)", sym->name,
1597 : 32 : &sym->declared_at, sym->ns->proc_name->name);
1598 : : else
1599 : 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1600 : : "must have deferred length as procedure %qs "
1601 : : "is BIND(C)", sym->name, &sym->declared_at,
1602 : 32 : sym->ns->proc_name->name);
1603 : : retval = false;
1604 : : }
1605 : 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1606 : : "Deferred-length character dummy "
1607 : : "argument %qs at %L of procedure "
1608 : : "%qs with BIND(C) attribute",
1609 : : sym->name, &sym->declared_at,
1610 : 129 : sym->ns->proc_name->name))
1611 : 102 : retval = false;
1612 : : }
1613 : 2046 : else if (sym->attr.value
1614 : 351 : && (!cl || !cl->length
1615 : 351 : || cl->length->expr_type != EXPR_CONSTANT
1616 : 351 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1617 : : {
1618 : 1 : gfc_error ("Character dummy argument %qs at %L must be "
1619 : : "of length 1 as it has the VALUE attribute",
1620 : : sym->name, &sym->declared_at);
1621 : 1 : retval = false;
1622 : : }
1623 : 2045 : else if (!cl || !cl->length)
1624 : : {
1625 : : /* Assumed length; F2018, 18.3.6 (5)(2).
1626 : : Uses the CFI array descriptor - also for scalars and
1627 : : explicit-size/assumed-size arrays. */
1628 : 876 : if (!gfc_notify_std (GFC_STD_F2018,
1629 : : "Assumed-length character dummy argument "
1630 : : "%qs at %L of procedure %qs with BIND(C) "
1631 : : "attribute", sym->name, &sym->declared_at,
1632 : 876 : sym->ns->proc_name->name))
1633 : 102 : retval = false;
1634 : : }
1635 : 1169 : else if (cl->length->expr_type != EXPR_CONSTANT
1636 : 855 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1637 : : {
1638 : : /* F2018, 18.3.6, (5), item 4. */
1639 : 653 : if (!sym->attr.dimension
1640 : 645 : || sym->as->type == AS_ASSUMED_SIZE
1641 : 639 : || sym->as->type == AS_EXPLICIT)
1642 : : {
1643 : 20 : gfc_error ("Character dummy argument %qs at %L must be "
1644 : : "of constant length of one or assumed length, "
1645 : : "unless it has assumed shape or assumed rank, "
1646 : : "as procedure %qs has the BIND(C) attribute",
1647 : : sym->name, &sym->declared_at,
1648 : 20 : sym->ns->proc_name->name);
1649 : 20 : retval = false;
1650 : : }
1651 : : /* else: valid only since F2018 - and an assumed-shape/rank
1652 : : array; however, gfc_notify_std is already called when
1653 : : those array types are used. Thus, silently accept F200x. */
1654 : : }
1655 : : }
1656 : :
1657 : : /* We have to make sure that any param to a bind(c) routine does
1658 : : not have the allocatable, pointer, or optional attributes,
1659 : : according to J3/04-007, section 5.1. */
1660 : 12223 : if (sym->attr.allocatable == 1
1661 : 12619 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1662 : : "ALLOCATABLE attribute in procedure %qs "
1663 : : "with BIND(C)", sym->name,
1664 : : &(sym->declared_at),
1665 : 396 : sym->ns->proc_name->name))
1666 : : retval = false;
1667 : :
1668 : 12223 : if (sym->attr.pointer == 1
1669 : 12856 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1670 : : "POINTER attribute in procedure %qs "
1671 : : "with BIND(C)", sym->name,
1672 : : &(sym->declared_at),
1673 : 633 : sym->ns->proc_name->name))
1674 : : retval = false;
1675 : :
1676 : 12223 : if (sym->attr.optional == 1 && sym->attr.value)
1677 : : {
1678 : 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1679 : : "and the VALUE attribute because procedure %qs "
1680 : : "is BIND(C)", sym->name, &(sym->declared_at),
1681 : 9 : sym->ns->proc_name->name);
1682 : 9 : retval = false;
1683 : : }
1684 : 12214 : else if (sym->attr.optional == 1
1685 : 12879 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1686 : : "at %L with OPTIONAL attribute in "
1687 : : "procedure %qs which is BIND(C)",
1688 : : sym->name, &(sym->declared_at),
1689 : 665 : sym->ns->proc_name->name))
1690 : : retval = false;
1691 : :
1692 : : /* Make sure that if it has the dimension attribute, that it is
1693 : : either assumed size or explicit shape. Deferred shape is already
1694 : : covered by the pointer/allocatable attribute. */
1695 : 4263 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1696 : 13528 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1697 : : "at %L as dummy argument to the BIND(C) "
1698 : : "procedure %qs at %L", sym->name,
1699 : : &(sym->declared_at),
1700 : : sym->ns->proc_name->name,
1701 : 1305 : &(sym->ns->proc_name->declared_at)))
1702 : : retval = false;
1703 : : }
1704 : : }
1705 : :
1706 : : return retval;
1707 : : }
1708 : :
1709 : :
1710 : :
1711 : : /* Function called by variable_decl() that adds a name to the symbol table. */
1712 : :
1713 : : static bool
1714 : 220542 : build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1715 : : gfc_array_spec **as, locus *var_locus)
1716 : : {
1717 : 220542 : symbol_attribute attr;
1718 : 220542 : gfc_symbol *sym;
1719 : 220542 : int upper;
1720 : 220542 : gfc_symtree *st;
1721 : :
1722 : : /* Symbols in a submodule are host associated from the parent module or
1723 : : submodules. Therefore, they can be overridden by declarations in the
1724 : : submodule scope. Deal with this by attaching the existing symbol to
1725 : : a new symtree and recycling the old symtree with a new symbol... */
1726 : 220542 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1727 : 220542 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1728 : 12 : && st->n.sym != NULL
1729 : 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1730 : : {
1731 : 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1732 : 12 : s->n.sym = st->n.sym;
1733 : 12 : sym = gfc_new_symbol (name, gfc_current_ns);
1734 : :
1735 : :
1736 : 12 : st->n.sym = sym;
1737 : 12 : sym->refs++;
1738 : 12 : gfc_set_sym_referenced (sym);
1739 : 12 : }
1740 : : /* ...Otherwise generate a new symtree and new symbol. */
1741 : 220530 : else if (gfc_get_symbol (name, NULL, &sym))
1742 : : return false;
1743 : :
1744 : : /* Check if the name has already been defined as a type. The
1745 : : first letter of the symtree will be in upper case then. Of
1746 : : course, this is only necessary if the upper case letter is
1747 : : actually different. */
1748 : :
1749 : 220542 : upper = TOUPPER(name[0]);
1750 : 220542 : if (upper != name[0])
1751 : : {
1752 : 219908 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1753 : 219908 : gfc_symtree *st;
1754 : :
1755 : 219908 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1756 : 219908 : strcpy (u_name, name);
1757 : 219908 : u_name[0] = upper;
1758 : :
1759 : 219908 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1760 : :
1761 : : /* STRUCTURE types can alias symbol names */
1762 : 219908 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1763 : : {
1764 : 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1765 : : &st->n.sym->declared_at);
1766 : 1 : return false;
1767 : : }
1768 : : }
1769 : :
1770 : : /* Start updating the symbol table. Add basic type attribute if present. */
1771 : 220541 : if (current_ts.type != BT_UNKNOWN
1772 : 220541 : && (sym->attr.implicit_type == 0
1773 : 191 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1774 : 440895 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1775 : : return false;
1776 : :
1777 : 220515 : if (sym->ts.type == BT_CHARACTER)
1778 : : {
1779 : 25689 : sym->ts.u.cl = cl;
1780 : 25689 : sym->ts.deferred = cl_deferred;
1781 : : }
1782 : :
1783 : : /* Add dimension attribute if present. */
1784 : 220515 : if (!gfc_set_array_spec (sym, *as, var_locus))
1785 : : return false;
1786 : 220513 : *as = NULL;
1787 : :
1788 : : /* Add attribute to symbol. The copy is so that we can reset the
1789 : : dimension attribute. */
1790 : 220513 : attr = current_attr;
1791 : 220513 : attr.dimension = 0;
1792 : 220513 : attr.codimension = 0;
1793 : :
1794 : 220513 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1795 : : return false;
1796 : :
1797 : : /* Finish any work that may need to be done for the binding label,
1798 : : if it's a bind(c). The bind(c) attr is found before the symbol
1799 : : is made, and before the symbol name (for data decls), so the
1800 : : current_ts is holding the binding label, or nothing if the
1801 : : name= attr wasn't given. Therefore, test here if we're dealing
1802 : : with a bind(c) and make sure the binding label is set correctly. */
1803 : 220500 : if (sym->attr.is_bind_c == 1)
1804 : : {
1805 : 1100 : if (!sym->binding_label)
1806 : : {
1807 : : /* Set the binding label and verify that if a NAME= was specified
1808 : : then only one identifier was in the entity-decl-list. */
1809 : 118 : if (!set_binding_label (&sym->binding_label, sym->name,
1810 : : num_idents_on_line))
1811 : : return false;
1812 : : }
1813 : : }
1814 : :
1815 : : /* See if we know we're in a common block, and if it's a bind(c)
1816 : : common then we need to make sure we're an interoperable type. */
1817 : 220498 : if (sym->attr.in_common == 1)
1818 : : {
1819 : : /* Test the common block object. */
1820 : 628 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1821 : 6 : && sym->ts.is_c_interop != 1)
1822 : : {
1823 : 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1824 : : "must be declared with a C interoperable "
1825 : : "kind since common block %qs is BIND(C)",
1826 : : sym->name, sym->common_block->name,
1827 : 0 : sym->common_block->name);
1828 : 0 : gfc_clear_error ();
1829 : : }
1830 : : }
1831 : :
1832 : 220498 : sym->attr.implied_index = 0;
1833 : :
1834 : : /* Use the parameter expressions for a parameterized derived type. */
1835 : 220498 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1836 : 30065 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1837 : 374 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1838 : :
1839 : 220498 : if (sym->ts.type == BT_CLASS)
1840 : 9243 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1841 : :
1842 : : return true;
1843 : : }
1844 : :
1845 : :
1846 : : /* Set character constant to the given length. The constant will be padded or
1847 : : truncated. If we're inside an array constructor without a typespec, we
1848 : : additionally check that all elements have the same length; check_len -1
1849 : : means no checking. */
1850 : :
1851 : : void
1852 : 11373 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1853 : : gfc_charlen_t check_len)
1854 : : {
1855 : 11373 : gfc_char_t *s;
1856 : 11373 : gfc_charlen_t slen;
1857 : :
1858 : 11373 : if (expr->ts.type != BT_CHARACTER)
1859 : : return;
1860 : :
1861 : 11372 : if (expr->expr_type != EXPR_CONSTANT)
1862 : : {
1863 : 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1864 : 1 : return;
1865 : : }
1866 : :
1867 : 11371 : slen = expr->value.character.length;
1868 : 11371 : if (len != slen)
1869 : : {
1870 : 1403 : s = gfc_get_wide_string (len + 1);
1871 : 1403 : memcpy (s, expr->value.character.string,
1872 : 1403 : MIN (len, slen) * sizeof (gfc_char_t));
1873 : 1403 : if (len > slen)
1874 : 1265 : gfc_wide_memset (&s[slen], ' ', len - slen);
1875 : :
1876 : 1403 : if (warn_character_truncation && slen > len)
1877 : 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1878 : : "CHARACTER expression at %L is being truncated "
1879 : : "(%ld/%ld)", &expr->where,
1880 : : (long) slen, (long) len);
1881 : :
1882 : : /* Apply the standard by 'hand' otherwise it gets cleared for
1883 : : initializers. */
1884 : 1403 : if (check_len != -1 && slen != check_len
1885 : 12 : && !(gfc_option.allow_std & GFC_STD_GNU))
1886 : 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
1887 : : "at %L must have the same length (%ld/%ld)",
1888 : : &expr->where, (long) slen,
1889 : : (long) check_len);
1890 : :
1891 : 1403 : s[len] = '\0';
1892 : 1403 : free (expr->value.character.string);
1893 : 1403 : expr->value.character.string = s;
1894 : 1403 : expr->value.character.length = len;
1895 : : /* If explicit representation was given, clear it
1896 : : as it is no longer needed after padding. */
1897 : 1403 : if (expr->representation.length)
1898 : : {
1899 : 80 : expr->representation.length = 0;
1900 : 80 : free (expr->representation.string);
1901 : 80 : expr->representation.string = NULL;
1902 : : }
1903 : : }
1904 : : }
1905 : :
1906 : :
1907 : : /* Function to create and update the enumerator history
1908 : : using the information passed as arguments.
1909 : : Pointer "max_enum" is also updated, to point to
1910 : : enum history node containing largest initializer.
1911 : :
1912 : : SYM points to the symbol node of enumerator.
1913 : : INIT points to its enumerator value. */
1914 : :
1915 : : static void
1916 : 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
1917 : : {
1918 : 543 : enumerator_history *new_enum_history;
1919 : 543 : gcc_assert (sym != NULL && init != NULL);
1920 : :
1921 : 543 : new_enum_history = XCNEW (enumerator_history);
1922 : :
1923 : 543 : new_enum_history->sym = sym;
1924 : 543 : new_enum_history->initializer = init;
1925 : 543 : new_enum_history->next = NULL;
1926 : :
1927 : 543 : if (enum_history == NULL)
1928 : : {
1929 : 160 : enum_history = new_enum_history;
1930 : 160 : max_enum = enum_history;
1931 : : }
1932 : : else
1933 : : {
1934 : 383 : new_enum_history->next = enum_history;
1935 : 383 : enum_history = new_enum_history;
1936 : :
1937 : 383 : if (mpz_cmp (max_enum->initializer->value.integer,
1938 : 383 : new_enum_history->initializer->value.integer) < 0)
1939 : 381 : max_enum = new_enum_history;
1940 : : }
1941 : 543 : }
1942 : :
1943 : :
1944 : : /* Function to free enum kind history. */
1945 : :
1946 : : void
1947 : 175 : gfc_free_enum_history (void)
1948 : : {
1949 : 175 : enumerator_history *current = enum_history;
1950 : 175 : enumerator_history *next;
1951 : :
1952 : 718 : while (current != NULL)
1953 : : {
1954 : 543 : next = current->next;
1955 : 543 : free (current);
1956 : 543 : current = next;
1957 : : }
1958 : 175 : max_enum = NULL;
1959 : 175 : enum_history = NULL;
1960 : 175 : }
1961 : :
1962 : :
1963 : : /* Function called by variable_decl() that adds an initialization
1964 : : expression to a symbol. */
1965 : :
1966 : : static bool
1967 : 225808 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1968 : : {
1969 : 225808 : symbol_attribute attr;
1970 : 225808 : gfc_symbol *sym;
1971 : 225808 : gfc_expr *init;
1972 : :
1973 : 225808 : init = *initp;
1974 : 225808 : if (find_special (name, &sym, false))
1975 : : return false;
1976 : :
1977 : 225808 : attr = sym->attr;
1978 : :
1979 : : /* If this symbol is confirming an implicit parameter type,
1980 : : then an initialization expression is not allowed. */
1981 : 225808 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
1982 : : {
1983 : 1 : if (*initp != NULL)
1984 : : {
1985 : 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
1986 : : sym->name);
1987 : 0 : return false;
1988 : : }
1989 : : else
1990 : : return true;
1991 : : }
1992 : :
1993 : 225807 : if (init == NULL)
1994 : : {
1995 : : /* An initializer is required for PARAMETER declarations. */
1996 : 199376 : if (attr.flavor == FL_PARAMETER)
1997 : : {
1998 : 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1999 : 1 : return false;
2000 : : }
2001 : : }
2002 : : else
2003 : : {
2004 : : /* If a variable appears in a DATA block, it cannot have an
2005 : : initializer. */
2006 : 26431 : if (sym->attr.data)
2007 : : {
2008 : 0 : gfc_error ("Variable %qs at %C with an initializer already "
2009 : : "appears in a DATA statement", sym->name);
2010 : 0 : return false;
2011 : : }
2012 : :
2013 : : /* Check if the assignment can happen. This has to be put off
2014 : : until later for derived type variables and procedure pointers. */
2015 : 25455 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2016 : 25432 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2017 : 25382 : && !sym->attr.proc_pointer
2018 : 51732 : && !gfc_check_assign_symbol (sym, NULL, init))
2019 : : return false;
2020 : :
2021 : 26400 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2022 : 2919 : && init->ts.type == BT_CHARACTER)
2023 : : {
2024 : : /* Update symbol character length according initializer. */
2025 : 2881 : if (!gfc_check_assign_symbol (sym, NULL, init))
2026 : : return false;
2027 : :
2028 : 2881 : if (sym->ts.u.cl->length == NULL)
2029 : : {
2030 : 737 : gfc_charlen_t clen;
2031 : : /* If there are multiple CHARACTER variables declared on the
2032 : : same line, we don't want them to share the same length. */
2033 : 737 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2034 : :
2035 : 737 : if (sym->attr.flavor == FL_PARAMETER)
2036 : : {
2037 : 728 : if (init->expr_type == EXPR_CONSTANT)
2038 : : {
2039 : 489 : clen = init->value.character.length;
2040 : 489 : sym->ts.u.cl->length
2041 : 489 : = gfc_get_int_expr (gfc_charlen_int_kind,
2042 : : NULL, clen);
2043 : : }
2044 : 239 : else if (init->expr_type == EXPR_ARRAY)
2045 : : {
2046 : 239 : if (init->ts.u.cl && init->ts.u.cl->length)
2047 : : {
2048 : 227 : const gfc_expr *length = init->ts.u.cl->length;
2049 : 227 : if (length->expr_type != EXPR_CONSTANT)
2050 : : {
2051 : 1 : gfc_error ("Cannot initialize parameter array "
2052 : : "at %L "
2053 : : "with variable length elements",
2054 : : &sym->declared_at);
2055 : 1 : return false;
2056 : : }
2057 : 226 : clen = mpz_get_si (length->value.integer);
2058 : 226 : }
2059 : 12 : else if (init->value.constructor)
2060 : : {
2061 : 12 : gfc_constructor *c;
2062 : 12 : c = gfc_constructor_first (init->value.constructor);
2063 : 12 : clen = c->expr->value.character.length;
2064 : : }
2065 : : else
2066 : 0 : gcc_unreachable ();
2067 : 238 : sym->ts.u.cl->length
2068 : 238 : = gfc_get_int_expr (gfc_charlen_int_kind,
2069 : : NULL, clen);
2070 : : }
2071 : 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2072 : 0 : sym->ts.u.cl->length =
2073 : 0 : gfc_copy_expr (init->ts.u.cl->length);
2074 : : }
2075 : : }
2076 : : /* Update initializer character length according symbol. */
2077 : 2144 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
2078 : : {
2079 : 2141 : if (!gfc_specification_expr (sym->ts.u.cl->length))
2080 : : return false;
2081 : :
2082 : 2141 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind,
2083 : : false);
2084 : : /* resolve_charlen will complain later on if the length
2085 : : is too large. Just skeep the initialization in that case. */
2086 : 2141 : if (mpz_cmp (sym->ts.u.cl->length->value.integer,
2087 : 2141 : gfc_integer_kinds[k].huge) <= 0)
2088 : : {
2089 : 2140 : HOST_WIDE_INT len
2090 : 2140 : = gfc_mpz_get_hwi (sym->ts.u.cl->length->value.integer);
2091 : :
2092 : 2140 : if (init->expr_type == EXPR_CONSTANT)
2093 : 1560 : gfc_set_constant_character_len (len, init, -1);
2094 : 580 : else if (init->expr_type == EXPR_ARRAY)
2095 : : {
2096 : 579 : gfc_constructor *c;
2097 : :
2098 : : /* Build a new charlen to prevent simplification from
2099 : : deleting the length before it is resolved. */
2100 : 579 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2101 : 579 : init->ts.u.cl->length
2102 : 579 : = gfc_copy_expr (sym->ts.u.cl->length);
2103 : :
2104 : 579 : for (c = gfc_constructor_first (init->value.constructor);
2105 : 3557 : c; c = gfc_constructor_next (c))
2106 : 2978 : gfc_set_constant_character_len (len, c->expr, -1);
2107 : : }
2108 : : }
2109 : : }
2110 : : }
2111 : :
2112 : 26399 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2113 : 2747 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2114 : : {
2115 : 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2116 : : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2117 : 3 : return false;
2118 : : }
2119 : :
2120 : : /* If sym is implied-shape, set its upper bounds from init. */
2121 : 26396 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2122 : 2744 : && sym->as->type == AS_IMPLIED_SHAPE)
2123 : : {
2124 : 409 : int dim;
2125 : :
2126 : 409 : if (init->rank == 0)
2127 : : {
2128 : 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2129 : : " with scalar", &sym->declared_at);
2130 : 1 : return false;
2131 : : }
2132 : :
2133 : : /* The shape may be NULL for EXPR_ARRAY, set it. */
2134 : 408 : if (init->shape == NULL)
2135 : : {
2136 : 5 : if (init->expr_type != EXPR_ARRAY)
2137 : : {
2138 : 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2139 : 2 : return false;
2140 : : }
2141 : :
2142 : 3 : init->shape = gfc_get_shape (1);
2143 : 3 : if (!gfc_array_size (init, &init->shape[0]))
2144 : : {
2145 : 1 : gfc_error ("Cannot determine shape of initializer at %L",
2146 : : &init->where);
2147 : 1 : free (init->shape);
2148 : 1 : init->shape = NULL;
2149 : 1 : return false;
2150 : : }
2151 : : }
2152 : :
2153 : 899 : for (dim = 0; dim < sym->as->rank; ++dim)
2154 : : {
2155 : 495 : int k;
2156 : 495 : gfc_expr *e, *lower;
2157 : :
2158 : 495 : lower = sym->as->lower[dim];
2159 : :
2160 : : /* If the lower bound is an array element from another
2161 : : parameterized array, then it is marked with EXPR_VARIABLE and
2162 : : is an initialization expression. Try to reduce it. */
2163 : 495 : if (lower->expr_type == EXPR_VARIABLE)
2164 : 7 : gfc_reduce_init_expr (lower);
2165 : :
2166 : 495 : if (lower->expr_type == EXPR_CONSTANT)
2167 : : {
2168 : : /* All dimensions must be without upper bound. */
2169 : 494 : gcc_assert (!sym->as->upper[dim]);
2170 : :
2171 : 494 : k = lower->ts.kind;
2172 : 494 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2173 : 494 : mpz_add (e->value.integer, lower->value.integer,
2174 : 494 : init->shape[dim]);
2175 : 494 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2176 : 494 : sym->as->upper[dim] = e;
2177 : : }
2178 : : else
2179 : : {
2180 : 1 : gfc_error ("Non-constant lower bound in implied-shape"
2181 : : " declaration at %L", &lower->where);
2182 : 1 : return false;
2183 : : }
2184 : : }
2185 : :
2186 : 404 : sym->as->type = AS_EXPLICIT;
2187 : : }
2188 : :
2189 : : /* Ensure that explicit bounds are simplified. */
2190 : 26391 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2191 : 2739 : && sym->as->type == AS_EXPLICIT)
2192 : : {
2193 : 6144 : for (int dim = 0; dim < sym->as->rank; ++dim)
2194 : : {
2195 : 3417 : gfc_expr *e;
2196 : :
2197 : 3417 : e = sym->as->lower[dim];
2198 : 3417 : if (e->expr_type != EXPR_CONSTANT)
2199 : 12 : gfc_reduce_init_expr (e);
2200 : :
2201 : 3417 : e = sym->as->upper[dim];
2202 : 3417 : if (e->expr_type != EXPR_CONSTANT)
2203 : 96 : gfc_reduce_init_expr (e);
2204 : : }
2205 : : }
2206 : :
2207 : : /* Need to check if the expression we initialized this
2208 : : to was one of the iso_c_binding named constants. If so,
2209 : : and we're a parameter (constant), let it be iso_c.
2210 : : For example:
2211 : : integer(c_int), parameter :: my_int = c_int
2212 : : integer(my_int) :: my_int_2
2213 : : If we mark my_int as iso_c (since we can see it's value
2214 : : is equal to one of the named constants), then my_int_2
2215 : : will be considered C interoperable. */
2216 : 26391 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2217 : : {
2218 : 22500 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2219 : 22500 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2220 : : /* attr bits needed for module files. */
2221 : 22500 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2222 : 22500 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2223 : 22500 : if (init->ts.is_iso_c)
2224 : 63 : sym->ts.f90_type = init->ts.f90_type;
2225 : : }
2226 : :
2227 : : /* Catch the case: type(t), parameter :: x = z'1'. */
2228 : 26391 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2229 : : {
2230 : 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2231 : : "literal constant", name, &sym->declared_at);
2232 : 1 : return false;
2233 : : }
2234 : :
2235 : : /* Add initializer. Make sure we keep the ranks sane. */
2236 : 26390 : if (sym->attr.dimension && init->rank == 0)
2237 : : {
2238 : 1065 : mpz_t size;
2239 : 1065 : gfc_expr *array;
2240 : 1065 : int n;
2241 : 1065 : if (sym->attr.flavor == FL_PARAMETER
2242 : 447 : && gfc_is_constant_expr (init)
2243 : 447 : && (init->expr_type == EXPR_CONSTANT
2244 : 31 : || init->expr_type == EXPR_STRUCTURE)
2245 : 1512 : && spec_size (sym->as, &size))
2246 : : {
2247 : 443 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2248 : : &init->where);
2249 : 443 : if (init->ts.type == BT_DERIVED)
2250 : 31 : array->ts.u.derived = init->ts.u.derived;
2251 : 67577 : for (n = 0; n < (int)mpz_get_si (size); n++)
2252 : 133966 : gfc_constructor_append_expr (&array->value.constructor,
2253 : : n == 0
2254 : : ? init
2255 : 66832 : : gfc_copy_expr (init),
2256 : : &init->where);
2257 : :
2258 : 443 : array->shape = gfc_get_shape (sym->as->rank);
2259 : 1012 : for (n = 0; n < sym->as->rank; n++)
2260 : 569 : spec_dimen_size (sym->as, n, &array->shape[n]);
2261 : :
2262 : 443 : init = array;
2263 : 443 : mpz_clear (size);
2264 : : }
2265 : 1065 : init->rank = sym->as->rank;
2266 : : }
2267 : :
2268 : 26390 : sym->value = init;
2269 : 26390 : if (sym->attr.save == SAVE_NONE)
2270 : 22571 : sym->attr.save = SAVE_IMPLICIT;
2271 : 26390 : *initp = NULL;
2272 : : }
2273 : :
2274 : : return true;
2275 : : }
2276 : :
2277 : :
2278 : : /* Function called by variable_decl() that adds a name to a structure
2279 : : being built. */
2280 : :
2281 : : static bool
2282 : 15389 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2283 : : gfc_array_spec **as)
2284 : : {
2285 : 15389 : gfc_state_data *s;
2286 : 15389 : gfc_component *c;
2287 : :
2288 : : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2289 : : constructing, it must have the pointer attribute. */
2290 : 15389 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2291 : 2819 : && current_ts.u.derived == gfc_current_block ()
2292 : 217 : && current_attr.pointer == 0)
2293 : : {
2294 : 48 : if (current_attr.allocatable
2295 : 48 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2296 : : "must have the POINTER attribute"))
2297 : : {
2298 : : return false;
2299 : : }
2300 : 47 : else if (current_attr.allocatable == 0)
2301 : : {
2302 : 0 : gfc_error ("Component at %C must have the POINTER attribute");
2303 : 0 : return false;
2304 : : }
2305 : : }
2306 : :
2307 : : /* F03:C437. */
2308 : 15388 : if (current_ts.type == BT_CLASS
2309 : 715 : && !(current_attr.pointer || current_attr.allocatable))
2310 : : {
2311 : 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2312 : : "or pointer", name);
2313 : 5 : return false;
2314 : : }
2315 : :
2316 : 15383 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2317 : : {
2318 : 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2319 : : {
2320 : 0 : gfc_error ("Array component of structure at %C must have explicit "
2321 : : "or deferred shape");
2322 : 0 : return false;
2323 : : }
2324 : : }
2325 : :
2326 : : /* If we are in a nested union/map definition, gfc_add_component will not
2327 : : properly find repeated components because:
2328 : : (i) gfc_add_component does a flat search, where components of unions
2329 : : and maps are implicity chained so nested components may conflict.
2330 : : (ii) Unions and maps are not linked as components of their parent
2331 : : structures until after they are parsed.
2332 : : For (i) we use gfc_find_component which searches recursively, and for (ii)
2333 : : we search each block directly from the parse stack until we find the top
2334 : : level structure. */
2335 : :
2336 : 15383 : s = gfc_state_stack;
2337 : 15383 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2338 : : {
2339 : 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2340 : : {
2341 : 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2342 : 1434 : if (c != NULL)
2343 : : {
2344 : 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2345 : : name, &c->loc);
2346 : 0 : return false;
2347 : : }
2348 : : /* Break after we've searched the entire chain. */
2349 : 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2350 : : break;
2351 : 1000 : s = s->previous;
2352 : : }
2353 : : }
2354 : :
2355 : 15383 : if (!gfc_add_component (gfc_current_block(), name, &c))
2356 : : return false;
2357 : :
2358 : 15377 : c->ts = current_ts;
2359 : 15377 : if (c->ts.type == BT_CHARACTER)
2360 : 1708 : c->ts.u.cl = cl;
2361 : :
2362 : 15377 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2363 : 12564 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2364 : 1785 : && saved_kind_expr != NULL)
2365 : 91 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2366 : :
2367 : 15377 : c->attr = current_attr;
2368 : :
2369 : 15377 : c->initializer = *init;
2370 : 15377 : *init = NULL;
2371 : :
2372 : 15377 : c->as = *as;
2373 : 15377 : if (c->as != NULL)
2374 : : {
2375 : 3851 : if (c->as->corank)
2376 : 91 : c->attr.codimension = 1;
2377 : 3851 : if (c->as->rank)
2378 : 3782 : c->attr.dimension = 1;
2379 : : }
2380 : 15377 : *as = NULL;
2381 : :
2382 : 15377 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2383 : :
2384 : : /* Check array components. */
2385 : 15377 : if (!c->attr.dimension)
2386 : 11595 : goto scalar;
2387 : :
2388 : 3782 : if (c->attr.pointer)
2389 : : {
2390 : 543 : if (c->as->type != AS_DEFERRED)
2391 : : {
2392 : 5 : gfc_error ("Pointer array component of structure at %C must have a "
2393 : : "deferred shape");
2394 : 5 : return false;
2395 : : }
2396 : : }
2397 : 3239 : else if (c->attr.allocatable)
2398 : : {
2399 : 1842 : if (c->as->type != AS_DEFERRED)
2400 : : {
2401 : 12 : gfc_error ("Allocatable component of structure at %C must have a "
2402 : : "deferred shape");
2403 : 12 : return false;
2404 : : }
2405 : : }
2406 : : else
2407 : : {
2408 : 1397 : if (c->as->type != AS_EXPLICIT)
2409 : : {
2410 : 7 : gfc_error ("Array component of structure at %C must have an "
2411 : : "explicit shape");
2412 : 7 : return false;
2413 : : }
2414 : : }
2415 : :
2416 : 1390 : scalar:
2417 : 15353 : if (c->ts.type == BT_CLASS)
2418 : 705 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2419 : :
2420 : 14648 : if (c->attr.pdt_kind || c->attr.pdt_len)
2421 : : {
2422 : 277 : gfc_symbol *sym;
2423 : 277 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2424 : : 0, &sym);
2425 : 277 : if (sym == NULL)
2426 : : {
2427 : 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2428 : : "in the type parameter name list at %L",
2429 : 0 : c->name, &gfc_current_block ()->declared_at);
2430 : 0 : return false;
2431 : : }
2432 : 277 : sym->ts = c->ts;
2433 : 277 : sym->attr.pdt_kind = c->attr.pdt_kind;
2434 : 277 : sym->attr.pdt_len = c->attr.pdt_len;
2435 : 277 : if (c->initializer)
2436 : 93 : sym->value = gfc_copy_expr (c->initializer);
2437 : 277 : sym->attr.flavor = FL_VARIABLE;
2438 : : }
2439 : :
2440 : 14648 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2441 : 2103 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2442 : 39 : && decl_type_param_list)
2443 : 39 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2444 : :
2445 : : return true;
2446 : : }
2447 : :
2448 : :
2449 : : /* Match a 'NULL()', and possibly take care of some side effects. */
2450 : :
2451 : : match
2452 : 1388 : gfc_match_null (gfc_expr **result)
2453 : : {
2454 : 1388 : gfc_symbol *sym;
2455 : 1388 : match m, m2 = MATCH_NO;
2456 : :
2457 : 1388 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2458 : : return MATCH_ERROR;
2459 : :
2460 : 1388 : if (m == MATCH_NO)
2461 : : {
2462 : 488 : locus old_loc;
2463 : 488 : char name[GFC_MAX_SYMBOL_LEN + 1];
2464 : :
2465 : 488 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2466 : 482 : return m2;
2467 : :
2468 : 6 : old_loc = gfc_current_locus;
2469 : 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2470 : : return MATCH_ERROR;
2471 : 6 : if (m2 != MATCH_YES
2472 : 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2473 : : return MATCH_ERROR;
2474 : 6 : if (m2 == MATCH_NO)
2475 : : {
2476 : 0 : gfc_current_locus = old_loc;
2477 : 0 : return MATCH_NO;
2478 : : }
2479 : : }
2480 : :
2481 : : /* The NULL symbol now has to be/become an intrinsic function. */
2482 : 906 : if (gfc_get_symbol ("null", NULL, &sym))
2483 : : {
2484 : 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2485 : 0 : return MATCH_ERROR;
2486 : : }
2487 : :
2488 : 906 : gfc_intrinsic_symbol (sym);
2489 : :
2490 : 906 : if (sym->attr.proc != PROC_INTRINSIC
2491 : 653 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2492 : 1558 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2493 : 652 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2494 : 0 : return MATCH_ERROR;
2495 : :
2496 : 906 : *result = gfc_get_null_expr (&gfc_current_locus);
2497 : :
2498 : : /* Invalid per F2008, C512. */
2499 : 906 : if (m2 == MATCH_YES)
2500 : : {
2501 : 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2502 : 6 : return MATCH_ERROR;
2503 : : }
2504 : :
2505 : : return MATCH_YES;
2506 : : }
2507 : :
2508 : :
2509 : : /* Match the initialization expr for a data pointer or procedure pointer. */
2510 : :
2511 : : static match
2512 : 1064 : match_pointer_init (gfc_expr **init, int procptr)
2513 : : {
2514 : 1064 : match m;
2515 : :
2516 : 1064 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2517 : : {
2518 : 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2519 : : "a PURE procedure");
2520 : 1 : return MATCH_ERROR;
2521 : : }
2522 : 1063 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2523 : :
2524 : : /* Match NULL() initialization. */
2525 : 1063 : m = gfc_match_null (init);
2526 : 1063 : if (m != MATCH_NO)
2527 : : return m;
2528 : :
2529 : : /* Match non-NULL initialization. */
2530 : 165 : gfc_matching_ptr_assignment = !procptr;
2531 : 165 : gfc_matching_procptr_assignment = procptr;
2532 : 165 : m = gfc_match_rvalue (init);
2533 : 165 : gfc_matching_ptr_assignment = 0;
2534 : 165 : gfc_matching_procptr_assignment = 0;
2535 : 165 : if (m == MATCH_ERROR)
2536 : : return MATCH_ERROR;
2537 : 164 : else if (m == MATCH_NO)
2538 : : {
2539 : 2 : gfc_error ("Error in pointer initialization at %C");
2540 : 2 : return MATCH_ERROR;
2541 : : }
2542 : :
2543 : 162 : if (!procptr && !gfc_resolve_expr (*init))
2544 : : return MATCH_ERROR;
2545 : :
2546 : 161 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2547 : : "initialization at %C"))
2548 : : return MATCH_ERROR;
2549 : :
2550 : : return MATCH_YES;
2551 : : }
2552 : :
2553 : :
2554 : : static bool
2555 : 244975 : check_function_name (char *name)
2556 : : {
2557 : : /* In functions that have a RESULT variable defined, the function name always
2558 : : refers to function calls. Therefore, the name is not allowed to appear in
2559 : : specification statements. When checking this, be careful about
2560 : : 'hidden' procedure pointer results ('ppr@'). */
2561 : :
2562 : 244975 : if (gfc_current_state () == COMP_FUNCTION)
2563 : : {
2564 : 39452 : gfc_symbol *block = gfc_current_block ();
2565 : 39452 : if (block && block->result && block->result != block
2566 : 13114 : && strcmp (block->result->name, "ppr@") != 0
2567 : 13055 : && strcmp (block->name, name) == 0)
2568 : : {
2569 : 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2570 : : "from appearing in a specification statement",
2571 : : block->result->name, &block->result->declared_at, name);
2572 : 9 : return false;
2573 : : }
2574 : : }
2575 : :
2576 : : return true;
2577 : : }
2578 : :
2579 : :
2580 : : /* Match a variable name with an optional initializer. When this
2581 : : subroutine is called, a variable is expected to be parsed next.
2582 : : Depending on what is happening at the moment, updates either the
2583 : : symbol table or the current interface. */
2584 : :
2585 : : static match
2586 : 235613 : variable_decl (int elem)
2587 : : {
2588 : 235613 : char name[GFC_MAX_SYMBOL_LEN + 1];
2589 : 235613 : static unsigned int fill_id = 0;
2590 : 235613 : gfc_expr *initializer, *char_len;
2591 : 235613 : gfc_array_spec *as;
2592 : 235613 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2593 : 235613 : gfc_charlen *cl;
2594 : 235613 : bool cl_deferred;
2595 : 235613 : locus var_locus;
2596 : 235613 : match m;
2597 : 235613 : bool t;
2598 : 235613 : gfc_symbol *sym;
2599 : 235613 : char c;
2600 : :
2601 : 235613 : initializer = NULL;
2602 : 235613 : as = NULL;
2603 : 235613 : cp_as = NULL;
2604 : :
2605 : : /* When we get here, we've just matched a list of attributes and
2606 : : maybe a type and a double colon. The next thing we expect to see
2607 : : is the name of the symbol. */
2608 : :
2609 : : /* If we are parsing a structure with legacy support, we allow the symbol
2610 : : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2611 : 235613 : m = MATCH_NO;
2612 : 235613 : gfc_gobble_whitespace ();
2613 : 235613 : c = gfc_peek_ascii_char ();
2614 : 235613 : if (c == '%')
2615 : : {
2616 : 12 : gfc_next_ascii_char (); /* Burn % character. */
2617 : 12 : m = gfc_match ("fill");
2618 : 12 : if (m == MATCH_YES)
2619 : : {
2620 : 11 : if (gfc_current_state () != COMP_STRUCTURE)
2621 : : {
2622 : 2 : if (flag_dec_structure)
2623 : 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2624 : : else
2625 : 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2626 : : "%<-fdec-structure%>", "%FILL");
2627 : 2 : m = MATCH_ERROR;
2628 : 2 : goto cleanup;
2629 : : }
2630 : :
2631 : 9 : if (attr_seen)
2632 : : {
2633 : 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2634 : 1 : m = MATCH_ERROR;
2635 : 1 : goto cleanup;
2636 : : }
2637 : :
2638 : : /* %FILL components are given invalid fortran names. */
2639 : 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2640 : : }
2641 : : else
2642 : : {
2643 : 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2644 : 1 : return MATCH_ERROR;
2645 : : }
2646 : : }
2647 : : else
2648 : : {
2649 : 235601 : m = gfc_match_name (name);
2650 : 235600 : if (m != MATCH_YES)
2651 : 10 : goto cleanup;
2652 : : }
2653 : :
2654 : 235598 : var_locus = gfc_current_locus;
2655 : :
2656 : : /* Now we could see the optional array spec. or character length. */
2657 : 235598 : m = gfc_match_array_spec (&as, true, true);
2658 : 235597 : if (m == MATCH_ERROR)
2659 : 56 : goto cleanup;
2660 : :
2661 : 235541 : if (m == MATCH_NO)
2662 : 187726 : as = gfc_copy_array_spec (current_as);
2663 : 47815 : else if (current_as
2664 : 47815 : && !merge_array_spec (current_as, as, true))
2665 : : {
2666 : 4 : m = MATCH_ERROR;
2667 : 4 : goto cleanup;
2668 : : }
2669 : :
2670 : 235537 : if (flag_cray_pointer)
2671 : 3027 : cp_as = gfc_copy_array_spec (as);
2672 : :
2673 : : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2674 : : determine (and check) whether it can be implied-shape. If it
2675 : : was parsed as assumed-size, change it because PARAMETERs cannot
2676 : : be assumed-size.
2677 : :
2678 : : An explicit-shape-array cannot appear under several conditions.
2679 : : That check is done here as well. */
2680 : 235537 : if (as)
2681 : : {
2682 : 67816 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2683 : : {
2684 : 2 : m = MATCH_ERROR;
2685 : 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2686 : : name, &var_locus);
2687 : 2 : goto cleanup;
2688 : : }
2689 : :
2690 : 67814 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2691 : 4611 : && current_attr.flavor == FL_PARAMETER)
2692 : 373 : as->type = AS_IMPLIED_SHAPE;
2693 : :
2694 : 67814 : if (as->type == AS_IMPLIED_SHAPE
2695 : 67814 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2696 : : &var_locus))
2697 : : {
2698 : 1 : m = MATCH_ERROR;
2699 : 1 : goto cleanup;
2700 : : }
2701 : :
2702 : 67813 : gfc_seen_div0 = false;
2703 : :
2704 : : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2705 : : constant expressions shall appear only in a subprogram, derived
2706 : : type definition, BLOCK construct, or interface body. */
2707 : 67813 : if (as->type == AS_EXPLICIT
2708 : 35946 : && gfc_current_state () != COMP_BLOCK
2709 : : && gfc_current_state () != COMP_DERIVED
2710 : : && gfc_current_state () != COMP_FUNCTION
2711 : : && gfc_current_state () != COMP_INTERFACE
2712 : : && gfc_current_state () != COMP_SUBROUTINE)
2713 : : {
2714 : : gfc_expr *e;
2715 : 46710 : bool not_constant = false;
2716 : :
2717 : 46710 : for (int i = 0; i < as->rank; i++)
2718 : : {
2719 : 26686 : e = gfc_copy_expr (as->lower[i]);
2720 : 26686 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2721 : : {
2722 : 0 : m = MATCH_ERROR;
2723 : 0 : goto cleanup;
2724 : : }
2725 : :
2726 : 26686 : gfc_simplify_expr (e, 0);
2727 : 26686 : if (e && (e->expr_type != EXPR_CONSTANT))
2728 : : {
2729 : : not_constant = true;
2730 : : break;
2731 : : }
2732 : 26686 : gfc_free_expr (e);
2733 : :
2734 : 26686 : e = gfc_copy_expr (as->upper[i]);
2735 : 26686 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2736 : : {
2737 : 4 : m = MATCH_ERROR;
2738 : 4 : goto cleanup;
2739 : : }
2740 : :
2741 : 26682 : gfc_simplify_expr (e, 0);
2742 : 26682 : if (e && (e->expr_type != EXPR_CONSTANT))
2743 : : {
2744 : : not_constant = true;
2745 : : break;
2746 : : }
2747 : 26669 : gfc_free_expr (e);
2748 : : }
2749 : :
2750 : 20037 : if (not_constant && e->ts.type != BT_INTEGER)
2751 : : {
2752 : 4 : gfc_error ("Explicit array shape at %C must be constant of "
2753 : : "INTEGER type and not %s type",
2754 : : gfc_basic_typename (e->ts.type));
2755 : 4 : m = MATCH_ERROR;
2756 : 4 : goto cleanup;
2757 : : }
2758 : 9 : if (not_constant)
2759 : : {
2760 : 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2761 : 9 : m = MATCH_ERROR;
2762 : 9 : goto cleanup;
2763 : : }
2764 : : }
2765 : 67796 : if (as->type == AS_EXPLICIT)
2766 : : {
2767 : 84071 : for (int i = 0; i < as->rank; i++)
2768 : : {
2769 : 48142 : gfc_expr *e, *n;
2770 : 48142 : e = as->lower[i];
2771 : 48142 : if (e->expr_type != EXPR_CONSTANT)
2772 : : {
2773 : 427 : n = gfc_copy_expr (e);
2774 : 427 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2775 : : {
2776 : 0 : m = MATCH_ERROR;
2777 : 0 : goto cleanup;
2778 : : }
2779 : :
2780 : 427 : if (n->expr_type == EXPR_CONSTANT)
2781 : 22 : gfc_replace_expr (e, n);
2782 : : else
2783 : 405 : gfc_free_expr (n);
2784 : : }
2785 : 48142 : e = as->upper[i];
2786 : 48142 : if (e->expr_type != EXPR_CONSTANT)
2787 : : {
2788 : 6184 : n = gfc_copy_expr (e);
2789 : 6184 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2790 : : {
2791 : 0 : m = MATCH_ERROR;
2792 : 0 : goto cleanup;
2793 : : }
2794 : :
2795 : 6184 : if (n->expr_type == EXPR_CONSTANT)
2796 : 45 : gfc_replace_expr (e, n);
2797 : : else
2798 : 6139 : gfc_free_expr (n);
2799 : : }
2800 : : /* For an explicit-shape spec with constant bounds, ensure
2801 : : that the effective upper bound is not lower than the
2802 : : respective lower bound minus one. Otherwise adjust it so
2803 : : that the extent is trivially derived to be zero. */
2804 : 48142 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2805 : 47737 : && as->upper[i]->expr_type == EXPR_CONSTANT
2806 : 41997 : && as->lower[i]->ts.type == BT_INTEGER
2807 : 41997 : && as->upper[i]->ts.type == BT_INTEGER
2808 : 41992 : && mpz_cmp (as->upper[i]->value.integer,
2809 : 41992 : as->lower[i]->value.integer) < 0)
2810 : 484 : mpz_sub_ui (as->upper[i]->value.integer,
2811 : : as->lower[i]->value.integer, 1);
2812 : : }
2813 : : }
2814 : : }
2815 : :
2816 : 235517 : char_len = NULL;
2817 : 235517 : cl = NULL;
2818 : 235517 : cl_deferred = false;
2819 : :
2820 : 235517 : if (current_ts.type == BT_CHARACTER)
2821 : : {
2822 : 27437 : switch (match_char_length (&char_len, &cl_deferred, false))
2823 : : {
2824 : 435 : case MATCH_YES:
2825 : 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2826 : :
2827 : 435 : cl->length = char_len;
2828 : 435 : break;
2829 : :
2830 : : /* Non-constant lengths need to be copied after the first
2831 : : element. Also copy assumed lengths. */
2832 : 27001 : case MATCH_NO:
2833 : 27001 : if (elem > 1
2834 : 3410 : && (current_ts.u.cl->length == NULL
2835 : 2426 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2836 : : {
2837 : 1015 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2838 : 1015 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
2839 : : }
2840 : : else
2841 : 25986 : cl = current_ts.u.cl;
2842 : :
2843 : 27001 : cl_deferred = current_ts.deferred;
2844 : :
2845 : 27001 : break;
2846 : :
2847 : 1 : case MATCH_ERROR:
2848 : 1 : goto cleanup;
2849 : : }
2850 : : }
2851 : :
2852 : : /* The dummy arguments and result of the abbreviated form of MODULE
2853 : : PROCEDUREs, used in SUBMODULES should not be redefined. */
2854 : 235516 : if (gfc_current_ns->proc_name
2855 : 231053 : && gfc_current_ns->proc_name->abr_modproc_decl)
2856 : : {
2857 : 38 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2858 : 38 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2859 : : {
2860 : 2 : m = MATCH_ERROR;
2861 : 2 : gfc_error ("%qs at %C is a redefinition of the declaration "
2862 : : "in the corresponding interface for MODULE "
2863 : : "PROCEDURE %qs", sym->name,
2864 : 2 : gfc_current_ns->proc_name->name);
2865 : 2 : goto cleanup;
2866 : : }
2867 : : }
2868 : :
2869 : : /* %FILL components may not have initializers. */
2870 : 235514 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
2871 : : {
2872 : 1 : gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2873 : 1 : m = MATCH_ERROR;
2874 : 1 : goto cleanup;
2875 : : }
2876 : :
2877 : : /* If this symbol has already shown up in a Cray Pointer declaration,
2878 : : and this is not a component declaration,
2879 : : then we want to set the type & bail out. */
2880 : 235513 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2881 : : {
2882 : 2923 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2883 : 2923 : if (sym != NULL && sym->attr.cray_pointee)
2884 : : {
2885 : 101 : m = MATCH_YES;
2886 : 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
2887 : : {
2888 : 1 : m = MATCH_ERROR;
2889 : 1 : goto cleanup;
2890 : : }
2891 : :
2892 : : /* Check to see if we have an array specification. */
2893 : 100 : if (cp_as != NULL)
2894 : : {
2895 : 49 : if (sym->as != NULL)
2896 : : {
2897 : 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
2898 : 1 : gfc_free_array_spec (cp_as);
2899 : 1 : m = MATCH_ERROR;
2900 : 1 : goto cleanup;
2901 : : }
2902 : : else
2903 : : {
2904 : 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2905 : 0 : gfc_internal_error ("Cannot set pointee array spec.");
2906 : :
2907 : : /* Fix the array spec. */
2908 : 48 : m = gfc_mod_pointee_as (sym->as);
2909 : 48 : if (m == MATCH_ERROR)
2910 : 0 : goto cleanup;
2911 : : }
2912 : : }
2913 : 99 : goto cleanup;
2914 : : }
2915 : : else
2916 : : {
2917 : 2822 : gfc_free_array_spec (cp_as);
2918 : : }
2919 : : }
2920 : :
2921 : : /* Procedure pointer as function result. */
2922 : 235412 : if (gfc_current_state () == COMP_FUNCTION
2923 : 38445 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
2924 : 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2925 : 7 : strcpy (name, "ppr@");
2926 : :
2927 : 235412 : if (gfc_current_state () == COMP_FUNCTION
2928 : 38445 : && strcmp (name, gfc_current_block ()->name) == 0
2929 : 6873 : && gfc_current_block ()->result
2930 : 6873 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2931 : 16 : strcpy (name, "ppr@");
2932 : :
2933 : : /* OK, we've successfully matched the declaration. Now put the
2934 : : symbol in the current namespace, because it might be used in the
2935 : : optional initialization expression for this symbol, e.g. this is
2936 : : perfectly legal:
2937 : :
2938 : : integer, parameter :: i = huge(i)
2939 : :
2940 : : This is only true for parameters or variables of a basic type.
2941 : : For components of derived types, it is not true, so we don't
2942 : : create a symbol for those yet. If we fail to create the symbol,
2943 : : bail out. */
2944 : 235412 : if (!gfc_comp_struct (gfc_current_state ())
2945 : 219994 : && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2946 : : {
2947 : 43 : m = MATCH_ERROR;
2948 : 43 : goto cleanup;
2949 : : }
2950 : :
2951 : 235369 : if (!check_function_name (name))
2952 : : {
2953 : 0 : m = MATCH_ERROR;
2954 : 0 : goto cleanup;
2955 : : }
2956 : :
2957 : : /* We allow old-style initializations of the form
2958 : : integer i /2/, j(4) /3*3, 1/
2959 : : (if no colon has been seen). These are different from data
2960 : : statements in that initializers are only allowed to apply to the
2961 : : variable immediately preceding, i.e.
2962 : : integer i, j /1, 2/
2963 : : is not allowed. Therefore we have to do some work manually, that
2964 : : could otherwise be left to the matchers for DATA statements. */
2965 : :
2966 : 235369 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
2967 : : {
2968 : 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2969 : : "initialization at %C"))
2970 : : return MATCH_ERROR;
2971 : :
2972 : : /* Allow old style initializations for components of STRUCTUREs and MAPs
2973 : : but not components of derived types. */
2974 : 146 : else if (gfc_current_state () == COMP_DERIVED)
2975 : : {
2976 : 2 : gfc_error ("Invalid old style initialization for derived type "
2977 : : "component at %C");
2978 : 2 : m = MATCH_ERROR;
2979 : 2 : goto cleanup;
2980 : : }
2981 : :
2982 : : /* For structure components, read the initializer as a special
2983 : : expression and let the rest of this function apply the initializer
2984 : : as usual. */
2985 : 144 : else if (gfc_comp_struct (gfc_current_state ()))
2986 : : {
2987 : 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
2988 : 74 : if (m == MATCH_NO)
2989 : 0 : gfc_error ("Syntax error in old style initialization of %s at %C",
2990 : : name);
2991 : 74 : if (m != MATCH_YES)
2992 : 14 : goto cleanup;
2993 : : }
2994 : :
2995 : : /* Otherwise we treat the old style initialization just like a
2996 : : DATA declaration for the current variable. */
2997 : : else
2998 : 70 : return match_old_style_init (name);
2999 : : }
3000 : :
3001 : : /* The double colon must be present in order to have initializers.
3002 : : Otherwise the statement is ambiguous with an assignment statement. */
3003 : 235283 : if (colon_seen)
3004 : : {
3005 : 194297 : if (gfc_match (" =>") == MATCH_YES)
3006 : : {
3007 : 929 : if (!current_attr.pointer)
3008 : : {
3009 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3010 : 0 : m = MATCH_ERROR;
3011 : 0 : goto cleanup;
3012 : : }
3013 : :
3014 : 929 : m = match_pointer_init (&initializer, 0);
3015 : 929 : if (m != MATCH_YES)
3016 : 10 : goto cleanup;
3017 : :
3018 : : /* The target of a pointer initialization must have the SAVE
3019 : : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3020 : : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3021 : 919 : if (initializer->expr_type == EXPR_VARIABLE
3022 : 123 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3023 : 25 : && (gfc_current_state () == COMP_PROGRAM
3024 : : || gfc_current_state () == COMP_MODULE
3025 : 25 : || gfc_current_state () == COMP_SUBMODULE))
3026 : 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3027 : : }
3028 : 193368 : else if (gfc_match_char ('=') == MATCH_YES)
3029 : : {
3030 : 22077 : if (current_attr.pointer)
3031 : : {
3032 : 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3033 : : "not %<=%>");
3034 : 0 : m = MATCH_ERROR;
3035 : 0 : goto cleanup;
3036 : : }
3037 : :
3038 : 22077 : m = gfc_match_init_expr (&initializer);
3039 : 22077 : if (m == MATCH_NO)
3040 : : {
3041 : 0 : gfc_error ("Expected an initialization expression at %C");
3042 : 0 : m = MATCH_ERROR;
3043 : : }
3044 : :
3045 : 8381 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3046 : 22079 : && !gfc_comp_struct (gfc_state_stack->state))
3047 : : {
3048 : 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3049 : : "a PURE procedure");
3050 : 1 : m = MATCH_ERROR;
3051 : : }
3052 : :
3053 : 22077 : if (current_attr.flavor != FL_PARAMETER
3054 : 8381 : && !gfc_comp_struct (gfc_state_stack->state))
3055 : 6400 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3056 : :
3057 : 22077 : if (m != MATCH_YES)
3058 : 149 : goto cleanup;
3059 : : }
3060 : : }
3061 : :
3062 : 235124 : if (initializer != NULL && current_attr.allocatable
3063 : 3 : && gfc_comp_struct (gfc_current_state ()))
3064 : : {
3065 : 2 : gfc_error ("Initialization of allocatable component at %C is not "
3066 : : "allowed");
3067 : 2 : m = MATCH_ERROR;
3068 : 2 : goto cleanup;
3069 : : }
3070 : :
3071 : 235122 : if (gfc_current_state () == COMP_DERIVED
3072 : 14376 : && initializer && initializer->ts.type == BT_HOLLERITH)
3073 : : {
3074 : 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3075 : : "constant at %L is not allowed", &initializer->where);
3076 : 1 : m = MATCH_ERROR;
3077 : 1 : goto cleanup;
3078 : : }
3079 : :
3080 : 235121 : if (gfc_current_state () == COMP_DERIVED
3081 : 14375 : && gfc_current_block ()->attr.pdt_template)
3082 : : {
3083 : 496 : gfc_symbol *param;
3084 : 496 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3085 : : 0, ¶m);
3086 : 496 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3087 : : {
3088 : 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3089 : : "not appear in the type parameter list at %L",
3090 : 1 : &gfc_current_block ()->declared_at);
3091 : 1 : m = MATCH_ERROR;
3092 : 4 : goto cleanup;
3093 : : }
3094 : 495 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3095 : : {
3096 : 1 : gfc_error ("The component at %C that appears in the type parameter "
3097 : : "list at %L has neither the KIND nor LEN attribute",
3098 : 1 : &gfc_current_block ()->declared_at);
3099 : 1 : m = MATCH_ERROR;
3100 : 1 : goto cleanup;
3101 : : }
3102 : 494 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3103 : : {
3104 : 1 : gfc_error ("The component at %C which is a type parameter must be "
3105 : : "a scalar");
3106 : 1 : m = MATCH_ERROR;
3107 : 1 : goto cleanup;
3108 : : }
3109 : 493 : else if (param && initializer)
3110 : : {
3111 : 94 : if (initializer->ts.type == BT_BOZ)
3112 : : {
3113 : 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3114 : : "initializer", &initializer->where);
3115 : 1 : m = MATCH_ERROR;
3116 : 1 : goto cleanup;
3117 : : }
3118 : 93 : param->value = gfc_copy_expr (initializer);
3119 : : }
3120 : : }
3121 : :
3122 : : /* Before adding a possible initializer, do a simple check for compatibility
3123 : : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3124 : : good thing. */
3125 : 22908 : if (current_ts.type == BT_DERIVED && initializer
3126 : 236316 : && (gfc_numeric_ts (&initializer->ts)
3127 : 1197 : || initializer->ts.type == BT_LOGICAL
3128 : 1197 : || initializer->ts.type == BT_CHARACTER))
3129 : : {
3130 : 2 : gfc_error ("Incompatible initialization between a derived type "
3131 : : "entity and an entity with %qs type at %C",
3132 : : gfc_typename (initializer));
3133 : 2 : m = MATCH_ERROR;
3134 : 2 : goto cleanup;
3135 : : }
3136 : :
3137 : :
3138 : : /* Add the initializer. Note that it is fine if initializer is
3139 : : NULL here, because we sometimes also need to check if a
3140 : : declaration *must* have an initialization expression. */
3141 : 235115 : if (!gfc_comp_struct (gfc_current_state ()))
3142 : 219726 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
3143 : : else
3144 : : {
3145 : 15389 : if (current_ts.type == BT_DERIVED
3146 : 2103 : && !current_attr.pointer && !initializer)
3147 : 1595 : initializer = gfc_default_initializer (¤t_ts);
3148 : 15389 : t = build_struct (name, cl, &initializer, &as);
3149 : :
3150 : : /* If we match a nested structure definition we expect to see the
3151 : : * body even if the variable declarations blow up, so we need to keep
3152 : : * the structure declaration around. */
3153 : 15389 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3154 : 34 : gfc_commit_symbol (gfc_new_block);
3155 : : }
3156 : :
3157 : 235115 : m = (t) ? MATCH_YES : MATCH_ERROR;
3158 : :
3159 : 235540 : cleanup:
3160 : : /* Free stuff up and return. */
3161 : 235540 : gfc_seen_div0 = false;
3162 : 235540 : gfc_free_expr (initializer);
3163 : 235540 : gfc_free_array_spec (as);
3164 : :
3165 : 235540 : return m;
3166 : : }
3167 : :
3168 : :
3169 : : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3170 : : This assumes that the byte size is equal to the kind number for
3171 : : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3172 : :
3173 : : static match
3174 : 89267 : gfc_match_old_kind_spec (gfc_typespec *ts)
3175 : : {
3176 : 89267 : match m;
3177 : 89267 : int original_kind;
3178 : :
3179 : 89267 : if (gfc_match_char ('*') != MATCH_YES)
3180 : : return MATCH_NO;
3181 : :
3182 : 1160 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3183 : 1160 : if (m != MATCH_YES)
3184 : : return MATCH_ERROR;
3185 : :
3186 : 1160 : original_kind = ts->kind;
3187 : :
3188 : : /* Massage the kind numbers for complex types. */
3189 : 1160 : if (ts->type == BT_COMPLEX)
3190 : : {
3191 : 88 : if (ts->kind % 2)
3192 : : {
3193 : 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3194 : : gfc_basic_typename (ts->type), original_kind);
3195 : 0 : return MATCH_ERROR;
3196 : : }
3197 : 88 : ts->kind /= 2;
3198 : :
3199 : : }
3200 : :
3201 : 1160 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3202 : 0 : ts->kind = 8;
3203 : :
3204 : 1160 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3205 : : {
3206 : 868 : if (ts->kind == 4)
3207 : : {
3208 : 217 : if (flag_real4_kind == 8)
3209 : 24 : ts->kind = 8;
3210 : 217 : if (flag_real4_kind == 10)
3211 : 24 : ts->kind = 10;
3212 : 217 : if (flag_real4_kind == 16)
3213 : 24 : ts->kind = 16;
3214 : : }
3215 : 651 : else if (ts->kind == 8)
3216 : : {
3217 : 646 : if (flag_real8_kind == 4)
3218 : 24 : ts->kind = 4;
3219 : 646 : if (flag_real8_kind == 10)
3220 : 24 : ts->kind = 10;
3221 : 646 : if (flag_real8_kind == 16)
3222 : 24 : ts->kind = 16;
3223 : : }
3224 : : }
3225 : :
3226 : 1160 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3227 : : {
3228 : 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3229 : : gfc_basic_typename (ts->type), original_kind);
3230 : 8 : return MATCH_ERROR;
3231 : : }
3232 : :
3233 : 1152 : if (!gfc_notify_std (GFC_STD_GNU,
3234 : : "Nonstandard type declaration %s*%d at %C",
3235 : : gfc_basic_typename(ts->type), original_kind))
3236 : : return MATCH_ERROR;
3237 : :
3238 : : return MATCH_YES;
3239 : : }
3240 : :
3241 : :
3242 : : /* Match a kind specification. Since kinds are generally optional, we
3243 : : usually return MATCH_NO if something goes wrong. If a "kind="
3244 : : string is found, then we know we have an error. */
3245 : :
3246 : : match
3247 : 130341 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3248 : : {
3249 : 130341 : locus where, loc;
3250 : 130341 : gfc_expr *e;
3251 : 130341 : match m, n;
3252 : 130341 : char c;
3253 : :
3254 : 130341 : m = MATCH_NO;
3255 : 130341 : n = MATCH_YES;
3256 : 130341 : e = NULL;
3257 : 130341 : saved_kind_expr = NULL;
3258 : :
3259 : 130341 : where = loc = gfc_current_locus;
3260 : :
3261 : 130341 : if (kind_expr_only)
3262 : 0 : goto kind_expr;
3263 : :
3264 : 130341 : if (gfc_match_char ('(') == MATCH_NO)
3265 : : return MATCH_NO;
3266 : :
3267 : : /* Also gobbles optional text. */
3268 : 40036 : if (gfc_match (" kind = ") == MATCH_YES)
3269 : 40036 : m = MATCH_ERROR;
3270 : :
3271 : 40036 : loc = gfc_current_locus;
3272 : :
3273 : 40036 : kind_expr:
3274 : :
3275 : 40036 : n = gfc_match_init_expr (&e);
3276 : :
3277 : 40036 : if (gfc_derived_parameter_expr (e))
3278 : : {
3279 : 77 : ts->kind = 0;
3280 : 77 : saved_kind_expr = gfc_copy_expr (e);
3281 : 77 : goto close_brackets;
3282 : : }
3283 : :
3284 : 39959 : if (n != MATCH_YES)
3285 : : {
3286 : 175 : if (gfc_matching_function)
3287 : : {
3288 : : /* The function kind expression might include use associated or
3289 : : imported parameters and try again after the specification
3290 : : expressions..... */
3291 : 152 : if (gfc_match_char (')') != MATCH_YES)
3292 : : {
3293 : 1 : gfc_error ("Missing right parenthesis at %C");
3294 : 1 : m = MATCH_ERROR;
3295 : 1 : goto no_match;
3296 : : }
3297 : :
3298 : 151 : gfc_free_expr (e);
3299 : 151 : gfc_undo_symbols ();
3300 : 151 : return MATCH_YES;
3301 : : }
3302 : : else
3303 : : {
3304 : : /* ....or else, the match is real. */
3305 : 23 : if (n == MATCH_NO)
3306 : 0 : gfc_error ("Expected initialization expression at %C");
3307 : 23 : if (n != MATCH_YES)
3308 : 23 : return MATCH_ERROR;
3309 : : }
3310 : : }
3311 : :
3312 : 39784 : if (e->rank != 0)
3313 : : {
3314 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3315 : 0 : m = MATCH_ERROR;
3316 : 0 : goto no_match;
3317 : : }
3318 : :
3319 : 39784 : if (gfc_extract_int (e, &ts->kind, 1))
3320 : : {
3321 : 0 : m = MATCH_ERROR;
3322 : 0 : goto no_match;
3323 : : }
3324 : :
3325 : : /* Before throwing away the expression, let's see if we had a
3326 : : C interoperable kind (and store the fact). */
3327 : 39784 : if (e->ts.is_c_interop == 1)
3328 : : {
3329 : : /* Mark this as C interoperable if being declared with one
3330 : : of the named constants from iso_c_binding. */
3331 : 14499 : ts->is_c_interop = e->ts.is_iso_c;
3332 : 14499 : ts->f90_type = e->ts.f90_type;
3333 : 14499 : if (e->symtree)
3334 : 14498 : ts->interop_kind = e->symtree->n.sym;
3335 : : }
3336 : :
3337 : 39784 : gfc_free_expr (e);
3338 : 39784 : e = NULL;
3339 : :
3340 : : /* Ignore errors to this point, if we've gotten here. This means
3341 : : we ignore the m=MATCH_ERROR from above. */
3342 : 39784 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3343 : : {
3344 : 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3345 : : gfc_basic_typename (ts->type));
3346 : 7 : gfc_current_locus = where;
3347 : 7 : return MATCH_ERROR;
3348 : : }
3349 : :
3350 : : /* Warn if, e.g., c_int is used for a REAL variable, but not
3351 : : if, e.g., c_double is used for COMPLEX as the standard
3352 : : explicitly says that the kind type parameter for complex and real
3353 : : variable is the same, i.e. c_float == c_float_complex. */
3354 : 39777 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3355 : 16 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3356 : 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3357 : 12 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3358 : : "is %s", gfc_basic_typename (ts->f90_type), &where,
3359 : : gfc_basic_typename (ts->type));
3360 : :
3361 : 39765 : close_brackets:
3362 : :
3363 : 39854 : gfc_gobble_whitespace ();
3364 : 39854 : if ((c = gfc_next_ascii_char ()) != ')'
3365 : 39854 : && (ts->type != BT_CHARACTER || c != ','))
3366 : : {
3367 : 0 : if (ts->type == BT_CHARACTER)
3368 : 0 : gfc_error ("Missing right parenthesis or comma at %C");
3369 : : else
3370 : 0 : gfc_error ("Missing right parenthesis at %C");
3371 : 0 : m = MATCH_ERROR;
3372 : 0 : goto no_match;
3373 : : }
3374 : : else
3375 : : /* All tests passed. */
3376 : 39854 : m = MATCH_YES;
3377 : :
3378 : 39854 : if(m == MATCH_ERROR)
3379 : : gfc_current_locus = where;
3380 : :
3381 : 39854 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3382 : 0 : ts->kind = 8;
3383 : :
3384 : 39854 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3385 : : {
3386 : 13446 : if (ts->kind == 4)
3387 : : {
3388 : 4413 : if (flag_real4_kind == 8)
3389 : 54 : ts->kind = 8;
3390 : 4413 : if (flag_real4_kind == 10)
3391 : 54 : ts->kind = 10;
3392 : 4413 : if (flag_real4_kind == 16)
3393 : 54 : ts->kind = 16;
3394 : : }
3395 : 9033 : else if (ts->kind == 8)
3396 : : {
3397 : 6124 : if (flag_real8_kind == 4)
3398 : 48 : ts->kind = 4;
3399 : 6124 : if (flag_real8_kind == 10)
3400 : 48 : ts->kind = 10;
3401 : 6124 : if (flag_real8_kind == 16)
3402 : 48 : ts->kind = 16;
3403 : : }
3404 : : }
3405 : :
3406 : : /* Return what we know from the test(s). */
3407 : : return m;
3408 : :
3409 : 1 : no_match:
3410 : 1 : gfc_free_expr (e);
3411 : 1 : gfc_current_locus = where;
3412 : 1 : return m;
3413 : : }
3414 : :
3415 : :
3416 : : static match
3417 : 3845 : match_char_kind (int * kind, int * is_iso_c)
3418 : : {
3419 : 3845 : locus where;
3420 : 3845 : gfc_expr *e;
3421 : 3845 : match m, n;
3422 : 3845 : bool fail;
3423 : :
3424 : 3845 : m = MATCH_NO;
3425 : 3845 : e = NULL;
3426 : 3845 : where = gfc_current_locus;
3427 : :
3428 : 3845 : n = gfc_match_init_expr (&e);
3429 : :
3430 : 3845 : if (n != MATCH_YES && gfc_matching_function)
3431 : : {
3432 : : /* The expression might include use-associated or imported
3433 : : parameters and try again after the specification
3434 : : expressions. */
3435 : 7 : gfc_free_expr (e);
3436 : 7 : gfc_undo_symbols ();
3437 : 7 : return MATCH_YES;
3438 : : }
3439 : :
3440 : 7 : if (n == MATCH_NO)
3441 : 2 : gfc_error ("Expected initialization expression at %C");
3442 : 3838 : if (n != MATCH_YES)
3443 : : return MATCH_ERROR;
3444 : :
3445 : 3831 : if (e->rank != 0)
3446 : : {
3447 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3448 : 0 : m = MATCH_ERROR;
3449 : 0 : goto no_match;
3450 : : }
3451 : :
3452 : 3831 : if (gfc_derived_parameter_expr (e))
3453 : : {
3454 : 14 : saved_kind_expr = e;
3455 : 14 : *kind = 0;
3456 : 14 : return MATCH_YES;
3457 : : }
3458 : :
3459 : 3817 : fail = gfc_extract_int (e, kind, 1);
3460 : 3817 : *is_iso_c = e->ts.is_iso_c;
3461 : 3817 : if (fail)
3462 : : {
3463 : 0 : m = MATCH_ERROR;
3464 : 0 : goto no_match;
3465 : : }
3466 : :
3467 : 3817 : gfc_free_expr (e);
3468 : :
3469 : : /* Ignore errors to this point, if we've gotten here. This means
3470 : : we ignore the m=MATCH_ERROR from above. */
3471 : 3817 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3472 : : {
3473 : 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3474 : 14 : m = MATCH_ERROR;
3475 : : }
3476 : : else
3477 : : /* All tests passed. */
3478 : : m = MATCH_YES;
3479 : :
3480 : 14 : if (m == MATCH_ERROR)
3481 : 14 : gfc_current_locus = where;
3482 : :
3483 : : /* Return what we know from the test(s). */
3484 : : return m;
3485 : :
3486 : 0 : no_match:
3487 : 0 : gfc_free_expr (e);
3488 : 0 : gfc_current_locus = where;
3489 : 0 : return m;
3490 : : }
3491 : :
3492 : :
3493 : : /* Match the various kind/length specifications in a CHARACTER
3494 : : declaration. We don't return MATCH_NO. */
3495 : :
3496 : : match
3497 : 26797 : gfc_match_char_spec (gfc_typespec *ts)
3498 : : {
3499 : 26797 : int kind, seen_length, is_iso_c;
3500 : 26797 : gfc_charlen *cl;
3501 : 26797 : gfc_expr *len;
3502 : 26797 : match m;
3503 : 26797 : bool deferred;
3504 : :
3505 : 26797 : len = NULL;
3506 : 26797 : seen_length = 0;
3507 : 26797 : kind = 0;
3508 : 26797 : is_iso_c = 0;
3509 : 26797 : deferred = false;
3510 : :
3511 : : /* Try the old-style specification first. */
3512 : 26797 : old_char_selector = 0;
3513 : :
3514 : 26797 : m = match_char_length (&len, &deferred, true);
3515 : 26797 : if (m != MATCH_NO)
3516 : : {
3517 : 2262 : if (m == MATCH_YES)
3518 : 2262 : old_char_selector = 1;
3519 : 2262 : seen_length = 1;
3520 : 2262 : goto done;
3521 : : }
3522 : :
3523 : 24535 : m = gfc_match_char ('(');
3524 : 24535 : if (m != MATCH_YES)
3525 : : {
3526 : 1331 : m = MATCH_YES; /* Character without length is a single char. */
3527 : 1331 : goto done;
3528 : : }
3529 : :
3530 : : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3531 : 23204 : if (gfc_match (" kind =") == MATCH_YES)
3532 : : {
3533 : 2675 : m = match_char_kind (&kind, &is_iso_c);
3534 : :
3535 : 2675 : if (m == MATCH_ERROR)
3536 : 16 : goto done;
3537 : 2659 : if (m == MATCH_NO)
3538 : 0 : goto syntax;
3539 : :
3540 : 2659 : if (gfc_match (" , len =") == MATCH_NO)
3541 : 322 : goto rparen;
3542 : :
3543 : 2337 : m = char_len_param_value (&len, &deferred);
3544 : 2337 : if (m == MATCH_NO)
3545 : 0 : goto syntax;
3546 : 2337 : if (m == MATCH_ERROR)
3547 : 2 : goto done;
3548 : 2335 : seen_length = 1;
3549 : :
3550 : 2335 : goto rparen;
3551 : : }
3552 : :
3553 : : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3554 : 20529 : if (gfc_match (" len =") == MATCH_YES)
3555 : : {
3556 : 12993 : m = char_len_param_value (&len, &deferred);
3557 : 12993 : if (m == MATCH_NO)
3558 : 2 : goto syntax;
3559 : 12991 : if (m == MATCH_ERROR)
3560 : 8 : goto done;
3561 : 12983 : seen_length = 1;
3562 : :
3563 : 12983 : if (gfc_match_char (')') == MATCH_YES)
3564 : 11931 : goto done;
3565 : :
3566 : 1052 : if (gfc_match (" , kind =") != MATCH_YES)
3567 : 0 : goto syntax;
3568 : :
3569 : 1052 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3570 : 2 : goto done;
3571 : :
3572 : 1050 : goto rparen;
3573 : : }
3574 : :
3575 : : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3576 : 7536 : m = char_len_param_value (&len, &deferred);
3577 : 7536 : if (m == MATCH_NO)
3578 : 0 : goto syntax;
3579 : 7536 : if (m == MATCH_ERROR)
3580 : 44 : goto done;
3581 : 7492 : seen_length = 1;
3582 : :
3583 : 7492 : m = gfc_match_char (')');
3584 : 7492 : if (m == MATCH_YES)
3585 : 7372 : goto done;
3586 : :
3587 : 120 : if (gfc_match_char (',') != MATCH_YES)
3588 : 2 : goto syntax;
3589 : :
3590 : 118 : gfc_match (" kind ="); /* Gobble optional text. */
3591 : :
3592 : 118 : m = match_char_kind (&kind, &is_iso_c);
3593 : 118 : if (m == MATCH_ERROR)
3594 : 3 : goto done;
3595 : 115 : if (m == MATCH_NO)
3596 : 0 : goto syntax;
3597 : :
3598 : 115 : rparen:
3599 : : /* Require a right-paren at this point. */
3600 : 3822 : m = gfc_match_char (')');
3601 : 3822 : if (m == MATCH_YES)
3602 : 3822 : goto done;
3603 : :
3604 : 0 : syntax:
3605 : 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3606 : 4 : m = MATCH_ERROR;
3607 : 4 : gfc_free_expr (len);
3608 : 4 : return m;
3609 : :
3610 : 26793 : done:
3611 : : /* Deal with character functions after USE and IMPORT statements. */
3612 : 26793 : if (gfc_matching_function)
3613 : : {
3614 : 1069 : gfc_free_expr (len);
3615 : 1069 : gfc_undo_symbols ();
3616 : 1069 : return MATCH_YES;
3617 : : }
3618 : :
3619 : 25724 : if (m != MATCH_YES)
3620 : : {
3621 : 65 : gfc_free_expr (len);
3622 : 65 : return m;
3623 : : }
3624 : :
3625 : : /* Do some final massaging of the length values. */
3626 : 25659 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3627 : :
3628 : 25659 : if (seen_length == 0)
3629 : 1596 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3630 : : else
3631 : : {
3632 : : /* If gfortran ends up here, then len may be reducible to a constant.
3633 : : Try to do that here. If it does not reduce, simply assign len to
3634 : : charlen. A complication occurs with user-defined generic functions,
3635 : : which are not resolved. Use a private namespace to deal with
3636 : : generic functions. */
3637 : :
3638 : 24063 : if (len && len->expr_type != EXPR_CONSTANT)
3639 : : {
3640 : 2375 : gfc_namespace *old_ns;
3641 : 2375 : gfc_expr *e;
3642 : :
3643 : 2375 : old_ns = gfc_current_ns;
3644 : 2375 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3645 : :
3646 : 2375 : e = gfc_copy_expr (len);
3647 : 2375 : gfc_push_suppress_errors ();
3648 : 2375 : gfc_reduce_init_expr (e);
3649 : 2375 : gfc_pop_suppress_errors ();
3650 : 2375 : if (e->expr_type == EXPR_CONSTANT)
3651 : : {
3652 : 291 : gfc_replace_expr (len, e);
3653 : 291 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3654 : 7 : mpz_set_ui (len->value.integer, 0);
3655 : : }
3656 : : else
3657 : 2084 : gfc_free_expr (e);
3658 : :
3659 : 2375 : gfc_free_namespace (gfc_current_ns);
3660 : 2375 : gfc_current_ns = old_ns;
3661 : : }
3662 : :
3663 : 24063 : cl->length = len;
3664 : : }
3665 : :
3666 : 25659 : ts->u.cl = cl;
3667 : 25659 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3668 : 25659 : ts->deferred = deferred;
3669 : :
3670 : : /* We have to know if it was a C interoperable kind so we can
3671 : : do accurate type checking of bind(c) procs, etc. */
3672 : 25659 : if (kind != 0)
3673 : : /* Mark this as C interoperable if being declared with one
3674 : : of the named constants from iso_c_binding. */
3675 : 3740 : ts->is_c_interop = is_iso_c;
3676 : 21919 : else if (len != NULL)
3677 : : /* Here, we might have parsed something such as: character(c_char)
3678 : : In this case, the parsing code above grabs the c_char when
3679 : : looking for the length (line 1690, roughly). it's the last
3680 : : testcase for parsing the kind params of a character variable.
3681 : : However, it's not actually the length. this seems like it
3682 : : could be an error.
3683 : : To see if the user used a C interop kind, test the expr
3684 : : of the so called length, and see if it's C interoperable. */
3685 : 14686 : ts->is_c_interop = len->ts.is_iso_c;
3686 : :
3687 : : return MATCH_YES;
3688 : : }
3689 : :
3690 : :
3691 : : /* Matches a RECORD declaration. */
3692 : :
3693 : : static match
3694 : 805236 : match_record_decl (char *name)
3695 : : {
3696 : 805236 : locus old_loc;
3697 : 805236 : old_loc = gfc_current_locus;
3698 : 805236 : match m;
3699 : :
3700 : 805236 : m = gfc_match (" record /");
3701 : 805236 : if (m == MATCH_YES)
3702 : : {
3703 : 353 : if (!flag_dec_structure)
3704 : : {
3705 : 6 : gfc_current_locus = old_loc;
3706 : 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3707 : : "%<-fdec-structure%>");
3708 : 6 : return MATCH_ERROR;
3709 : : }
3710 : 347 : m = gfc_match (" %n/", name);
3711 : 347 : if (m == MATCH_YES)
3712 : : return MATCH_YES;
3713 : : }
3714 : :
3715 : 804886 : gfc_current_locus = old_loc;
3716 : 804886 : if (flag_dec_structure
3717 : 804886 : && (gfc_match (" record% ") == MATCH_YES
3718 : 8026 : || gfc_match (" record%t") == MATCH_YES))
3719 : 6 : gfc_error ("Structure name expected after RECORD at %C");
3720 : 804886 : if (m == MATCH_NO)
3721 : : return MATCH_NO;
3722 : :
3723 : : return MATCH_ERROR;
3724 : : }
3725 : :
3726 : :
3727 : : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3728 : : of expressions to substitute into the possibly parameterized expression
3729 : : 'e'. Using a list is inefficient but should not be too bad since the
3730 : : number of type parameters is not likely to be large. */
3731 : : static bool
3732 : 1592 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3733 : : int* f)
3734 : : {
3735 : 1592 : gfc_actual_arglist *param;
3736 : 1592 : gfc_expr *copy;
3737 : :
3738 : 1592 : if (e->expr_type != EXPR_VARIABLE)
3739 : : return false;
3740 : :
3741 : 799 : gcc_assert (e->symtree);
3742 : 799 : if (e->symtree->n.sym->attr.pdt_kind
3743 : 656 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3744 : : {
3745 : 812 : for (param = type_param_spec_list; param; param = param->next)
3746 : 812 : if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3747 : : break;
3748 : :
3749 : 502 : if (param)
3750 : : {
3751 : 502 : copy = gfc_copy_expr (param->expr);
3752 : 502 : *e = *copy;
3753 : 502 : free (copy);
3754 : : }
3755 : : }
3756 : :
3757 : : return false;
3758 : : }
3759 : :
3760 : :
3761 : : static bool
3762 : 585 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3763 : : {
3764 : 585 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3765 : : }
3766 : :
3767 : :
3768 : : bool
3769 : 646 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3770 : : {
3771 : 646 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3772 : 646 : type_param_spec_list = param_list;
3773 : 646 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3774 : 646 : type_param_spec_list = old_param_spec_list;
3775 : 646 : return res;
3776 : : }
3777 : :
3778 : : /* Determines the instance of a parameterized derived type to be used by
3779 : : matching determining the values of the kind parameters and using them
3780 : : in the name of the instance. If the instance exists, it is used, otherwise
3781 : : a new derived type is created. */
3782 : : match
3783 : 492 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3784 : : gfc_actual_arglist **ext_param_list)
3785 : : {
3786 : : /* The PDT template symbol. */
3787 : 492 : gfc_symbol *pdt = *sym;
3788 : : /* The symbol for the parameter in the template f2k_namespace. */
3789 : 492 : gfc_symbol *param;
3790 : : /* The hoped for instance of the PDT. */
3791 : 492 : gfc_symbol *instance;
3792 : : /* The list of parameters appearing in the PDT declaration. */
3793 : 492 : gfc_formal_arglist *type_param_name_list;
3794 : : /* Used to store the parameter specification list during recursive calls. */
3795 : 492 : gfc_actual_arglist *old_param_spec_list;
3796 : : /* Pointers to the parameter specification being used. */
3797 : 492 : gfc_actual_arglist *actual_param;
3798 : 492 : gfc_actual_arglist *tail = NULL;
3799 : : /* Used to build up the name of the PDT instance. The prefix uses 4
3800 : : characters and each KIND parameter 2 more. Allow 8 of the latter. */
3801 : 492 : char name[GFC_MAX_SYMBOL_LEN + 21];
3802 : :
3803 : 492 : bool name_seen = (param_list == NULL);
3804 : 492 : bool assumed_seen = false;
3805 : 492 : bool deferred_seen = false;
3806 : 492 : bool spec_error = false;
3807 : 492 : int kind_value, i;
3808 : 492 : gfc_expr *kind_expr;
3809 : 492 : gfc_component *c1, *c2;
3810 : 492 : match m;
3811 : :
3812 : 492 : type_param_spec_list = NULL;
3813 : :
3814 : 492 : type_param_name_list = pdt->formal;
3815 : 492 : actual_param = param_list;
3816 : 492 : sprintf (name, "Pdt%s", pdt->name);
3817 : :
3818 : : /* Run through the parameter name list and pick up the actual
3819 : : parameter values or use the default values in the PDT declaration. */
3820 : 1313 : for (; type_param_name_list;
3821 : 821 : type_param_name_list = type_param_name_list->next)
3822 : : {
3823 : 833 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3824 : : {
3825 : 756 : if (actual_param->spec_type == SPEC_ASSUMED)
3826 : : spec_error = deferred_seen;
3827 : : else
3828 : 756 : spec_error = assumed_seen;
3829 : :
3830 : 756 : if (spec_error)
3831 : : {
3832 : : gfc_error ("The type parameter spec list at %C cannot contain "
3833 : : "both ASSUMED and DEFERRED parameters");
3834 : : goto error_return;
3835 : : }
3836 : : }
3837 : :
3838 : 756 : if (actual_param && actual_param->name)
3839 : 833 : name_seen = true;
3840 : 833 : param = type_param_name_list->sym;
3841 : :
3842 : 833 : if (!param || !param->name)
3843 : 1 : continue;
3844 : :
3845 : 832 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
3846 : : /* An error should already have been thrown in resolve.cc
3847 : : (resolve_fl_derived0). */
3848 : 832 : if (!pdt->attr.use_assoc && !c1)
3849 : 3 : goto error_return;
3850 : :
3851 : 829 : kind_expr = NULL;
3852 : 829 : if (!name_seen)
3853 : : {
3854 : 479 : if (!actual_param && !(c1 && c1->initializer))
3855 : : {
3856 : 1 : gfc_error ("The type parameter spec list at %C does not contain "
3857 : : "enough parameter expressions");
3858 : 1 : goto error_return;
3859 : : }
3860 : 478 : else if (!actual_param && c1 && c1->initializer)
3861 : 1 : kind_expr = gfc_copy_expr (c1->initializer);
3862 : 477 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3863 : 379 : kind_expr = gfc_copy_expr (actual_param->expr);
3864 : : }
3865 : : else
3866 : : {
3867 : : actual_param = param_list;
3868 : 463 : for (;actual_param; actual_param = actual_param->next)
3869 : 383 : if (actual_param->name
3870 : 381 : && strcmp (actual_param->name, param->name) == 0)
3871 : : break;
3872 : 350 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3873 : 231 : kind_expr = gfc_copy_expr (actual_param->expr);
3874 : : else
3875 : : {
3876 : 119 : if (c1->initializer)
3877 : 111 : kind_expr = gfc_copy_expr (c1->initializer);
3878 : 8 : else if (!(actual_param && param->attr.pdt_len))
3879 : : {
3880 : 0 : gfc_error ("The derived parameter %qs at %C does not "
3881 : : "have a default value", param->name);
3882 : 0 : goto error_return;
3883 : : }
3884 : : }
3885 : : }
3886 : :
3887 : : /* Store the current parameter expressions in a temporary actual
3888 : : arglist 'list' so that they can be substituted in the corresponding
3889 : : expressions in the PDT instance. */
3890 : 828 : if (type_param_spec_list == NULL)
3891 : : {
3892 : 490 : type_param_spec_list = gfc_get_actual_arglist ();
3893 : 490 : tail = type_param_spec_list;
3894 : : }
3895 : : else
3896 : : {
3897 : 338 : tail->next = gfc_get_actual_arglist ();
3898 : 338 : tail = tail->next;
3899 : : }
3900 : 828 : tail->name = param->name;
3901 : :
3902 : 828 : if (kind_expr)
3903 : : {
3904 : : /* Try simplification even for LEN expressions. */
3905 : 722 : bool ok;
3906 : 722 : gfc_resolve_expr (kind_expr);
3907 : 722 : ok = gfc_simplify_expr (kind_expr, 1);
3908 : : /* Variable expressions seem to default to BT_PROCEDURE.
3909 : : TODO find out why this is and fix it. */
3910 : 722 : if (kind_expr->ts.type != BT_INTEGER
3911 : 27 : && kind_expr->ts.type != BT_PROCEDURE)
3912 : : {
3913 : 3 : gfc_error ("The parameter expression at %C must be of "
3914 : : "INTEGER type and not %s type",
3915 : : gfc_basic_typename (kind_expr->ts.type));
3916 : 3 : goto error_return;
3917 : : }
3918 : 719 : if (kind_expr->ts.type == BT_INTEGER && !ok)
3919 : : {
3920 : 2 : gfc_error ("The parameter expression at %C does not "
3921 : : "simplify to an INTEGER constant");
3922 : 2 : goto error_return;
3923 : : }
3924 : :
3925 : 717 : tail->expr = gfc_copy_expr (kind_expr);
3926 : : }
3927 : :
3928 : 823 : if (actual_param)
3929 : 742 : tail->spec_type = actual_param->spec_type;
3930 : :
3931 : 823 : if (!param->attr.pdt_kind)
3932 : : {
3933 : 411 : if (!name_seen && actual_param)
3934 : 251 : actual_param = actual_param->next;
3935 : 411 : if (kind_expr)
3936 : : {
3937 : 307 : gfc_free_expr (kind_expr);
3938 : 307 : kind_expr = NULL;
3939 : : }
3940 : 411 : continue;
3941 : : }
3942 : :
3943 : 412 : if (actual_param
3944 : 355 : && (actual_param->spec_type == SPEC_ASSUMED
3945 : 355 : || actual_param->spec_type == SPEC_DEFERRED))
3946 : : {
3947 : 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
3948 : : "ASSUMED or DEFERRED", param->name);
3949 : 2 : goto error_return;
3950 : : }
3951 : :
3952 : 410 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
3953 : : {
3954 : 1 : gfc_error ("The value for the KIND parameter %qs at %C does not "
3955 : : "reduce to a constant expression", param->name);
3956 : 1 : goto error_return;
3957 : : }
3958 : :
3959 : 409 : gfc_extract_int (kind_expr, &kind_value);
3960 : 409 : sprintf (name + strlen (name), "_%d", kind_value);
3961 : :
3962 : 409 : if (!name_seen && actual_param)
3963 : 218 : actual_param = actual_param->next;
3964 : 409 : gfc_free_expr (kind_expr);
3965 : : }
3966 : :
3967 : 480 : if (!name_seen && actual_param)
3968 : : {
3969 : 1 : gfc_error ("The type parameter spec list at %C contains too many "
3970 : : "parameter expressions");
3971 : 1 : goto error_return;
3972 : : }
3973 : :
3974 : : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3975 : : build it, using 'pdt' as a template. */
3976 : 479 : if (gfc_get_symbol (name, pdt->ns, &instance))
3977 : : {
3978 : 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
3979 : 0 : goto error_return;
3980 : : }
3981 : :
3982 : 479 : m = MATCH_YES;
3983 : :
3984 : 479 : if (instance->attr.flavor == FL_DERIVED
3985 : 479 : && instance->attr.pdt_type)
3986 : : {
3987 : 277 : instance->refs++;
3988 : 277 : if (ext_param_list)
3989 : 62 : *ext_param_list = type_param_spec_list;
3990 : 277 : *sym = instance;
3991 : 277 : gfc_commit_symbols ();
3992 : 277 : return m;
3993 : : }
3994 : :
3995 : : /* Start building the new instance of the parameterized type. */
3996 : 202 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
3997 : 202 : instance->attr.pdt_template = 0;
3998 : 202 : instance->attr.pdt_type = 1;
3999 : 202 : instance->declared_at = gfc_current_locus;
4000 : :
4001 : : /* Add the components, replacing the parameters in all expressions
4002 : : with the expressions for their values in 'type_param_spec_list'. */
4003 : 202 : c1 = pdt->components;
4004 : 202 : tail = type_param_spec_list;
4005 : 846 : for (; c1; c1 = c1->next)
4006 : : {
4007 : 645 : gfc_add_component (instance, c1->name, &c2);
4008 : :
4009 : 645 : c2->ts = c1->ts;
4010 : 645 : c2->attr = c1->attr;
4011 : :
4012 : : /* The order of declaration of the type_specs might not be the
4013 : : same as that of the components. */
4014 : 645 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4015 : : {
4016 : 529 : for (tail = type_param_spec_list; tail; tail = tail->next)
4017 : 529 : if (strcmp (c1->name, tail->name) == 0)
4018 : : break;
4019 : : }
4020 : :
4021 : : /* Deal with type extension by recursively calling this function
4022 : : to obtain the instance of the extended type. */
4023 : 645 : if (gfc_current_state () != COMP_DERIVED
4024 : 645 : && c1 == pdt->components
4025 : 202 : && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4026 : 15 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
4027 : 660 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4028 : : {
4029 : 15 : gfc_formal_arglist *f;
4030 : :
4031 : 15 : old_param_spec_list = type_param_spec_list;
4032 : :
4033 : : /* Obtain a spec list appropriate to the extended type..*/
4034 : 15 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4035 : 15 : type_param_spec_list = actual_param;
4036 : 32 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4037 : 17 : actual_param = actual_param->next;
4038 : 15 : if (actual_param)
4039 : : {
4040 : 15 : gfc_free_actual_arglist (actual_param->next);
4041 : 15 : actual_param->next = NULL;
4042 : : }
4043 : :
4044 : : /* Now obtain the PDT instance for the extended type. */
4045 : 15 : c2->param_list = type_param_spec_list;
4046 : 15 : m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
4047 : : NULL);
4048 : 15 : type_param_spec_list = old_param_spec_list;
4049 : :
4050 : 15 : c2->ts.u.derived->refs++;
4051 : 15 : gfc_set_sym_referenced (c2->ts.u.derived);
4052 : :
4053 : : /* Set extension level. */
4054 : 15 : if (c2->ts.u.derived->attr.extension == 255)
4055 : : {
4056 : : /* Since the extension field is 8 bit wide, we can only have
4057 : : up to 255 extension levels. */
4058 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4059 : : c2->ts.u.derived->name,
4060 : : &c2->ts.u.derived->declared_at);
4061 : 0 : goto error_return;
4062 : : }
4063 : 15 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4064 : :
4065 : 15 : continue;
4066 : 15 : }
4067 : :
4068 : : /* Set the component kind using the parameterized expression. */
4069 : 630 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4070 : 211 : && c1->kind_expr != NULL)
4071 : : {
4072 : 130 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4073 : 130 : gfc_insert_kind_parameter_exprs (e);
4074 : 130 : gfc_simplify_expr (e, 1);
4075 : 130 : gfc_extract_int (e, &c2->ts.kind);
4076 : 130 : gfc_free_expr (e);
4077 : 130 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4078 : : {
4079 : 1 : gfc_error ("Kind %d not supported for type %s at %C",
4080 : : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4081 : 1 : goto error_return;
4082 : : }
4083 : : }
4084 : :
4085 : : /* Similarly, set the string length if parameterized. */
4086 : 629 : if (c1->ts.type == BT_CHARACTER
4087 : 67 : && c1->ts.u.cl->length
4088 : 696 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4089 : : {
4090 : 67 : gfc_expr *e;
4091 : 67 : e = gfc_copy_expr (c1->ts.u.cl->length);
4092 : 67 : gfc_insert_kind_parameter_exprs (e);
4093 : 67 : gfc_simplify_expr (e, 1);
4094 : 67 : c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4095 : 67 : c2->ts.u.cl->length = e;
4096 : 67 : c2->attr.pdt_string = 1;
4097 : : }
4098 : :
4099 : : /* Set up either the KIND/LEN initializer, if constant,
4100 : : or the parameterized expression. Use the template
4101 : : initializer if one is not already set in this instance. */
4102 : 629 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4103 : : {
4104 : 337 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4105 : 292 : c2->initializer = gfc_copy_expr (tail->expr);
4106 : 45 : else if (tail && tail->expr)
4107 : : {
4108 : 4 : c2->param_list = gfc_get_actual_arglist ();
4109 : 4 : c2->param_list->name = tail->name;
4110 : 4 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4111 : 4 : c2->param_list->next = NULL;
4112 : : }
4113 : :
4114 : 337 : if (!c2->initializer && c1->initializer)
4115 : 15 : c2->initializer = gfc_copy_expr (c1->initializer);
4116 : : }
4117 : :
4118 : : /* Copy the array spec. */
4119 : 629 : c2->as = gfc_copy_array_spec (c1->as);
4120 : 629 : if (c1->ts.type == BT_CLASS)
4121 : 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4122 : :
4123 : : /* Determine if an array spec is parameterized. If so, substitute
4124 : : in the parameter expressions for the bounds and set the pdt_array
4125 : : attribute. Notice that this attribute must be unconditionally set
4126 : : if this is an array of parameterized character length. */
4127 : 629 : if (c1->as && c1->as->type == AS_EXPLICIT)
4128 : : {
4129 : : bool pdt_array = false;
4130 : :
4131 : : /* Are the bounds of the array parameterized? */
4132 : 327 : for (i = 0; i < c1->as->rank; i++)
4133 : : {
4134 : 202 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4135 : 0 : pdt_array = true;
4136 : 202 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4137 : 188 : pdt_array = true;
4138 : : }
4139 : :
4140 : : /* If they are, free the expressions for the bounds and
4141 : : replace them with the template expressions with substitute
4142 : : values. */
4143 : 313 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4144 : : {
4145 : 188 : gfc_expr *e;
4146 : 188 : e = gfc_copy_expr (c1->as->lower[i]);
4147 : 188 : gfc_insert_kind_parameter_exprs (e);
4148 : 188 : gfc_simplify_expr (e, 1);
4149 : 188 : gfc_free_expr (c2->as->lower[i]);
4150 : 188 : c2->as->lower[i] = e;
4151 : 188 : e = gfc_copy_expr (c1->as->upper[i]);
4152 : 188 : gfc_insert_kind_parameter_exprs (e);
4153 : 188 : gfc_simplify_expr (e, 1);
4154 : 188 : gfc_free_expr (c2->as->upper[i]);
4155 : 188 : c2->as->upper[i] = e;
4156 : : }
4157 : 125 : c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
4158 : 125 : if (c1->initializer)
4159 : : {
4160 : 12 : c2->initializer = gfc_copy_expr (c1->initializer);
4161 : 12 : gfc_insert_kind_parameter_exprs (c2->initializer);
4162 : 12 : gfc_simplify_expr (c2->initializer, 1);
4163 : : }
4164 : : }
4165 : :
4166 : : /* Recurse into this function for PDT components. */
4167 : 629 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4168 : 39 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4169 : : {
4170 : 39 : gfc_actual_arglist *params;
4171 : : /* The component in the template has a list of specification
4172 : : expressions derived from its declaration. */
4173 : 39 : params = gfc_copy_actual_arglist (c1->param_list);
4174 : 39 : actual_param = params;
4175 : : /* Substitute the template parameters with the expressions
4176 : : from the specification list. */
4177 : 118 : for (;actual_param; actual_param = actual_param->next)
4178 : 40 : gfc_insert_parameter_exprs (actual_param->expr,
4179 : : type_param_spec_list);
4180 : :
4181 : : /* Now obtain the PDT instance for the component. */
4182 : 39 : old_param_spec_list = type_param_spec_list;
4183 : 39 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
4184 : 39 : type_param_spec_list = old_param_spec_list;
4185 : :
4186 : 39 : c2->param_list = params;
4187 : 39 : if (!(c2->attr.pointer || c2->attr.allocatable))
4188 : 26 : c2->initializer = gfc_default_initializer (&c2->ts);
4189 : :
4190 : 39 : if (c2->attr.allocatable)
4191 : 7 : instance->attr.alloc_comp = 1;
4192 : : }
4193 : : }
4194 : :
4195 : 201 : gfc_commit_symbol (instance);
4196 : 201 : if (ext_param_list)
4197 : 7 : *ext_param_list = type_param_spec_list;
4198 : 201 : *sym = instance;
4199 : 201 : return m;
4200 : :
4201 : 14 : error_return:
4202 : 14 : gfc_free_actual_arglist (type_param_spec_list);
4203 : 14 : return MATCH_ERROR;
4204 : : }
4205 : :
4206 : :
4207 : : /* Match a legacy nonstandard BYTE type-spec. */
4208 : :
4209 : : static match
4210 : 986741 : match_byte_typespec (gfc_typespec *ts)
4211 : : {
4212 : 986741 : if (gfc_match (" byte") == MATCH_YES)
4213 : : {
4214 : 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4215 : : return MATCH_ERROR;
4216 : :
4217 : 31 : if (gfc_current_form == FORM_FREE)
4218 : : {
4219 : 19 : char c = gfc_peek_ascii_char ();
4220 : 19 : if (!gfc_is_whitespace (c) && c != ',')
4221 : : return MATCH_NO;
4222 : : }
4223 : :
4224 : 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4225 : : {
4226 : 0 : gfc_error ("BYTE type used at %C "
4227 : : "is not available on the target machine");
4228 : 0 : return MATCH_ERROR;
4229 : : }
4230 : :
4231 : 29 : ts->type = BT_INTEGER;
4232 : 29 : ts->kind = 1;
4233 : 29 : return MATCH_YES;
4234 : : }
4235 : : return MATCH_NO;
4236 : : }
4237 : :
4238 : :
4239 : : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4240 : : structure to the matched specification. This is necessary for FUNCTION and
4241 : : IMPLICIT statements.
4242 : :
4243 : : If implicit_flag is nonzero, then we don't check for the optional
4244 : : kind specification. Not doing so is needed for matching an IMPLICIT
4245 : : statement correctly. */
4246 : :
4247 : : match
4248 : 986741 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4249 : : {
4250 : : /* Provide sufficient space to hold "pdtsymbol". */
4251 : 986741 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4252 : 986741 : gfc_symbol *sym, *dt_sym;
4253 : 986741 : match m;
4254 : 986741 : char c;
4255 : 986741 : bool seen_deferred_kind, matched_type;
4256 : 986741 : const char *dt_name;
4257 : :
4258 : 986741 : decl_type_param_list = NULL;
4259 : :
4260 : : /* A belt and braces check that the typespec is correctly being treated
4261 : : as a deferred characteristic association. */
4262 : 1973482 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4263 : 69329 : && (gfc_current_block ()->result->ts.kind == -1)
4264 : 996236 : && (ts->kind == -1);
4265 : 986741 : gfc_clear_ts (ts);
4266 : 986741 : if (seen_deferred_kind)
4267 : 7690 : ts->kind = -1;
4268 : :
4269 : : /* Clear the current binding label, in case one is given. */
4270 : 986741 : curr_binding_label = NULL;
4271 : :
4272 : : /* Match BYTE type-spec. */
4273 : 986741 : m = match_byte_typespec (ts);
4274 : 986741 : if (m != MATCH_NO)
4275 : : return m;
4276 : :
4277 : 986710 : m = gfc_match (" type (");
4278 : 986710 : matched_type = (m == MATCH_YES);
4279 : 986710 : if (matched_type)
4280 : : {
4281 : 24163 : gfc_gobble_whitespace ();
4282 : 24163 : if (gfc_peek_ascii_char () == '*')
4283 : : {
4284 : 3945 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4285 : : return m;
4286 : 3945 : if (gfc_comp_struct (gfc_current_state ()))
4287 : : {
4288 : 2 : gfc_error ("Assumed type at %C is not allowed for components");
4289 : 2 : return MATCH_ERROR;
4290 : : }
4291 : 3943 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4292 : : return MATCH_ERROR;
4293 : 3941 : ts->type = BT_ASSUMED;
4294 : 3941 : return MATCH_YES;
4295 : : }
4296 : :
4297 : 20218 : m = gfc_match ("%n", name);
4298 : 20218 : matched_type = (m == MATCH_YES);
4299 : : }
4300 : :
4301 : 20218 : if ((matched_type && strcmp ("integer", name) == 0)
4302 : 982765 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4303 : : {
4304 : 89432 : ts->type = BT_INTEGER;
4305 : 89432 : ts->kind = gfc_default_integer_kind;
4306 : 89432 : goto get_kind;
4307 : : }
4308 : :
4309 : 20213 : if ((matched_type && strcmp ("character", name) == 0)
4310 : 893333 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4311 : : {
4312 : 25198 : if (matched_type
4313 : 25198 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4314 : : "intrinsic-type-spec at %C"))
4315 : : return MATCH_ERROR;
4316 : :
4317 : 25197 : ts->type = BT_CHARACTER;
4318 : 25197 : if (implicit_flag == 0)
4319 : 25092 : m = gfc_match_char_spec (ts);
4320 : : else
4321 : : m = MATCH_YES;
4322 : :
4323 : 25197 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4324 : : {
4325 : 1 : gfc_error ("Malformed type-spec at %C");
4326 : 1 : return MATCH_ERROR;
4327 : : }
4328 : :
4329 : 25196 : return m;
4330 : : }
4331 : :
4332 : 20209 : if ((matched_type && strcmp ("real", name) == 0)
4333 : 868135 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4334 : : {
4335 : 27342 : ts->type = BT_REAL;
4336 : 27342 : ts->kind = gfc_default_real_kind;
4337 : 27342 : goto get_kind;
4338 : : }
4339 : :
4340 : 840793 : if ((matched_type
4341 : 20206 : && (strcmp ("doubleprecision", name) == 0
4342 : 20205 : || (strcmp ("double", name) == 0
4343 : 5 : && gfc_match (" precision") == MATCH_YES)))
4344 : 840793 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4345 : : {
4346 : 2544 : if (matched_type
4347 : 2544 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4348 : : "intrinsic-type-spec at %C"))
4349 : : return MATCH_ERROR;
4350 : :
4351 : 2543 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4352 : : {
4353 : 2 : gfc_error ("Malformed type-spec at %C");
4354 : 2 : return MATCH_ERROR;
4355 : : }
4356 : :
4357 : 2541 : ts->type = BT_REAL;
4358 : 2541 : ts->kind = gfc_default_double_kind;
4359 : 2541 : return MATCH_YES;
4360 : : }
4361 : :
4362 : 20202 : if ((matched_type && strcmp ("complex", name) == 0)
4363 : 838249 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4364 : : {
4365 : 3639 : ts->type = BT_COMPLEX;
4366 : 3639 : ts->kind = gfc_default_complex_kind;
4367 : 3639 : goto get_kind;
4368 : : }
4369 : :
4370 : 834610 : if ((matched_type
4371 : 20202 : && (strcmp ("doublecomplex", name) == 0
4372 : 20201 : || (strcmp ("double", name) == 0
4373 : 2 : && gfc_match (" complex") == MATCH_YES)))
4374 : 834610 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4375 : : {
4376 : 201 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4377 : : return MATCH_ERROR;
4378 : :
4379 : 200 : if (matched_type
4380 : 200 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4381 : : "intrinsic-type-spec at %C"))
4382 : : return MATCH_ERROR;
4383 : :
4384 : 200 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4385 : : {
4386 : 2 : gfc_error ("Malformed type-spec at %C");
4387 : 2 : return MATCH_ERROR;
4388 : : }
4389 : :
4390 : 198 : ts->type = BT_COMPLEX;
4391 : 198 : ts->kind = gfc_default_double_kind;
4392 : 198 : return MATCH_YES;
4393 : : }
4394 : :
4395 : 20199 : if ((matched_type && strcmp ("logical", name) == 0)
4396 : 834409 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4397 : : {
4398 : 8977 : ts->type = BT_LOGICAL;
4399 : 8977 : ts->kind = gfc_default_logical_kind;
4400 : 8977 : goto get_kind;
4401 : : }
4402 : :
4403 : 825432 : if (matched_type)
4404 : : {
4405 : 20196 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4406 : 20196 : if (m == MATCH_ERROR)
4407 : : return m;
4408 : :
4409 : 20196 : gfc_gobble_whitespace ();
4410 : 20196 : if (gfc_peek_ascii_char () != ')')
4411 : : {
4412 : 1 : gfc_error ("Malformed type-spec at %C");
4413 : 1 : return MATCH_ERROR;
4414 : : }
4415 : 20195 : m = gfc_match_char (')'); /* Burn closing ')'. */
4416 : : }
4417 : :
4418 : 825431 : if (m != MATCH_YES)
4419 : 805236 : m = match_record_decl (name);
4420 : :
4421 : 825431 : if (matched_type || m == MATCH_YES)
4422 : : {
4423 : 20539 : ts->type = BT_DERIVED;
4424 : : /* We accept record/s/ or type(s) where s is a structure, but we
4425 : : * don't need all the extra derived-type stuff for structures. */
4426 : 20539 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4427 : : {
4428 : 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4429 : 1 : return MATCH_ERROR;
4430 : : }
4431 : :
4432 : 20538 : if (sym && sym->attr.flavor == FL_DERIVED
4433 : 20414 : && sym->attr.pdt_template
4434 : 380 : && gfc_current_state () != COMP_DERIVED)
4435 : : {
4436 : 341 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4437 : 341 : if (m != MATCH_YES)
4438 : : return m;
4439 : 328 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4440 : 328 : ts->u.derived = sym;
4441 : 328 : const char* lower = gfc_dt_lower_string (sym->name);
4442 : 328 : size_t len = strlen (lower);
4443 : : /* Reallocate with sufficient size. */
4444 : 328 : if (len > GFC_MAX_SYMBOL_LEN)
4445 : 2 : name = XALLOCAVEC (char, len + 1);
4446 : 328 : memcpy (name, lower, len);
4447 : 328 : name[len] = '\0';
4448 : : }
4449 : :
4450 : 20525 : if (sym && sym->attr.flavor == FL_STRUCT)
4451 : : {
4452 : 361 : ts->u.derived = sym;
4453 : 361 : return MATCH_YES;
4454 : : }
4455 : : /* Actually a derived type. */
4456 : : }
4457 : :
4458 : : else
4459 : : {
4460 : : /* Match nested STRUCTURE declarations; only valid within another
4461 : : structure declaration. */
4462 : 804892 : if (flag_dec_structure
4463 : 8032 : && (gfc_current_state () == COMP_STRUCTURE
4464 : 7570 : || gfc_current_state () == COMP_MAP))
4465 : : {
4466 : 732 : m = gfc_match (" structure");
4467 : 732 : if (m == MATCH_YES)
4468 : : {
4469 : 27 : m = gfc_match_structure_decl ();
4470 : 27 : if (m == MATCH_YES)
4471 : : {
4472 : : /* gfc_new_block is updated by match_structure_decl. */
4473 : 26 : ts->type = BT_DERIVED;
4474 : 26 : ts->u.derived = gfc_new_block;
4475 : 26 : return MATCH_YES;
4476 : : }
4477 : : }
4478 : 706 : if (m == MATCH_ERROR)
4479 : : return MATCH_ERROR;
4480 : : }
4481 : :
4482 : : /* Match CLASS declarations. */
4483 : 804865 : m = gfc_match (" class ( * )");
4484 : 804865 : if (m == MATCH_ERROR)
4485 : : return MATCH_ERROR;
4486 : 804865 : else if (m == MATCH_YES)
4487 : : {
4488 : 1442 : gfc_symbol *upe;
4489 : 1442 : gfc_symtree *st;
4490 : 1442 : ts->type = BT_CLASS;
4491 : 1442 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4492 : 1442 : if (upe == NULL)
4493 : : {
4494 : 855 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4495 : 855 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4496 : 855 : st->n.sym = upe;
4497 : 855 : gfc_set_sym_referenced (upe);
4498 : 855 : upe->refs++;
4499 : 855 : upe->ts.type = BT_VOID;
4500 : 855 : upe->attr.unlimited_polymorphic = 1;
4501 : : /* This is essential to force the construction of
4502 : : unlimited polymorphic component class containers. */
4503 : 855 : upe->attr.zero_comp = 1;
4504 : 855 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4505 : : &gfc_current_locus))
4506 : : return MATCH_ERROR;
4507 : : }
4508 : : else
4509 : : {
4510 : 587 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4511 : 587 : st->n.sym = upe;
4512 : 587 : upe->refs++;
4513 : : }
4514 : 1442 : ts->u.derived = upe;
4515 : 1442 : return m;
4516 : : }
4517 : :
4518 : 803423 : m = gfc_match (" class (");
4519 : :
4520 : 803423 : if (m == MATCH_YES)
4521 : 7654 : m = gfc_match ("%n", name);
4522 : : else
4523 : : return m;
4524 : :
4525 : 7654 : if (m != MATCH_YES)
4526 : : return m;
4527 : 7654 : ts->type = BT_CLASS;
4528 : :
4529 : 7654 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4530 : : return MATCH_ERROR;
4531 : :
4532 : 7653 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4533 : 7653 : if (m == MATCH_ERROR)
4534 : : return m;
4535 : :
4536 : 7653 : m = gfc_match_char (')');
4537 : 7653 : if (m != MATCH_YES)
4538 : : return m;
4539 : : }
4540 : :
4541 : : /* Defer association of the derived type until the end of the
4542 : : specification block. However, if the derived type can be
4543 : : found, add it to the typespec. */
4544 : 27817 : if (gfc_matching_function)
4545 : : {
4546 : 685 : ts->u.derived = NULL;
4547 : 685 : if (gfc_current_state () != COMP_INTERFACE
4548 : 685 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4549 : : {
4550 : 435 : sym = gfc_find_dt_in_generic (sym);
4551 : 435 : ts->u.derived = sym;
4552 : : }
4553 : 685 : return MATCH_YES;
4554 : : }
4555 : :
4556 : : /* Search for the name but allow the components to be defined later. If
4557 : : type = -1, this typespec has been seen in a function declaration but
4558 : : the type could not be accessed at that point. The actual derived type is
4559 : : stored in a symtree with the first letter of the name capitalized; the
4560 : : symtree with the all lower-case name contains the associated
4561 : : generic function. */
4562 : 27132 : dt_name = gfc_dt_upper_string (name);
4563 : 27132 : sym = NULL;
4564 : 27132 : dt_sym = NULL;
4565 : 27132 : if (ts->kind != -1)
4566 : : {
4567 : 26363 : gfc_get_ha_symbol (name, &sym);
4568 : 26363 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4569 : : {
4570 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4571 : 0 : return MATCH_ERROR;
4572 : : }
4573 : 26363 : if (sym->generic && !dt_sym)
4574 : 10918 : dt_sym = gfc_find_dt_in_generic (sym);
4575 : :
4576 : : /* Host associated PDTs can get confused with their constructors
4577 : : because they ar instantiated in the template's namespace. */
4578 : 26363 : if (!dt_sym)
4579 : : {
4580 : 433 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4581 : : {
4582 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4583 : 0 : return MATCH_ERROR;
4584 : : }
4585 : 433 : if (dt_sym && !dt_sym->attr.pdt_type)
4586 : 0 : dt_sym = NULL;
4587 : : }
4588 : : }
4589 : 769 : else if (ts->kind == -1)
4590 : : {
4591 : 1538 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4592 : 769 : || gfc_current_ns->has_import_set;
4593 : 769 : gfc_find_symbol (name, NULL, iface, &sym);
4594 : 769 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4595 : : {
4596 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4597 : 0 : return MATCH_ERROR;
4598 : : }
4599 : 769 : if (sym && sym->generic && !dt_sym)
4600 : 0 : dt_sym = gfc_find_dt_in_generic (sym);
4601 : :
4602 : 769 : ts->kind = 0;
4603 : 769 : if (sym == NULL)
4604 : : return MATCH_NO;
4605 : : }
4606 : :
4607 : 27123 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4608 : 26812 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4609 : 27121 : || sym->attr.subroutine)
4610 : : {
4611 : 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
4612 : : "entity at %L, which has the same name", name,
4613 : : &sym->declared_at);
4614 : 2 : return MATCH_ERROR;
4615 : : }
4616 : :
4617 : 27121 : if (sym && sym->attr.flavor == FL_DERIVED
4618 : 27121 : && sym->attr.pdt_template
4619 : 0 : && gfc_current_state () != COMP_DERIVED)
4620 : : {
4621 : 0 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4622 : 0 : if (m != MATCH_YES)
4623 : : return m;
4624 : 0 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4625 : 0 : ts->u.derived = sym;
4626 : 0 : strcpy (name, gfc_dt_lower_string (sym->name));
4627 : : }
4628 : :
4629 : 27121 : gfc_save_symbol_data (sym);
4630 : 27121 : gfc_set_sym_referenced (sym);
4631 : 27121 : if (!sym->attr.generic
4632 : 27121 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
4633 : : return MATCH_ERROR;
4634 : :
4635 : 27121 : if (!sym->attr.function
4636 : 27121 : && !gfc_add_function (&sym->attr, sym->name, NULL))
4637 : : return MATCH_ERROR;
4638 : :
4639 : 27121 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4640 : 27015 : && dt_sym->attr.pdt_template
4641 : 48 : && gfc_current_state () != COMP_DERIVED)
4642 : : {
4643 : 9 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
4644 : 9 : if (m != MATCH_YES)
4645 : : return m;
4646 : 9 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
4647 : : }
4648 : :
4649 : 27121 : if (!dt_sym)
4650 : : {
4651 : 106 : gfc_interface *intr, *head;
4652 : :
4653 : : /* Use upper case to save the actual derived-type symbol. */
4654 : 106 : gfc_get_symbol (dt_name, NULL, &dt_sym);
4655 : 106 : dt_sym->name = gfc_get_string ("%s", sym->name);
4656 : 106 : head = sym->generic;
4657 : 106 : intr = gfc_get_interface ();
4658 : 106 : intr->sym = dt_sym;
4659 : 106 : intr->where = gfc_current_locus;
4660 : 106 : intr->next = head;
4661 : 106 : sym->generic = intr;
4662 : 106 : sym->attr.if_source = IFSRC_DECL;
4663 : : }
4664 : : else
4665 : 27015 : gfc_save_symbol_data (dt_sym);
4666 : :
4667 : 27121 : gfc_set_sym_referenced (dt_sym);
4668 : :
4669 : 106 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4670 : 27227 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
4671 : : return MATCH_ERROR;
4672 : :
4673 : 27121 : ts->u.derived = dt_sym;
4674 : :
4675 : 27121 : return MATCH_YES;
4676 : :
4677 : 129390 : get_kind:
4678 : 129390 : if (matched_type
4679 : 129390 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4680 : : "intrinsic-type-spec at %C"))
4681 : : return MATCH_ERROR;
4682 : :
4683 : : /* For all types except double, derived and character, look for an
4684 : : optional kind specifier. MATCH_NO is actually OK at this point. */
4685 : 129387 : if (implicit_flag == 1)
4686 : : {
4687 : 240 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4688 : : return MATCH_ERROR;
4689 : :
4690 : 240 : return MATCH_YES;
4691 : : }
4692 : :
4693 : 129147 : if (gfc_current_form == FORM_FREE)
4694 : : {
4695 : 118990 : c = gfc_peek_ascii_char ();
4696 : 118990 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
4697 : 59280 : && c != ':' && c != ',')
4698 : : {
4699 : 163 : if (matched_type && c == ')')
4700 : : {
4701 : 2 : gfc_next_ascii_char ();
4702 : 2 : return MATCH_YES;
4703 : : }
4704 : 161 : gfc_error ("Malformed type-spec at %C");
4705 : 161 : return MATCH_NO;
4706 : : }
4707 : : }
4708 : :
4709 : 128984 : m = gfc_match_kind_spec (ts, false);
4710 : 128984 : if (m == MATCH_ERROR)
4711 : : return MATCH_ERROR;
4712 : :
4713 : 128953 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
4714 : : {
4715 : 89228 : m = gfc_match_old_kind_spec (ts);
4716 : 89228 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4717 : : return MATCH_ERROR;
4718 : : }
4719 : :
4720 : 128945 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4721 : : {
4722 : 0 : gfc_error ("Malformed type-spec at %C");
4723 : 0 : return MATCH_ERROR;
4724 : : }
4725 : :
4726 : : /* Defer association of the KIND expression of function results
4727 : : until after USE and IMPORT statements. */
4728 : 4442 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
4729 : 133352 : || gfc_matching_function)
4730 : 6505 : return MATCH_YES;
4731 : :
4732 : 122440 : if (m == MATCH_NO)
4733 : 124649 : m = MATCH_YES; /* No kind specifier found. */
4734 : :
4735 : : return m;
4736 : : }
4737 : :
4738 : :
4739 : : /* Match an IMPLICIT NONE statement. Actually, this statement is
4740 : : already matched in parse.cc, or we would not end up here in the
4741 : : first place. So the only thing we need to check, is if there is
4742 : : trailing garbage. If not, the match is successful. */
4743 : :
4744 : : match
4745 : 20300 : gfc_match_implicit_none (void)
4746 : : {
4747 : 20300 : char c;
4748 : 20300 : match m;
4749 : 20300 : char name[GFC_MAX_SYMBOL_LEN + 1];
4750 : 20300 : bool type = false;
4751 : 20300 : bool external = false;
4752 : 20300 : locus cur_loc = gfc_current_locus;
4753 : :
4754 : 20300 : if (gfc_current_ns->seen_implicit_none
4755 : 20298 : || gfc_current_ns->has_implicit_none_export)
4756 : : {
4757 : 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4758 : 4 : return MATCH_ERROR;
4759 : : }
4760 : :
4761 : 20296 : gfc_gobble_whitespace ();
4762 : 20296 : c = gfc_peek_ascii_char ();
4763 : 20296 : if (c == '(')
4764 : : {
4765 : 930 : (void) gfc_next_ascii_char ();
4766 : 930 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
4767 : : return MATCH_ERROR;
4768 : :
4769 : 929 : gfc_gobble_whitespace ();
4770 : 929 : if (gfc_peek_ascii_char () == ')')
4771 : : {
4772 : 1 : (void) gfc_next_ascii_char ();
4773 : 1 : type = true;
4774 : : }
4775 : : else
4776 : 2764 : for(;;)
4777 : : {
4778 : 1846 : m = gfc_match (" %n", name);
4779 : 1846 : if (m != MATCH_YES)
4780 : : return MATCH_ERROR;
4781 : :
4782 : 1846 : if (strcmp (name, "type") == 0)
4783 : : type = true;
4784 : 928 : else if (strcmp (name, "external") == 0)
4785 : : external = true;
4786 : : else
4787 : : return MATCH_ERROR;
4788 : :
4789 : 1846 : gfc_gobble_whitespace ();
4790 : 1846 : c = gfc_next_ascii_char ();
4791 : 1846 : if (c == ',')
4792 : 918 : continue;
4793 : 928 : if (c == ')')
4794 : : break;
4795 : : return MATCH_ERROR;
4796 : : }
4797 : : }
4798 : : else
4799 : : type = true;
4800 : :
4801 : 20295 : if (gfc_match_eos () != MATCH_YES)
4802 : : return MATCH_ERROR;
4803 : :
4804 : 20295 : gfc_set_implicit_none (type, external, &cur_loc);
4805 : :
4806 : 20295 : return MATCH_YES;
4807 : : }
4808 : :
4809 : :
4810 : : /* Match the letter range(s) of an IMPLICIT statement. */
4811 : :
4812 : : static match
4813 : 629 : match_implicit_range (void)
4814 : : {
4815 : 629 : char c, c1, c2;
4816 : 629 : int inner;
4817 : 629 : locus cur_loc;
4818 : :
4819 : 629 : cur_loc = gfc_current_locus;
4820 : :
4821 : 629 : gfc_gobble_whitespace ();
4822 : 629 : c = gfc_next_ascii_char ();
4823 : 629 : if (c != '(')
4824 : : {
4825 : 58 : gfc_error ("Missing character range in IMPLICIT at %C");
4826 : 58 : goto bad;
4827 : : }
4828 : :
4829 : : inner = 1;
4830 : 1235 : while (inner)
4831 : : {
4832 : 747 : gfc_gobble_whitespace ();
4833 : 747 : c1 = gfc_next_ascii_char ();
4834 : 747 : if (!ISALPHA (c1))
4835 : 48 : goto bad;
4836 : :
4837 : 699 : gfc_gobble_whitespace ();
4838 : 699 : c = gfc_next_ascii_char ();
4839 : :
4840 : 699 : switch (c)
4841 : : {
4842 : 198 : case ')':
4843 : 198 : inner = 0; /* Fall through. */
4844 : :
4845 : : case ',':
4846 : : c2 = c1;
4847 : : break;
4848 : :
4849 : 456 : case '-':
4850 : 456 : gfc_gobble_whitespace ();
4851 : 456 : c2 = gfc_next_ascii_char ();
4852 : 456 : if (!ISALPHA (c2))
4853 : 0 : goto bad;
4854 : :
4855 : 456 : gfc_gobble_whitespace ();
4856 : 456 : c = gfc_next_ascii_char ();
4857 : :
4858 : 456 : if ((c != ',') && (c != ')'))
4859 : 0 : goto bad;
4860 : 456 : if (c == ')')
4861 : 290 : inner = 0;
4862 : :
4863 : : break;
4864 : :
4865 : 35 : default:
4866 : 35 : goto bad;
4867 : : }
4868 : :
4869 : 664 : if (c1 > c2)
4870 : : {
4871 : 0 : gfc_error ("Letters must be in alphabetic order in "
4872 : : "IMPLICIT statement at %C");
4873 : 0 : goto bad;
4874 : : }
4875 : :
4876 : : /* See if we can add the newly matched range to the pending
4877 : : implicits from this IMPLICIT statement. We do not check for
4878 : : conflicts with whatever earlier IMPLICIT statements may have
4879 : : set. This is done when we've successfully finished matching
4880 : : the current one. */
4881 : 664 : if (!gfc_add_new_implicit_range (c1, c2))
4882 : 0 : goto bad;
4883 : : }
4884 : :
4885 : : return MATCH_YES;
4886 : :
4887 : 141 : bad:
4888 : 141 : gfc_syntax_error (ST_IMPLICIT);
4889 : :
4890 : 141 : gfc_current_locus = cur_loc;
4891 : 141 : return MATCH_ERROR;
4892 : : }
4893 : :
4894 : :
4895 : : /* Match an IMPLICIT statement, storing the types for
4896 : : gfc_set_implicit() if the statement is accepted by the parser.
4897 : : There is a strange looking, but legal syntactic construction
4898 : : possible. It looks like:
4899 : :
4900 : : IMPLICIT INTEGER (a-b) (c-d)
4901 : :
4902 : : This is legal if "a-b" is a constant expression that happens to
4903 : : equal one of the legal kinds for integers. The real problem
4904 : : happens with an implicit specification that looks like:
4905 : :
4906 : : IMPLICIT INTEGER (a-b)
4907 : :
4908 : : In this case, a typespec matcher that is "greedy" (as most of the
4909 : : matchers are) gobbles the character range as a kindspec, leaving
4910 : : nothing left. We therefore have to go a bit more slowly in the
4911 : : matching process by inhibiting the kindspec checking during
4912 : : typespec matching and checking for a kind later. */
4913 : :
4914 : : match
4915 : 20741 : gfc_match_implicit (void)
4916 : : {
4917 : 20741 : gfc_typespec ts;
4918 : 20741 : locus cur_loc;
4919 : 20741 : char c;
4920 : 20741 : match m;
4921 : :
4922 : 20741 : if (gfc_current_ns->seen_implicit_none)
4923 : : {
4924 : 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4925 : : "statement");
4926 : 4 : return MATCH_ERROR;
4927 : : }
4928 : :
4929 : 20737 : gfc_clear_ts (&ts);
4930 : :
4931 : : /* We don't allow empty implicit statements. */
4932 : 20737 : if (gfc_match_eos () == MATCH_YES)
4933 : : {
4934 : 0 : gfc_error ("Empty IMPLICIT statement at %C");
4935 : 0 : return MATCH_ERROR;
4936 : : }
4937 : :
4938 : 20766 : do
4939 : : {
4940 : : /* First cleanup. */
4941 : 20766 : gfc_clear_new_implicit ();
4942 : :
4943 : : /* A basic type is mandatory here. */
4944 : 20766 : m = gfc_match_decl_type_spec (&ts, 1);
4945 : 20766 : if (m == MATCH_ERROR)
4946 : 0 : goto error;
4947 : 20766 : if (m == MATCH_NO)
4948 : 20298 : goto syntax;
4949 : :
4950 : 468 : cur_loc = gfc_current_locus;
4951 : 468 : m = match_implicit_range ();
4952 : :
4953 : 468 : if (m == MATCH_YES)
4954 : : {
4955 : : /* We may have <TYPE> (<RANGE>). */
4956 : 327 : gfc_gobble_whitespace ();
4957 : 327 : c = gfc_peek_ascii_char ();
4958 : 327 : if (c == ',' || c == '\n' || c == ';' || c == '!')
4959 : : {
4960 : : /* Check for CHARACTER with no length parameter. */
4961 : 300 : if (ts.type == BT_CHARACTER && !ts.u.cl)
4962 : : {
4963 : 31 : ts.kind = gfc_default_character_kind;
4964 : 31 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4965 : 31 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4966 : : NULL, 1);
4967 : : }
4968 : :
4969 : : /* Record the Successful match. */
4970 : 300 : if (!gfc_merge_new_implicit (&ts))
4971 : : return MATCH_ERROR;
4972 : 298 : if (c == ',')
4973 : 28 : c = gfc_next_ascii_char ();
4974 : 270 : else if (gfc_match_eos () == MATCH_ERROR)
4975 : 0 : goto error;
4976 : 298 : continue;
4977 : : }
4978 : :
4979 : 27 : gfc_current_locus = cur_loc;
4980 : : }
4981 : :
4982 : : /* Discard the (incorrectly) matched range. */
4983 : 168 : gfc_clear_new_implicit ();
4984 : :
4985 : : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
4986 : 168 : if (ts.type == BT_CHARACTER)
4987 : 74 : m = gfc_match_char_spec (&ts);
4988 : 94 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
4989 : : {
4990 : 90 : m = gfc_match_kind_spec (&ts, false);
4991 : 90 : if (m == MATCH_NO)
4992 : : {
4993 : 39 : m = gfc_match_old_kind_spec (&ts);
4994 : 39 : if (m == MATCH_ERROR)
4995 : 0 : goto error;
4996 : 39 : if (m == MATCH_NO)
4997 : 0 : goto syntax;
4998 : : }
4999 : : }
5000 : 168 : if (m == MATCH_ERROR)
5001 : 7 : goto error;
5002 : :
5003 : 161 : m = match_implicit_range ();
5004 : 161 : if (m == MATCH_ERROR)
5005 : 0 : goto error;
5006 : 161 : if (m == MATCH_NO)
5007 : 0 : goto syntax;
5008 : :
5009 : 161 : gfc_gobble_whitespace ();
5010 : 161 : c = gfc_next_ascii_char ();
5011 : 161 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5012 : 0 : goto syntax;
5013 : :
5014 : 161 : if (!gfc_merge_new_implicit (&ts))
5015 : : return MATCH_ERROR;
5016 : : }
5017 : 459 : while (c == ',');
5018 : :
5019 : : return MATCH_YES;
5020 : :
5021 : 20298 : syntax:
5022 : 20298 : gfc_syntax_error (ST_IMPLICIT);
5023 : :
5024 : : error:
5025 : : return MATCH_ERROR;
5026 : : }
5027 : :
5028 : :
5029 : : match
5030 : 2738 : gfc_match_import (void)
5031 : : {
5032 : 2738 : char name[GFC_MAX_SYMBOL_LEN + 1];
5033 : 2738 : match m;
5034 : 2738 : gfc_symbol *sym;
5035 : 2738 : gfc_symtree *st;
5036 : :
5037 : 2738 : if (gfc_current_ns->proc_name == NULL
5038 : 2737 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
5039 : : {
5040 : 3 : gfc_error ("IMPORT statement at %C only permitted in "
5041 : : "an INTERFACE body");
5042 : 3 : return MATCH_ERROR;
5043 : : }
5044 : :
5045 : 2735 : if (gfc_current_ns->proc_name->attr.module_procedure)
5046 : : {
5047 : 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5048 : : "in a module procedure interface body");
5049 : 1 : return MATCH_ERROR;
5050 : : }
5051 : :
5052 : 2734 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5053 : : return MATCH_ERROR;
5054 : :
5055 : 2730 : if (gfc_match_eos () == MATCH_YES)
5056 : : {
5057 : : /* All host variables should be imported. */
5058 : 199 : gfc_current_ns->has_import_set = 1;
5059 : 199 : return MATCH_YES;
5060 : : }
5061 : :
5062 : 2531 : if (gfc_match (" ::") == MATCH_YES)
5063 : : {
5064 : 648 : if (gfc_match_eos () == MATCH_YES)
5065 : : {
5066 : 1 : gfc_error ("Expecting list of named entities at %C");
5067 : 1 : return MATCH_ERROR;
5068 : : }
5069 : : }
5070 : :
5071 : 3181 : for(;;)
5072 : : {
5073 : 3181 : sym = NULL;
5074 : 3181 : m = gfc_match (" %n", name);
5075 : 3181 : switch (m)
5076 : : {
5077 : 3181 : case MATCH_YES:
5078 : 3181 : if (gfc_current_ns->parent != NULL
5079 : 3181 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5080 : : {
5081 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5082 : 0 : return MATCH_ERROR;
5083 : : }
5084 : 1 : else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
5085 : 3181 : && gfc_find_symbol (name,
5086 : : gfc_current_ns->proc_name->ns->parent,
5087 : : 1, &sym))
5088 : : {
5089 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5090 : 0 : return MATCH_ERROR;
5091 : : }
5092 : :
5093 : 3181 : if (sym == NULL)
5094 : : {
5095 : 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5096 : : "at %C - does not exist.", name);
5097 : 1 : return MATCH_ERROR;
5098 : : }
5099 : :
5100 : 3180 : if (gfc_find_symtree (gfc_current_ns->sym_root, name))
5101 : : {
5102 : 6 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5103 : : "at %C", name);
5104 : 6 : goto next_item;
5105 : : }
5106 : :
5107 : 3174 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5108 : 3174 : st->n.sym = sym;
5109 : 3174 : sym->refs++;
5110 : 3174 : sym->attr.imported = 1;
5111 : :
5112 : 3174 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5113 : : {
5114 : : /* The actual derived type is stored in a symtree with the first
5115 : : letter of the name capitalized; the symtree with the all
5116 : : lower-case name contains the associated generic function. */
5117 : 535 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5118 : : gfc_dt_upper_string (name));
5119 : 535 : st->n.sym = sym;
5120 : 535 : sym->refs++;
5121 : 535 : sym->attr.imported = 1;
5122 : : }
5123 : :
5124 : 3174 : goto next_item;
5125 : :
5126 : : case MATCH_NO:
5127 : : break;
5128 : :
5129 : : case MATCH_ERROR:
5130 : : return MATCH_ERROR;
5131 : : }
5132 : :
5133 : 3180 : next_item:
5134 : 3180 : if (gfc_match_eos () == MATCH_YES)
5135 : : break;
5136 : 651 : if (gfc_match_char (',') != MATCH_YES)
5137 : 0 : goto syntax;
5138 : : }
5139 : :
5140 : : return MATCH_YES;
5141 : :
5142 : 0 : syntax:
5143 : 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5144 : 0 : return MATCH_ERROR;
5145 : : }
5146 : :
5147 : :
5148 : : /* A minimal implementation of gfc_match without whitespace, escape
5149 : : characters or variable arguments. Returns true if the next
5150 : : characters match the TARGET template exactly. */
5151 : :
5152 : : static bool
5153 : 116777 : match_string_p (const char *target)
5154 : : {
5155 : 116777 : const char *p;
5156 : :
5157 : 736109 : for (p = target; *p; p++)
5158 : 619333 : if ((char) gfc_next_ascii_char () != *p)
5159 : : return false;
5160 : : return true;
5161 : : }
5162 : :
5163 : : /* Matches an attribute specification including array specs. If
5164 : : successful, leaves the variables current_attr and current_as
5165 : : holding the specification. Also sets the colon_seen variable for
5166 : : later use by matchers associated with initializations.
5167 : :
5168 : : This subroutine is a little tricky in the sense that we don't know
5169 : : if we really have an attr-spec until we hit the double colon.
5170 : : Until that time, we can only return MATCH_NO. This forces us to
5171 : : check for duplicate specification at this level. */
5172 : :
5173 : : static match
5174 : 177415 : match_attr_spec (void)
5175 : : {
5176 : : /* Modifiers that can exist in a type statement. */
5177 : 177415 : enum
5178 : : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5179 : : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5180 : : DECL_DIMENSION, DECL_EXTERNAL,
5181 : : DECL_INTRINSIC, DECL_OPTIONAL,
5182 : : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5183 : : DECL_STATIC, DECL_AUTOMATIC,
5184 : : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5185 : : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5186 : : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5187 : : };
5188 : :
5189 : : /* GFC_DECL_END is the sentinel, index starts at 0. */
5190 : : #define NUM_DECL GFC_DECL_END
5191 : :
5192 : : /* Make sure that values from sym_intent are safe to be used here. */
5193 : 177415 : gcc_assert (INTENT_IN > 0);
5194 : :
5195 : 177415 : locus start, seen_at[NUM_DECL];
5196 : 177415 : int seen[NUM_DECL];
5197 : 177415 : unsigned int d;
5198 : 177415 : const char *attr;
5199 : 177415 : match m;
5200 : 177415 : bool t;
5201 : :
5202 : 177415 : gfc_clear_attr (¤t_attr);
5203 : 177415 : start = gfc_current_locus;
5204 : :
5205 : 177415 : current_as = NULL;
5206 : 177415 : colon_seen = 0;
5207 : 177415 : attr_seen = 0;
5208 : :
5209 : : /* See if we get all of the keywords up to the final double colon. */
5210 : 4790205 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5211 : 4612790 : seen[d] = 0;
5212 : :
5213 : 271969 : for (;;)
5214 : : {
5215 : 271969 : char ch;
5216 : :
5217 : 271969 : d = DECL_NONE;
5218 : 271969 : gfc_gobble_whitespace ();
5219 : :
5220 : 271969 : ch = gfc_next_ascii_char ();
5221 : 271969 : if (ch == ':')
5222 : : {
5223 : : /* This is the successful exit condition for the loop. */
5224 : 148589 : if (gfc_next_ascii_char () == ':')
5225 : : break;
5226 : : }
5227 : 123380 : else if (ch == ',')
5228 : : {
5229 : 94566 : gfc_gobble_whitespace ();
5230 : 94566 : switch (gfc_peek_ascii_char ())
5231 : : {
5232 : 12887 : case 'a':
5233 : 12887 : gfc_next_ascii_char ();
5234 : 12887 : switch (gfc_next_ascii_char ())
5235 : : {
5236 : 12823 : case 'l':
5237 : 12823 : if (match_string_p ("locatable"))
5238 : : {
5239 : : /* Matched "allocatable". */
5240 : : d = DECL_ALLOCATABLE;
5241 : : }
5242 : : break;
5243 : :
5244 : 23 : case 's':
5245 : 23 : if (match_string_p ("ynchronous"))
5246 : : {
5247 : : /* Matched "asynchronous". */
5248 : : d = DECL_ASYNCHRONOUS;
5249 : : }
5250 : : break;
5251 : :
5252 : 41 : case 'u':
5253 : 41 : if (match_string_p ("tomatic"))
5254 : : {
5255 : : /* Matched "automatic". */
5256 : : d = DECL_AUTOMATIC;
5257 : : }
5258 : : break;
5259 : : }
5260 : : break;
5261 : :
5262 : 144 : case 'b':
5263 : : /* Try and match the bind(c). */
5264 : 144 : m = gfc_match_bind_c (NULL, true);
5265 : 144 : if (m == MATCH_YES)
5266 : : d = DECL_IS_BIND_C;
5267 : 0 : else if (m == MATCH_ERROR)
5268 : 0 : goto cleanup;
5269 : : break;
5270 : :
5271 : 1772 : case 'c':
5272 : 1772 : gfc_next_ascii_char ();
5273 : 1772 : if ('o' != gfc_next_ascii_char ())
5274 : : break;
5275 : 1771 : switch (gfc_next_ascii_char ())
5276 : : {
5277 : 46 : case 'd':
5278 : 46 : if (match_string_p ("imension"))
5279 : : {
5280 : : d = DECL_CODIMENSION;
5281 : : break;
5282 : : }
5283 : : /* FALLTHRU */
5284 : 1725 : case 'n':
5285 : 1725 : if (match_string_p ("tiguous"))
5286 : : {
5287 : : d = DECL_CONTIGUOUS;
5288 : : break;
5289 : : }
5290 : : }
5291 : : break;
5292 : :
5293 : 17172 : case 'd':
5294 : 17172 : if (match_string_p ("dimension"))
5295 : : d = DECL_DIMENSION;
5296 : : break;
5297 : :
5298 : 167 : case 'e':
5299 : 167 : if (match_string_p ("external"))
5300 : : d = DECL_EXTERNAL;
5301 : : break;
5302 : :
5303 : 22356 : case 'i':
5304 : 22356 : if (match_string_p ("int"))
5305 : : {
5306 : 22356 : ch = gfc_next_ascii_char ();
5307 : 22356 : if (ch == 'e')
5308 : : {
5309 : 22350 : if (match_string_p ("nt"))
5310 : : {
5311 : : /* Matched "intent". */
5312 : 22349 : d = match_intent_spec ();
5313 : 22349 : if (d == INTENT_UNKNOWN)
5314 : : {
5315 : 2 : m = MATCH_ERROR;
5316 : 2 : goto cleanup;
5317 : : }
5318 : : }
5319 : : }
5320 : 6 : else if (ch == 'r')
5321 : : {
5322 : 6 : if (match_string_p ("insic"))
5323 : : {
5324 : : /* Matched "intrinsic". */
5325 : : d = DECL_INTRINSIC;
5326 : : }
5327 : : }
5328 : : }
5329 : : break;
5330 : :
5331 : 127 : case 'k':
5332 : 127 : if (match_string_p ("kind"))
5333 : : d = DECL_KIND;
5334 : : break;
5335 : :
5336 : 155 : case 'l':
5337 : 155 : if (match_string_p ("len"))
5338 : : d = DECL_LEN;
5339 : : break;
5340 : :
5341 : 3466 : case 'o':
5342 : 3466 : if (match_string_p ("optional"))
5343 : : d = DECL_OPTIONAL;
5344 : : break;
5345 : :
5346 : 23479 : case 'p':
5347 : 23479 : gfc_next_ascii_char ();
5348 : 23479 : switch (gfc_next_ascii_char ())
5349 : : {
5350 : 12138 : case 'a':
5351 : 12138 : if (match_string_p ("rameter"))
5352 : : {
5353 : : /* Matched "parameter". */
5354 : : d = DECL_PARAMETER;
5355 : : }
5356 : : break;
5357 : :
5358 : 10873 : case 'o':
5359 : 10873 : if (match_string_p ("inter"))
5360 : : {
5361 : : /* Matched "pointer". */
5362 : : d = DECL_POINTER;
5363 : : }
5364 : : break;
5365 : :
5366 : 231 : case 'r':
5367 : 231 : ch = gfc_next_ascii_char ();
5368 : 231 : if (ch == 'i')
5369 : : {
5370 : 183 : if (match_string_p ("vate"))
5371 : : {
5372 : : /* Matched "private". */
5373 : : d = DECL_PRIVATE;
5374 : : }
5375 : : }
5376 : 48 : else if (ch == 'o')
5377 : : {
5378 : 48 : if (match_string_p ("tected"))
5379 : : {
5380 : : /* Matched "protected". */
5381 : : d = DECL_PROTECTED;
5382 : : }
5383 : : }
5384 : : break;
5385 : :
5386 : 237 : case 'u':
5387 : 237 : if (match_string_p ("blic"))
5388 : : {
5389 : : /* Matched "public". */
5390 : : d = DECL_PUBLIC;
5391 : : }
5392 : : break;
5393 : : }
5394 : : break;
5395 : :
5396 : 1114 : case 's':
5397 : 1114 : gfc_next_ascii_char ();
5398 : 1114 : switch (gfc_next_ascii_char ())
5399 : : {
5400 : 1101 : case 'a':
5401 : 1101 : if (match_string_p ("ve"))
5402 : : {
5403 : : /* Matched "save". */
5404 : : d = DECL_SAVE;
5405 : : }
5406 : : break;
5407 : :
5408 : 13 : case 't':
5409 : 13 : if (match_string_p ("atic"))
5410 : : {
5411 : : /* Matched "static". */
5412 : : d = DECL_STATIC;
5413 : : }
5414 : : break;
5415 : : }
5416 : : break;
5417 : :
5418 : 4785 : case 't':
5419 : 4785 : if (match_string_p ("target"))
5420 : : d = DECL_TARGET;
5421 : : break;
5422 : :
5423 : 6942 : case 'v':
5424 : 6942 : gfc_next_ascii_char ();
5425 : 6942 : ch = gfc_next_ascii_char ();
5426 : 6942 : if (ch == 'a')
5427 : : {
5428 : 6444 : if (match_string_p ("lue"))
5429 : : {
5430 : : /* Matched "value". */
5431 : : d = DECL_VALUE;
5432 : : }
5433 : : }
5434 : 498 : else if (ch == 'o')
5435 : : {
5436 : 498 : if (match_string_p ("latile"))
5437 : : {
5438 : : /* Matched "volatile". */
5439 : : d = DECL_VOLATILE;
5440 : : }
5441 : : }
5442 : : break;
5443 : : }
5444 : : }
5445 : :
5446 : : /* No double colon and no recognizable decl_type, so assume that
5447 : : we've been looking at something else the whole time. */
5448 : 22347 : if (d == DECL_NONE)
5449 : : {
5450 : 28817 : m = MATCH_NO;
5451 : 28817 : goto cleanup;
5452 : : }
5453 : :
5454 : : /* Check to make sure any parens are paired up correctly. */
5455 : 94562 : if (gfc_match_parens () == MATCH_ERROR)
5456 : : {
5457 : 1 : m = MATCH_ERROR;
5458 : 1 : goto cleanup;
5459 : : }
5460 : :
5461 : 94561 : seen[d]++;
5462 : 94561 : seen_at[d] = gfc_current_locus;
5463 : :
5464 : 94561 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5465 : : {
5466 : 17217 : gfc_array_spec *as = NULL;
5467 : :
5468 : 17217 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5469 : : d == DECL_CODIMENSION);
5470 : :
5471 : 17217 : if (current_as == NULL)
5472 : 17199 : current_as = as;
5473 : 18 : else if (m == MATCH_YES)
5474 : : {
5475 : 18 : if (!merge_array_spec (as, current_as, false))
5476 : 2 : m = MATCH_ERROR;
5477 : 18 : free (as);
5478 : : }
5479 : :
5480 : 17217 : if (m == MATCH_NO)
5481 : : {
5482 : 0 : if (d == DECL_CODIMENSION)
5483 : 0 : gfc_error ("Missing codimension specification at %C");
5484 : : else
5485 : 0 : gfc_error ("Missing dimension specification at %C");
5486 : : m = MATCH_ERROR;
5487 : : }
5488 : :
5489 : 17217 : if (m == MATCH_ERROR)
5490 : 7 : goto cleanup;
5491 : : }
5492 : : }
5493 : :
5494 : : /* Since we've seen a double colon, we have to be looking at an
5495 : : attr-spec. This means that we can now issue errors. */
5496 : 4011855 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5497 : 3863269 : if (seen[d] > 1)
5498 : : {
5499 : 2 : switch (d)
5500 : : {
5501 : : case DECL_ALLOCATABLE:
5502 : : attr = "ALLOCATABLE";
5503 : : break;
5504 : 0 : case DECL_ASYNCHRONOUS:
5505 : 0 : attr = "ASYNCHRONOUS";
5506 : 0 : break;
5507 : 0 : case DECL_CODIMENSION:
5508 : 0 : attr = "CODIMENSION";
5509 : 0 : break;
5510 : 0 : case DECL_CONTIGUOUS:
5511 : 0 : attr = "CONTIGUOUS";
5512 : 0 : break;
5513 : 0 : case DECL_DIMENSION:
5514 : 0 : attr = "DIMENSION";
5515 : 0 : break;
5516 : 0 : case DECL_EXTERNAL:
5517 : 0 : attr = "EXTERNAL";
5518 : 0 : break;
5519 : 0 : case DECL_IN:
5520 : 0 : attr = "INTENT (IN)";
5521 : 0 : break;
5522 : 0 : case DECL_OUT:
5523 : 0 : attr = "INTENT (OUT)";
5524 : 0 : break;
5525 : 0 : case DECL_INOUT:
5526 : 0 : attr = "INTENT (IN OUT)";
5527 : 0 : break;
5528 : 0 : case DECL_INTRINSIC:
5529 : 0 : attr = "INTRINSIC";
5530 : 0 : break;
5531 : 0 : case DECL_OPTIONAL:
5532 : 0 : attr = "OPTIONAL";
5533 : 0 : break;
5534 : 0 : case DECL_KIND:
5535 : 0 : attr = "KIND";
5536 : 0 : break;
5537 : 0 : case DECL_LEN:
5538 : 0 : attr = "LEN";
5539 : 0 : break;
5540 : 0 : case DECL_PARAMETER:
5541 : 0 : attr = "PARAMETER";
5542 : 0 : break;
5543 : 0 : case DECL_POINTER:
5544 : 0 : attr = "POINTER";
5545 : 0 : break;
5546 : 0 : case DECL_PROTECTED:
5547 : 0 : attr = "PROTECTED";
5548 : 0 : break;
5549 : 0 : case DECL_PRIVATE:
5550 : 0 : attr = "PRIVATE";
5551 : 0 : break;
5552 : 0 : case DECL_PUBLIC:
5553 : 0 : attr = "PUBLIC";
5554 : 0 : break;
5555 : 0 : case DECL_SAVE:
5556 : 0 : attr = "SAVE";
5557 : 0 : break;
5558 : 0 : case DECL_STATIC:
5559 : 0 : attr = "STATIC";
5560 : 0 : break;
5561 : 1 : case DECL_AUTOMATIC:
5562 : 1 : attr = "AUTOMATIC";
5563 : 1 : break;
5564 : 0 : case DECL_TARGET:
5565 : 0 : attr = "TARGET";
5566 : 0 : break;
5567 : 0 : case DECL_IS_BIND_C:
5568 : 0 : attr = "IS_BIND_C";
5569 : 0 : break;
5570 : 0 : case DECL_VALUE:
5571 : 0 : attr = "VALUE";
5572 : 0 : break;
5573 : 1 : case DECL_VOLATILE:
5574 : 1 : attr = "VOLATILE";
5575 : 1 : break;
5576 : 0 : default:
5577 : 0 : attr = NULL; /* This shouldn't happen. */
5578 : : }
5579 : :
5580 : 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5581 : 2 : m = MATCH_ERROR;
5582 : 2 : goto cleanup;
5583 : : }
5584 : :
5585 : : /* Now that we've dealt with duplicate attributes, add the attributes
5586 : : to the current attribute. */
5587 : 4011035 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5588 : : {
5589 : 3862522 : if (seen[d] == 0)
5590 : 3767977 : continue;
5591 : : else
5592 : 94545 : attr_seen = 1;
5593 : :
5594 : 94545 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
5595 : 52 : && !flag_dec_static)
5596 : : {
5597 : 3 : gfc_error ("%s at %L is a DEC extension, enable with "
5598 : : "%<-fdec-static%>",
5599 : : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5600 : 2 : m = MATCH_ERROR;
5601 : 2 : goto cleanup;
5602 : : }
5603 : : /* Allow SAVE with STATIC, but don't complain. */
5604 : 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
5605 : 0 : continue;
5606 : :
5607 : 94543 : if (gfc_comp_struct (gfc_current_state ())
5608 : 5430 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
5609 : 4539 : && d != DECL_POINTER && d != DECL_PRIVATE
5610 : 3127 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5611 : : {
5612 : 3085 : bool is_derived = gfc_current_state () == COMP_DERIVED;
5613 : 3085 : if (d == DECL_ALLOCATABLE)
5614 : : {
5615 : 2790 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5616 : : ? G_("ALLOCATABLE attribute at %C in a "
5617 : : "TYPE definition")
5618 : : : G_("ALLOCATABLE attribute at %C in a "
5619 : : "STRUCTURE definition")))
5620 : : {
5621 : 2 : m = MATCH_ERROR;
5622 : 2 : goto cleanup;
5623 : : }
5624 : : }
5625 : 295 : else if (d == DECL_KIND)
5626 : : {
5627 : 125 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5628 : : ? G_("KIND attribute at %C in a "
5629 : : "TYPE definition")
5630 : : : G_("KIND attribute at %C in a "
5631 : : "STRUCTURE definition")))
5632 : : {
5633 : 1 : m = MATCH_ERROR;
5634 : 1 : goto cleanup;
5635 : : }
5636 : 124 : if (current_ts.type != BT_INTEGER)
5637 : : {
5638 : 2 : gfc_error ("Component with KIND attribute at %C must be "
5639 : : "INTEGER");
5640 : 2 : m = MATCH_ERROR;
5641 : 2 : goto cleanup;
5642 : : }
5643 : : }
5644 : 170 : else if (d == DECL_LEN)
5645 : : {
5646 : 154 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5647 : : ? G_("LEN attribute at %C in a "
5648 : : "TYPE definition")
5649 : : : G_("LEN attribute at %C in a "
5650 : : "STRUCTURE definition")))
5651 : : {
5652 : 0 : m = MATCH_ERROR;
5653 : 0 : goto cleanup;
5654 : : }
5655 : 154 : if (current_ts.type != BT_INTEGER)
5656 : : {
5657 : 1 : gfc_error ("Component with LEN attribute at %C must be "
5658 : : "INTEGER");
5659 : 1 : m = MATCH_ERROR;
5660 : 1 : goto cleanup;
5661 : : }
5662 : : }
5663 : : else
5664 : : {
5665 : 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
5666 : : "TYPE definition")
5667 : : : G_("Attribute at %L is not allowed in a "
5668 : : "STRUCTURE definition"), &seen_at[d]);
5669 : 16 : m = MATCH_ERROR;
5670 : 16 : goto cleanup;
5671 : : }
5672 : : }
5673 : :
5674 : 94521 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5675 : 420 : && gfc_current_state () != COMP_MODULE)
5676 : : {
5677 : 102 : if (d == DECL_PRIVATE)
5678 : : attr = "PRIVATE";
5679 : : else
5680 : 30 : attr = "PUBLIC";
5681 : 102 : if (gfc_current_state () == COMP_DERIVED
5682 : 96 : && gfc_state_stack->previous
5683 : 96 : && gfc_state_stack->previous->state == COMP_MODULE)
5684 : : {
5685 : 93 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5686 : : "at %L in a TYPE definition", attr,
5687 : : &seen_at[d]))
5688 : : {
5689 : 2 : m = MATCH_ERROR;
5690 : 2 : goto cleanup;
5691 : : }
5692 : : }
5693 : : else
5694 : : {
5695 : 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
5696 : : "specification part of a module", attr, &seen_at[d]);
5697 : 9 : m = MATCH_ERROR;
5698 : 9 : goto cleanup;
5699 : : }
5700 : : }
5701 : :
5702 : 94510 : if (gfc_current_state () != COMP_DERIVED
5703 : 89111 : && (d == DECL_KIND || d == DECL_LEN))
5704 : : {
5705 : 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
5706 : : "definition", &seen_at[d]);
5707 : 3 : m = MATCH_ERROR;
5708 : 3 : goto cleanup;
5709 : : }
5710 : :
5711 : 94507 : switch (d)
5712 : : {
5713 : 12821 : case DECL_ALLOCATABLE:
5714 : 12821 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
5715 : 12821 : break;
5716 : :
5717 : 22 : case DECL_ASYNCHRONOUS:
5718 : 22 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5719 : : t = false;
5720 : : else
5721 : 22 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
5722 : : break;
5723 : :
5724 : 44 : case DECL_CODIMENSION:
5725 : 44 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
5726 : 44 : break;
5727 : :
5728 : 1725 : case DECL_CONTIGUOUS:
5729 : 1725 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5730 : : t = false;
5731 : : else
5732 : 1724 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
5733 : : break;
5734 : :
5735 : 17164 : case DECL_DIMENSION:
5736 : 17164 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
5737 : 17164 : break;
5738 : :
5739 : 166 : case DECL_EXTERNAL:
5740 : 166 : t = gfc_add_external (¤t_attr, &seen_at[d]);
5741 : 166 : break;
5742 : :
5743 : 16812 : case DECL_IN:
5744 : 16812 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
5745 : 16812 : break;
5746 : :
5747 : 3046 : case DECL_OUT:
5748 : 3046 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
5749 : 3046 : break;
5750 : :
5751 : 2485 : case DECL_INOUT:
5752 : 2485 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
5753 : 2485 : break;
5754 : :
5755 : 5 : case DECL_INTRINSIC:
5756 : 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
5757 : 5 : break;
5758 : :
5759 : 3465 : case DECL_OPTIONAL:
5760 : 3465 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
5761 : 3465 : break;
5762 : :
5763 : 122 : case DECL_KIND:
5764 : 122 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
5765 : 122 : break;
5766 : :
5767 : 153 : case DECL_LEN:
5768 : 153 : t = gfc_add_len (¤t_attr, &seen_at[d]);
5769 : 153 : break;
5770 : :
5771 : 12137 : case DECL_PARAMETER:
5772 : 12137 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
5773 : 12137 : break;
5774 : :
5775 : 10872 : case DECL_POINTER:
5776 : 10872 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
5777 : 10872 : break;
5778 : :
5779 : 47 : case DECL_PROTECTED:
5780 : 47 : if (gfc_current_state () != COMP_MODULE
5781 : 45 : || (gfc_current_ns->proc_name
5782 : 45 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5783 : : {
5784 : 2 : gfc_error ("PROTECTED at %C only allowed in specification "
5785 : : "part of a module");
5786 : 2 : t = false;
5787 : 2 : break;
5788 : : }
5789 : :
5790 : 45 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5791 : : t = false;
5792 : : else
5793 : 41 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
5794 : : break;
5795 : :
5796 : 180 : case DECL_PRIVATE:
5797 : 180 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
5798 : : &seen_at[d]);
5799 : 180 : break;
5800 : :
5801 : 229 : case DECL_PUBLIC:
5802 : 229 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
5803 : : &seen_at[d]);
5804 : 229 : break;
5805 : :
5806 : 1111 : case DECL_STATIC:
5807 : 1111 : case DECL_SAVE:
5808 : 1111 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5809 : 1111 : break;
5810 : :
5811 : 37 : case DECL_AUTOMATIC:
5812 : 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
5813 : 37 : break;
5814 : :
5815 : 4783 : case DECL_TARGET:
5816 : 4783 : t = gfc_add_target (¤t_attr, &seen_at[d]);
5817 : 4783 : break;
5818 : :
5819 : 143 : case DECL_IS_BIND_C:
5820 : 143 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
5821 : 143 : break;
5822 : :
5823 : 6443 : case DECL_VALUE:
5824 : 6443 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5825 : : t = false;
5826 : : else
5827 : 6443 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
5828 : : break;
5829 : :
5830 : 495 : case DECL_VOLATILE:
5831 : 495 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5832 : : t = false;
5833 : : else
5834 : 494 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
5835 : : break;
5836 : :
5837 : 0 : default:
5838 : 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
5839 : : }
5840 : :
5841 : 94501 : if (!t)
5842 : : {
5843 : 35 : m = MATCH_ERROR;
5844 : 35 : goto cleanup;
5845 : : }
5846 : : }
5847 : :
5848 : : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5849 : 148513 : if ((gfc_current_state () == COMP_MODULE
5850 : 148513 : || gfc_current_state () == COMP_SUBMODULE)
5851 : 4841 : && !current_attr.save
5852 : 4665 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5853 : 4572 : current_attr.save = SAVE_IMPLICIT;
5854 : :
5855 : 148513 : colon_seen = 1;
5856 : 148513 : return MATCH_YES;
5857 : :
5858 : 28902 : cleanup:
5859 : 28902 : gfc_current_locus = start;
5860 : 28902 : gfc_free_array_spec (current_as);
5861 : 28902 : current_as = NULL;
5862 : 28902 : attr_seen = 0;
5863 : 28902 : return m;
5864 : : }
5865 : :
5866 : :
5867 : : /* Set the binding label, dest_label, either with the binding label
5868 : : stored in the given gfc_typespec, ts, or if none was provided, it
5869 : : will be the symbol name in all lower case, as required by the draft
5870 : : (J3/04-007, section 15.4.1). If a binding label was given and
5871 : : there is more than one argument (num_idents), it is an error. */
5872 : :
5873 : : static bool
5874 : 290 : set_binding_label (const char **dest_label, const char *sym_name,
5875 : : int num_idents)
5876 : : {
5877 : 290 : if (num_idents > 1 && has_name_equals)
5878 : : {
5879 : 4 : gfc_error ("Multiple identifiers provided with "
5880 : : "single NAME= specifier at %C");
5881 : 4 : return false;
5882 : : }
5883 : :
5884 : 286 : if (curr_binding_label)
5885 : : /* Binding label given; store in temp holder till have sym. */
5886 : 106 : *dest_label = curr_binding_label;
5887 : : else
5888 : : {
5889 : : /* No binding label given, and the NAME= specifier did not exist,
5890 : : which means there was no NAME="". */
5891 : 180 : if (sym_name != NULL && has_name_equals == 0)
5892 : 150 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5893 : : }
5894 : :
5895 : : return true;
5896 : : }
5897 : :
5898 : :
5899 : : /* Set the status of the given common block as being BIND(C) or not,
5900 : : depending on the given parameter, is_bind_c. */
5901 : :
5902 : : static void
5903 : 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5904 : : {
5905 : 76 : com_block->is_bind_c = is_bind_c;
5906 : 76 : return;
5907 : : }
5908 : :
5909 : :
5910 : : /* Verify that the given gfc_typespec is for a C interoperable type. */
5911 : :
5912 : : bool
5913 : 15200 : gfc_verify_c_interop (gfc_typespec *ts)
5914 : : {
5915 : 15200 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5916 : 2902 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5917 : 5785 : ? true : false;
5918 : 12306 : else if (ts->type == BT_CLASS)
5919 : : return false;
5920 : 12298 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5921 : 3270 : return false;
5922 : :
5923 : : return true;
5924 : : }
5925 : :
5926 : :
5927 : : /* Verify that the variables of a given common block, which has been
5928 : : defined with the attribute specifier bind(c), to be of a C
5929 : : interoperable type. Errors will be reported here, if
5930 : : encountered. */
5931 : :
5932 : : bool
5933 : 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
5934 : : {
5935 : 1 : gfc_symbol *curr_sym = NULL;
5936 : 1 : bool retval = true;
5937 : :
5938 : 1 : curr_sym = com_block->head;
5939 : :
5940 : : /* Make sure we have at least one symbol. */
5941 : 1 : if (curr_sym == NULL)
5942 : : return retval;
5943 : :
5944 : : /* Here we know we have a symbol, so we'll execute this loop
5945 : : at least once. */
5946 : 1 : do
5947 : : {
5948 : : /* The second to last param, 1, says this is in a common block. */
5949 : 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5950 : 1 : curr_sym = curr_sym->common_next;
5951 : 1 : } while (curr_sym != NULL);
5952 : :
5953 : : return retval;
5954 : : }
5955 : :
5956 : :
5957 : : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5958 : : an appropriate error message is reported. */
5959 : :
5960 : : bool
5961 : 5005 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5962 : : int is_in_common, gfc_common_head *com_block)
5963 : : {
5964 : 5005 : bool bind_c_function = false;
5965 : 5005 : bool retval = true;
5966 : :
5967 : 5005 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
5968 : 2020 : bind_c_function = true;
5969 : :
5970 : 5005 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
5971 : : {
5972 : 2020 : tmp_sym = tmp_sym->result;
5973 : : /* Make sure it wasn't an implicitly typed result. */
5974 : 2020 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
5975 : : {
5976 : 1 : gfc_warning (OPT_Wc_binding_type,
5977 : : "Implicitly declared BIND(C) function %qs at "
5978 : : "%L may not be C interoperable", tmp_sym->name,
5979 : : &tmp_sym->declared_at);
5980 : 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
5981 : : /* Mark it as C interoperable to prevent duplicate warnings. */
5982 : 1 : tmp_sym->ts.is_c_interop = 1;
5983 : 1 : tmp_sym->attr.is_c_interop = 1;
5984 : : }
5985 : : }
5986 : :
5987 : : /* Here, we know we have the bind(c) attribute, so if we have
5988 : : enough type info, then verify that it's a C interop kind.
5989 : : The info could be in the symbol already, or possibly still in
5990 : : the given ts (current_ts), so look in both. */
5991 : 5005 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
5992 : : {
5993 : 2158 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
5994 : : {
5995 : : /* See if we're dealing with a sym in a common block or not. */
5996 : 160 : if (is_in_common == 1 && warn_c_binding_type)
5997 : : {
5998 : 0 : gfc_warning (OPT_Wc_binding_type,
5999 : : "Variable %qs in common block %qs at %L "
6000 : : "may not be a C interoperable "
6001 : : "kind though common block %qs is BIND(C)",
6002 : : tmp_sym->name, com_block->name,
6003 : 0 : &(tmp_sym->declared_at), com_block->name);
6004 : : }
6005 : : else
6006 : : {
6007 : 160 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6008 : 158 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6009 : : {
6010 : 3 : gfc_error ("Type declaration %qs at %L is not C "
6011 : : "interoperable but it is BIND(C)",
6012 : : tmp_sym->name, &(tmp_sym->declared_at));
6013 : 3 : retval = false;
6014 : : }
6015 : 157 : else if (warn_c_binding_type)
6016 : 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6017 : : "may not be a C interoperable "
6018 : : "kind but it is BIND(C)",
6019 : : tmp_sym->name, &(tmp_sym->declared_at));
6020 : : }
6021 : : }
6022 : :
6023 : : /* Variables declared w/in a common block can't be bind(c)
6024 : : since there's no way for C to see these variables, so there's
6025 : : semantically no reason for the attribute. */
6026 : 2158 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6027 : : {
6028 : 1 : gfc_error ("Variable %qs in common block %qs at "
6029 : : "%L cannot be declared with BIND(C) "
6030 : : "since it is not a global",
6031 : 1 : tmp_sym->name, com_block->name,
6032 : : &(tmp_sym->declared_at));
6033 : 1 : retval = false;
6034 : : }
6035 : :
6036 : : /* Scalar variables that are bind(c) cannot have the pointer
6037 : : or allocatable attributes. */
6038 : 2158 : if (tmp_sym->attr.is_bind_c == 1)
6039 : : {
6040 : 1640 : if (tmp_sym->attr.pointer == 1)
6041 : : {
6042 : 1 : gfc_error ("Variable %qs at %L cannot have both the "
6043 : : "POINTER and BIND(C) attributes",
6044 : : tmp_sym->name, &(tmp_sym->declared_at));
6045 : 1 : retval = false;
6046 : : }
6047 : :
6048 : 1640 : if (tmp_sym->attr.allocatable == 1)
6049 : : {
6050 : 1 : gfc_error ("Variable %qs at %L cannot have both the "
6051 : : "ALLOCATABLE and BIND(C) attributes",
6052 : : tmp_sym->name, &(tmp_sym->declared_at));
6053 : 1 : retval = false;
6054 : : }
6055 : :
6056 : : }
6057 : :
6058 : : /* If it is a BIND(C) function, make sure the return value is a
6059 : : scalar value. The previous tests in this function made sure
6060 : : the type is interoperable. */
6061 : 2158 : if (bind_c_function && tmp_sym->as != NULL)
6062 : 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6063 : : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6064 : :
6065 : : /* BIND(C) functions cannot return a character string. */
6066 : 2020 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6067 : 68 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6068 : 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6069 : : "type at %L must have length 1", tmp_sym->name,
6070 : : &(tmp_sym->declared_at));
6071 : : }
6072 : :
6073 : : /* See if the symbol has been marked as private. If it has, make sure
6074 : : there is no binding label and warn the user if there is one. */
6075 : 5005 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6076 : 10 : && tmp_sym->binding_label)
6077 : : /* Use gfc_warning_now because we won't say that the symbol fails
6078 : : just because of this. */
6079 : 7 : gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6080 : : "given the binding label %qs", tmp_sym->name,
6081 : : &(tmp_sym->declared_at), tmp_sym->binding_label);
6082 : :
6083 : 5005 : return retval;
6084 : : }
6085 : :
6086 : :
6087 : : /* Set the appropriate fields for a symbol that's been declared as
6088 : : BIND(C) (the is_bind_c flag and the binding label), and verify that
6089 : : the type is C interoperable. Errors are reported by the functions
6090 : : used to set/test these fields. */
6091 : :
6092 : : static bool
6093 : 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6094 : : {
6095 : 47 : bool retval = true;
6096 : :
6097 : : /* TODO: Do we need to make sure the vars aren't marked private? */
6098 : :
6099 : : /* Set the is_bind_c bit in symbol_attribute. */
6100 : 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6101 : :
6102 : 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6103 : : return false;
6104 : :
6105 : : return retval;
6106 : : }
6107 : :
6108 : :
6109 : : /* Set the fields marking the given common block as BIND(C), including
6110 : : a binding label, and report any errors encountered. */
6111 : :
6112 : : static bool
6113 : 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6114 : : {
6115 : 76 : bool retval = true;
6116 : :
6117 : : /* destLabel, common name, typespec (which may have binding label). */
6118 : 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6119 : : num_idents))
6120 : : return false;
6121 : :
6122 : : /* Set the given common block (com_block) to being bind(c) (1). */
6123 : 76 : set_com_block_bind_c (com_block, 1);
6124 : :
6125 : 76 : return retval;
6126 : : }
6127 : :
6128 : :
6129 : : /* Retrieve the list of one or more identifiers that the given bind(c)
6130 : : attribute applies to. */
6131 : :
6132 : : static bool
6133 : 102 : get_bind_c_idents (void)
6134 : : {
6135 : 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6136 : 102 : int num_idents = 0;
6137 : 102 : gfc_symbol *tmp_sym = NULL;
6138 : 102 : match found_id;
6139 : 102 : gfc_common_head *com_block = NULL;
6140 : :
6141 : 102 : if (gfc_match_name (name) == MATCH_YES)
6142 : : {
6143 : 38 : found_id = MATCH_YES;
6144 : 38 : gfc_get_ha_symbol (name, &tmp_sym);
6145 : : }
6146 : 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6147 : : {
6148 : 64 : found_id = MATCH_YES;
6149 : 64 : com_block = gfc_get_common (name, 0);
6150 : : }
6151 : : else
6152 : : {
6153 : 0 : gfc_error ("Need either entity or common block name for "
6154 : : "attribute specification statement at %C");
6155 : 0 : return false;
6156 : : }
6157 : :
6158 : : /* Save the current identifier and look for more. */
6159 : 123 : do
6160 : : {
6161 : : /* Increment the number of identifiers found for this spec stmt. */
6162 : 123 : num_idents++;
6163 : :
6164 : : /* Make sure we have a sym or com block, and verify that it can
6165 : : be bind(c). Set the appropriate field(s) and look for more
6166 : : identifiers. */
6167 : 123 : if (tmp_sym != NULL || com_block != NULL)
6168 : : {
6169 : 123 : if (tmp_sym != NULL)
6170 : : {
6171 : 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6172 : : return false;
6173 : : }
6174 : : else
6175 : : {
6176 : 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6177 : : return false;
6178 : : }
6179 : :
6180 : : /* Look to see if we have another identifier. */
6181 : 122 : tmp_sym = NULL;
6182 : 122 : if (gfc_match_eos () == MATCH_YES)
6183 : : found_id = MATCH_NO;
6184 : 21 : else if (gfc_match_char (',') != MATCH_YES)
6185 : : found_id = MATCH_NO;
6186 : 21 : else if (gfc_match_name (name) == MATCH_YES)
6187 : : {
6188 : 9 : found_id = MATCH_YES;
6189 : 9 : gfc_get_ha_symbol (name, &tmp_sym);
6190 : : }
6191 : 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6192 : : {
6193 : 12 : found_id = MATCH_YES;
6194 : 12 : com_block = gfc_get_common (name, 0);
6195 : : }
6196 : : else
6197 : : {
6198 : 0 : gfc_error ("Missing entity or common block name for "
6199 : : "attribute specification statement at %C");
6200 : 0 : return false;
6201 : : }
6202 : : }
6203 : : else
6204 : : {
6205 : 0 : gfc_internal_error ("Missing symbol");
6206 : : }
6207 : 122 : } while (found_id == MATCH_YES);
6208 : :
6209 : : /* if we get here we were successful */
6210 : : return true;
6211 : : }
6212 : :
6213 : :
6214 : : /* Try and match a BIND(C) attribute specification statement. */
6215 : :
6216 : : match
6217 : 128 : gfc_match_bind_c_stmt (void)
6218 : : {
6219 : 128 : match found_match = MATCH_NO;
6220 : 128 : gfc_typespec *ts;
6221 : :
6222 : 128 : ts = ¤t_ts;
6223 : :
6224 : : /* This may not be necessary. */
6225 : 128 : gfc_clear_ts (ts);
6226 : : /* Clear the temporary binding label holder. */
6227 : 128 : curr_binding_label = NULL;
6228 : :
6229 : : /* Look for the bind(c). */
6230 : 128 : found_match = gfc_match_bind_c (NULL, true);
6231 : :
6232 : 128 : if (found_match == MATCH_YES)
6233 : : {
6234 : 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6235 : : return MATCH_ERROR;
6236 : :
6237 : : /* Look for the :: now, but it is not required. */
6238 : 102 : gfc_match (" :: ");
6239 : :
6240 : : /* Get the identifier(s) that needs to be updated. This may need to
6241 : : change to hand the flag(s) for the attr specified so all identifiers
6242 : : found can have all appropriate parts updated (assuming that the same
6243 : : spec stmt can have multiple attrs, such as both bind(c) and
6244 : : allocatable...). */
6245 : 102 : if (!get_bind_c_idents ())
6246 : : /* Error message should have printed already. */
6247 : : return MATCH_ERROR;
6248 : : }
6249 : :
6250 : : return found_match;
6251 : : }
6252 : :
6253 : :
6254 : : /* Match a data declaration statement. */
6255 : :
6256 : : match
6257 : 852737 : gfc_match_data_decl (void)
6258 : : {
6259 : 852737 : gfc_symbol *sym;
6260 : 852737 : match m;
6261 : 852737 : int elem;
6262 : :
6263 : 852737 : type_param_spec_list = NULL;
6264 : 852737 : decl_type_param_list = NULL;
6265 : :
6266 : 852737 : num_idents_on_line = 0;
6267 : :
6268 : 852737 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6269 : 852737 : if (m != MATCH_YES)
6270 : : return m;
6271 : :
6272 : 176364 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6273 : 28225 : && !gfc_comp_struct (gfc_current_state ()))
6274 : : {
6275 : 25456 : sym = gfc_use_derived (current_ts.u.derived);
6276 : :
6277 : 25456 : if (sym == NULL)
6278 : : {
6279 : 15 : m = MATCH_ERROR;
6280 : 15 : goto cleanup;
6281 : : }
6282 : :
6283 : 25441 : current_ts.u.derived = sym;
6284 : : }
6285 : :
6286 : 176349 : m = match_attr_spec ();
6287 : 176349 : if (m == MATCH_ERROR)
6288 : : {
6289 : 84 : m = MATCH_NO;
6290 : 84 : goto cleanup;
6291 : : }
6292 : :
6293 : : /* F2018:C708. */
6294 : 176265 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6295 : : {
6296 : 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6297 : 6 : m = MATCH_ERROR;
6298 : 6 : goto cleanup;
6299 : : }
6300 : :
6301 : 176259 : if (current_ts.type == BT_CLASS
6302 : 9023 : && current_ts.u.derived->attr.unlimited_polymorphic)
6303 : 1415 : goto ok;
6304 : :
6305 : 174844 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6306 : 26788 : && current_ts.u.derived->components == NULL
6307 : 2340 : && !current_ts.u.derived->attr.zero_comp)
6308 : : {
6309 : :
6310 : 185 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6311 : 134 : goto ok;
6312 : :
6313 : 51 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6314 : 24 : goto ok;
6315 : :
6316 : 27 : gfc_find_symbol (current_ts.u.derived->name,
6317 : : current_ts.u.derived->ns, 1, &sym);
6318 : :
6319 : : /* Any symbol that we find had better be a type definition
6320 : : which has its components defined, or be a structure definition
6321 : : actively being parsed. */
6322 : 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6323 : 26 : && (current_ts.u.derived->components != NULL
6324 : 26 : || current_ts.u.derived->attr.zero_comp
6325 : 26 : || current_ts.u.derived == gfc_new_block))
6326 : 26 : goto ok;
6327 : :
6328 : 1 : gfc_error ("Derived type at %C has not been previously defined "
6329 : : "and so cannot appear in a derived type definition");
6330 : 1 : m = MATCH_ERROR;
6331 : 1 : goto cleanup;
6332 : : }
6333 : :
6334 : 174659 : ok:
6335 : : /* If we have an old-style character declaration, and no new-style
6336 : : attribute specifications, then there a comma is optional between
6337 : : the type specification and the variable list. */
6338 : 176258 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6339 : 1441 : gfc_match_char (',');
6340 : :
6341 : : /* Give the types/attributes to symbols that follow. Give the element
6342 : : a number so that repeat character length expressions can be copied. */
6343 : : elem = 1;
6344 : 235613 : for (;;)
6345 : : {
6346 : 235613 : num_idents_on_line++;
6347 : 235613 : m = variable_decl (elem++);
6348 : 235611 : if (m == MATCH_ERROR)
6349 : 398 : goto cleanup;
6350 : 235213 : if (m == MATCH_NO)
6351 : : break;
6352 : :
6353 : 235202 : if (gfc_match_eos () == MATCH_YES)
6354 : 175827 : goto cleanup;
6355 : 59375 : if (gfc_match_char (',') != MATCH_YES)
6356 : : break;
6357 : : }
6358 : :
6359 : 31 : if (!gfc_error_flag_test ())
6360 : : {
6361 : : /* An anonymous structure declaration is unambiguous; if we matched one
6362 : : according to gfc_match_structure_decl, we need to return MATCH_YES
6363 : : here to avoid confusing the remaining matchers, even if there was an
6364 : : error during variable_decl. We must flush any such errors. Note this
6365 : : causes the parser to gracefully continue parsing the remaining input
6366 : : as a structure body, which likely follows. */
6367 : 8 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
6368 : 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6369 : : {
6370 : 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
6371 : : " at %C");
6372 : : /* Skip the bad variable_decl and line up for the start of the
6373 : : structure body. */
6374 : 1 : gfc_error_recovery ();
6375 : 1 : m = MATCH_YES;
6376 : 1 : goto cleanup;
6377 : : }
6378 : :
6379 : 7 : gfc_error ("Syntax error in data declaration at %C");
6380 : : }
6381 : :
6382 : 30 : m = MATCH_ERROR;
6383 : :
6384 : 30 : gfc_free_data_all (gfc_current_ns);
6385 : :
6386 : 176362 : cleanup:
6387 : 176362 : if (saved_kind_expr)
6388 : 91 : gfc_free_expr (saved_kind_expr);
6389 : 176362 : if (type_param_spec_list)
6390 : 337 : gfc_free_actual_arglist (type_param_spec_list);
6391 : 176362 : if (decl_type_param_list)
6392 : 364 : gfc_free_actual_arglist (decl_type_param_list);
6393 : 176362 : saved_kind_expr = NULL;
6394 : 176362 : gfc_free_array_spec (current_as);
6395 : 176362 : current_as = NULL;
6396 : 176362 : return m;
6397 : : }
6398 : :
6399 : : static bool
6400 : 20890 : in_module_or_interface(void)
6401 : : {
6402 : 20890 : if (gfc_current_state () == COMP_MODULE
6403 : 20890 : || gfc_current_state () == COMP_SUBMODULE
6404 : 20890 : || gfc_current_state () == COMP_INTERFACE)
6405 : : return true;
6406 : :
6407 : 17617 : if (gfc_state_stack->state == COMP_CONTAINS
6408 : 17002 : || gfc_state_stack->state == COMP_FUNCTION
6409 : 16924 : || gfc_state_stack->state == COMP_SUBROUTINE)
6410 : : {
6411 : 693 : gfc_state_data *p;
6412 : 728 : for (p = gfc_state_stack->previous; p ; p = p->previous)
6413 : : {
6414 : 724 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
6415 : 90 : || p->state == COMP_INTERFACE)
6416 : : return true;
6417 : : }
6418 : : }
6419 : : return false;
6420 : : }
6421 : :
6422 : : /* Match a prefix associated with a function or subroutine
6423 : : declaration. If the typespec pointer is nonnull, then a typespec
6424 : : can be matched. Note that if nothing matches, MATCH_YES is
6425 : : returned (the null string was matched). */
6426 : :
6427 : : match
6428 : 200029 : gfc_match_prefix (gfc_typespec *ts)
6429 : : {
6430 : 200029 : bool seen_type;
6431 : 200029 : bool seen_impure;
6432 : 200029 : bool found_prefix;
6433 : :
6434 : 200029 : gfc_clear_attr (¤t_attr);
6435 : 200029 : seen_type = false;
6436 : 200029 : seen_impure = false;
6437 : :
6438 : 200029 : gcc_assert (!gfc_matching_prefix);
6439 : 200029 : gfc_matching_prefix = true;
6440 : :
6441 : 206922 : do
6442 : : {
6443 : 224152 : found_prefix = false;
6444 : :
6445 : : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6446 : : corresponding attribute seems natural and distinguishes these
6447 : : procedures from procedure types of PROC_MODULE, which these are
6448 : : as well. */
6449 : 224152 : if (gfc_match ("module% ") == MATCH_YES)
6450 : : {
6451 : 21167 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6452 : 277 : goto error;
6453 : :
6454 : 20890 : if (!in_module_or_interface ())
6455 : : {
6456 : 16928 : gfc_error ("MODULE prefix at %C found outside of a module, "
6457 : : "submodule, or interface");
6458 : 16928 : goto error;
6459 : : }
6460 : :
6461 : 3962 : current_attr.module_procedure = 1;
6462 : 3962 : found_prefix = true;
6463 : : }
6464 : :
6465 : 206947 : if (!seen_type && ts != NULL)
6466 : : {
6467 : 111793 : match m;
6468 : 111793 : m = gfc_match_decl_type_spec (ts, 0);
6469 : 111793 : if (m == MATCH_ERROR)
6470 : 15 : goto error;
6471 : 111778 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
6472 : : {
6473 : : seen_type = true;
6474 : : found_prefix = true;
6475 : : }
6476 : : }
6477 : :
6478 : 206932 : if (gfc_match ("elemental% ") == MATCH_YES)
6479 : : {
6480 : 4316 : if (!gfc_add_elemental (¤t_attr, NULL))
6481 : 2 : goto error;
6482 : :
6483 : : found_prefix = true;
6484 : : }
6485 : :
6486 : 206930 : if (gfc_match ("pure% ") == MATCH_YES)
6487 : : {
6488 : 2051 : if (!gfc_add_pure (¤t_attr, NULL))
6489 : 2 : goto error;
6490 : :
6491 : : found_prefix = true;
6492 : : }
6493 : :
6494 : 206928 : if (gfc_match ("recursive% ") == MATCH_YES)
6495 : : {
6496 : 435 : if (!gfc_add_recursive (¤t_attr, NULL))
6497 : 2 : goto error;
6498 : :
6499 : : found_prefix = true;
6500 : : }
6501 : :
6502 : : /* IMPURE is a somewhat special case, as it needs not set an actual
6503 : : attribute but rather only prevents ELEMENTAL routines from being
6504 : : automatically PURE. */
6505 : 206926 : if (gfc_match ("impure% ") == MATCH_YES)
6506 : : {
6507 : 484 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6508 : 4 : goto error;
6509 : :
6510 : : seen_impure = true;
6511 : : found_prefix = true;
6512 : : }
6513 : : }
6514 : : while (found_prefix);
6515 : :
6516 : : /* IMPURE and PURE must not both appear, of course. */
6517 : 182799 : if (seen_impure && current_attr.pure)
6518 : : {
6519 : 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
6520 : 4 : goto error;
6521 : : }
6522 : :
6523 : : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6524 : 182319 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
6525 : : {
6526 : 3827 : if (!gfc_add_pure (¤t_attr, NULL))
6527 : 0 : goto error;
6528 : : }
6529 : :
6530 : : /* At this point, the next item is not a prefix. */
6531 : 182795 : gcc_assert (gfc_matching_prefix);
6532 : :
6533 : 182795 : gfc_matching_prefix = false;
6534 : 182795 : return MATCH_YES;
6535 : :
6536 : 17234 : error:
6537 : 17234 : gcc_assert (gfc_matching_prefix);
6538 : 17234 : gfc_matching_prefix = false;
6539 : 17234 : return MATCH_ERROR;
6540 : : }
6541 : :
6542 : :
6543 : : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6544 : :
6545 : : static bool
6546 : 50041 : copy_prefix (symbol_attribute *dest, locus *where)
6547 : : {
6548 : 50041 : if (dest->module_procedure)
6549 : : {
6550 : 530 : if (current_attr.elemental)
6551 : 4 : dest->elemental = 1;
6552 : :
6553 : 530 : if (current_attr.pure)
6554 : 12 : dest->pure = 1;
6555 : :
6556 : 530 : if (current_attr.recursive)
6557 : 8 : dest->recursive = 1;
6558 : :
6559 : : /* Module procedures are unusual in that the 'dest' is copied from
6560 : : the interface declaration. However, this is an oportunity to
6561 : : check that the submodule declaration is compliant with the
6562 : : interface. */
6563 : 530 : if (dest->elemental && !current_attr.elemental)
6564 : : {
6565 : 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6566 : : "missing at %L", where);
6567 : 1 : return false;
6568 : : }
6569 : :
6570 : 529 : if (dest->pure && !current_attr.pure)
6571 : : {
6572 : 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6573 : : "missing at %L", where);
6574 : 1 : return false;
6575 : : }
6576 : :
6577 : 528 : if (dest->recursive && !current_attr.recursive)
6578 : : {
6579 : 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6580 : : "missing at %L", where);
6581 : 1 : return false;
6582 : : }
6583 : :
6584 : : return true;
6585 : : }
6586 : :
6587 : 49511 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
6588 : : return false;
6589 : :
6590 : 49509 : if (current_attr.pure && !gfc_add_pure (dest, where))
6591 : : return false;
6592 : :
6593 : 49509 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
6594 : : return false;
6595 : :
6596 : : return true;
6597 : : }
6598 : :
6599 : :
6600 : : /* Match a formal argument list or, if typeparam is true, a
6601 : : type_param_name_list. */
6602 : :
6603 : : match
6604 : 400333 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6605 : : int null_flag, bool typeparam)
6606 : : {
6607 : 400333 : gfc_formal_arglist *head, *tail, *p, *q;
6608 : 400333 : char name[GFC_MAX_SYMBOL_LEN + 1];
6609 : 400333 : gfc_symbol *sym;
6610 : 400333 : match m;
6611 : 400333 : gfc_formal_arglist *formal = NULL;
6612 : :
6613 : 400333 : head = tail = NULL;
6614 : :
6615 : : /* Keep the interface formal argument list and null it so that the
6616 : : matching for the new declaration can be done. The numbers and
6617 : : names of the arguments are checked here. The interface formal
6618 : : arguments are retained in formal_arglist and the characteristics
6619 : : are compared in resolve.cc(resolve_fl_procedure). See the remark
6620 : : in get_proc_name about the eventual need to copy the formal_arglist
6621 : : and populate the formal namespace of the interface symbol. */
6622 : 400333 : if (progname->attr.module_procedure
6623 : 534 : && progname->attr.host_assoc)
6624 : : {
6625 : 153 : formal = progname->formal;
6626 : 153 : progname->formal = NULL;
6627 : : }
6628 : :
6629 : 400333 : if (gfc_match_char ('(') != MATCH_YES)
6630 : : {
6631 : 239125 : if (null_flag)
6632 : 4860 : goto ok;
6633 : : return MATCH_NO;
6634 : : }
6635 : :
6636 : 161208 : if (gfc_match_char (')') == MATCH_YES)
6637 : : {
6638 : 7399 : if (typeparam)
6639 : : {
6640 : 1 : gfc_error_now ("A type parameter list is required at %C");
6641 : 1 : m = MATCH_ERROR;
6642 : 1 : goto cleanup;
6643 : : }
6644 : : else
6645 : 7398 : goto ok;
6646 : : }
6647 : :
6648 : 205871 : for (;;)
6649 : : {
6650 : 205871 : if (gfc_match_char ('*') == MATCH_YES)
6651 : : {
6652 : 7840 : sym = NULL;
6653 : 7840 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6654 : : "Alternate-return argument at %C"))
6655 : : {
6656 : 1 : m = MATCH_ERROR;
6657 : 1 : goto cleanup;
6658 : : }
6659 : 7839 : else if (typeparam)
6660 : 2 : gfc_error_now ("A parameter name is required at %C");
6661 : : }
6662 : : else
6663 : : {
6664 : 198031 : m = gfc_match_name (name);
6665 : 198031 : if (m != MATCH_YES)
6666 : : {
6667 : 14812 : if(typeparam)
6668 : 1 : gfc_error_now ("A parameter name is required at %C");
6669 : 14812 : goto cleanup;
6670 : : }
6671 : :
6672 : 183219 : if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6673 : 4 : goto cleanup;
6674 : 183215 : else if (typeparam
6675 : 183215 : && gfc_get_symbol (name, progname->f2k_derived, &sym))
6676 : 0 : goto cleanup;
6677 : : }
6678 : :
6679 : 191054 : p = gfc_get_formal_arglist ();
6680 : :
6681 : 191054 : if (head == NULL)
6682 : : head = tail = p;
6683 : : else
6684 : : {
6685 : 51366 : tail->next = p;
6686 : 51366 : tail = p;
6687 : : }
6688 : :
6689 : 191054 : tail->sym = sym;
6690 : :
6691 : : /* We don't add the VARIABLE flavor because the name could be a
6692 : : dummy procedure. We don't apply these attributes to formal
6693 : : arguments of statement functions. */
6694 : 183215 : if (sym != NULL && !st_flag
6695 : 275039 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6696 : 83985 : || !gfc_missing_attr (&sym->attr, NULL)))
6697 : : {
6698 : 0 : m = MATCH_ERROR;
6699 : 0 : goto cleanup;
6700 : : }
6701 : :
6702 : : /* The name of a program unit can be in a different namespace,
6703 : : so check for it explicitly. After the statement is accepted,
6704 : : the name is checked for especially in gfc_get_symbol(). */
6705 : 191054 : if (gfc_new_block != NULL && sym != NULL && !typeparam
6706 : 83054 : && strcmp (sym->name, gfc_new_block->name) == 0)
6707 : : {
6708 : 0 : gfc_error ("Name %qs at %C is the name of the procedure",
6709 : : sym->name);
6710 : 0 : m = MATCH_ERROR;
6711 : 0 : goto cleanup;
6712 : : }
6713 : :
6714 : 191054 : if (gfc_match_char (')') == MATCH_YES)
6715 : 97827 : goto ok;
6716 : :
6717 : 93227 : m = gfc_match_char (',');
6718 : 93227 : if (m != MATCH_YES)
6719 : : {
6720 : 41165 : if (typeparam)
6721 : 1 : gfc_error_now ("Expected parameter list in type declaration "
6722 : : "at %C");
6723 : : else
6724 : 41164 : gfc_error ("Unexpected junk in formal argument list at %C");
6725 : 41165 : goto cleanup;
6726 : : }
6727 : : }
6728 : :
6729 : 110085 : ok:
6730 : : /* Check for duplicate symbols in the formal argument list. */
6731 : 110085 : if (head != NULL)
6732 : : {
6733 : 147854 : for (p = head; p->next; p = p->next)
6734 : : {
6735 : 50075 : if (p->sym == NULL)
6736 : 323 : continue;
6737 : :
6738 : 210500 : for (q = p->next; q; q = q->next)
6739 : 160796 : if (p->sym == q->sym)
6740 : : {
6741 : 48 : if (typeparam)
6742 : 1 : gfc_error_now ("Duplicate name %qs in parameter "
6743 : : "list at %C", p->sym->name);
6744 : : else
6745 : 47 : gfc_error ("Duplicate symbol %qs in formal argument "
6746 : : "list at %C", p->sym->name);
6747 : :
6748 : 48 : m = MATCH_ERROR;
6749 : 48 : goto cleanup;
6750 : : }
6751 : : }
6752 : : }
6753 : :
6754 : 110037 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6755 : : {
6756 : 1 : m = MATCH_ERROR;
6757 : 1 : goto cleanup;
6758 : : }
6759 : :
6760 : : /* gfc_error_now used in following and return with MATCH_YES because
6761 : : doing otherwise results in a cascade of extraneous errors and in
6762 : : some cases an ICE in symbol.cc(gfc_release_symbol). */
6763 : 110036 : if (progname->attr.module_procedure && progname->attr.host_assoc)
6764 : : {
6765 : 152 : bool arg_count_mismatch = false;
6766 : :
6767 : 152 : if (!formal && head)
6768 : : arg_count_mismatch = true;
6769 : :
6770 : : /* Abbreviated module procedure declaration is not meant to have any
6771 : : formal arguments! */
6772 : 152 : if (!progname->abr_modproc_decl && formal && !head)
6773 : 1 : arg_count_mismatch = true;
6774 : :
6775 : 292 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
6776 : : {
6777 : 140 : if ((p->next != NULL && q->next == NULL)
6778 : 139 : || (p->next == NULL && q->next != NULL))
6779 : : arg_count_mismatch = true;
6780 : 138 : else if ((p->sym == NULL && q->sym == NULL)
6781 : 138 : || strcmp (p->sym->name, q->sym->name) == 0)
6782 : 137 : continue;
6783 : : else
6784 : 1 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6785 : : "argument names (%s/%s) at %C",
6786 : : p->sym->name, q->sym->name);
6787 : : }
6788 : :
6789 : 152 : if (arg_count_mismatch)
6790 : 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6791 : : "formal arguments at %C");
6792 : : }
6793 : :
6794 : : return MATCH_YES;
6795 : :
6796 : 56032 : cleanup:
6797 : 56032 : gfc_free_formal_arglist (head);
6798 : 56032 : return m;
6799 : : }
6800 : :
6801 : :
6802 : : /* Match a RESULT specification following a function declaration or
6803 : : ENTRY statement. Also matches the end-of-statement. */
6804 : :
6805 : : static match
6806 : 6431 : match_result (gfc_symbol *function, gfc_symbol **result)
6807 : : {
6808 : 6431 : char name[GFC_MAX_SYMBOL_LEN + 1];
6809 : 6431 : gfc_symbol *r;
6810 : 6431 : match m;
6811 : :
6812 : 6431 : if (gfc_match (" result (") != MATCH_YES)
6813 : : return MATCH_NO;
6814 : :
6815 : 4948 : m = gfc_match_name (name);
6816 : 4948 : if (m != MATCH_YES)
6817 : : return m;
6818 : :
6819 : : /* Get the right paren, and that's it because there could be the
6820 : : bind(c) attribute after the result clause. */
6821 : 4948 : if (gfc_match_char (')') != MATCH_YES)
6822 : : {
6823 : : /* TODO: should report the missing right paren here. */
6824 : : return MATCH_ERROR;
6825 : : }
6826 : :
6827 : 4948 : if (strcmp (function->name, name) == 0)
6828 : : {
6829 : 1 : gfc_error ("RESULT variable at %C must be different than function name");
6830 : 1 : return MATCH_ERROR;
6831 : : }
6832 : :
6833 : 4947 : if (gfc_get_symbol (name, NULL, &r))
6834 : : return MATCH_ERROR;
6835 : :
6836 : 4947 : if (!gfc_add_result (&r->attr, r->name, NULL))
6837 : : return MATCH_ERROR;
6838 : :
6839 : 4947 : *result = r;
6840 : :
6841 : 4947 : return MATCH_YES;
6842 : : }
6843 : :
6844 : :
6845 : : /* Match a function suffix, which could be a combination of a result
6846 : : clause and BIND(C), either one, or neither. The draft does not
6847 : : require them to come in a specific order. */
6848 : :
6849 : : static match
6850 : 6435 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6851 : : {
6852 : 6435 : match is_bind_c; /* Found bind(c). */
6853 : 6435 : match is_result; /* Found result clause. */
6854 : 6435 : match found_match; /* Status of whether we've found a good match. */
6855 : 6435 : char peek_char; /* Character we're going to peek at. */
6856 : 6435 : bool allow_binding_name;
6857 : :
6858 : : /* Initialize to having found nothing. */
6859 : 6435 : found_match = MATCH_NO;
6860 : 6435 : is_bind_c = MATCH_NO;
6861 : 6435 : is_result = MATCH_NO;
6862 : :
6863 : : /* Get the next char to narrow between result and bind(c). */
6864 : 6435 : gfc_gobble_whitespace ();
6865 : 6435 : peek_char = gfc_peek_ascii_char ();
6866 : :
6867 : : /* C binding names are not allowed for internal procedures. */
6868 : 6435 : if (gfc_current_state () == COMP_CONTAINS
6869 : 3813 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
6870 : : allow_binding_name = false;
6871 : : else
6872 : 5034 : allow_binding_name = true;
6873 : :
6874 : 6435 : switch (peek_char)
6875 : : {
6876 : 4579 : case 'r':
6877 : : /* Look for result clause. */
6878 : 4579 : is_result = match_result (sym, result);
6879 : 4579 : if (is_result == MATCH_YES)
6880 : : {
6881 : : /* Now see if there is a bind(c) after it. */
6882 : 4578 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6883 : : /* We've found the result clause and possibly bind(c). */
6884 : 4578 : found_match = MATCH_YES;
6885 : : }
6886 : : else
6887 : : /* This should only be MATCH_ERROR. */
6888 : : found_match = is_result;
6889 : : break;
6890 : 1856 : case 'b':
6891 : : /* Look for bind(c) first. */
6892 : 1856 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6893 : 1856 : if (is_bind_c == MATCH_YES)
6894 : : {
6895 : : /* Now see if a result clause followed it. */
6896 : 1852 : is_result = match_result (sym, result);
6897 : 1852 : found_match = MATCH_YES;
6898 : : }
6899 : : else
6900 : : {
6901 : : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6902 : : found_match = MATCH_ERROR;
6903 : : }
6904 : : break;
6905 : 0 : default:
6906 : 0 : gfc_error ("Unexpected junk after function declaration at %C");
6907 : 0 : found_match = MATCH_ERROR;
6908 : 0 : break;
6909 : : }
6910 : :
6911 : 6430 : if (is_bind_c == MATCH_YES)
6912 : : {
6913 : : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6914 : 2001 : if (gfc_current_state () == COMP_CONTAINS
6915 : 414 : && sym->ns->proc_name->attr.flavor != FL_MODULE
6916 : 2013 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6917 : : "at %L may not be specified for an internal "
6918 : : "procedure", &gfc_current_locus))
6919 : : return MATCH_ERROR;
6920 : :
6921 : 1998 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6922 : : return MATCH_ERROR;
6923 : : }
6924 : :
6925 : : return found_match;
6926 : : }
6927 : :
6928 : :
6929 : : /* Procedure pointer return value without RESULT statement:
6930 : : Add "hidden" result variable named "ppr@". */
6931 : :
6932 : : static bool
6933 : 60637 : add_hidden_procptr_result (gfc_symbol *sym)
6934 : : {
6935 : 60637 : bool case1,case2;
6936 : :
6937 : 60637 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6938 : : return false;
6939 : :
6940 : : /* First usage case: PROCEDURE and EXTERNAL statements. */
6941 : 1141 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6942 : 1141 : && strcmp (gfc_current_block ()->name, sym->name) == 0
6943 : 60668 : && sym->attr.external;
6944 : : /* Second usage case: INTERFACE statements. */
6945 : 10833 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6946 : 10833 : && gfc_state_stack->previous->state == COMP_FUNCTION
6947 : 60689 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
6948 : :
6949 : 60482 : if (case1 || case2)
6950 : : {
6951 : 123 : gfc_symtree *stree;
6952 : 123 : if (case1)
6953 : 93 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
6954 : : else
6955 : : {
6956 : 30 : gfc_symtree *st2;
6957 : 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
6958 : 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
6959 : 30 : st2->n.sym = stree->n.sym;
6960 : 30 : stree->n.sym->refs++;
6961 : : }
6962 : 123 : sym->result = stree->n.sym;
6963 : :
6964 : 123 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
6965 : 123 : sym->result->attr.pointer = sym->attr.pointer;
6966 : 123 : sym->result->attr.external = sym->attr.external;
6967 : 123 : sym->result->attr.referenced = sym->attr.referenced;
6968 : 123 : sym->result->ts = sym->ts;
6969 : 123 : sym->attr.proc_pointer = 0;
6970 : 123 : sym->attr.pointer = 0;
6971 : 123 : sym->attr.external = 0;
6972 : 123 : if (sym->result->attr.external && sym->result->attr.pointer)
6973 : : {
6974 : 4 : sym->result->attr.pointer = 0;
6975 : 4 : sym->result->attr.proc_pointer = 1;
6976 : : }
6977 : :
6978 : 123 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
6979 : : }
6980 : : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
6981 : 60359 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
6982 : 69 : && sym->result && sym->result != sym && sym->result->attr.external
6983 : 28 : && sym == gfc_current_ns->proc_name
6984 : 28 : && sym == sym->result->ns->proc_name
6985 : 28 : && strcmp ("ppr@", sym->result->name) == 0)
6986 : : {
6987 : 28 : sym->result->attr.proc_pointer = 1;
6988 : 28 : sym->attr.pointer = 0;
6989 : 28 : return true;
6990 : : }
6991 : : else
6992 : : return false;
6993 : : }
6994 : :
6995 : :
6996 : : /* Match the interface for a PROCEDURE declaration,
6997 : : including brackets (R1212). */
6998 : :
6999 : : static match
7000 : 1446 : match_procedure_interface (gfc_symbol **proc_if)
7001 : : {
7002 : 1446 : match m;
7003 : 1446 : gfc_symtree *st;
7004 : 1446 : locus old_loc, entry_loc;
7005 : 1446 : gfc_namespace *old_ns = gfc_current_ns;
7006 : 1446 : char name[GFC_MAX_SYMBOL_LEN + 1];
7007 : :
7008 : 1446 : old_loc = entry_loc = gfc_current_locus;
7009 : 1446 : gfc_clear_ts (¤t_ts);
7010 : :
7011 : 1446 : if (gfc_match (" (") != MATCH_YES)
7012 : : {
7013 : 1 : gfc_current_locus = entry_loc;
7014 : 1 : return MATCH_NO;
7015 : : }
7016 : :
7017 : : /* Get the type spec. for the procedure interface. */
7018 : 1445 : old_loc = gfc_current_locus;
7019 : 1445 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7020 : 1445 : gfc_gobble_whitespace ();
7021 : 1445 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7022 : 371 : goto got_ts;
7023 : :
7024 : 1074 : if (m == MATCH_ERROR)
7025 : : return m;
7026 : :
7027 : : /* Procedure interface is itself a procedure. */
7028 : 1074 : gfc_current_locus = old_loc;
7029 : 1074 : m = gfc_match_name (name);
7030 : :
7031 : : /* First look to see if it is already accessible in the current
7032 : : namespace because it is use associated or contained. */
7033 : 1074 : st = NULL;
7034 : 1074 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7035 : : return MATCH_ERROR;
7036 : :
7037 : : /* If it is still not found, then try the parent namespace, if it
7038 : : exists and create the symbol there if it is still not found. */
7039 : 1074 : if (gfc_current_ns->parent)
7040 : 351 : gfc_current_ns = gfc_current_ns->parent;
7041 : 1074 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7042 : : return MATCH_ERROR;
7043 : :
7044 : 1074 : gfc_current_ns = old_ns;
7045 : 1074 : *proc_if = st->n.sym;
7046 : :
7047 : 1074 : if (*proc_if)
7048 : : {
7049 : 1074 : (*proc_if)->refs++;
7050 : : /* Resolve interface if possible. That way, attr.procedure is only set
7051 : : if it is declared by a later procedure-declaration-stmt, which is
7052 : : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7053 : 1074 : while ((*proc_if)->ts.interface
7054 : 1081 : && *proc_if != (*proc_if)->ts.interface)
7055 : 7 : *proc_if = (*proc_if)->ts.interface;
7056 : :
7057 : 1074 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7058 : 372 : && (*proc_if)->ts.type == BT_UNKNOWN
7059 : 1446 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7060 : : (*proc_if)->name, NULL))
7061 : : return MATCH_ERROR;
7062 : : }
7063 : :
7064 : 0 : got_ts:
7065 : 1445 : if (gfc_match (" )") != MATCH_YES)
7066 : : {
7067 : 0 : gfc_current_locus = entry_loc;
7068 : 0 : return MATCH_NO;
7069 : : }
7070 : :
7071 : : return MATCH_YES;
7072 : : }
7073 : :
7074 : :
7075 : : /* Match a PROCEDURE declaration (R1211). */
7076 : :
7077 : : static match
7078 : 1066 : match_procedure_decl (void)
7079 : : {
7080 : 1066 : match m;
7081 : 1066 : gfc_symbol *sym, *proc_if = NULL;
7082 : 1066 : int num;
7083 : 1066 : gfc_expr *initializer = NULL;
7084 : :
7085 : : /* Parse interface (with brackets). */
7086 : 1066 : m = match_procedure_interface (&proc_if);
7087 : 1066 : if (m != MATCH_YES)
7088 : : return m;
7089 : :
7090 : : /* Parse attributes (with colons). */
7091 : 1066 : m = match_attr_spec();
7092 : 1066 : if (m == MATCH_ERROR)
7093 : : return MATCH_ERROR;
7094 : :
7095 : 1065 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7096 : : {
7097 : 16 : current_attr.is_bind_c = 1;
7098 : 16 : has_name_equals = 0;
7099 : 16 : curr_binding_label = NULL;
7100 : : }
7101 : :
7102 : : /* Get procedure symbols. */
7103 : 67 : for(num=1;;num++)
7104 : : {
7105 : 1132 : m = gfc_match_symbol (&sym, 0);
7106 : 1132 : if (m == MATCH_NO)
7107 : 1 : goto syntax;
7108 : 1131 : else if (m == MATCH_ERROR)
7109 : : return m;
7110 : :
7111 : : /* Add current_attr to the symbol attributes. */
7112 : 1131 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7113 : : return MATCH_ERROR;
7114 : :
7115 : 1130 : if (sym->attr.is_bind_c)
7116 : : {
7117 : : /* Check for C1218. */
7118 : 52 : if (!proc_if || !proc_if->attr.is_bind_c)
7119 : : {
7120 : 1 : gfc_error ("BIND(C) attribute at %C requires "
7121 : : "an interface with BIND(C)");
7122 : 1 : return MATCH_ERROR;
7123 : : }
7124 : : /* Check for C1217. */
7125 : 51 : if (has_name_equals && sym->attr.pointer)
7126 : : {
7127 : 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7128 : : "POINTER attribute at %C");
7129 : 1 : return MATCH_ERROR;
7130 : : }
7131 : 50 : if (has_name_equals && sym->attr.dummy)
7132 : : {
7133 : 1 : gfc_error ("Dummy procedure at %C may not have "
7134 : : "BIND(C) attribute with NAME");
7135 : 1 : return MATCH_ERROR;
7136 : : }
7137 : : /* Set binding label for BIND(C). */
7138 : 49 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7139 : : return MATCH_ERROR;
7140 : : }
7141 : :
7142 : 1126 : if (!gfc_add_external (&sym->attr, NULL))
7143 : : return MATCH_ERROR;
7144 : :
7145 : 1122 : if (add_hidden_procptr_result (sym))
7146 : 66 : sym = sym->result;
7147 : :
7148 : 1122 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7149 : : return MATCH_ERROR;
7150 : :
7151 : : /* Set interface. */
7152 : 1121 : if (proc_if != NULL)
7153 : : {
7154 : 786 : if (sym->ts.type != BT_UNKNOWN)
7155 : : {
7156 : 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7157 : : sym->name, &gfc_current_locus,
7158 : : gfc_basic_typename (sym->ts.type));
7159 : 1 : return MATCH_ERROR;
7160 : : }
7161 : 785 : sym->ts.interface = proc_if;
7162 : 785 : sym->attr.untyped = 1;
7163 : 785 : sym->attr.if_source = IFSRC_IFBODY;
7164 : : }
7165 : 335 : else if (current_ts.type != BT_UNKNOWN)
7166 : : {
7167 : 197 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7168 : : return MATCH_ERROR;
7169 : 196 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7170 : 196 : sym->ts.interface->ts = current_ts;
7171 : 196 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7172 : 196 : sym->ts.interface->attr.function = 1;
7173 : 196 : sym->attr.function = 1;
7174 : 196 : sym->attr.if_source = IFSRC_UNKNOWN;
7175 : : }
7176 : :
7177 : 1119 : if (gfc_match (" =>") == MATCH_YES)
7178 : : {
7179 : 82 : if (!current_attr.pointer)
7180 : : {
7181 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7182 : 0 : m = MATCH_ERROR;
7183 : 0 : goto cleanup;
7184 : : }
7185 : :
7186 : 82 : m = match_pointer_init (&initializer, 1);
7187 : 82 : if (m != MATCH_YES)
7188 : 1 : goto cleanup;
7189 : :
7190 : 81 : if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
7191 : 0 : goto cleanup;
7192 : :
7193 : : }
7194 : :
7195 : 1118 : if (gfc_match_eos () == MATCH_YES)
7196 : : return MATCH_YES;
7197 : 67 : if (gfc_match_char (',') != MATCH_YES)
7198 : 0 : goto syntax;
7199 : : }
7200 : :
7201 : 1 : syntax:
7202 : 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7203 : 1 : return MATCH_ERROR;
7204 : :
7205 : 1 : cleanup:
7206 : : /* Free stuff up and return. */
7207 : 1 : gfc_free_expr (initializer);
7208 : 1 : return m;
7209 : : }
7210 : :
7211 : :
7212 : : static match
7213 : : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7214 : :
7215 : :
7216 : : /* Match a procedure pointer component declaration (R445). */
7217 : :
7218 : : static match
7219 : 380 : match_ppc_decl (void)
7220 : : {
7221 : 380 : match m;
7222 : 380 : gfc_symbol *proc_if = NULL;
7223 : 380 : gfc_typespec ts;
7224 : 380 : int num;
7225 : 380 : gfc_component *c;
7226 : 380 : gfc_expr *initializer = NULL;
7227 : 380 : gfc_typebound_proc* tb;
7228 : 380 : char name[GFC_MAX_SYMBOL_LEN + 1];
7229 : :
7230 : : /* Parse interface (with brackets). */
7231 : 380 : m = match_procedure_interface (&proc_if);
7232 : 380 : if (m != MATCH_YES)
7233 : 1 : goto syntax;
7234 : :
7235 : : /* Parse attributes. */
7236 : 379 : tb = XCNEW (gfc_typebound_proc);
7237 : 379 : tb->where = gfc_current_locus;
7238 : 379 : m = match_binding_attributes (tb, false, true);
7239 : 379 : if (m == MATCH_ERROR)
7240 : : return m;
7241 : :
7242 : 376 : gfc_clear_attr (¤t_attr);
7243 : 376 : current_attr.procedure = 1;
7244 : 376 : current_attr.proc_pointer = 1;
7245 : 376 : current_attr.access = tb->access;
7246 : 376 : current_attr.flavor = FL_PROCEDURE;
7247 : :
7248 : : /* Match the colons (required). */
7249 : 376 : if (gfc_match (" ::") != MATCH_YES)
7250 : : {
7251 : 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7252 : 1 : return MATCH_ERROR;
7253 : : }
7254 : :
7255 : : /* Check for C450. */
7256 : 375 : if (!tb->nopass && proc_if == NULL)
7257 : : {
7258 : 2 : gfc_error("NOPASS or explicit interface required at %C");
7259 : 2 : return MATCH_ERROR;
7260 : : }
7261 : :
7262 : 373 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7263 : : return MATCH_ERROR;
7264 : :
7265 : : /* Match PPC names. */
7266 : 372 : ts = current_ts;
7267 : 372 : for(num=1;;num++)
7268 : : {
7269 : 373 : m = gfc_match_name (name);
7270 : 373 : if (m == MATCH_NO)
7271 : 0 : goto syntax;
7272 : 373 : else if (m == MATCH_ERROR)
7273 : : return m;
7274 : :
7275 : 373 : if (!gfc_add_component (gfc_current_block(), name, &c))
7276 : : return MATCH_ERROR;
7277 : :
7278 : : /* Add current_attr to the symbol attributes. */
7279 : 373 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
7280 : : return MATCH_ERROR;
7281 : :
7282 : 373 : if (!gfc_add_external (&c->attr, NULL))
7283 : : return MATCH_ERROR;
7284 : :
7285 : 373 : if (!gfc_add_proc (&c->attr, name, NULL))
7286 : : return MATCH_ERROR;
7287 : :
7288 : 373 : if (num == 1)
7289 : 372 : c->tb = tb;
7290 : : else
7291 : : {
7292 : 1 : c->tb = XCNEW (gfc_typebound_proc);
7293 : 1 : c->tb->where = gfc_current_locus;
7294 : 1 : *c->tb = *tb;
7295 : : }
7296 : :
7297 : : /* Set interface. */
7298 : 373 : if (proc_if != NULL)
7299 : : {
7300 : 322 : c->ts.interface = proc_if;
7301 : 322 : c->attr.untyped = 1;
7302 : 322 : c->attr.if_source = IFSRC_IFBODY;
7303 : : }
7304 : 51 : else if (ts.type != BT_UNKNOWN)
7305 : : {
7306 : 23 : c->ts = ts;
7307 : 23 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7308 : 23 : c->ts.interface->result = c->ts.interface;
7309 : 23 : c->ts.interface->ts = ts;
7310 : 23 : c->ts.interface->attr.flavor = FL_PROCEDURE;
7311 : 23 : c->ts.interface->attr.function = 1;
7312 : 23 : c->attr.function = 1;
7313 : 23 : c->attr.if_source = IFSRC_UNKNOWN;
7314 : : }
7315 : :
7316 : 373 : if (gfc_match (" =>") == MATCH_YES)
7317 : : {
7318 : 53 : m = match_pointer_init (&initializer, 1);
7319 : 53 : if (m != MATCH_YES)
7320 : : {
7321 : 0 : gfc_free_expr (initializer);
7322 : 0 : return m;
7323 : : }
7324 : 53 : c->initializer = initializer;
7325 : : }
7326 : :
7327 : 373 : if (gfc_match_eos () == MATCH_YES)
7328 : : return MATCH_YES;
7329 : 1 : if (gfc_match_char (',') != MATCH_YES)
7330 : 0 : goto syntax;
7331 : : }
7332 : :
7333 : 1 : syntax:
7334 : 1 : gfc_error ("Syntax error in procedure pointer component at %C");
7335 : 1 : return MATCH_ERROR;
7336 : : }
7337 : :
7338 : :
7339 : : /* Match a PROCEDURE declaration inside an interface (R1206). */
7340 : :
7341 : : static match
7342 : 1456 : match_procedure_in_interface (void)
7343 : : {
7344 : 1456 : match m;
7345 : 1456 : gfc_symbol *sym;
7346 : 1456 : char name[GFC_MAX_SYMBOL_LEN + 1];
7347 : 1456 : locus old_locus;
7348 : :
7349 : 1456 : if (current_interface.type == INTERFACE_NAMELESS
7350 : 1456 : || current_interface.type == INTERFACE_ABSTRACT)
7351 : : {
7352 : 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
7353 : 1 : return MATCH_ERROR;
7354 : : }
7355 : :
7356 : : /* Check if the F2008 optional double colon appears. */
7357 : 1455 : gfc_gobble_whitespace ();
7358 : 1455 : old_locus = gfc_current_locus;
7359 : 1455 : if (gfc_match ("::") == MATCH_YES)
7360 : : {
7361 : 800 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
7362 : : "MODULE PROCEDURE statement at %L", &old_locus))
7363 : : return MATCH_ERROR;
7364 : : }
7365 : : else
7366 : 655 : gfc_current_locus = old_locus;
7367 : :
7368 : 2109 : for(;;)
7369 : : {
7370 : 2109 : m = gfc_match_name (name);
7371 : 2109 : if (m == MATCH_NO)
7372 : 0 : goto syntax;
7373 : 2109 : else if (m == MATCH_ERROR)
7374 : : return m;
7375 : 2109 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
7376 : : return MATCH_ERROR;
7377 : :
7378 : 2109 : if (!gfc_add_interface (sym))
7379 : : return MATCH_ERROR;
7380 : :
7381 : 2108 : if (gfc_match_eos () == MATCH_YES)
7382 : : break;
7383 : 655 : if (gfc_match_char (',') != MATCH_YES)
7384 : 0 : goto syntax;
7385 : : }
7386 : :
7387 : : return MATCH_YES;
7388 : :
7389 : 0 : syntax:
7390 : 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7391 : 0 : return MATCH_ERROR;
7392 : : }
7393 : :
7394 : :
7395 : : /* General matcher for PROCEDURE declarations. */
7396 : :
7397 : : static match match_procedure_in_type (void);
7398 : :
7399 : : match
7400 : 5682 : gfc_match_procedure (void)
7401 : : {
7402 : 5682 : match m;
7403 : :
7404 : 5682 : switch (gfc_current_state ())
7405 : : {
7406 : 1066 : case COMP_NONE:
7407 : 1066 : case COMP_PROGRAM:
7408 : 1066 : case COMP_MODULE:
7409 : 1066 : case COMP_SUBMODULE:
7410 : 1066 : case COMP_SUBROUTINE:
7411 : 1066 : case COMP_FUNCTION:
7412 : 1066 : case COMP_BLOCK:
7413 : 1066 : m = match_procedure_decl ();
7414 : 1066 : break;
7415 : 1456 : case COMP_INTERFACE:
7416 : 1456 : m = match_procedure_in_interface ();
7417 : 1456 : break;
7418 : 380 : case COMP_DERIVED:
7419 : 380 : m = match_ppc_decl ();
7420 : 380 : break;
7421 : 2780 : case COMP_DERIVED_CONTAINS:
7422 : 2780 : m = match_procedure_in_type ();
7423 : 2780 : break;
7424 : : default:
7425 : : return MATCH_NO;
7426 : : }
7427 : :
7428 : 5682 : if (m != MATCH_YES)
7429 : : return m;
7430 : :
7431 : 5627 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7432 : 4 : return MATCH_ERROR;
7433 : :
7434 : : return m;
7435 : : }
7436 : :
7437 : :
7438 : : /* Warn if a matched procedure has the same name as an intrinsic; this is
7439 : : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7440 : : parser-state-stack to find out whether we're in a module. */
7441 : :
7442 : : static void
7443 : 50038 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7444 : : {
7445 : 50038 : bool in_module;
7446 : :
7447 : 100076 : in_module = (gfc_state_stack->previous
7448 : 50038 : && (gfc_state_stack->previous->state == COMP_MODULE
7449 : 39163 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
7450 : :
7451 : 50038 : gfc_warn_intrinsic_shadow (sym, in_module, func);
7452 : 50038 : }
7453 : :
7454 : :
7455 : : /* Match a function declaration. */
7456 : :
7457 : : match
7458 : 106890 : gfc_match_function_decl (void)
7459 : : {
7460 : 106890 : char name[GFC_MAX_SYMBOL_LEN + 1];
7461 : 106890 : gfc_symbol *sym, *result;
7462 : 106890 : locus old_loc;
7463 : 106890 : match m;
7464 : 106890 : match suffix_match;
7465 : 106890 : match found_match; /* Status returned by match func. */
7466 : :
7467 : 106890 : if (gfc_current_state () != COMP_NONE
7468 : 63501 : && gfc_current_state () != COMP_INTERFACE
7469 : 41615 : && gfc_current_state () != COMP_CONTAINS)
7470 : : return MATCH_NO;
7471 : :
7472 : 106890 : gfc_clear_ts (¤t_ts);
7473 : :
7474 : 106890 : old_loc = gfc_current_locus;
7475 : :
7476 : 106890 : m = gfc_match_prefix (¤t_ts);
7477 |
