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