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 : 7273 : gfc_in_match_data (void)
125 : : {
126 : 7273 : return in_match_data;
127 : : }
128 : :
129 : : static void
130 : 4978 : set_in_match_data (bool set_value)
131 : : {
132 : 4978 : in_match_data = set_value;
133 : 2489 : }
134 : :
135 : : /* Free a gfc_data_variable structure and everything beneath it. */
136 : :
137 : : static void
138 : 5820 : free_variable (gfc_data_variable *p)
139 : : {
140 : 5820 : gfc_data_variable *q;
141 : :
142 : 8997 : for (; p; p = q)
143 : : {
144 : 3177 : q = p->next;
145 : 3177 : gfc_free_expr (p->expr);
146 : 3177 : gfc_free_iterator (&p->iter, 0);
147 : 3177 : free_variable (p->list);
148 : 3177 : free (p);
149 : : }
150 : 5820 : }
151 : :
152 : :
153 : : /* Free a gfc_data_value structure and everything beneath it. */
154 : :
155 : : static void
156 : 2643 : free_value (gfc_data_value *p)
157 : : {
158 : 2643 : gfc_data_value *q;
159 : :
160 : 11541 : for (; p; p = q)
161 : : {
162 : 8898 : q = p->next;
163 : 8898 : mpz_clear (p->repeat);
164 : 8898 : gfc_free_expr (p->expr);
165 : 8898 : free (p);
166 : : }
167 : 2643 : }
168 : :
169 : :
170 : : /* Free a list of gfc_data structures. */
171 : :
172 : : void
173 : 443446 : gfc_free_data (gfc_data *p)
174 : : {
175 : 443446 : gfc_data *q;
176 : :
177 : 446089 : for (; p; p = q)
178 : : {
179 : 2643 : q = p->next;
180 : 2643 : free_variable (p->var);
181 : 2643 : free_value (p->value);
182 : 2643 : free (p);
183 : : }
184 : 443446 : }
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 : 7493414 : gfc_reject_data (gfc_namespace *ns)
206 : : {
207 : 7493414 : gfc_data *d;
208 : :
209 : 7493416 : 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 : 7493414 : }
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 : 3135 : var_element (gfc_data_variable *new_var)
277 : : {
278 : 3135 : match m;
279 : 3135 : gfc_symbol *sym;
280 : :
281 : 3135 : memset (new_var, 0, sizeof (gfc_data_variable));
282 : :
283 : 3135 : if (gfc_match_char ('(') == MATCH_YES)
284 : 163 : return var_list (new_var);
285 : :
286 : 2972 : m = gfc_match_variable (&new_var->expr, 0);
287 : 2972 : if (m != MATCH_YES)
288 : : return m;
289 : :
290 : 2968 : 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 : 2966 : sym = new_var->expr->symtree->n.sym;
299 : :
300 : : /* Symbol should already have an associated type. */
301 : 2966 : if (!gfc_check_symbol_typed (sym, gfc_current_ns, false, gfc_current_locus))
302 : : return MATCH_ERROR;
303 : :
304 : 2965 : 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 : 2964 : if (gfc_current_state () != COMP_BLOCK_DATA
313 : 2828 : && sym->attr.in_common
314 : 2993 : && !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 : 2962 : 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 : 2586 : top_var_list (gfc_data *d)
330 : : {
331 : 2586 : gfc_data_variable var, *tail, *new_var;
332 : 2586 : match m;
333 : :
334 : 2586 : tail = NULL;
335 : :
336 : 2971 : for (;;)
337 : : {
338 : 2971 : m = var_element (&var);
339 : 2971 : if (m == MATCH_NO)
340 : 0 : goto syntax;
341 : 2971 : if (m == MATCH_ERROR)
342 : : return MATCH_ERROR;
343 : :
344 : 2956 : new_var = gfc_get_data_variable ();
345 : 2956 : *new_var = var;
346 : 2956 : if (new_var->expr)
347 : 2826 : new_var->expr->where = gfc_current_locus;
348 : :
349 : 2956 : if (tail == NULL)
350 : 2571 : d->var = new_var;
351 : : else
352 : 385 : tail->next = new_var;
353 : :
354 : 2956 : tail = new_var;
355 : :
356 : 2956 : 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 : 9324 : match_data_constant (gfc_expr **result)
373 : : {
374 : 9324 : char name[GFC_MAX_SYMBOL_LEN + 1];
375 : 9324 : gfc_symbol *sym, *dt_sym = NULL;
376 : 9324 : gfc_expr *expr;
377 : 9324 : match m;
378 : 9324 : locus old_loc;
379 : :
380 : 9324 : m = gfc_match_literal_constant (&expr, 1);
381 : 9324 : if (m == MATCH_YES)
382 : : {
383 : 8983 : *result = expr;
384 : 8983 : 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 : 2629 : top_val_list (gfc_data *data)
491 : : {
492 : 2629 : gfc_data_value *new_val, *tail;
493 : 2629 : gfc_expr *expr;
494 : 2629 : match m;
495 : :
496 : 2629 : tail = NULL;
497 : :
498 : 8935 : for (;;)
499 : : {
500 : 8935 : m = match_data_constant (&expr);
501 : 8935 : if (m == MATCH_NO)
502 : 3 : goto syntax;
503 : 8932 : if (m == MATCH_ERROR)
504 : : return MATCH_ERROR;
505 : :
506 : 8910 : new_val = gfc_get_data_value ();
507 : 8910 : mpz_init (new_val->repeat);
508 : :
509 : 8910 : if (tail == NULL)
510 : 2604 : data->value = new_val;
511 : : else
512 : 6306 : tail->next = new_val;
513 : :
514 : 8910 : tail = new_val;
515 : :
516 : 8910 : if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
517 : : {
518 : 8680 : tail->expr = expr;
519 : 8680 : 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 : 8906 : if (gfc_match_char ('/') == MATCH_YES)
534 : : break;
535 : 6307 : if (gfc_match_char (',') == MATCH_NO)
536 : 1 : goto syntax;
537 : : }
538 : :
539 : : return MATCH_YES;
540 : :
541 : 4 : syntax:
542 : 4 : gfc_syntax_error (ST_DATA);
543 : 4 : gfc_free_data_all (gfc_current_ns);
544 : 4 : return MATCH_ERROR;
545 : : }
546 : :
547 : :
548 : : /* Matches an old style initialization. */
549 : :
550 : : static match
551 : 70 : match_old_style_init (const char *name)
552 : : {
553 : 70 : match m;
554 : 70 : gfc_symtree *st;
555 : 70 : gfc_symbol *sym;
556 : 70 : gfc_data *newdata, *nd;
557 : :
558 : : /* Set up data structure to hold initializers. */
559 : 70 : gfc_find_sym_tree (name, NULL, 0, &st);
560 : 70 : sym = st->n.sym;
561 : :
562 : 70 : newdata = gfc_get_data ();
563 : 70 : newdata->var = gfc_get_data_variable ();
564 : 70 : newdata->var->expr = gfc_get_variable_expr (st);
565 : 70 : newdata->var->expr->where = sym->declared_at;
566 : 70 : newdata->where = gfc_current_locus;
567 : :
568 : : /* Match initial value list. This also eats the terminal '/'. */
569 : 70 : m = top_val_list (newdata);
570 : 70 : if (m != MATCH_YES)
571 : : {
572 : 1 : free (newdata);
573 : 1 : return m;
574 : : }
575 : :
576 : : /* Check that a BOZ did not creep into an old-style initialization. */
577 : 137 : for (nd = newdata; nd; nd = nd->next)
578 : : {
579 : 69 : if (nd->value->expr->ts.type == BT_BOZ
580 : 69 : && gfc_invalid_boz (G_("BOZ at %L cannot appear in an old-style "
581 : : "initialization"), &nd->value->expr->where))
582 : : return MATCH_ERROR;
583 : :
584 : 68 : if (nd->var->expr->ts.type != BT_INTEGER
585 : 27 : && nd->var->expr->ts.type != BT_REAL
586 : 21 : && nd->value->expr->ts.type == BT_BOZ)
587 : : {
588 : 0 : gfc_error (G_("BOZ literal constant near %L cannot be assigned to "
589 : : "a %qs variable in an old-style initialization"),
590 : 0 : &nd->value->expr->where,
591 : : gfc_typename (&nd->value->expr->ts));
592 : 0 : return MATCH_ERROR;
593 : : }
594 : : }
595 : :
596 : 68 : if (gfc_pure (NULL))
597 : : {
598 : 1 : gfc_error ("Initialization at %C is not allowed in a PURE procedure");
599 : 1 : free (newdata);
600 : 1 : return MATCH_ERROR;
601 : : }
602 : 67 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
603 : :
604 : : /* Mark the variable as having appeared in a data statement. */
605 : 67 : if (!gfc_add_data (&sym->attr, sym->name, &sym->declared_at))
606 : : {
607 : 2 : free (newdata);
608 : 2 : return MATCH_ERROR;
609 : : }
610 : :
611 : : /* Chain in namespace list of DATA initializers. */
612 : 65 : newdata->next = gfc_current_ns->data;
613 : 65 : gfc_current_ns->data = newdata;
614 : :
615 : 65 : return m;
616 : : }
617 : :
618 : :
619 : : /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
620 : : we are matching a DATA statement and are therefore issuing an error
621 : : if we encounter something unexpected, if not, we're trying to match
622 : : an old-style initialization expression of the form INTEGER I /2/. */
623 : :
624 : : match
625 : 2491 : gfc_match_data (void)
626 : : {
627 : 2491 : gfc_data *new_data;
628 : 2491 : gfc_expr *e;
629 : 2491 : gfc_ref *ref;
630 : 2491 : match m;
631 : 2491 : 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 : 2491 : c = gfc_peek_ascii_char ();
637 : 2491 : 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 : 2490 : if ((gfc_current_state () == COMP_FUNCTION
642 : 2490 : || 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 : 2489 : set_in_match_data (true);
650 : :
651 : 2683 : for (;;)
652 : : {
653 : 2586 : new_data = gfc_get_data ();
654 : 2586 : new_data->where = gfc_current_locus;
655 : :
656 : 2586 : m = top_var_list (new_data);
657 : 2586 : if (m != MATCH_YES)
658 : 18 : goto cleanup;
659 : :
660 : 2568 : 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 : 2567 : e = new_data->var->expr;
677 : 2567 : if (e)
678 : : {
679 : 2447 : bool invalid;
680 : :
681 : 2447 : invalid = false;
682 : 3753 : for (ref = e->ref; ref; ref = ref->next)
683 : 1306 : if ((ref->type == REF_COMPONENT
684 : 139 : && ref->u.c.component->attr.allocatable)
685 : 1304 : || (ref->type == REF_ARRAY
686 : 1117 : && e->symtree->n.sym->attr.pointer != 1
687 : 1114 : && ref->u.ar.as && ref->u.ar.as->type == AS_DEFERRED))
688 : 1306 : invalid = true;
689 : :
690 : 2447 : 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 : 2445 : if (!e->ref && e->ts.type == BT_DERIVED
701 : 41 : && e->symtree->n.sym->attr.pointer)
702 : 4 : goto partref;
703 : :
704 : 2441 : ref = e->ref;
705 : 2441 : 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 : 3738 : for (; ref; ref = ref->next)
711 : 1299 : if (ref->type == REF_COMPONENT
712 : 134 : && ref->u.c.component->attr.pointer
713 : 27 : && ref->next)
714 : 1 : goto partref;
715 : : }
716 : :
717 : 2559 : m = top_val_list (new_data);
718 : 2559 : if (m != MATCH_YES)
719 : 29 : goto cleanup;
720 : :
721 : 2530 : new_data->next = gfc_current_ns->data;
722 : 2530 : 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 : 2530 : 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 : 2530 : if (gfc_match_eos () == MATCH_YES)
741 : : break;
742 : :
743 : 97 : gfc_match_char (','); /* Optional comma */
744 : 97 : }
745 : :
746 : 2433 : set_in_match_data (false);
747 : :
748 : 2433 : 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 : 2433 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
754 : :
755 : 2433 : return MATCH_YES;
756 : :
757 : 6 : partref:
758 : :
759 : 6 : gfc_error ("part-ref with pointer attribute near %L is not "
760 : : "rightmost part-ref of data-stmt-object",
761 : : &e->where);
762 : :
763 : 56 : cleanup:
764 : 56 : set_in_match_data (false);
765 : 56 : gfc_free_data (new_data);
766 : 56 : return MATCH_ERROR;
767 : : }
768 : :
769 : :
770 : : /************************ Declaration statements *********************/
771 : :
772 : :
773 : : /* Like gfc_match_init_expr, but matches a 'clist' (old-style initialization
774 : : list). The difference here is the expression is a list of constants
775 : : and is surrounded by '/'.
776 : : The typespec ts must match the typespec of the variable which the
777 : : clist is initializing.
778 : : The arrayspec tells whether this should match a list of constants
779 : : corresponding to array elements or a scalar (as == NULL). */
780 : :
781 : : static match
782 : 74 : match_clist_expr (gfc_expr **result, gfc_typespec *ts, gfc_array_spec *as)
783 : : {
784 : 74 : gfc_constructor_base array_head = NULL;
785 : 74 : gfc_expr *expr = NULL;
786 : 74 : match m = MATCH_ERROR;
787 : 74 : locus where;
788 : 74 : mpz_t repeat, cons_size, as_size;
789 : 74 : bool scalar;
790 : 74 : int cmp;
791 : :
792 : 74 : gcc_assert (ts);
793 : :
794 : : /* We have already matched '/' - now look for a constant list, as with
795 : : top_val_list from decl.cc, but append the result to an array. */
796 : 74 : if (gfc_match ("/") == MATCH_YES)
797 : : {
798 : 1 : gfc_error ("Empty old style initializer list at %C");
799 : 1 : return MATCH_ERROR;
800 : : }
801 : :
802 : 73 : where = gfc_current_locus;
803 : 73 : scalar = !as || !as->rank;
804 : :
805 : 42 : if (!scalar && !spec_size (as, &as_size))
806 : : {
807 : 2 : gfc_error ("Array in initializer list at %L must have an explicit shape",
808 : 1 : as->type == AS_EXPLICIT ? &as->upper[0]->where : &where);
809 : : /* Nothing to cleanup yet. */
810 : 1 : return MATCH_ERROR;
811 : : }
812 : :
813 : 72 : mpz_init_set_ui (repeat, 0);
814 : :
815 : 143 : for (;;)
816 : : {
817 : 143 : m = match_data_constant (&expr);
818 : 143 : if (m != MATCH_YES)
819 : 3 : expr = NULL; /* match_data_constant may set expr to garbage */
820 : 3 : if (m == MATCH_NO)
821 : 2 : goto syntax;
822 : 141 : if (m == MATCH_ERROR)
823 : 1 : goto cleanup;
824 : :
825 : : /* Found r in repeat spec r*c; look for the constant to repeat. */
826 : 140 : if ( gfc_match_char ('*') == MATCH_YES)
827 : : {
828 : 18 : if (scalar)
829 : : {
830 : 1 : gfc_error ("Repeat spec invalid in scalar initializer at %C");
831 : 1 : goto cleanup;
832 : : }
833 : 17 : if (expr->ts.type != BT_INTEGER)
834 : : {
835 : 1 : gfc_error ("Repeat spec must be an integer at %C");
836 : 1 : goto cleanup;
837 : : }
838 : 16 : mpz_set (repeat, expr->value.integer);
839 : 16 : gfc_free_expr (expr);
840 : 16 : expr = NULL;
841 : :
842 : 16 : m = match_data_constant (&expr);
843 : 16 : if (m == MATCH_NO)
844 : : {
845 : 1 : m = MATCH_ERROR;
846 : 1 : gfc_error ("Expected data constant after repeat spec at %C");
847 : : }
848 : 16 : if (m != MATCH_YES)
849 : 1 : goto cleanup;
850 : : }
851 : : /* No repeat spec, we matched the data constant itself. */
852 : : else
853 : 122 : mpz_set_ui (repeat, 1);
854 : :
855 : 137 : if (!scalar)
856 : : {
857 : : /* Add the constant initializer as many times as repeated. */
858 : 251 : for (; mpz_cmp_ui (repeat, 0) > 0; mpz_sub_ui (repeat, repeat, 1))
859 : : {
860 : : /* Make sure types of elements match */
861 : 144 : if(ts && !gfc_compare_types (&expr->ts, ts)
862 : 12 : && !gfc_convert_type (expr, ts, 1))
863 : 0 : goto cleanup;
864 : :
865 : 144 : gfc_constructor_append_expr (&array_head,
866 : : gfc_copy_expr (expr), &gfc_current_locus);
867 : : }
868 : :
869 : 107 : gfc_free_expr (expr);
870 : 107 : expr = NULL;
871 : : }
872 : :
873 : : /* For scalar initializers quit after one element. */
874 : : else
875 : : {
876 : 30 : if(gfc_match_char ('/') != MATCH_YES)
877 : : {
878 : 1 : gfc_error ("End of scalar initializer expected at %C");
879 : 1 : goto cleanup;
880 : : }
881 : : break;
882 : : }
883 : :
884 : 107 : if (gfc_match_char ('/') == MATCH_YES)
885 : : break;
886 : 72 : if (gfc_match_char (',') == MATCH_NO)
887 : 1 : goto syntax;
888 : : }
889 : :
890 : : /* If we break early from here out, we encountered an error. */
891 : 64 : m = MATCH_ERROR;
892 : :
893 : : /* Set up expr as an array constructor. */
894 : 64 : if (!scalar)
895 : : {
896 : 35 : expr = gfc_get_array_expr (ts->type, ts->kind, &where);
897 : 35 : expr->ts = *ts;
898 : 35 : expr->value.constructor = array_head;
899 : :
900 : : /* Validate sizes. We built expr ourselves, so cons_size will be
901 : : constant (we fail above for non-constant expressions).
902 : : We still need to verify that the sizes match. */
903 : 35 : gcc_assert (gfc_array_size (expr, &cons_size));
904 : 35 : cmp = mpz_cmp (cons_size, as_size);
905 : 35 : if (cmp < 0)
906 : 2 : gfc_error ("Not enough elements in array initializer at %C");
907 : 33 : else if (cmp > 0)
908 : 3 : gfc_error ("Too many elements in array initializer at %C");
909 : 35 : mpz_clear (cons_size);
910 : 35 : if (cmp)
911 : 5 : goto cleanup;
912 : :
913 : : /* Set the rank/shape to match the LHS as auto-reshape is implied. */
914 : 30 : expr->rank = as->rank;
915 : 30 : expr->shape = gfc_get_shape (as->rank);
916 : 66 : for (int i = 0; i < as->rank; ++i)
917 : 36 : spec_dimen_size (as, i, &expr->shape[i]);
918 : : }
919 : :
920 : : /* Make sure scalar types match. */
921 : 29 : else if (!gfc_compare_types (&expr->ts, ts)
922 : 29 : && !gfc_convert_type (expr, ts, 1))
923 : 2 : goto cleanup;
924 : :
925 : 57 : if (expr->ts.u.cl)
926 : 1 : expr->ts.u.cl->length_from_typespec = 1;
927 : :
928 : 57 : *result = expr;
929 : 57 : m = MATCH_YES;
930 : 57 : goto done;
931 : :
932 : 3 : syntax:
933 : 3 : m = MATCH_ERROR;
934 : 3 : gfc_error ("Syntax error in old style initializer list at %C");
935 : :
936 : 15 : cleanup:
937 : 15 : if (expr)
938 : 10 : expr->value.constructor = NULL;
939 : 15 : gfc_free_expr (expr);
940 : 15 : gfc_constructor_free (array_head);
941 : :
942 : 72 : done:
943 : 72 : mpz_clear (repeat);
944 : 72 : if (!scalar)
945 : 41 : mpz_clear (as_size);
946 : : return m;
947 : : }
948 : :
949 : :
950 : : /* Auxiliary function to merge DIMENSION and CODIMENSION array specs. */
951 : :
952 : : static bool
953 : 84 : merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
954 : : {
955 : 84 : if ((from->type == AS_ASSUMED_RANK && to->corank)
956 : 82 : || (to->type == AS_ASSUMED_RANK && from->corank))
957 : : {
958 : 5 : gfc_error ("The assumed-rank array at %C shall not have a codimension");
959 : 5 : return false;
960 : : }
961 : :
962 : 79 : if (to->rank == 0 && from->rank > 0)
963 : : {
964 : 32 : to->rank = from->rank;
965 : 32 : to->type = from->type;
966 : 32 : to->cray_pointee = from->cray_pointee;
967 : 32 : to->cp_was_assumed = from->cp_was_assumed;
968 : :
969 : 102 : for (int i = to->corank - 1; i >= 0; i--)
970 : : {
971 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
972 : : cleans up elsewhere. */
973 : 70 : int j = from->rank + i;
974 : 70 : if (j >= GFC_MAX_DIMENSIONS)
975 : : break;
976 : :
977 : 70 : to->lower[j] = to->lower[i];
978 : 70 : to->upper[j] = to->upper[i];
979 : : }
980 : 77 : for (int i = 0; i < from->rank; i++)
981 : : {
982 : 45 : if (copy)
983 : : {
984 : 29 : to->lower[i] = gfc_copy_expr (from->lower[i]);
985 : 29 : to->upper[i] = gfc_copy_expr (from->upper[i]);
986 : : }
987 : : else
988 : : {
989 : 16 : to->lower[i] = from->lower[i];
990 : 16 : to->upper[i] = from->upper[i];
991 : : }
992 : : }
993 : : }
994 : 47 : else if (to->corank == 0 && from->corank > 0)
995 : : {
996 : 22 : to->corank = from->corank;
997 : 22 : to->cotype = from->cotype;
998 : :
999 : 75 : for (int i = 0; i < from->corank; i++)
1000 : : {
1001 : : /* Do not exceed the limits on lower[] and upper[]. gfortran
1002 : : cleans up elsewhere. */
1003 : 54 : int k = from->rank + i;
1004 : 54 : int j = to->rank + i;
1005 : 54 : if (j >= GFC_MAX_DIMENSIONS)
1006 : : break;
1007 : :
1008 : 53 : if (copy)
1009 : : {
1010 : 24 : to->lower[j] = gfc_copy_expr (from->lower[k]);
1011 : 24 : to->upper[j] = gfc_copy_expr (from->upper[k]);
1012 : : }
1013 : : else
1014 : : {
1015 : 29 : to->lower[j] = from->lower[k];
1016 : 29 : to->upper[j] = from->upper[k];
1017 : : }
1018 : : }
1019 : : }
1020 : :
1021 : 79 : if (to->rank + to->corank > GFC_MAX_DIMENSIONS)
1022 : : {
1023 : 1 : gfc_error ("Sum of array rank %d and corank %d at %C exceeds maximum "
1024 : : "allowed dimensions of %d",
1025 : : to->rank, to->corank, GFC_MAX_DIMENSIONS);
1026 : 1 : to->corank = GFC_MAX_DIMENSIONS - to->rank;
1027 : 1 : return false;
1028 : : }
1029 : : return true;
1030 : : }
1031 : :
1032 : :
1033 : : /* Match an intent specification. Since this can only happen after an
1034 : : INTENT word, a legal intent-spec must follow. */
1035 : :
1036 : : static sym_intent
1037 : 23858 : match_intent_spec (void)
1038 : : {
1039 : :
1040 : 23858 : if (gfc_match (" ( in out )") == MATCH_YES)
1041 : : return INTENT_INOUT;
1042 : 21196 : if (gfc_match (" ( in )") == MATCH_YES)
1043 : : return INTENT_IN;
1044 : 3229 : if (gfc_match (" ( out )") == MATCH_YES)
1045 : : return INTENT_OUT;
1046 : :
1047 : 2 : gfc_error ("Bad INTENT specification at %C");
1048 : 2 : return INTENT_UNKNOWN;
1049 : : }
1050 : :
1051 : :
1052 : : /* Matches a character length specification, which is either a
1053 : : specification expression, '*', or ':'. */
1054 : :
1055 : : static match
1056 : 24060 : char_len_param_value (gfc_expr **expr, bool *deferred)
1057 : : {
1058 : 24060 : match m;
1059 : 24060 : gfc_expr *p;
1060 : :
1061 : 24060 : *expr = NULL;
1062 : 24060 : *deferred = false;
1063 : :
1064 : 24060 : if (gfc_match_char ('*') == MATCH_YES)
1065 : : return MATCH_YES;
1066 : :
1067 : 18007 : if (gfc_match_char (':') == MATCH_YES)
1068 : : {
1069 : 2236 : if (!gfc_notify_std (GFC_STD_F2003, "deferred type parameter at %C"))
1070 : : return MATCH_ERROR;
1071 : :
1072 : 2234 : *deferred = true;
1073 : :
1074 : 2234 : return MATCH_YES;
1075 : : }
1076 : :
1077 : 15771 : m = gfc_match_expr (expr);
1078 : :
1079 : 15771 : if (m == MATCH_NO || m == MATCH_ERROR)
1080 : : return m;
1081 : :
1082 : 15766 : if (!gfc_expr_check_typed (*expr, gfc_current_ns, false))
1083 : : return MATCH_ERROR;
1084 : :
1085 : : /* Try to simplify the expression to catch things like CHARACTER(([1])). */
1086 : 15760 : p = gfc_copy_expr (*expr);
1087 : 15760 : if (gfc_is_constant_expr (p) && gfc_simplify_expr (p, 1))
1088 : 13379 : gfc_replace_expr (*expr, p);
1089 : : else
1090 : 2381 : gfc_free_expr (p);
1091 : :
1092 : 15760 : if ((*expr)->expr_type == EXPR_FUNCTION)
1093 : : {
1094 : 968 : if ((*expr)->ts.type == BT_INTEGER
1095 : 967 : || ((*expr)->ts.type == BT_UNKNOWN
1096 : 967 : && strcmp((*expr)->symtree->name, "null") != 0))
1097 : : return MATCH_YES;
1098 : :
1099 : 2 : goto syntax;
1100 : : }
1101 : 14792 : else if ((*expr)->expr_type == EXPR_CONSTANT)
1102 : : {
1103 : : /* F2008, 4.4.3.1: The length is a type parameter; its kind is
1104 : : processor dependent and its value is greater than or equal to zero.
1105 : : F2008, 4.4.3.2: If the character length parameter value evaluates
1106 : : to a negative value, the length of character entities declared
1107 : : is zero. */
1108 : :
1109 : 13326 : if ((*expr)->ts.type == BT_INTEGER)
1110 : : {
1111 : 13308 : if (mpz_cmp_si ((*expr)->value.integer, 0) < 0)
1112 : 4 : mpz_set_si ((*expr)->value.integer, 0);
1113 : : }
1114 : : else
1115 : 18 : goto syntax;
1116 : : }
1117 : 1466 : else if ((*expr)->expr_type == EXPR_ARRAY)
1118 : 8 : goto syntax;
1119 : 1458 : else if ((*expr)->expr_type == EXPR_VARIABLE)
1120 : : {
1121 : 1114 : bool t;
1122 : 1114 : gfc_expr *e;
1123 : :
1124 : 1114 : e = gfc_copy_expr (*expr);
1125 : :
1126 : : /* This catches the invalid code "[character(m(2:3)) :: 'x', 'y']",
1127 : : which causes an ICE if gfc_reduce_init_expr() is called. */
1128 : 1114 : if (e->ref && e->ref->type == REF_ARRAY
1129 : 8 : && e->ref->u.ar.type == AR_UNKNOWN
1130 : 7 : && e->ref->u.ar.dimen_type[0] == DIMEN_RANGE)
1131 : 2 : goto syntax;
1132 : :
1133 : 1112 : t = gfc_reduce_init_expr (e);
1134 : :
1135 : 1112 : if (!t && e->ts.type == BT_UNKNOWN
1136 : 7 : && e->symtree->n.sym->attr.untyped == 1
1137 : 7 : && (flag_implicit_none
1138 : 5 : || e->symtree->n.sym->ns->seen_implicit_none == 1
1139 : 1 : || e->symtree->n.sym->ns->parent->seen_implicit_none == 1))
1140 : : {
1141 : 7 : gfc_free_expr (e);
1142 : 7 : goto syntax;
1143 : : }
1144 : :
1145 : 1105 : if ((e->ref && e->ref->type == REF_ARRAY
1146 : 4 : && e->ref->u.ar.type != AR_ELEMENT)
1147 : 1104 : || (!e->ref && e->expr_type == EXPR_ARRAY))
1148 : : {
1149 : 2 : gfc_free_expr (e);
1150 : 2 : goto syntax;
1151 : : }
1152 : :
1153 : 1103 : gfc_free_expr (e);
1154 : : }
1155 : :
1156 : 14755 : if (gfc_seen_div0)
1157 : 52 : m = MATCH_ERROR;
1158 : :
1159 : : return m;
1160 : :
1161 : 39 : syntax:
1162 : 39 : gfc_error ("Scalar INTEGER expression expected at %L", &(*expr)->where);
1163 : 39 : return MATCH_ERROR;
1164 : : }
1165 : :
1166 : :
1167 : : /* A character length is a '*' followed by a literal integer or a
1168 : : char_len_param_value in parenthesis. */
1169 : :
1170 : : static match
1171 : 57004 : match_char_length (gfc_expr **expr, bool *deferred, bool obsolescent_check)
1172 : : {
1173 : 57004 : int length;
1174 : 57004 : match m;
1175 : :
1176 : 57004 : *deferred = false;
1177 : 57004 : m = gfc_match_char ('*');
1178 : 57004 : if (m != MATCH_YES)
1179 : : return m;
1180 : :
1181 : 2698 : m = gfc_match_small_literal_int (&length, NULL);
1182 : 2698 : if (m == MATCH_ERROR)
1183 : : return m;
1184 : :
1185 : 2698 : if (m == MATCH_YES)
1186 : : {
1187 : 2194 : if (obsolescent_check
1188 : 2194 : && !gfc_notify_std (GFC_STD_F95_OBS, "Old-style character length at %C"))
1189 : : return MATCH_ERROR;
1190 : 2194 : *expr = gfc_get_int_expr (gfc_charlen_int_kind, NULL, length);
1191 : 2194 : return m;
1192 : : }
1193 : :
1194 : 504 : if (gfc_match_char ('(') == MATCH_NO)
1195 : 0 : goto syntax;
1196 : :
1197 : 504 : m = char_len_param_value (expr, deferred);
1198 : 504 : if (m != MATCH_YES && gfc_matching_function)
1199 : : {
1200 : 0 : gfc_undo_symbols ();
1201 : 0 : m = MATCH_YES;
1202 : : }
1203 : :
1204 : 1 : if (m == MATCH_ERROR)
1205 : : return m;
1206 : 503 : if (m == MATCH_NO)
1207 : 0 : goto syntax;
1208 : :
1209 : 503 : if (gfc_match_char (')') == MATCH_NO)
1210 : : {
1211 : 0 : gfc_free_expr (*expr);
1212 : 0 : *expr = NULL;
1213 : 0 : goto syntax;
1214 : : }
1215 : :
1216 : : return MATCH_YES;
1217 : :
1218 : 0 : syntax:
1219 : 0 : gfc_error ("Syntax error in character length specification at %C");
1220 : 0 : return MATCH_ERROR;
1221 : : }
1222 : :
1223 : :
1224 : : /* Special subroutine for finding a symbol. Check if the name is found
1225 : : in the current name space. If not, and we're compiling a function or
1226 : : subroutine and the parent compilation unit is an interface, then check
1227 : : to see if the name we've been given is the name of the interface
1228 : : (located in another namespace). */
1229 : :
1230 : : static int
1231 : 244446 : find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
1232 : : {
1233 : 244446 : gfc_state_data *s;
1234 : 244446 : gfc_symtree *st;
1235 : 244446 : int i;
1236 : :
1237 : 244446 : i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
1238 : 244446 : if (i == 0)
1239 : : {
1240 : 244446 : *result = st ? st->n.sym : NULL;
1241 : 244446 : goto end;
1242 : : }
1243 : :
1244 : 0 : if (gfc_current_state () != COMP_SUBROUTINE
1245 : 0 : && gfc_current_state () != COMP_FUNCTION)
1246 : 0 : goto end;
1247 : :
1248 : 0 : s = gfc_state_stack->previous;
1249 : 0 : if (s == NULL)
1250 : 0 : goto end;
1251 : :
1252 : 0 : if (s->state != COMP_INTERFACE)
1253 : 0 : goto end;
1254 : 0 : if (s->sym == NULL)
1255 : 0 : goto end; /* Nameless interface. */
1256 : :
1257 : 0 : if (strcmp (name, s->sym->name) == 0)
1258 : : {
1259 : 0 : *result = s->sym;
1260 : 0 : return 0;
1261 : : }
1262 : :
1263 : 0 : end:
1264 : : return i;
1265 : : }
1266 : :
1267 : :
1268 : : /* Special subroutine for getting a symbol node associated with a
1269 : : procedure name, used in SUBROUTINE and FUNCTION statements. The
1270 : : symbol is created in the parent using with symtree node in the
1271 : : child unit pointing to the symbol. If the current namespace has no
1272 : : parent, then the symbol is just created in the current unit. */
1273 : :
1274 : : static int
1275 : 53432 : get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
1276 : : {
1277 : 53432 : gfc_symtree *st;
1278 : 53432 : gfc_symbol *sym;
1279 : 53432 : int rc = 0;
1280 : :
1281 : : /* Module functions have to be left in their own namespace because
1282 : : they have potentially (almost certainly!) already been referenced.
1283 : : In this sense, they are rather like external functions. This is
1284 : : fixed up in resolve.cc(resolve_entries), where the symbol name-
1285 : : space is set to point to the master function, so that the fake
1286 : : result mechanism can work. */
1287 : 53432 : if (module_fcn_entry)
1288 : : {
1289 : : /* Present if entry is declared to be a module procedure. */
1290 : 259 : rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
1291 : :
1292 : 259 : if (*result == NULL)
1293 : 216 : rc = gfc_get_symbol (name, NULL, result);
1294 : 86 : else if (!gfc_get_symbol (name, NULL, &sym) && sym
1295 : 43 : && (*result)->ts.type == BT_UNKNOWN
1296 : 86 : && sym->attr.flavor == FL_UNKNOWN)
1297 : : /* Pick up the typespec for the entry, if declared in the function
1298 : : body. Note that this symbol is FL_UNKNOWN because it will
1299 : : only have appeared in a type declaration. The local symtree
1300 : : is set to point to the module symbol and a unique symtree
1301 : : to the local version. This latter ensures a correct clearing
1302 : : of the symbols. */
1303 : : {
1304 : : /* If the ENTRY proceeds its specification, we need to ensure
1305 : : that this does not raise a "has no IMPLICIT type" error. */
1306 : 43 : if (sym->ts.type == BT_UNKNOWN)
1307 : 23 : sym->attr.untyped = 1;
1308 : :
1309 : 43 : (*result)->ts = sym->ts;
1310 : :
1311 : : /* Put the symbol in the procedure namespace so that, should
1312 : : the ENTRY precede its specification, the specification
1313 : : can be applied. */
1314 : 43 : (*result)->ns = gfc_current_ns;
1315 : :
1316 : 43 : gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
1317 : 43 : st->n.sym = *result;
1318 : 43 : st = gfc_get_unique_symtree (gfc_current_ns);
1319 : 43 : sym->refs++;
1320 : 43 : st->n.sym = sym;
1321 : : }
1322 : : }
1323 : : else
1324 : 53173 : rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
1325 : :
1326 : 53432 : if (rc)
1327 : : return rc;
1328 : :
1329 : 53431 : sym = *result;
1330 : 53431 : if (sym->attr.proc == PROC_ST_FUNCTION)
1331 : : return rc;
1332 : :
1333 : 53431 : if (sym->attr.module_procedure && sym->attr.if_source == IFSRC_IFBODY)
1334 : : {
1335 : : /* Create a partially populated interface symbol to carry the
1336 : : characteristics of the procedure and the result. */
1337 : 344 : sym->tlink = gfc_new_symbol (name, sym->ns);
1338 : 344 : gfc_add_type (sym->tlink, &(sym->ts), &gfc_current_locus);
1339 : 344 : gfc_copy_attr (&sym->tlink->attr, &sym->attr, NULL);
1340 : 344 : if (sym->attr.dimension)
1341 : 15 : sym->tlink->as = gfc_copy_array_spec (sym->as);
1342 : :
1343 : : /* Ideally, at this point, a copy would be made of the formal
1344 : : arguments and their namespace. However, this does not appear
1345 : : to be necessary, albeit at the expense of not being able to
1346 : : use gfc_compare_interfaces directly. */
1347 : :
1348 : 344 : if (sym->result && sym->result != sym)
1349 : : {
1350 : 54 : sym->tlink->result = sym->result;
1351 : 54 : sym->result = NULL;
1352 : : }
1353 : 290 : else if (sym->result)
1354 : : {
1355 : 61 : sym->tlink->result = sym->tlink;
1356 : : }
1357 : : }
1358 : 53087 : else if (sym && !sym->gfc_new
1359 : 19500 : && gfc_current_state () != COMP_INTERFACE)
1360 : : {
1361 : : /* Trap another encompassed procedure with the same name. All
1362 : : these conditions are necessary to avoid picking up an entry
1363 : : whose name clashes with that of the encompassing procedure;
1364 : : this is handled using gsymbols to register unique, globally
1365 : : accessible names. */
1366 : 18662 : if (sym->attr.flavor != 0
1367 : 16798 : && sym->attr.proc != 0
1368 : 2057 : && (sym->attr.subroutine || sym->attr.function || sym->attr.entry)
1369 : 6 : && sym->attr.if_source != IFSRC_UNKNOWN)
1370 : : {
1371 : 6 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1372 : : name, &sym->declared_at);
1373 : 6 : return true;
1374 : : }
1375 : 18656 : if (sym->attr.flavor != 0
1376 : 16792 : && sym->attr.entry && sym->attr.if_source != IFSRC_UNKNOWN)
1377 : : {
1378 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1379 : : name, &sym->declared_at);
1380 : 1 : return true;
1381 : : }
1382 : :
1383 : 18655 : if (sym->attr.external && sym->attr.procedure
1384 : 2 : && gfc_current_state () == COMP_CONTAINS)
1385 : : {
1386 : 1 : gfc_error_now ("Contained procedure %qs at %C clashes with "
1387 : : "procedure defined at %L",
1388 : : name, &sym->declared_at);
1389 : 1 : return true;
1390 : : }
1391 : :
1392 : : /* Trap a procedure with a name the same as interface in the
1393 : : encompassing scope. */
1394 : 18654 : if (sym->attr.generic != 0
1395 : 59 : && (sym->attr.subroutine || sym->attr.function)
1396 : 1 : && !sym->attr.mod_proc)
1397 : : {
1398 : 1 : gfc_error_now ("Name %qs at %C is already defined"
1399 : : " as a generic interface at %L",
1400 : : name, &sym->declared_at);
1401 : 1 : return true;
1402 : : }
1403 : :
1404 : : /* Trap declarations of attributes in encompassing scope. The
1405 : : signature for this is that ts.kind is nonzero for no-CLASS
1406 : : entity. For a CLASS entity, ts.kind is zero. */
1407 : 18653 : if ((sym->ts.kind != 0
1408 : 18313 : || sym->ts.type == BT_CLASS
1409 : 18312 : || sym->ts.type == BT_DERIVED)
1410 : 364 : && !sym->attr.implicit_type
1411 : 363 : && sym->attr.proc == 0
1412 : 345 : && gfc_current_ns->parent != NULL
1413 : 137 : && sym->attr.access == 0
1414 : 135 : && !module_fcn_entry)
1415 : : {
1416 : 5 : gfc_error_now ("Procedure %qs at %C has an explicit interface "
1417 : : "from a previous declaration", name);
1418 : 5 : return true;
1419 : : }
1420 : : }
1421 : :
1422 : : /* C1246 (R1225) MODULE shall appear only in the function-stmt or
1423 : : subroutine-stmt of a module subprogram or of a nonabstract interface
1424 : : body that is declared in the scoping unit of a module or submodule. */
1425 : 53417 : if (sym->attr.external
1426 : 67 : && (sym->attr.subroutine || sym->attr.function)
1427 : 66 : && sym->attr.if_source == IFSRC_IFBODY
1428 : 66 : && !current_attr.module_procedure
1429 : 3 : && sym->attr.proc == PROC_MODULE
1430 : 3 : && gfc_state_stack->state == COMP_CONTAINS)
1431 : : {
1432 : 1 : gfc_error_now ("Procedure %qs defined in interface body at %L "
1433 : : "clashes with internal procedure defined at %C",
1434 : : name, &sym->declared_at);
1435 : 1 : return true;
1436 : : }
1437 : :
1438 : 53416 : if (sym && !sym->gfc_new
1439 : 19829 : && sym->attr.flavor != FL_UNKNOWN
1440 : 17622 : && sym->attr.referenced == 0 && sym->attr.subroutine == 1
1441 : 198 : && gfc_state_stack->state == COMP_CONTAINS
1442 : 193 : && gfc_state_stack->previous->state == COMP_SUBROUTINE)
1443 : : {
1444 : 1 : gfc_error_now ("Procedure %qs at %C is already defined at %L",
1445 : : name, &sym->declared_at);
1446 : 1 : return true;
1447 : : }
1448 : :
1449 : 53415 : if (gfc_current_ns->parent == NULL || *result == NULL)
1450 : : return rc;
1451 : :
1452 : : /* Module function entries will already have a symtree in
1453 : : the current namespace but will need one at module level. */
1454 : 41998 : if (module_fcn_entry)
1455 : : {
1456 : : /* Present if entry is declared to be a module procedure. */
1457 : 257 : rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
1458 : 257 : if (st == NULL)
1459 : 216 : st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
1460 : : }
1461 : : else
1462 : 41741 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
1463 : :
1464 : 41998 : st->n.sym = sym;
1465 : 41998 : sym->refs++;
1466 : :
1467 : : /* See if the procedure should be a module procedure. */
1468 : :
1469 : 41998 : if (((sym->ns->proc_name != NULL
1470 : 41998 : && sym->ns->proc_name->attr.flavor == FL_MODULE
1471 : 18393 : && sym->attr.proc != PROC_MODULE)
1472 : 41998 : || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
1473 : 58019 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
1474 : : rc = 2;
1475 : :
1476 : : return rc;
1477 : : }
1478 : :
1479 : :
1480 : : /* Verify that the given symbol representing a parameter is C
1481 : : interoperable, by checking to see if it was marked as such after
1482 : : its declaration. If the given symbol is not interoperable, a
1483 : : warning is reported, thus removing the need to return the status to
1484 : : the calling function. The standard does not require the user use
1485 : : one of the iso_c_binding named constants to declare an
1486 : : interoperable parameter, but we can't be sure if the param is C
1487 : : interop or not if the user doesn't. For example, integer(4) may be
1488 : : legal Fortran, but doesn't have meaning in C. It may interop with
1489 : : a number of the C types, which causes a problem because the
1490 : : compiler can't know which one. This code is almost certainly not
1491 : : portable, and the user will get what they deserve if the C type
1492 : : across platforms isn't always interoperable with integer(4). If
1493 : : the user had used something like integer(c_int) or integer(c_long),
1494 : : the compiler could have automatically handled the varying sizes
1495 : : across platforms. */
1496 : :
1497 : : bool
1498 : 13789 : gfc_verify_c_interop_param (gfc_symbol *sym)
1499 : : {
1500 : 13789 : int is_c_interop = 0;
1501 : 13789 : bool retval = true;
1502 : :
1503 : : /* We check implicitly typed variables in symbol.cc:gfc_set_default_type().
1504 : : Don't repeat the checks here. */
1505 : 13789 : if (sym->attr.implicit_type)
1506 : : return true;
1507 : :
1508 : : /* For subroutines or functions that are passed to a BIND(C) procedure,
1509 : : they're interoperable if they're BIND(C) and their params are all
1510 : : interoperable. */
1511 : 13789 : if (sym->attr.flavor == FL_PROCEDURE)
1512 : : {
1513 : 2 : if (sym->attr.is_bind_c == 0)
1514 : : {
1515 : 0 : gfc_error_now ("Procedure %qs at %L must have the BIND(C) "
1516 : : "attribute to be C interoperable", sym->name,
1517 : : &(sym->declared_at));
1518 : 0 : return false;
1519 : : }
1520 : : else
1521 : : {
1522 : 2 : if (sym->attr.is_c_interop == 1)
1523 : : /* We've already checked this procedure; don't check it again. */
1524 : : return true;
1525 : : else
1526 : 2 : return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1527 : 2 : sym->common_block);
1528 : : }
1529 : : }
1530 : :
1531 : : /* See if we've stored a reference to a procedure that owns sym. */
1532 : 13787 : if (sym->ns != NULL && sym->ns->proc_name != NULL)
1533 : : {
1534 : 13787 : if (sym->ns->proc_name->attr.is_bind_c == 1)
1535 : : {
1536 : 13747 : is_c_interop = (gfc_verify_c_interop(&(sym->ts)) ? 1 : 0);
1537 : :
1538 : 3347 : if (is_c_interop != 1)
1539 : : {
1540 : : /* Make personalized messages to give better feedback. */
1541 : 3347 : if (sym->ts.type == BT_DERIVED)
1542 : 1 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1543 : : "BIND(C) procedure %qs but is not C interoperable "
1544 : : "because derived type %qs is not C interoperable",
1545 : : sym->name, &(sym->declared_at),
1546 : 1 : sym->ns->proc_name->name,
1547 : 1 : sym->ts.u.derived->name);
1548 : 3346 : else if (sym->ts.type == BT_CLASS)
1549 : 6 : gfc_error ("Variable %qs at %L is a dummy argument to the "
1550 : : "BIND(C) procedure %qs but is not C interoperable "
1551 : : "because it is polymorphic",
1552 : : sym->name, &(sym->declared_at),
1553 : 6 : sym->ns->proc_name->name);
1554 : 3340 : else if (warn_c_binding_type)
1555 : 27 : gfc_warning (OPT_Wc_binding_type,
1556 : : "Variable %qs at %L is a dummy argument of the "
1557 : : "BIND(C) procedure %qs but may not be C "
1558 : : "interoperable",
1559 : : sym->name, &(sym->declared_at),
1560 : 27 : sym->ns->proc_name->name);
1561 : : }
1562 : :
1563 : : /* Per F2018, 18.3.6 (5), pointer + contiguous is not permitted. */
1564 : 13747 : if (sym->attr.pointer && sym->attr.contiguous)
1565 : 2 : gfc_error ("Dummy argument %qs at %L may not be a pointer with "
1566 : : "CONTIGUOUS attribute as procedure %qs is BIND(C)",
1567 : 2 : sym->name, &sym->declared_at, sym->ns->proc_name->name);
1568 : :
1569 : : /* Per F2018, C1557, pointer/allocatable dummies to a bind(c)
1570 : : procedure that are default-initialized are not permitted. */
1571 : 13747 : if ((sym->attr.pointer || sym->attr.allocatable)
1572 : 1029 : && sym->ts.type == BT_DERIVED
1573 : 14117 : && gfc_has_default_initializer (sym->ts.u.derived))
1574 : : {
1575 : 8 : gfc_error ("Default-initialized %s dummy argument %qs "
1576 : : "at %L is not permitted in BIND(C) procedure %qs",
1577 : 4 : (sym->attr.pointer ? "pointer" : "allocatable"),
1578 : : sym->name, &sym->declared_at,
1579 : 4 : sym->ns->proc_name->name);
1580 : 4 : retval = false;
1581 : : }
1582 : :
1583 : : /* Character strings are only C interoperable if they have a
1584 : : length of 1. However, as an argument they are also interoperable
1585 : : when passed as descriptor (which requires len=: or len=*). */
1586 : 13747 : if (sym->ts.type == BT_CHARACTER)
1587 : : {
1588 : 2311 : gfc_charlen *cl = sym->ts.u.cl;
1589 : :
1590 : 2311 : if (sym->attr.allocatable || sym->attr.pointer)
1591 : : {
1592 : : /* F2018, 18.3.6 (6). */
1593 : 193 : if (!sym->ts.deferred)
1594 : : {
1595 : 64 : if (sym->attr.allocatable)
1596 : 32 : gfc_error ("Allocatable character dummy argument %qs "
1597 : : "at %L must have deferred length as "
1598 : : "procedure %qs is BIND(C)", sym->name,
1599 : 32 : &sym->declared_at, sym->ns->proc_name->name);
1600 : : else
1601 : 32 : gfc_error ("Pointer character dummy argument %qs at %L "
1602 : : "must have deferred length as procedure %qs "
1603 : : "is BIND(C)", sym->name, &sym->declared_at,
1604 : 32 : sym->ns->proc_name->name);
1605 : : retval = false;
1606 : : }
1607 : 129 : else if (!gfc_notify_std (GFC_STD_F2018,
1608 : : "Deferred-length character dummy "
1609 : : "argument %qs at %L of procedure "
1610 : : "%qs with BIND(C) attribute",
1611 : : sym->name, &sym->declared_at,
1612 : 129 : sym->ns->proc_name->name))
1613 : 102 : retval = false;
1614 : : }
1615 : 2118 : else if (sym->attr.value
1616 : 351 : && (!cl || !cl->length
1617 : 351 : || cl->length->expr_type != EXPR_CONSTANT
1618 : 351 : || mpz_cmp_si (cl->length->value.integer, 1) != 0))
1619 : : {
1620 : 1 : gfc_error ("Character dummy argument %qs at %L must be "
1621 : : "of length 1 as it has the VALUE attribute",
1622 : : sym->name, &sym->declared_at);
1623 : 1 : retval = false;
1624 : : }
1625 : 2117 : else if (!cl || !cl->length)
1626 : : {
1627 : : /* Assumed length; F2018, 18.3.6 (5)(2).
1628 : : Uses the CFI array descriptor - also for scalars and
1629 : : explicit-size/assumed-size arrays. */
1630 : 948 : if (!gfc_notify_std (GFC_STD_F2018,
1631 : : "Assumed-length character dummy argument "
1632 : : "%qs at %L of procedure %qs with BIND(C) "
1633 : : "attribute", sym->name, &sym->declared_at,
1634 : 948 : sym->ns->proc_name->name))
1635 : 102 : retval = false;
1636 : : }
1637 : 1169 : else if (cl->length->expr_type != EXPR_CONSTANT
1638 : 855 : || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1639 : : {
1640 : : /* F2018, 18.3.6, (5), item 4. */
1641 : 653 : if (!sym->attr.dimension
1642 : 645 : || sym->as->type == AS_ASSUMED_SIZE
1643 : 639 : || sym->as->type == AS_EXPLICIT)
1644 : : {
1645 : 20 : gfc_error ("Character dummy argument %qs at %L must be "
1646 : : "of constant length of one or assumed length, "
1647 : : "unless it has assumed shape or assumed rank, "
1648 : : "as procedure %qs has the BIND(C) attribute",
1649 : : sym->name, &sym->declared_at,
1650 : 20 : sym->ns->proc_name->name);
1651 : 20 : retval = false;
1652 : : }
1653 : : /* else: valid only since F2018 - and an assumed-shape/rank
1654 : : array; however, gfc_notify_std is already called when
1655 : : those array types are used. Thus, silently accept F200x. */
1656 : : }
1657 : : }
1658 : :
1659 : : /* We have to make sure that any param to a bind(c) routine does
1660 : : not have the allocatable, pointer, or optional attributes,
1661 : : according to J3/04-007, section 5.1. */
1662 : 13747 : if (sym->attr.allocatable == 1
1663 : 14143 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1664 : : "ALLOCATABLE attribute in procedure %qs "
1665 : : "with BIND(C)", sym->name,
1666 : : &(sym->declared_at),
1667 : 396 : sym->ns->proc_name->name))
1668 : : retval = false;
1669 : :
1670 : 13747 : if (sym->attr.pointer == 1
1671 : 14380 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs at %L with "
1672 : : "POINTER attribute in procedure %qs "
1673 : : "with BIND(C)", sym->name,
1674 : : &(sym->declared_at),
1675 : 633 : sym->ns->proc_name->name))
1676 : : retval = false;
1677 : :
1678 : 13747 : if (sym->attr.optional == 1 && sym->attr.value)
1679 : : {
1680 : 9 : gfc_error ("Variable %qs at %L cannot have both the OPTIONAL "
1681 : : "and the VALUE attribute because procedure %qs "
1682 : : "is BIND(C)", sym->name, &(sym->declared_at),
1683 : 9 : sym->ns->proc_name->name);
1684 : 9 : retval = false;
1685 : : }
1686 : 13738 : else if (sym->attr.optional == 1
1687 : 14505 : && !gfc_notify_std (GFC_STD_F2018, "Variable %qs "
1688 : : "at %L with OPTIONAL attribute in "
1689 : : "procedure %qs which is BIND(C)",
1690 : : sym->name, &(sym->declared_at),
1691 : 767 : sym->ns->proc_name->name))
1692 : : retval = false;
1693 : :
1694 : : /* Make sure that if it has the dimension attribute, that it is
1695 : : either assumed size or explicit shape. Deferred shape is already
1696 : : covered by the pointer/allocatable attribute. */
1697 : 4797 : if (sym->as != NULL && sym->as->type == AS_ASSUMED_SHAPE
1698 : 15070 : && !gfc_notify_std (GFC_STD_F2018, "Assumed-shape array %qs "
1699 : : "at %L as dummy argument to the BIND(C) "
1700 : : "procedure %qs at %L", sym->name,
1701 : : &(sym->declared_at),
1702 : : sym->ns->proc_name->name,
1703 : 1323 : &(sym->ns->proc_name->declared_at)))
1704 : : retval = false;
1705 : : }
1706 : : }
1707 : :
1708 : : return retval;
1709 : : }
1710 : :
1711 : :
1712 : :
1713 : : /* Function called by variable_decl() that adds a name to the symbol table. */
1714 : :
1715 : : static bool
1716 : 227186 : build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1717 : : gfc_array_spec **as, locus *var_locus)
1718 : : {
1719 : 227186 : symbol_attribute attr;
1720 : 227186 : gfc_symbol *sym;
1721 : 227186 : int upper;
1722 : 227186 : gfc_symtree *st;
1723 : :
1724 : : /* Symbols in a submodule are host associated from the parent module or
1725 : : submodules. Therefore, they can be overridden by declarations in the
1726 : : submodule scope. Deal with this by attaching the existing symbol to
1727 : : a new symtree and recycling the old symtree with a new symbol... */
1728 : 227186 : st = gfc_find_symtree (gfc_current_ns->sym_root, name);
1729 : 227186 : if (st != NULL && gfc_state_stack->state == COMP_SUBMODULE
1730 : 12 : && st->n.sym != NULL
1731 : 12 : && st->n.sym->attr.host_assoc && st->n.sym->attr.used_in_submodule)
1732 : : {
1733 : 12 : gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
1734 : 12 : s->n.sym = st->n.sym;
1735 : 12 : sym = gfc_new_symbol (name, gfc_current_ns);
1736 : :
1737 : :
1738 : 12 : st->n.sym = sym;
1739 : 12 : sym->refs++;
1740 : 12 : gfc_set_sym_referenced (sym);
1741 : 12 : }
1742 : : /* ...Otherwise generate a new symtree and new symbol. */
1743 : 227174 : else if (gfc_get_symbol (name, NULL, &sym))
1744 : : return false;
1745 : :
1746 : : /* Check if the name has already been defined as a type. The
1747 : : first letter of the symtree will be in upper case then. Of
1748 : : course, this is only necessary if the upper case letter is
1749 : : actually different. */
1750 : :
1751 : 227186 : upper = TOUPPER(name[0]);
1752 : 227186 : if (upper != name[0])
1753 : : {
1754 : 226552 : char u_name[GFC_MAX_SYMBOL_LEN + 1];
1755 : 226552 : gfc_symtree *st;
1756 : :
1757 : 226552 : gcc_assert (strlen(name) <= GFC_MAX_SYMBOL_LEN);
1758 : 226552 : strcpy (u_name, name);
1759 : 226552 : u_name[0] = upper;
1760 : :
1761 : 226552 : st = gfc_find_symtree (gfc_current_ns->sym_root, u_name);
1762 : :
1763 : : /* STRUCTURE types can alias symbol names */
1764 : 226552 : if (st != 0 && st->n.sym->attr.flavor != FL_STRUCT)
1765 : : {
1766 : 1 : gfc_error ("Symbol %qs at %C also declared as a type at %L", name,
1767 : : &st->n.sym->declared_at);
1768 : 1 : return false;
1769 : : }
1770 : : }
1771 : :
1772 : : /* Start updating the symbol table. Add basic type attribute if present. */
1773 : 227185 : if (current_ts.type != BT_UNKNOWN
1774 : 227185 : && (sym->attr.implicit_type == 0
1775 : 186 : || !gfc_compare_types (&sym->ts, ¤t_ts))
1776 : 454188 : && !gfc_add_type (sym, ¤t_ts, var_locus))
1777 : : return false;
1778 : :
1779 : 227159 : if (sym->ts.type == BT_CHARACTER)
1780 : : {
1781 : 27019 : sym->ts.u.cl = cl;
1782 : 27019 : sym->ts.deferred = cl_deferred;
1783 : : }
1784 : :
1785 : : /* Add dimension attribute if present. */
1786 : 227159 : if (!gfc_set_array_spec (sym, *as, var_locus))
1787 : : return false;
1788 : 227157 : *as = NULL;
1789 : :
1790 : : /* Add attribute to symbol. The copy is so that we can reset the
1791 : : dimension attribute. */
1792 : 227157 : attr = current_attr;
1793 : 227157 : attr.dimension = 0;
1794 : 227157 : attr.codimension = 0;
1795 : :
1796 : 227157 : if (!gfc_copy_attr (&sym->attr, &attr, var_locus))
1797 : : return false;
1798 : :
1799 : : /* Finish any work that may need to be done for the binding label,
1800 : : if it's a bind(c). The bind(c) attr is found before the symbol
1801 : : is made, and before the symbol name (for data decls), so the
1802 : : current_ts is holding the binding label, or nothing if the
1803 : : name= attr wasn't given. Therefore, test here if we're dealing
1804 : : with a bind(c) and make sure the binding label is set correctly. */
1805 : 227144 : if (sym->attr.is_bind_c == 1)
1806 : : {
1807 : 1100 : if (!sym->binding_label)
1808 : : {
1809 : : /* Set the binding label and verify that if a NAME= was specified
1810 : : then only one identifier was in the entity-decl-list. */
1811 : 118 : if (!set_binding_label (&sym->binding_label, sym->name,
1812 : : num_idents_on_line))
1813 : : return false;
1814 : : }
1815 : : }
1816 : :
1817 : : /* See if we know we're in a common block, and if it's a bind(c)
1818 : : common then we need to make sure we're an interoperable type. */
1819 : 227142 : if (sym->attr.in_common == 1)
1820 : : {
1821 : : /* Test the common block object. */
1822 : 628 : if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1823 : 6 : && sym->ts.is_c_interop != 1)
1824 : : {
1825 : 0 : gfc_error_now ("Variable %qs in common block %qs at %C "
1826 : : "must be declared with a C interoperable "
1827 : : "kind since common block %qs is BIND(C)",
1828 : : sym->name, sym->common_block->name,
1829 : 0 : sym->common_block->name);
1830 : 0 : gfc_clear_error ();
1831 : : }
1832 : : }
1833 : :
1834 : 227142 : sym->attr.implied_index = 0;
1835 : :
1836 : : /* Use the parameter expressions for a parameterized derived type. */
1837 : 227142 : if ((sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS)
1838 : 31529 : && sym->ts.u.derived->attr.pdt_type && type_param_spec_list)
1839 : 433 : sym->param_list = gfc_copy_actual_arglist (type_param_spec_list);
1840 : :
1841 : 227142 : if (sym->ts.type == BT_CLASS)
1842 : 9658 : return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
1843 : :
1844 : : return true;
1845 : : }
1846 : :
1847 : :
1848 : : /* Set character constant to the given length. The constant will be padded or
1849 : : truncated. If we're inside an array constructor without a typespec, we
1850 : : additionally check that all elements have the same length; check_len -1
1851 : : means no checking. */
1852 : :
1853 : : void
1854 : 12162 : gfc_set_constant_character_len (gfc_charlen_t len, gfc_expr *expr,
1855 : : gfc_charlen_t check_len)
1856 : : {
1857 : 12162 : gfc_char_t *s;
1858 : 12162 : gfc_charlen_t slen;
1859 : :
1860 : 12162 : if (expr->ts.type != BT_CHARACTER)
1861 : : return;
1862 : :
1863 : 12161 : if (expr->expr_type != EXPR_CONSTANT)
1864 : : {
1865 : 1 : gfc_error_now ("CHARACTER length must be a constant at %L", &expr->where);
1866 : 1 : return;
1867 : : }
1868 : :
1869 : 12160 : slen = expr->value.character.length;
1870 : 12160 : if (len != slen)
1871 : : {
1872 : 1469 : s = gfc_get_wide_string (len + 1);
1873 : 1469 : memcpy (s, expr->value.character.string,
1874 : 1469 : MIN (len, slen) * sizeof (gfc_char_t));
1875 : 1469 : if (len > slen)
1876 : 1321 : gfc_wide_memset (&s[slen], ' ', len - slen);
1877 : :
1878 : 1469 : if (warn_character_truncation && slen > len)
1879 : 1 : gfc_warning_now (OPT_Wcharacter_truncation,
1880 : : "CHARACTER expression at %L is being truncated "
1881 : : "(%ld/%ld)", &expr->where,
1882 : : (long) slen, (long) len);
1883 : :
1884 : : /* Apply the standard by 'hand' otherwise it gets cleared for
1885 : : initializers. */
1886 : 1469 : if (check_len != -1 && slen != check_len
1887 : 6 : && !(gfc_option.allow_std & GFC_STD_GNU))
1888 : 0 : gfc_error_now ("The CHARACTER elements of the array constructor "
1889 : : "at %L must have the same length (%ld/%ld)",
1890 : : &expr->where, (long) slen,
1891 : : (long) check_len);
1892 : :
1893 : 1469 : s[len] = '\0';
1894 : 1469 : free (expr->value.character.string);
1895 : 1469 : expr->value.character.string = s;
1896 : 1469 : expr->value.character.length = len;
1897 : : /* If explicit representation was given, clear it
1898 : : as it is no longer needed after padding. */
1899 : 1469 : if (expr->representation.length)
1900 : : {
1901 : 80 : expr->representation.length = 0;
1902 : 80 : free (expr->representation.string);
1903 : 80 : expr->representation.string = NULL;
1904 : : }
1905 : : }
1906 : : }
1907 : :
1908 : :
1909 : : /* Function to create and update the enumerator history
1910 : : using the information passed as arguments.
1911 : : Pointer "max_enum" is also updated, to point to
1912 : : enum history node containing largest initializer.
1913 : :
1914 : : SYM points to the symbol node of enumerator.
1915 : : INIT points to its enumerator value. */
1916 : :
1917 : : static void
1918 : 543 : create_enum_history (gfc_symbol *sym, gfc_expr *init)
1919 : : {
1920 : 543 : enumerator_history *new_enum_history;
1921 : 543 : gcc_assert (sym != NULL && init != NULL);
1922 : :
1923 : 543 : new_enum_history = XCNEW (enumerator_history);
1924 : :
1925 : 543 : new_enum_history->sym = sym;
1926 : 543 : new_enum_history->initializer = init;
1927 : 543 : new_enum_history->next = NULL;
1928 : :
1929 : 543 : if (enum_history == NULL)
1930 : : {
1931 : 160 : enum_history = new_enum_history;
1932 : 160 : max_enum = enum_history;
1933 : : }
1934 : : else
1935 : : {
1936 : 383 : new_enum_history->next = enum_history;
1937 : 383 : enum_history = new_enum_history;
1938 : :
1939 : 383 : if (mpz_cmp (max_enum->initializer->value.integer,
1940 : 383 : new_enum_history->initializer->value.integer) < 0)
1941 : 381 : max_enum = new_enum_history;
1942 : : }
1943 : 543 : }
1944 : :
1945 : :
1946 : : /* Function to free enum kind history. */
1947 : :
1948 : : void
1949 : 175 : gfc_free_enum_history (void)
1950 : : {
1951 : 175 : enumerator_history *current = enum_history;
1952 : 175 : enumerator_history *next;
1953 : :
1954 : 718 : while (current != NULL)
1955 : : {
1956 : 543 : next = current->next;
1957 : 543 : free (current);
1958 : 543 : current = next;
1959 : : }
1960 : 175 : max_enum = NULL;
1961 : 175 : enum_history = NULL;
1962 : 175 : }
1963 : :
1964 : :
1965 : : /* Function to fix initializer character length if the length of the
1966 : : symbol or component is constant. */
1967 : :
1968 : : static bool
1969 : 2523 : fix_initializer_charlen (gfc_typespec *ts, gfc_expr *init)
1970 : : {
1971 : 2523 : if (!gfc_specification_expr (ts->u.cl->length))
1972 : : return false;
1973 : :
1974 : 2523 : int k = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
1975 : :
1976 : : /* resolve_charlen will complain later on if the length
1977 : : is too large. Just skip the initialization in that case. */
1978 : 2523 : if (mpz_cmp (ts->u.cl->length->value.integer,
1979 : 2523 : gfc_integer_kinds[k].huge) <= 0)
1980 : : {
1981 : 2522 : HOST_WIDE_INT len
1982 : 2522 : = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
1983 : :
1984 : 2522 : if (init->expr_type == EXPR_CONSTANT)
1985 : 1828 : gfc_set_constant_character_len (len, init, -1);
1986 : 694 : else if (init->expr_type == EXPR_ARRAY)
1987 : : {
1988 : 693 : gfc_constructor *cons;
1989 : :
1990 : : /* Build a new charlen to prevent simplification from
1991 : : deleting the length before it is resolved. */
1992 : 693 : init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1993 : 693 : init->ts.u.cl->length = gfc_copy_expr (ts->u.cl->length);
1994 : 693 : cons = gfc_constructor_first (init->value.constructor);
1995 : 4632 : for (; cons; cons = gfc_constructor_next (cons))
1996 : 3246 : gfc_set_constant_character_len (len, cons->expr, -1);
1997 : : }
1998 : : }
1999 : :
2000 : : return true;
2001 : : }
2002 : :
2003 : :
2004 : : /* Function called by variable_decl() that adds an initialization
2005 : : expression to a symbol. */
2006 : :
2007 : : static bool
2008 : 232455 : add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
2009 : : {
2010 : 232455 : symbol_attribute attr;
2011 : 232455 : gfc_symbol *sym;
2012 : 232455 : gfc_expr *init;
2013 : :
2014 : 232455 : init = *initp;
2015 : 232455 : if (find_special (name, &sym, false))
2016 : : return false;
2017 : :
2018 : 232455 : attr = sym->attr;
2019 : :
2020 : : /* If this symbol is confirming an implicit parameter type,
2021 : : then an initialization expression is not allowed. */
2022 : 232455 : if (attr.flavor == FL_PARAMETER && sym->value != NULL)
2023 : : {
2024 : 1 : if (*initp != NULL)
2025 : : {
2026 : 0 : gfc_error ("Initializer not allowed for PARAMETER %qs at %C",
2027 : : sym->name);
2028 : 0 : return false;
2029 : : }
2030 : : else
2031 : : return true;
2032 : : }
2033 : :
2034 : 232454 : if (init == NULL)
2035 : : {
2036 : : /* An initializer is required for PARAMETER declarations. */
2037 : 205418 : if (attr.flavor == FL_PARAMETER)
2038 : : {
2039 : 1 : gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
2040 : 1 : return false;
2041 : : }
2042 : : }
2043 : : else
2044 : : {
2045 : : /* If a variable appears in a DATA block, it cannot have an
2046 : : initializer. */
2047 : 27036 : if (sym->attr.data)
2048 : : {
2049 : 0 : gfc_error ("Variable %qs at %C with an initializer already "
2050 : : "appears in a DATA statement", sym->name);
2051 : 0 : return false;
2052 : : }
2053 : :
2054 : : /* Check if the assignment can happen. This has to be put off
2055 : : until later for derived type variables and procedure pointers. */
2056 : 26003 : if (!gfc_bt_struct (sym->ts.type) && !gfc_bt_struct (init->ts.type)
2057 : 25980 : && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
2058 : 25930 : && !sym->attr.proc_pointer
2059 : 52883 : && !gfc_check_assign_symbol (sym, NULL, init))
2060 : : return false;
2061 : :
2062 : 27005 : if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
2063 : 3061 : && init->ts.type == BT_CHARACTER)
2064 : : {
2065 : : /* Update symbol character length according initializer. */
2066 : 2987 : if (!gfc_check_assign_symbol (sym, NULL, init))
2067 : : return false;
2068 : :
2069 : 2987 : if (sym->ts.u.cl->length == NULL)
2070 : : {
2071 : 767 : gfc_charlen_t clen;
2072 : : /* If there are multiple CHARACTER variables declared on the
2073 : : same line, we don't want them to share the same length. */
2074 : 767 : sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2075 : :
2076 : 767 : if (sym->attr.flavor == FL_PARAMETER)
2077 : : {
2078 : 758 : if (init->expr_type == EXPR_CONSTANT)
2079 : : {
2080 : 519 : clen = init->value.character.length;
2081 : 519 : sym->ts.u.cl->length
2082 : 519 : = gfc_get_int_expr (gfc_charlen_int_kind,
2083 : : NULL, clen);
2084 : : }
2085 : 239 : else if (init->expr_type == EXPR_ARRAY)
2086 : : {
2087 : 239 : if (init->ts.u.cl && init->ts.u.cl->length)
2088 : : {
2089 : 227 : const gfc_expr *length = init->ts.u.cl->length;
2090 : 227 : if (length->expr_type != EXPR_CONSTANT)
2091 : : {
2092 : 1 : gfc_error ("Cannot initialize parameter array "
2093 : : "at %L "
2094 : : "with variable length elements",
2095 : : &sym->declared_at);
2096 : 1 : return false;
2097 : : }
2098 : 226 : clen = mpz_get_si (length->value.integer);
2099 : 226 : }
2100 : 12 : else if (init->value.constructor)
2101 : : {
2102 : 12 : gfc_constructor *c;
2103 : 12 : c = gfc_constructor_first (init->value.constructor);
2104 : 12 : clen = c->expr->value.character.length;
2105 : : }
2106 : : else
2107 : 0 : gcc_unreachable ();
2108 : 238 : sym->ts.u.cl->length
2109 : 238 : = gfc_get_int_expr (gfc_charlen_int_kind,
2110 : : NULL, clen);
2111 : : }
2112 : 0 : else if (init->ts.u.cl && init->ts.u.cl->length)
2113 : 0 : sym->ts.u.cl->length =
2114 : 0 : gfc_copy_expr (init->ts.u.cl->length);
2115 : : }
2116 : : }
2117 : : /* Update initializer character length according to symbol. */
2118 : 2220 : else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT
2119 : 2220 : && !fix_initializer_charlen (&sym->ts, init))
2120 : : return false;
2121 : : }
2122 : :
2123 : 27004 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension && sym->as
2124 : 2776 : && sym->as->rank && init->rank && init->rank != sym->as->rank)
2125 : : {
2126 : 3 : gfc_error ("Rank mismatch of array at %L and its initializer "
2127 : : "(%d/%d)", &sym->declared_at, sym->as->rank, init->rank);
2128 : 3 : return false;
2129 : : }
2130 : :
2131 : : /* If sym is implied-shape, set its upper bounds from init. */
2132 : 27001 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2133 : 2773 : && sym->as->type == AS_IMPLIED_SHAPE)
2134 : : {
2135 : 411 : int dim;
2136 : :
2137 : 411 : if (init->rank == 0)
2138 : : {
2139 : 1 : gfc_error ("Cannot initialize implied-shape array at %L"
2140 : : " with scalar", &sym->declared_at);
2141 : 1 : return false;
2142 : : }
2143 : :
2144 : : /* The shape may be NULL for EXPR_ARRAY, set it. */
2145 : 410 : if (init->shape == NULL)
2146 : : {
2147 : 5 : if (init->expr_type != EXPR_ARRAY)
2148 : : {
2149 : 2 : gfc_error ("Bad shape of initializer at %L", &init->where);
2150 : 2 : return false;
2151 : : }
2152 : :
2153 : 3 : init->shape = gfc_get_shape (1);
2154 : 3 : if (!gfc_array_size (init, &init->shape[0]))
2155 : : {
2156 : 1 : gfc_error ("Cannot determine shape of initializer at %L",
2157 : : &init->where);
2158 : 1 : free (init->shape);
2159 : 1 : init->shape = NULL;
2160 : 1 : return false;
2161 : : }
2162 : : }
2163 : :
2164 : 903 : for (dim = 0; dim < sym->as->rank; ++dim)
2165 : : {
2166 : 497 : int k;
2167 : 497 : gfc_expr *e, *lower;
2168 : :
2169 : 497 : lower = sym->as->lower[dim];
2170 : :
2171 : : /* If the lower bound is an array element from another
2172 : : parameterized array, then it is marked with EXPR_VARIABLE and
2173 : : is an initialization expression. Try to reduce it. */
2174 : 497 : if (lower->expr_type == EXPR_VARIABLE)
2175 : 7 : gfc_reduce_init_expr (lower);
2176 : :
2177 : 497 : if (lower->expr_type == EXPR_CONSTANT)
2178 : : {
2179 : : /* All dimensions must be without upper bound. */
2180 : 496 : gcc_assert (!sym->as->upper[dim]);
2181 : :
2182 : 496 : k = lower->ts.kind;
2183 : 496 : e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
2184 : 496 : mpz_add (e->value.integer, lower->value.integer,
2185 : 496 : init->shape[dim]);
2186 : 496 : mpz_sub_ui (e->value.integer, e->value.integer, 1);
2187 : 496 : sym->as->upper[dim] = e;
2188 : : }
2189 : : else
2190 : : {
2191 : 1 : gfc_error ("Non-constant lower bound in implied-shape"
2192 : : " declaration at %L", &lower->where);
2193 : 1 : return false;
2194 : : }
2195 : : }
2196 : :
2197 : 406 : sym->as->type = AS_EXPLICIT;
2198 : : }
2199 : :
2200 : : /* Ensure that explicit bounds are simplified. */
2201 : 26996 : if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
2202 : 2768 : && sym->as->type == AS_EXPLICIT)
2203 : : {
2204 : 6202 : for (int dim = 0; dim < sym->as->rank; ++dim)
2205 : : {
2206 : 3446 : gfc_expr *e;
2207 : :
2208 : 3446 : e = sym->as->lower[dim];
2209 : 3446 : if (e->expr_type != EXPR_CONSTANT)
2210 : 12 : gfc_reduce_init_expr (e);
2211 : :
2212 : 3446 : e = sym->as->upper[dim];
2213 : 3446 : if (e->expr_type != EXPR_CONSTANT)
2214 : 96 : gfc_reduce_init_expr (e);
2215 : : }
2216 : : }
2217 : :
2218 : : /* Need to check if the expression we initialized this
2219 : : to was one of the iso_c_binding named constants. If so,
2220 : : and we're a parameter (constant), let it be iso_c.
2221 : : For example:
2222 : : integer(c_int), parameter :: my_int = c_int
2223 : : integer(my_int) :: my_int_2
2224 : : If we mark my_int as iso_c (since we can see it's value
2225 : : is equal to one of the named constants), then my_int_2
2226 : : will be considered C interoperable. */
2227 : 26996 : if (sym->ts.type != BT_CHARACTER && !gfc_bt_struct (sym->ts.type))
2228 : : {
2229 : 22906 : sym->ts.is_iso_c |= init->ts.is_iso_c;
2230 : 22906 : sym->ts.is_c_interop |= init->ts.is_c_interop;
2231 : : /* attr bits needed for module files. */
2232 : 22906 : sym->attr.is_iso_c |= init->ts.is_iso_c;
2233 : 22906 : sym->attr.is_c_interop |= init->ts.is_c_interop;
2234 : 22906 : if (init->ts.is_iso_c)
2235 : 69 : sym->ts.f90_type = init->ts.f90_type;
2236 : : }
2237 : :
2238 : : /* Catch the case: type(t), parameter :: x = z'1'. */
2239 : 26996 : if (sym->ts.type == BT_DERIVED && init->ts.type == BT_BOZ)
2240 : : {
2241 : 1 : gfc_error ("Entity %qs at %L is incompatible with a BOZ "
2242 : : "literal constant", name, &sym->declared_at);
2243 : 1 : return false;
2244 : : }
2245 : :
2246 : : /* Add initializer. Make sure we keep the ranks sane. */
2247 : 26995 : if (sym->attr.dimension && init->rank == 0)
2248 : : {
2249 : 1124 : mpz_t size;
2250 : 1124 : gfc_expr *array;
2251 : 1124 : int n;
2252 : 1124 : if (sym->attr.flavor == FL_PARAMETER
2253 : 448 : && gfc_is_constant_expr (init)
2254 : 448 : && (init->expr_type == EXPR_CONSTANT
2255 : 31 : || init->expr_type == EXPR_STRUCTURE)
2256 : 1572 : && spec_size (sym->as, &size))
2257 : : {
2258 : 444 : array = gfc_get_array_expr (init->ts.type, init->ts.kind,
2259 : : &init->where);
2260 : 444 : if (init->ts.type == BT_DERIVED)
2261 : 31 : array->ts.u.derived = init->ts.u.derived;
2262 : 67579 : for (n = 0; n < (int)mpz_get_si (size); n++)
2263 : 133967 : gfc_constructor_append_expr (&array->value.constructor,
2264 : : n == 0
2265 : : ? init
2266 : 66832 : : gfc_copy_expr (init),
2267 : : &init->where);
2268 : :
2269 : 444 : array->shape = gfc_get_shape (sym->as->rank);
2270 : 1014 : for (n = 0; n < sym->as->rank; n++)
2271 : 570 : spec_dimen_size (sym->as, n, &array->shape[n]);
2272 : :
2273 : 444 : init = array;
2274 : 444 : mpz_clear (size);
2275 : : }
2276 : 1124 : init->rank = sym->as->rank;
2277 : : }
2278 : :
2279 : 26995 : sym->value = init;
2280 : 26995 : if (sym->attr.save == SAVE_NONE)
2281 : 22975 : sym->attr.save = SAVE_IMPLICIT;
2282 : 26995 : *initp = NULL;
2283 : : }
2284 : :
2285 : : return true;
2286 : : }
2287 : :
2288 : :
2289 : : /* Function called by variable_decl() that adds a name to a structure
2290 : : being built. */
2291 : :
2292 : : static bool
2293 : 15957 : build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
2294 : : gfc_array_spec **as)
2295 : : {
2296 : 15957 : gfc_state_data *s;
2297 : 15957 : gfc_component *c;
2298 : :
2299 : : /* F03:C438/C439. If the current symbol is of the same derived type that we're
2300 : : constructing, it must have the pointer attribute. */
2301 : 15957 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
2302 : 2878 : && current_ts.u.derived == gfc_current_block ()
2303 : 217 : && current_attr.pointer == 0)
2304 : : {
2305 : 48 : if (current_attr.allocatable
2306 : 48 : && !gfc_notify_std(GFC_STD_F2008, "Component at %C "
2307 : : "must have the POINTER attribute"))
2308 : : {
2309 : : return false;
2310 : : }
2311 : 47 : else if (current_attr.allocatable == 0)
2312 : : {
2313 : 0 : gfc_error ("Component at %C must have the POINTER attribute");
2314 : 0 : return false;
2315 : : }
2316 : : }
2317 : :
2318 : : /* F03:C437. */
2319 : 15956 : if (current_ts.type == BT_CLASS
2320 : 729 : && !(current_attr.pointer || current_attr.allocatable))
2321 : : {
2322 : 5 : gfc_error ("Component %qs with CLASS at %C must be allocatable "
2323 : : "or pointer", name);
2324 : 5 : return false;
2325 : : }
2326 : :
2327 : 15951 : if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
2328 : : {
2329 : 0 : if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
2330 : : {
2331 : 0 : gfc_error ("Array component of structure at %C must have explicit "
2332 : : "or deferred shape");
2333 : 0 : return false;
2334 : : }
2335 : : }
2336 : :
2337 : : /* If we are in a nested union/map definition, gfc_add_component will not
2338 : : properly find repeated components because:
2339 : : (i) gfc_add_component does a flat search, where components of unions
2340 : : and maps are implicity chained so nested components may conflict.
2341 : : (ii) Unions and maps are not linked as components of their parent
2342 : : structures until after they are parsed.
2343 : : For (i) we use gfc_find_component which searches recursively, and for (ii)
2344 : : we search each block directly from the parse stack until we find the top
2345 : : level structure. */
2346 : :
2347 : 15951 : s = gfc_state_stack;
2348 : 15951 : if (s->state == COMP_UNION || s->state == COMP_MAP)
2349 : : {
2350 : 1434 : while (s->state == COMP_UNION || gfc_comp_struct (s->state))
2351 : : {
2352 : 1434 : c = gfc_find_component (s->sym, name, true, true, NULL);
2353 : 1434 : if (c != NULL)
2354 : : {
2355 : 0 : gfc_error_now ("Component %qs at %C already declared at %L",
2356 : : name, &c->loc);
2357 : 0 : return false;
2358 : : }
2359 : : /* Break after we've searched the entire chain. */
2360 : 1434 : if (s->state == COMP_DERIVED || s->state == COMP_STRUCTURE)
2361 : : break;
2362 : 1000 : s = s->previous;
2363 : : }
2364 : : }
2365 : :
2366 : 15951 : if (!gfc_add_component (gfc_current_block(), name, &c))
2367 : : return false;
2368 : :
2369 : 15945 : c->ts = current_ts;
2370 : 15945 : if (c->ts.type == BT_CHARACTER)
2371 : 1822 : c->ts.u.cl = cl;
2372 : :
2373 : 15945 : if (c->ts.type != BT_CLASS && c->ts.type != BT_DERIVED
2374 : 13073 : && (c->ts.kind == 0 || c->ts.type == BT_CHARACTER)
2375 : 1899 : && saved_kind_expr != NULL)
2376 : 91 : c->kind_expr = gfc_copy_expr (saved_kind_expr);
2377 : :
2378 : 15945 : c->attr = current_attr;
2379 : :
2380 : 15945 : c->initializer = *init;
2381 : 15945 : *init = NULL;
2382 : :
2383 : : /* Update initializer character length according to component. */
2384 : 1822 : if (c->ts.type == BT_CHARACTER && c->ts.u.cl->length
2385 : 1461 : && c->ts.u.cl->length->expr_type == EXPR_CONSTANT
2386 : 1415 : && c->initializer && c->initializer->ts.type == BT_CHARACTER
2387 : 16251 : && !fix_initializer_charlen (&c->ts, c->initializer))
2388 : : return false;
2389 : :
2390 : 15945 : c->as = *as;
2391 : 15945 : if (c->as != NULL)
2392 : : {
2393 : 4027 : if (c->as->corank)
2394 : 91 : c->attr.codimension = 1;
2395 : 4027 : if (c->as->rank)
2396 : 3958 : c->attr.dimension = 1;
2397 : : }
2398 : 15945 : *as = NULL;
2399 : :
2400 : 15945 : gfc_apply_init (&c->ts, &c->attr, c->initializer);
2401 : :
2402 : : /* Check array components. */
2403 : 15945 : if (!c->attr.dimension)
2404 : 11987 : goto scalar;
2405 : :
2406 : 3958 : if (c->attr.pointer)
2407 : : {
2408 : 615 : if (c->as->type != AS_DEFERRED)
2409 : : {
2410 : 5 : gfc_error ("Pointer array component of structure at %C must have a "
2411 : : "deferred shape");
2412 : 5 : return false;
2413 : : }
2414 : : }
2415 : 3343 : else if (c->attr.allocatable)
2416 : : {
2417 : 1872 : if (c->as->type != AS_DEFERRED)
2418 : : {
2419 : 12 : gfc_error ("Allocatable component of structure at %C must have a "
2420 : : "deferred shape");
2421 : 12 : return false;
2422 : : }
2423 : : }
2424 : : else
2425 : : {
2426 : 1471 : if (c->as->type != AS_EXPLICIT)
2427 : : {
2428 : 7 : gfc_error ("Array component of structure at %C must have an "
2429 : : "explicit shape");
2430 : 7 : return false;
2431 : : }
2432 : : }
2433 : :
2434 : 1464 : scalar:
2435 : 15921 : if (c->ts.type == BT_CLASS)
2436 : 719 : return gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
2437 : :
2438 : 15202 : if (c->attr.pdt_kind || c->attr.pdt_len)
2439 : : {
2440 : 310 : gfc_symbol *sym;
2441 : 310 : gfc_find_symbol (c->name, gfc_current_block ()->f2k_derived,
2442 : : 0, &sym);
2443 : 310 : if (sym == NULL)
2444 : : {
2445 : 0 : gfc_error ("Type parameter %qs at %C has no corresponding entry "
2446 : : "in the type parameter name list at %L",
2447 : 0 : c->name, &gfc_current_block ()->declared_at);
2448 : 0 : return false;
2449 : : }
2450 : 310 : sym->ts = c->ts;
2451 : 310 : sym->attr.pdt_kind = c->attr.pdt_kind;
2452 : 310 : sym->attr.pdt_len = c->attr.pdt_len;
2453 : 310 : if (c->initializer)
2454 : 104 : sym->value = gfc_copy_expr (c->initializer);
2455 : 310 : sym->attr.flavor = FL_VARIABLE;
2456 : : }
2457 : :
2458 : 15202 : if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS)
2459 : 2148 : && c->ts.u.derived && c->ts.u.derived->attr.pdt_template
2460 : 39 : && decl_type_param_list)
2461 : 39 : c->param_list = gfc_copy_actual_arglist (decl_type_param_list);
2462 : :
2463 : : return true;
2464 : : }
2465 : :
2466 : :
2467 : : /* Match a 'NULL()', and possibly take care of some side effects. */
2468 : :
2469 : : match
2470 : 1488 : gfc_match_null (gfc_expr **result)
2471 : : {
2472 : 1488 : gfc_symbol *sym;
2473 : 1488 : match m, m2 = MATCH_NO;
2474 : :
2475 : 1488 : if ((m = gfc_match (" null ( )")) == MATCH_ERROR)
2476 : : return MATCH_ERROR;
2477 : :
2478 : 1488 : if (m == MATCH_NO)
2479 : : {
2480 : 499 : locus old_loc;
2481 : 499 : char name[GFC_MAX_SYMBOL_LEN + 1];
2482 : :
2483 : 499 : if ((m2 = gfc_match (" null (")) != MATCH_YES)
2484 : 493 : return m2;
2485 : :
2486 : 6 : old_loc = gfc_current_locus;
2487 : 6 : if ((m2 = gfc_match (" %n ) ", name)) == MATCH_ERROR)
2488 : : return MATCH_ERROR;
2489 : 6 : if (m2 != MATCH_YES
2490 : 6 : && ((m2 = gfc_match (" mold = %n )", name)) == MATCH_ERROR))
2491 : : return MATCH_ERROR;
2492 : 6 : if (m2 == MATCH_NO)
2493 : : {
2494 : 0 : gfc_current_locus = old_loc;
2495 : 0 : return MATCH_NO;
2496 : : }
2497 : : }
2498 : :
2499 : : /* The NULL symbol now has to be/become an intrinsic function. */
2500 : 995 : if (gfc_get_symbol ("null", NULL, &sym))
2501 : : {
2502 : 0 : gfc_error ("NULL() initialization at %C is ambiguous");
2503 : 0 : return MATCH_ERROR;
2504 : : }
2505 : :
2506 : 995 : gfc_intrinsic_symbol (sym);
2507 : :
2508 : 995 : if (sym->attr.proc != PROC_INTRINSIC
2509 : 741 : && !(sym->attr.use_assoc && sym->attr.intrinsic)
2510 : 1735 : && (!gfc_add_procedure(&sym->attr, PROC_INTRINSIC, sym->name, NULL)
2511 : 740 : || !gfc_add_function (&sym->attr, sym->name, NULL)))
2512 : 0 : return MATCH_ERROR;
2513 : :
2514 : 995 : *result = gfc_get_null_expr (&gfc_current_locus);
2515 : :
2516 : : /* Invalid per F2008, C512. */
2517 : 995 : if (m2 == MATCH_YES)
2518 : : {
2519 : 6 : gfc_error ("NULL() initialization at %C may not have MOLD");
2520 : 6 : return MATCH_ERROR;
2521 : : }
2522 : :
2523 : : return MATCH_YES;
2524 : : }
2525 : :
2526 : :
2527 : : /* Match the initialization expr for a data pointer or procedure pointer. */
2528 : :
2529 : : static match
2530 : 1156 : match_pointer_init (gfc_expr **init, int procptr)
2531 : : {
2532 : 1156 : match m;
2533 : :
2534 : 1156 : if (gfc_pure (NULL) && !gfc_comp_struct (gfc_state_stack->state))
2535 : : {
2536 : 1 : gfc_error ("Initialization of pointer at %C is not allowed in "
2537 : : "a PURE procedure");
2538 : 1 : return MATCH_ERROR;
2539 : : }
2540 : 1155 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
2541 : :
2542 : : /* Match NULL() initialization. */
2543 : 1155 : m = gfc_match_null (init);
2544 : 1155 : if (m != MATCH_NO)
2545 : : return m;
2546 : :
2547 : : /* Match non-NULL initialization. */
2548 : 168 : gfc_matching_ptr_assignment = !procptr;
2549 : 168 : gfc_matching_procptr_assignment = procptr;
2550 : 168 : m = gfc_match_rvalue (init);
2551 : 168 : gfc_matching_ptr_assignment = 0;
2552 : 168 : gfc_matching_procptr_assignment = 0;
2553 : 168 : if (m == MATCH_ERROR)
2554 : : return MATCH_ERROR;
2555 : 167 : else if (m == MATCH_NO)
2556 : : {
2557 : 2 : gfc_error ("Error in pointer initialization at %C");
2558 : 2 : return MATCH_ERROR;
2559 : : }
2560 : :
2561 : 165 : if (!procptr && !gfc_resolve_expr (*init))
2562 : : return MATCH_ERROR;
2563 : :
2564 : 164 : if (!gfc_notify_std (GFC_STD_F2008, "non-NULL pointer "
2565 : : "initialization at %C"))
2566 : : return MATCH_ERROR;
2567 : :
2568 : : return MATCH_YES;
2569 : : }
2570 : :
2571 : :
2572 : : static bool
2573 : 252226 : check_function_name (char *name)
2574 : : {
2575 : : /* In functions that have a RESULT variable defined, the function name always
2576 : : refers to function calls. Therefore, the name is not allowed to appear in
2577 : : specification statements. When checking this, be careful about
2578 : : 'hidden' procedure pointer results ('ppr@'). */
2579 : :
2580 : 252226 : if (gfc_current_state () == COMP_FUNCTION)
2581 : : {
2582 : 40144 : gfc_symbol *block = gfc_current_block ();
2583 : 40144 : if (block && block->result && block->result != block
2584 : 13480 : && strcmp (block->result->name, "ppr@") != 0
2585 : 13421 : && strcmp (block->name, name) == 0)
2586 : : {
2587 : 9 : gfc_error ("RESULT variable %qs at %L prohibits FUNCTION name %qs at %C "
2588 : : "from appearing in a specification statement",
2589 : : block->result->name, &block->result->declared_at, name);
2590 : 9 : return false;
2591 : : }
2592 : : }
2593 : :
2594 : : return true;
2595 : : }
2596 : :
2597 : :
2598 : : /* Match a variable name with an optional initializer. When this
2599 : : subroutine is called, a variable is expected to be parsed next.
2600 : : Depending on what is happening at the moment, updates either the
2601 : : symbol table or the current interface. */
2602 : :
2603 : : static match
2604 : 242825 : variable_decl (int elem)
2605 : : {
2606 : 242825 : char name[GFC_MAX_SYMBOL_LEN + 1];
2607 : 242825 : static unsigned int fill_id = 0;
2608 : 242825 : gfc_expr *initializer, *char_len;
2609 : 242825 : gfc_array_spec *as;
2610 : 242825 : gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */
2611 : 242825 : gfc_charlen *cl;
2612 : 242825 : bool cl_deferred;
2613 : 242825 : locus var_locus;
2614 : 242825 : match m;
2615 : 242825 : bool t;
2616 : 242825 : gfc_symbol *sym;
2617 : 242825 : char c;
2618 : :
2619 : 242825 : initializer = NULL;
2620 : 242825 : as = NULL;
2621 : 242825 : cp_as = NULL;
2622 : :
2623 : : /* When we get here, we've just matched a list of attributes and
2624 : : maybe a type and a double colon. The next thing we expect to see
2625 : : is the name of the symbol. */
2626 : :
2627 : : /* If we are parsing a structure with legacy support, we allow the symbol
2628 : : name to be '%FILL' which gives it an anonymous (inaccessible) name. */
2629 : 242825 : m = MATCH_NO;
2630 : 242825 : gfc_gobble_whitespace ();
2631 : 242825 : c = gfc_peek_ascii_char ();
2632 : 242825 : if (c == '%')
2633 : : {
2634 : 12 : gfc_next_ascii_char (); /* Burn % character. */
2635 : 12 : m = gfc_match ("fill");
2636 : 12 : if (m == MATCH_YES)
2637 : : {
2638 : 11 : if (gfc_current_state () != COMP_STRUCTURE)
2639 : : {
2640 : 2 : if (flag_dec_structure)
2641 : 1 : gfc_error ("%qs not allowed outside STRUCTURE at %C", "%FILL");
2642 : : else
2643 : 1 : gfc_error ("%qs at %C is a DEC extension, enable with "
2644 : : "%<-fdec-structure%>", "%FILL");
2645 : 2 : m = MATCH_ERROR;
2646 : 2 : goto cleanup;
2647 : : }
2648 : :
2649 : 9 : if (attr_seen)
2650 : : {
2651 : 1 : gfc_error ("%qs entity cannot have attributes at %C", "%FILL");
2652 : 1 : m = MATCH_ERROR;
2653 : 1 : goto cleanup;
2654 : : }
2655 : :
2656 : : /* %FILL components are given invalid fortran names. */
2657 : 8 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "%%FILL%u", fill_id++);
2658 : : }
2659 : : else
2660 : : {
2661 : 1 : gfc_error ("Invalid character %qc in variable name at %C", c);
2662 : 1 : return MATCH_ERROR;
2663 : : }
2664 : : }
2665 : : else
2666 : : {
2667 : 242813 : m = gfc_match_name (name);
2668 : 242812 : if (m != MATCH_YES)
2669 : 10 : goto cleanup;
2670 : : }
2671 : :
2672 : 242810 : var_locus = gfc_current_locus;
2673 : :
2674 : : /* Now we could see the optional array spec. or character length. */
2675 : 242810 : m = gfc_match_array_spec (&as, true, true);
2676 : 242809 : if (m == MATCH_ERROR)
2677 : 56 : goto cleanup;
2678 : :
2679 : 242753 : if (m == MATCH_NO)
2680 : 193109 : as = gfc_copy_array_spec (current_as);
2681 : 49644 : else if (current_as
2682 : 49644 : && !merge_array_spec (current_as, as, true))
2683 : : {
2684 : 4 : m = MATCH_ERROR;
2685 : 4 : goto cleanup;
2686 : : }
2687 : :
2688 : 242749 : if (flag_cray_pointer)
2689 : 3063 : cp_as = gfc_copy_array_spec (as);
2690 : :
2691 : : /* At this point, we know for sure if the symbol is PARAMETER and can thus
2692 : : determine (and check) whether it can be implied-shape. If it
2693 : : was parsed as assumed-size, change it because PARAMETERs cannot
2694 : : be assumed-size.
2695 : :
2696 : : An explicit-shape-array cannot appear under several conditions.
2697 : : That check is done here as well. */
2698 : 242749 : if (as)
2699 : : {
2700 : 70380 : if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
2701 : : {
2702 : 2 : m = MATCH_ERROR;
2703 : 2 : gfc_error ("Non-PARAMETER symbol %qs at %L cannot be implied-shape",
2704 : : name, &var_locus);
2705 : 2 : goto cleanup;
2706 : : }
2707 : :
2708 : 70378 : if (as->type == AS_ASSUMED_SIZE && as->rank == 1
2709 : 5085 : && current_attr.flavor == FL_PARAMETER)
2710 : 375 : as->type = AS_IMPLIED_SHAPE;
2711 : :
2712 : 70378 : if (as->type == AS_IMPLIED_SHAPE
2713 : 70378 : && !gfc_notify_std (GFC_STD_F2008, "Implied-shape array at %L",
2714 : : &var_locus))
2715 : : {
2716 : 1 : m = MATCH_ERROR;
2717 : 1 : goto cleanup;
2718 : : }
2719 : :
2720 : 70377 : gfc_seen_div0 = false;
2721 : :
2722 : : /* F2018:C830 (R816) An explicit-shape-spec whose bounds are not
2723 : : constant expressions shall appear only in a subprogram, derived
2724 : : type definition, BLOCK construct, or interface body. */
2725 : 70377 : if (as->type == AS_EXPLICIT
2726 : 36949 : && gfc_current_state () != COMP_BLOCK
2727 : : && gfc_current_state () != COMP_DERIVED
2728 : : && gfc_current_state () != COMP_FUNCTION
2729 : : && gfc_current_state () != COMP_INTERFACE
2730 : : && gfc_current_state () != COMP_SUBROUTINE)
2731 : : {
2732 : : gfc_expr *e;
2733 : 47328 : bool not_constant = false;
2734 : :
2735 : 47328 : for (int i = 0; i < as->rank; i++)
2736 : : {
2737 : 27011 : e = gfc_copy_expr (as->lower[i]);
2738 : 27011 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2739 : : {
2740 : 0 : m = MATCH_ERROR;
2741 : 0 : goto cleanup;
2742 : : }
2743 : :
2744 : 27011 : gfc_simplify_expr (e, 0);
2745 : 27011 : if (e && (e->expr_type != EXPR_CONSTANT))
2746 : : {
2747 : : not_constant = true;
2748 : : break;
2749 : : }
2750 : 27011 : gfc_free_expr (e);
2751 : :
2752 : 27011 : e = gfc_copy_expr (as->upper[i]);
2753 : 27011 : if (!gfc_resolve_expr (e) && gfc_seen_div0)
2754 : : {
2755 : 4 : m = MATCH_ERROR;
2756 : 4 : goto cleanup;
2757 : : }
2758 : :
2759 : 27007 : gfc_simplify_expr (e, 0);
2760 : 27007 : if (e && (e->expr_type != EXPR_CONSTANT))
2761 : : {
2762 : : not_constant = true;
2763 : : break;
2764 : : }
2765 : 26994 : gfc_free_expr (e);
2766 : : }
2767 : :
2768 : 20330 : if (not_constant && e->ts.type != BT_INTEGER)
2769 : : {
2770 : 4 : gfc_error ("Explicit array shape at %C must be constant of "
2771 : : "INTEGER type and not %s type",
2772 : : gfc_basic_typename (e->ts.type));
2773 : 4 : m = MATCH_ERROR;
2774 : 4 : goto cleanup;
2775 : : }
2776 : 9 : if (not_constant)
2777 : : {
2778 : 9 : gfc_error ("Explicit shaped array with nonconstant bounds at %C");
2779 : 9 : m = MATCH_ERROR;
2780 : 9 : goto cleanup;
2781 : : }
2782 : : }
2783 : 70360 : if (as->type == AS_EXPLICIT)
2784 : : {
2785 : 87106 : for (int i = 0; i < as->rank; i++)
2786 : : {
2787 : 50174 : gfc_expr *e, *n;
2788 : 50174 : e = as->lower[i];
2789 : 50174 : if (e->expr_type != EXPR_CONSTANT)
2790 : : {
2791 : 445 : n = gfc_copy_expr (e);
2792 : 445 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2793 : : {
2794 : 0 : m = MATCH_ERROR;
2795 : 0 : goto cleanup;
2796 : : }
2797 : :
2798 : 445 : if (n->expr_type == EXPR_CONSTANT)
2799 : 22 : gfc_replace_expr (e, n);
2800 : : else
2801 : 423 : gfc_free_expr (n);
2802 : : }
2803 : 50174 : e = as->upper[i];
2804 : 50174 : if (e->expr_type != EXPR_CONSTANT)
2805 : : {
2806 : 6207 : n = gfc_copy_expr (e);
2807 : 6207 : if (!gfc_simplify_expr (n, 1) && gfc_seen_div0)
2808 : : {
2809 : 0 : m = MATCH_ERROR;
2810 : 0 : goto cleanup;
2811 : : }
2812 : :
2813 : 6207 : if (n->expr_type == EXPR_CONSTANT)
2814 : 45 : gfc_replace_expr (e, n);
2815 : : else
2816 : 6162 : gfc_free_expr (n);
2817 : : }
2818 : : /* For an explicit-shape spec with constant bounds, ensure
2819 : : that the effective upper bound is not lower than the
2820 : : respective lower bound minus one. Otherwise adjust it so
2821 : : that the extent is trivially derived to be zero. */
2822 : 50174 : if (as->lower[i]->expr_type == EXPR_CONSTANT
2823 : 49751 : && as->upper[i]->expr_type == EXPR_CONSTANT
2824 : 44006 : && as->lower[i]->ts.type == BT_INTEGER
2825 : 44006 : && as->upper[i]->ts.type == BT_INTEGER
2826 : 44001 : && mpz_cmp (as->upper[i]->value.integer,
2827 : 44001 : as->lower[i]->value.integer) < 0)
2828 : 857 : mpz_sub_ui (as->upper[i]->value.integer,
2829 : : as->lower[i]->value.integer, 1);
2830 : : }
2831 : : }
2832 : : }
2833 : :
2834 : 242729 : char_len = NULL;
2835 : 242729 : cl = NULL;
2836 : 242729 : cl_deferred = false;
2837 : :
2838 : 242729 : if (current_ts.type == BT_CHARACTER)
2839 : : {
2840 : 28881 : switch (match_char_length (&char_len, &cl_deferred, false))
2841 : : {
2842 : 435 : case MATCH_YES:
2843 : 435 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2844 : :
2845 : 435 : cl->length = char_len;
2846 : 435 : break;
2847 : :
2848 : : /* Non-constant lengths need to be copied after the first
2849 : : element. Also copy assumed lengths. */
2850 : 28445 : case MATCH_NO:
2851 : 28445 : if (elem > 1
2852 : 3645 : && (current_ts.u.cl->length == NULL
2853 : 2504 : || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
2854 : : {
2855 : 1172 : cl = gfc_new_charlen (gfc_current_ns, NULL);
2856 : 1172 : cl->length = gfc_copy_expr (current_ts.u.cl->length);
2857 : : }
2858 : : else
2859 : 27273 : cl = current_ts.u.cl;
2860 : :
2861 : 28445 : cl_deferred = current_ts.deferred;
2862 : :
2863 : 28445 : break;
2864 : :
2865 : 1 : case MATCH_ERROR:
2866 : 1 : goto cleanup;
2867 : : }
2868 : : }
2869 : :
2870 : : /* The dummy arguments and result of the abbreviated form of MODULE
2871 : : PROCEDUREs, used in SUBMODULES should not be redefined. */
2872 : 242728 : if (gfc_current_ns->proc_name
2873 : 238252 : && gfc_current_ns->proc_name->abr_modproc_decl)
2874 : : {
2875 : 38 : gfc_find_symbol (name, gfc_current_ns, 1, &sym);
2876 : 38 : if (sym != NULL && (sym->attr.dummy || sym->attr.result))
2877 : : {
2878 : 2 : m = MATCH_ERROR;
2879 : 2 : gfc_error ("%qs at %C is a redefinition of the declaration "
2880 : : "in the corresponding interface for MODULE "
2881 : : "PROCEDURE %qs", sym->name,
2882 : 2 : gfc_current_ns->proc_name->name);
2883 : 2 : goto cleanup;
2884 : : }
2885 : : }
2886 : :
2887 : : /* %FILL components may not have initializers. */
2888 : 242726 : if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
2889 : : {
2890 : 1 : gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
2891 : 1 : m = MATCH_ERROR;
2892 : 1 : goto cleanup;
2893 : : }
2894 : :
2895 : : /* If this symbol has already shown up in a Cray Pointer declaration,
2896 : : and this is not a component declaration,
2897 : : then we want to set the type & bail out. */
2898 : 242725 : if (flag_cray_pointer && !gfc_comp_struct (gfc_current_state ()))
2899 : : {
2900 : 2959 : gfc_find_symbol (name, gfc_current_ns, 0, &sym);
2901 : 2959 : if (sym != NULL && sym->attr.cray_pointee)
2902 : : {
2903 : 101 : m = MATCH_YES;
2904 : 101 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
2905 : : {
2906 : 1 : m = MATCH_ERROR;
2907 : 1 : goto cleanup;
2908 : : }
2909 : :
2910 : : /* Check to see if we have an array specification. */
2911 : 100 : if (cp_as != NULL)
2912 : : {
2913 : 49 : if (sym->as != NULL)
2914 : : {
2915 : 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
2916 : 1 : gfc_free_array_spec (cp_as);
2917 : 1 : m = MATCH_ERROR;
2918 : 1 : goto cleanup;
2919 : : }
2920 : : else
2921 : : {
2922 : 48 : if (!gfc_set_array_spec (sym, cp_as, &var_locus))
2923 : 0 : gfc_internal_error ("Cannot set pointee array spec.");
2924 : :
2925 : : /* Fix the array spec. */
2926 : 48 : m = gfc_mod_pointee_as (sym->as);
2927 : 48 : if (m == MATCH_ERROR)
2928 : 0 : goto cleanup;
2929 : : }
2930 : : }
2931 : 99 : goto cleanup;
2932 : : }
2933 : : else
2934 : : {
2935 : 2858 : gfc_free_array_spec (cp_as);
2936 : : }
2937 : : }
2938 : :
2939 : : /* Procedure pointer as function result. */
2940 : 242624 : if (gfc_current_state () == COMP_FUNCTION
2941 : 39135 : && strcmp ("ppr@", gfc_current_block ()->name) == 0
2942 : 25 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
2943 : 7 : strcpy (name, "ppr@");
2944 : :
2945 : 242624 : if (gfc_current_state () == COMP_FUNCTION
2946 : 39135 : && strcmp (name, gfc_current_block ()->name) == 0
2947 : 6926 : && gfc_current_block ()->result
2948 : 6926 : && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
2949 : 16 : strcpy (name, "ppr@");
2950 : :
2951 : : /* OK, we've successfully matched the declaration. Now put the
2952 : : symbol in the current namespace, because it might be used in the
2953 : : optional initialization expression for this symbol, e.g. this is
2954 : : perfectly legal:
2955 : :
2956 : : integer, parameter :: i = huge(i)
2957 : :
2958 : : This is only true for parameters or variables of a basic type.
2959 : : For components of derived types, it is not true, so we don't
2960 : : create a symbol for those yet. If we fail to create the symbol,
2961 : : bail out. */
2962 : 242624 : if (!gfc_comp_struct (gfc_current_state ())
2963 : 226638 : && !build_sym (name, cl, cl_deferred, &as, &var_locus))
2964 : : {
2965 : 44 : m = MATCH_ERROR;
2966 : 44 : goto cleanup;
2967 : : }
2968 : :
2969 : 242580 : if (!check_function_name (name))
2970 : : {
2971 : 0 : m = MATCH_ERROR;
2972 : 0 : goto cleanup;
2973 : : }
2974 : :
2975 : : /* We allow old-style initializations of the form
2976 : : integer i /2/, j(4) /3*3, 1/
2977 : : (if no colon has been seen). These are different from data
2978 : : statements in that initializers are only allowed to apply to the
2979 : : variable immediately preceding, i.e.
2980 : : integer i, j /1, 2/
2981 : : is not allowed. Therefore we have to do some work manually, that
2982 : : could otherwise be left to the matchers for DATA statements. */
2983 : :
2984 : 242580 : if (!colon_seen && gfc_match (" /") == MATCH_YES)
2985 : : {
2986 : 146 : if (!gfc_notify_std (GFC_STD_GNU, "Old-style "
2987 : : "initialization at %C"))
2988 : : return MATCH_ERROR;
2989 : :
2990 : : /* Allow old style initializations for components of STRUCTUREs and MAPs
2991 : : but not components of derived types. */
2992 : 146 : else if (gfc_current_state () == COMP_DERIVED)
2993 : : {
2994 : 2 : gfc_error ("Invalid old style initialization for derived type "
2995 : : "component at %C");
2996 : 2 : m = MATCH_ERROR;
2997 : 2 : goto cleanup;
2998 : : }
2999 : :
3000 : : /* For structure components, read the initializer as a special
3001 : : expression and let the rest of this function apply the initializer
3002 : : as usual. */
3003 : 144 : else if (gfc_comp_struct (gfc_current_state ()))
3004 : : {
3005 : 74 : m = match_clist_expr (&initializer, ¤t_ts, as);
3006 : 74 : if (m == MATCH_NO)
3007 : 0 : gfc_error ("Syntax error in old style initialization of %s at %C",
3008 : : name);
3009 : 74 : if (m != MATCH_YES)
3010 : 14 : goto cleanup;
3011 : : }
3012 : :
3013 : : /* Otherwise we treat the old style initialization just like a
3014 : : DATA declaration for the current variable. */
3015 : : else
3016 : 70 : return match_old_style_init (name);
3017 : : }
3018 : :
3019 : : /* The double colon must be present in order to have initializers.
3020 : : Otherwise the statement is ambiguous with an assignment statement. */
3021 : 242494 : if (colon_seen)
3022 : : {
3023 : 201466 : if (gfc_match (" =>") == MATCH_YES)
3024 : : {
3025 : 1012 : if (!current_attr.pointer)
3026 : : {
3027 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
3028 : 0 : m = MATCH_ERROR;
3029 : 0 : goto cleanup;
3030 : : }
3031 : :
3032 : 1012 : m = match_pointer_init (&initializer, 0);
3033 : 1012 : if (m != MATCH_YES)
3034 : 10 : goto cleanup;
3035 : :
3036 : : /* The target of a pointer initialization must have the SAVE
3037 : : attribute. A variable in PROGRAM, MODULE, or SUBMODULE scope
3038 : : is implicit SAVEd. Explicitly, set the SAVE_IMPLICIT value. */
3039 : 1002 : if (initializer->expr_type == EXPR_VARIABLE
3040 : 126 : && initializer->symtree->n.sym->attr.save == SAVE_NONE
3041 : 25 : && (gfc_current_state () == COMP_PROGRAM
3042 : : || gfc_current_state () == COMP_MODULE
3043 : 25 : || gfc_current_state () == COMP_SUBMODULE))
3044 : 11 : initializer->symtree->n.sym->attr.save = SAVE_IMPLICIT;
3045 : : }
3046 : 200454 : else if (gfc_match_char ('=') == MATCH_YES)
3047 : : {
3048 : 22739 : if (current_attr.pointer)
3049 : : {
3050 : 0 : gfc_error ("Pointer initialization at %C requires %<=>%>, "
3051 : : "not %<=%>");
3052 : 0 : m = MATCH_ERROR;
3053 : 0 : goto cleanup;
3054 : : }
3055 : :
3056 : 22739 : m = gfc_match_init_expr (&initializer);
3057 : 22739 : if (m == MATCH_NO)
3058 : : {
3059 : 0 : gfc_error ("Expected an initialization expression at %C");
3060 : 0 : m = MATCH_ERROR;
3061 : : }
3062 : :
3063 : 8803 : if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
3064 : 22741 : && !gfc_comp_struct (gfc_state_stack->state))
3065 : : {
3066 : 1 : gfc_error ("Initialization of variable at %C is not allowed in "
3067 : : "a PURE procedure");
3068 : 1 : m = MATCH_ERROR;
3069 : : }
3070 : :
3071 : 22739 : if (current_attr.flavor != FL_PARAMETER
3072 : 8803 : && !gfc_comp_struct (gfc_state_stack->state))
3073 : 6691 : gfc_unset_implicit_pure (gfc_current_ns->proc_name);
3074 : :
3075 : 22739 : if (m != MATCH_YES)
3076 : 149 : goto cleanup;
3077 : : }
3078 : : }
3079 : :
3080 : 242335 : if (initializer != NULL && current_attr.allocatable
3081 : 3 : && gfc_comp_struct (gfc_current_state ()))
3082 : : {
3083 : 2 : gfc_error ("Initialization of allocatable component at %C is not "
3084 : : "allowed");
3085 : 2 : m = MATCH_ERROR;
3086 : 2 : goto cleanup;
3087 : : }
3088 : :
3089 : 242333 : if (gfc_current_state () == COMP_DERIVED
3090 : 14944 : && initializer && initializer->ts.type == BT_HOLLERITH)
3091 : : {
3092 : 1 : gfc_error ("Initialization of structure component with a HOLLERITH "
3093 : : "constant at %L is not allowed", &initializer->where);
3094 : 1 : m = MATCH_ERROR;
3095 : 1 : goto cleanup;
3096 : : }
3097 : :
3098 : 242332 : if (gfc_current_state () == COMP_DERIVED
3099 : 14943 : && gfc_current_block ()->attr.pdt_template)
3100 : : {
3101 : 529 : gfc_symbol *param;
3102 : 529 : gfc_find_symbol (name, gfc_current_block ()->f2k_derived,
3103 : : 0, ¶m);
3104 : 529 : if (!param && (current_attr.pdt_kind || current_attr.pdt_len))
3105 : : {
3106 : 1 : gfc_error ("The component with KIND or LEN attribute at %C does not "
3107 : : "not appear in the type parameter list at %L",
3108 : 1 : &gfc_current_block ()->declared_at);
3109 : 1 : m = MATCH_ERROR;
3110 : 4 : goto cleanup;
3111 : : }
3112 : 528 : else if (param && !(current_attr.pdt_kind || current_attr.pdt_len))
3113 : : {
3114 : 1 : gfc_error ("The component at %C that appears in the type parameter "
3115 : : "list at %L has neither the KIND nor LEN attribute",
3116 : 1 : &gfc_current_block ()->declared_at);
3117 : 1 : m = MATCH_ERROR;
3118 : 1 : goto cleanup;
3119 : : }
3120 : 527 : else if (as && (current_attr.pdt_kind || current_attr.pdt_len))
3121 : : {
3122 : 1 : gfc_error ("The component at %C which is a type parameter must be "
3123 : : "a scalar");
3124 : 1 : m = MATCH_ERROR;
3125 : 1 : goto cleanup;
3126 : : }
3127 : 526 : else if (param && initializer)
3128 : : {
3129 : 105 : if (initializer->ts.type == BT_BOZ)
3130 : : {
3131 : 1 : gfc_error ("BOZ literal constant at %L cannot appear as an "
3132 : : "initializer", &initializer->where);
3133 : 1 : m = MATCH_ERROR;
3134 : 1 : goto cleanup;
3135 : : }
3136 : 104 : param->value = gfc_copy_expr (initializer);
3137 : : }
3138 : : }
3139 : :
3140 : : /* Before adding a possible initializer, do a simple check for compatibility
3141 : : of lhs and rhs types. Assigning a REAL value to a derived type is not a
3142 : : good thing. */
3143 : 24002 : if (current_ts.type == BT_DERIVED && initializer
3144 : 243584 : && (gfc_numeric_ts (&initializer->ts)
3145 : 1254 : || initializer->ts.type == BT_LOGICAL
3146 : 1254 : || initializer->ts.type == BT_CHARACTER))
3147 : : {
3148 : 2 : gfc_error ("Incompatible initialization between a derived type "
3149 : : "entity and an entity with %qs type at %C",
3150 : : gfc_typename (initializer));
3151 : 2 : m = MATCH_ERROR;
3152 : 2 : goto cleanup;
3153 : : }
3154 : :
3155 : :
3156 : : /* Add the initializer. Note that it is fine if initializer is
3157 : : NULL here, because we sometimes also need to check if a
3158 : : declaration *must* have an initialization expression. */
3159 : 242326 : if (!gfc_comp_struct (gfc_current_state ()))
3160 : 226369 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
3161 : : else
3162 : : {
3163 : 15957 : if (current_ts.type == BT_DERIVED
3164 : 2148 : && !current_attr.pointer && !initializer)
3165 : 1634 : initializer = gfc_default_initializer (¤t_ts);
3166 : 15957 : t = build_struct (name, cl, &initializer, &as);
3167 : :
3168 : : /* If we match a nested structure definition we expect to see the
3169 : : * body even if the variable declarations blow up, so we need to keep
3170 : : * the structure declaration around. */
3171 : 15957 : if (gfc_new_block && gfc_new_block->attr.flavor == FL_STRUCT)
3172 : 34 : gfc_commit_symbol (gfc_new_block);
3173 : : }
3174 : :
3175 : 242326 : m = (t) ? MATCH_YES : MATCH_ERROR;
3176 : :
3177 : 242752 : cleanup:
3178 : : /* Free stuff up and return. */
3179 : 242752 : gfc_seen_div0 = false;
3180 : 242752 : gfc_free_expr (initializer);
3181 : 242752 : gfc_free_array_spec (as);
3182 : :
3183 : 242752 : return m;
3184 : : }
3185 : :
3186 : :
3187 : : /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
3188 : : This assumes that the byte size is equal to the kind number for
3189 : : non-COMPLEX types, and equal to twice the kind number for COMPLEX. */
3190 : :
3191 : : static match
3192 : 91961 : gfc_match_old_kind_spec (gfc_typespec *ts)
3193 : : {
3194 : 91961 : match m;
3195 : 91961 : int original_kind;
3196 : :
3197 : 91961 : if (gfc_match_char ('*') != MATCH_YES)
3198 : : return MATCH_NO;
3199 : :
3200 : 1151 : m = gfc_match_small_literal_int (&ts->kind, NULL);
3201 : 1151 : if (m != MATCH_YES)
3202 : : return MATCH_ERROR;
3203 : :
3204 : 1151 : original_kind = ts->kind;
3205 : :
3206 : : /* Massage the kind numbers for complex types. */
3207 : 1151 : if (ts->type == BT_COMPLEX)
3208 : : {
3209 : 89 : if (ts->kind % 2)
3210 : : {
3211 : 0 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3212 : : gfc_basic_typename (ts->type), original_kind);
3213 : 0 : return MATCH_ERROR;
3214 : : }
3215 : 89 : ts->kind /= 2;
3216 : :
3217 : : }
3218 : :
3219 : 1151 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3220 : 0 : ts->kind = 8;
3221 : :
3222 : 1151 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3223 : : {
3224 : 859 : if (ts->kind == 4)
3225 : : {
3226 : 217 : if (flag_real4_kind == 8)
3227 : 24 : ts->kind = 8;
3228 : 217 : if (flag_real4_kind == 10)
3229 : 24 : ts->kind = 10;
3230 : 217 : if (flag_real4_kind == 16)
3231 : 24 : ts->kind = 16;
3232 : : }
3233 : 642 : else if (ts->kind == 8)
3234 : : {
3235 : 637 : if (flag_real8_kind == 4)
3236 : 24 : ts->kind = 4;
3237 : 637 : if (flag_real8_kind == 10)
3238 : 24 : ts->kind = 10;
3239 : 637 : if (flag_real8_kind == 16)
3240 : 24 : ts->kind = 16;
3241 : : }
3242 : : }
3243 : :
3244 : 1151 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3245 : : {
3246 : 8 : gfc_error ("Old-style type declaration %s*%d not supported at %C",
3247 : : gfc_basic_typename (ts->type), original_kind);
3248 : 8 : return MATCH_ERROR;
3249 : : }
3250 : :
3251 : 1143 : if (!gfc_notify_std (GFC_STD_GNU,
3252 : : "Nonstandard type declaration %s*%d at %C",
3253 : : gfc_basic_typename(ts->type), original_kind))
3254 : : return MATCH_ERROR;
3255 : :
3256 : : return MATCH_YES;
3257 : : }
3258 : :
3259 : :
3260 : : /* Match a kind specification. Since kinds are generally optional, we
3261 : : usually return MATCH_NO if something goes wrong. If a "kind="
3262 : : string is found, then we know we have an error. */
3263 : :
3264 : : match
3265 : 134120 : gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
3266 : : {
3267 : 134120 : locus where, loc;
3268 : 134120 : gfc_expr *e;
3269 : 134120 : match m, n;
3270 : 134120 : char c;
3271 : :
3272 : 134120 : m = MATCH_NO;
3273 : 134120 : n = MATCH_YES;
3274 : 134120 : e = NULL;
3275 : 134120 : saved_kind_expr = NULL;
3276 : :
3277 : 134120 : where = loc = gfc_current_locus;
3278 : :
3279 : 134120 : if (kind_expr_only)
3280 : 0 : goto kind_expr;
3281 : :
3282 : 134120 : if (gfc_match_char ('(') == MATCH_NO)
3283 : : return MATCH_NO;
3284 : :
3285 : : /* Also gobbles optional text. */
3286 : 41034 : if (gfc_match (" kind = ") == MATCH_YES)
3287 : 41034 : m = MATCH_ERROR;
3288 : :
3289 : 41034 : loc = gfc_current_locus;
3290 : :
3291 : 41034 : kind_expr:
3292 : :
3293 : 41034 : n = gfc_match_init_expr (&e);
3294 : :
3295 : 41034 : if (gfc_derived_parameter_expr (e))
3296 : : {
3297 : 77 : ts->kind = 0;
3298 : 77 : saved_kind_expr = gfc_copy_expr (e);
3299 : 77 : goto close_brackets;
3300 : : }
3301 : :
3302 : 40957 : if (n != MATCH_YES)
3303 : : {
3304 : 181 : if (gfc_matching_function)
3305 : : {
3306 : : /* The function kind expression might include use associated or
3307 : : imported parameters and try again after the specification
3308 : : expressions..... */
3309 : 155 : if (gfc_match_char (')') != MATCH_YES)
3310 : : {
3311 : 1 : gfc_error ("Missing right parenthesis at %C");
3312 : 1 : m = MATCH_ERROR;
3313 : 1 : goto no_match;
3314 : : }
3315 : :
3316 : 154 : gfc_free_expr (e);
3317 : 154 : gfc_undo_symbols ();
3318 : 154 : return MATCH_YES;
3319 : : }
3320 : : else
3321 : : {
3322 : : /* ....or else, the match is real. */
3323 : 26 : if (n == MATCH_NO)
3324 : 0 : gfc_error ("Expected initialization expression at %C");
3325 : 26 : if (n != MATCH_YES)
3326 : 26 : return MATCH_ERROR;
3327 : : }
3328 : : }
3329 : :
3330 : 40776 : if (e->rank != 0)
3331 : : {
3332 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3333 : 0 : m = MATCH_ERROR;
3334 : 0 : goto no_match;
3335 : : }
3336 : :
3337 : 40776 : if (gfc_extract_int (e, &ts->kind, 1))
3338 : : {
3339 : 0 : m = MATCH_ERROR;
3340 : 0 : goto no_match;
3341 : : }
3342 : :
3343 : : /* Before throwing away the expression, let's see if we had a
3344 : : C interoperable kind (and store the fact). */
3345 : 40776 : if (e->ts.is_c_interop == 1)
3346 : : {
3347 : : /* Mark this as C interoperable if being declared with one
3348 : : of the named constants from iso_c_binding. */
3349 : 14940 : ts->is_c_interop = e->ts.is_iso_c;
3350 : 14940 : ts->f90_type = e->ts.f90_type;
3351 : 14940 : if (e->symtree)
3352 : 14939 : ts->interop_kind = e->symtree->n.sym;
3353 : : }
3354 : :
3355 : 40776 : gfc_free_expr (e);
3356 : 40776 : e = NULL;
3357 : :
3358 : : /* Ignore errors to this point, if we've gotten here. This means
3359 : : we ignore the m=MATCH_ERROR from above. */
3360 : 40776 : if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
3361 : : {
3362 : 7 : gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
3363 : : gfc_basic_typename (ts->type));
3364 : 7 : gfc_current_locus = where;
3365 : 7 : return MATCH_ERROR;
3366 : : }
3367 : :
3368 : : /* Warn if, e.g., c_int is used for a REAL variable, but not
3369 : : if, e.g., c_double is used for COMPLEX as the standard
3370 : : explicitly says that the kind type parameter for complex and real
3371 : : variable is the same, i.e. c_float == c_float_complex. */
3372 : 40769 : if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
3373 : 16 : && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
3374 : 1 : || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
3375 : 12 : gfc_warning_now (0, "C kind type parameter is for type %s but type at %L "
3376 : : "is %s", gfc_basic_typename (ts->f90_type), &where,
3377 : : gfc_basic_typename (ts->type));
3378 : :
3379 : 40757 : close_brackets:
3380 : :
3381 : 40846 : gfc_gobble_whitespace ();
3382 : 40846 : if ((c = gfc_next_ascii_char ()) != ')'
3383 : 40846 : && (ts->type != BT_CHARACTER || c != ','))
3384 : : {
3385 : 0 : if (ts->type == BT_CHARACTER)
3386 : 0 : gfc_error ("Missing right parenthesis or comma at %C");
3387 : : else
3388 : 0 : gfc_error ("Missing right parenthesis at %C");
3389 : 0 : m = MATCH_ERROR;
3390 : 0 : goto no_match;
3391 : : }
3392 : : else
3393 : : /* All tests passed. */
3394 : 40846 : m = MATCH_YES;
3395 : :
3396 : 40846 : if(m == MATCH_ERROR)
3397 : : gfc_current_locus = where;
3398 : :
3399 : 40846 : if (ts->type == BT_INTEGER && ts->kind == 4 && flag_integer4_kind == 8)
3400 : 0 : ts->kind = 8;
3401 : :
3402 : 40846 : if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
3403 : : {
3404 : 13484 : if (ts->kind == 4)
3405 : : {
3406 : 4413 : if (flag_real4_kind == 8)
3407 : 54 : ts->kind = 8;
3408 : 4413 : if (flag_real4_kind == 10)
3409 : 54 : ts->kind = 10;
3410 : 4413 : if (flag_real4_kind == 16)
3411 : 54 : ts->kind = 16;
3412 : : }
3413 : 9071 : else if (ts->kind == 8)
3414 : : {
3415 : 6153 : if (flag_real8_kind == 4)
3416 : 48 : ts->kind = 4;
3417 : 6153 : if (flag_real8_kind == 10)
3418 : 48 : ts->kind = 10;
3419 : 6153 : if (flag_real8_kind == 16)
3420 : 48 : ts->kind = 16;
3421 : : }
3422 : : }
3423 : :
3424 : : /* Return what we know from the test(s). */
3425 : : return m;
3426 : :
3427 : 1 : no_match:
3428 : 1 : gfc_free_expr (e);
3429 : 1 : gfc_current_locus = where;
3430 : 1 : return m;
3431 : : }
3432 : :
3433 : :
3434 : : static match
3435 : 4098 : match_char_kind (int * kind, int * is_iso_c)
3436 : : {
3437 : 4098 : locus where;
3438 : 4098 : gfc_expr *e;
3439 : 4098 : match m, n;
3440 : 4098 : bool fail;
3441 : :
3442 : 4098 : m = MATCH_NO;
3443 : 4098 : e = NULL;
3444 : 4098 : where = gfc_current_locus;
3445 : :
3446 : 4098 : n = gfc_match_init_expr (&e);
3447 : :
3448 : 4098 : if (n != MATCH_YES && gfc_matching_function)
3449 : : {
3450 : : /* The expression might include use-associated or imported
3451 : : parameters and try again after the specification
3452 : : expressions. */
3453 : 7 : gfc_free_expr (e);
3454 : 7 : gfc_undo_symbols ();
3455 : 7 : return MATCH_YES;
3456 : : }
3457 : :
3458 : 7 : if (n == MATCH_NO)
3459 : 2 : gfc_error ("Expected initialization expression at %C");
3460 : 4091 : if (n != MATCH_YES)
3461 : : return MATCH_ERROR;
3462 : :
3463 : 4084 : if (e->rank != 0)
3464 : : {
3465 : 0 : gfc_error ("Expected scalar initialization expression at %C");
3466 : 0 : m = MATCH_ERROR;
3467 : 0 : goto no_match;
3468 : : }
3469 : :
3470 : 4084 : if (gfc_derived_parameter_expr (e))
3471 : : {
3472 : 14 : saved_kind_expr = e;
3473 : 14 : *kind = 0;
3474 : 14 : return MATCH_YES;
3475 : : }
3476 : :
3477 : 4070 : fail = gfc_extract_int (e, kind, 1);
3478 : 4070 : *is_iso_c = e->ts.is_iso_c;
3479 : 4070 : if (fail)
3480 : : {
3481 : 0 : m = MATCH_ERROR;
3482 : 0 : goto no_match;
3483 : : }
3484 : :
3485 : 4070 : gfc_free_expr (e);
3486 : :
3487 : : /* Ignore errors to this point, if we've gotten here. This means
3488 : : we ignore the m=MATCH_ERROR from above. */
3489 : 4070 : if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
3490 : : {
3491 : 14 : gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
3492 : 14 : m = MATCH_ERROR;
3493 : : }
3494 : : else
3495 : : /* All tests passed. */
3496 : : m = MATCH_YES;
3497 : :
3498 : 14 : if (m == MATCH_ERROR)
3499 : 14 : gfc_current_locus = where;
3500 : :
3501 : : /* Return what we know from the test(s). */
3502 : : return m;
3503 : :
3504 : 0 : no_match:
3505 : 0 : gfc_free_expr (e);
3506 : 0 : gfc_current_locus = where;
3507 : 0 : return m;
3508 : : }
3509 : :
3510 : :
3511 : : /* Match the various kind/length specifications in a CHARACTER
3512 : : declaration. We don't return MATCH_NO. */
3513 : :
3514 : : match
3515 : 28123 : gfc_match_char_spec (gfc_typespec *ts)
3516 : : {
3517 : 28123 : int kind, seen_length, is_iso_c;
3518 : 28123 : gfc_charlen *cl;
3519 : 28123 : gfc_expr *len;
3520 : 28123 : match m;
3521 : 28123 : bool deferred;
3522 : :
3523 : 28123 : len = NULL;
3524 : 28123 : seen_length = 0;
3525 : 28123 : kind = 0;
3526 : 28123 : is_iso_c = 0;
3527 : 28123 : deferred = false;
3528 : :
3529 : : /* Try the old-style specification first. */
3530 : 28123 : old_char_selector = 0;
3531 : :
3532 : 28123 : m = match_char_length (&len, &deferred, true);
3533 : 28123 : if (m != MATCH_NO)
3534 : : {
3535 : 2262 : if (m == MATCH_YES)
3536 : 2262 : old_char_selector = 1;
3537 : 2262 : seen_length = 1;
3538 : 2262 : goto done;
3539 : : }
3540 : :
3541 : 25861 : m = gfc_match_char ('(');
3542 : 25861 : if (m != MATCH_YES)
3543 : : {
3544 : 1775 : m = MATCH_YES; /* Character without length is a single char. */
3545 : 1775 : goto done;
3546 : : }
3547 : :
3548 : : /* Try the weird case: ( KIND = <int> [ , LEN = <len-param> ] ). */
3549 : 24086 : if (gfc_match (" kind =") == MATCH_YES)
3550 : : {
3551 : 2885 : m = match_char_kind (&kind, &is_iso_c);
3552 : :
3553 : 2885 : if (m == MATCH_ERROR)
3554 : 16 : goto done;
3555 : 2869 : if (m == MATCH_NO)
3556 : 0 : goto syntax;
3557 : :
3558 : 2869 : if (gfc_match (" , len =") == MATCH_NO)
3559 : 514 : goto rparen;
3560 : :
3561 : 2355 : m = char_len_param_value (&len, &deferred);
3562 : 2355 : if (m == MATCH_NO)
3563 : 0 : goto syntax;
3564 : 2355 : if (m == MATCH_ERROR)
3565 : 2 : goto done;
3566 : 2353 : seen_length = 1;
3567 : :
3568 : 2353 : goto rparen;
3569 : : }
3570 : :
3571 : : /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>". */
3572 : 21201 : if (gfc_match (" len =") == MATCH_YES)
3573 : : {
3574 : 13154 : m = char_len_param_value (&len, &deferred);
3575 : 13154 : if (m == MATCH_NO)
3576 : 2 : goto syntax;
3577 : 13152 : if (m == MATCH_ERROR)
3578 : 8 : goto done;
3579 : 13144 : seen_length = 1;
3580 : :
3581 : 13144 : if (gfc_match_char (')') == MATCH_YES)
3582 : 12049 : goto done;
3583 : :
3584 : 1095 : if (gfc_match (" , kind =") != MATCH_YES)
3585 : 0 : goto syntax;
3586 : :
3587 : 1095 : if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
3588 : 2 : goto done;
3589 : :
3590 : 1093 : goto rparen;
3591 : : }
3592 : :
3593 : : /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ). */
3594 : 8047 : m = char_len_param_value (&len, &deferred);
3595 : 8047 : if (m == MATCH_NO)
3596 : 0 : goto syntax;
3597 : 8047 : if (m == MATCH_ERROR)
3598 : 44 : goto done;
3599 : 8003 : seen_length = 1;
3600 : :
3601 : 8003 : m = gfc_match_char (')');
3602 : 8003 : if (m == MATCH_YES)
3603 : 7883 : goto done;
3604 : :
3605 : 120 : if (gfc_match_char (',') != MATCH_YES)
3606 : 2 : goto syntax;
3607 : :
3608 : 118 : gfc_match (" kind ="); /* Gobble optional text. */
3609 : :
3610 : 118 : m = match_char_kind (&kind, &is_iso_c);
3611 : 118 : if (m == MATCH_ERROR)
3612 : 3 : goto done;
3613 : 115 : if (m == MATCH_NO)
3614 : 0 : goto syntax;
3615 : :
3616 : 115 : rparen:
3617 : : /* Require a right-paren at this point. */
3618 : 4075 : m = gfc_match_char (')');
3619 : 4075 : if (m == MATCH_YES)
3620 : 4075 : goto done;
3621 : :
3622 : 0 : syntax:
3623 : 4 : gfc_error ("Syntax error in CHARACTER declaration at %C");
3624 : 4 : m = MATCH_ERROR;
3625 : 4 : gfc_free_expr (len);
3626 : 4 : return m;
3627 : :
3628 : 28119 : done:
3629 : : /* Deal with character functions after USE and IMPORT statements. */
3630 : 28119 : if (gfc_matching_function)
3631 : : {
3632 : 1075 : gfc_free_expr (len);
3633 : 1075 : gfc_undo_symbols ();
3634 : 1075 : return MATCH_YES;
3635 : : }
3636 : :
3637 : 27044 : if (m != MATCH_YES)
3638 : : {
3639 : 65 : gfc_free_expr (len);
3640 : 65 : return m;
3641 : : }
3642 : :
3643 : : /* Do some final massaging of the length values. */
3644 : 26979 : cl = gfc_new_charlen (gfc_current_ns, NULL);
3645 : :
3646 : 26979 : if (seen_length == 0)
3647 : 2232 : cl->length = gfc_get_int_expr (gfc_charlen_int_kind, NULL, 1);
3648 : : else
3649 : : {
3650 : : /* If gfortran ends up here, then len may be reducible to a constant.
3651 : : Try to do that here. If it does not reduce, simply assign len to
3652 : : charlen. A complication occurs with user-defined generic functions,
3653 : : which are not resolved. Use a private namespace to deal with
3654 : : generic functions. */
3655 : :
3656 : 24747 : if (len && len->expr_type != EXPR_CONSTANT)
3657 : : {
3658 : 2377 : gfc_namespace *old_ns;
3659 : 2377 : gfc_expr *e;
3660 : :
3661 : 2377 : old_ns = gfc_current_ns;
3662 : 2377 : gfc_current_ns = gfc_get_namespace (NULL, 0);
3663 : :
3664 : 2377 : e = gfc_copy_expr (len);
3665 : 2377 : gfc_push_suppress_errors ();
3666 : 2377 : gfc_reduce_init_expr (e);
3667 : 2377 : gfc_pop_suppress_errors ();
3668 : 2377 : if (e->expr_type == EXPR_CONSTANT)
3669 : : {
3670 : 291 : gfc_replace_expr (len, e);
3671 : 291 : if (mpz_cmp_si (len->value.integer, 0) < 0)
3672 : 7 : mpz_set_ui (len->value.integer, 0);
3673 : : }
3674 : : else
3675 : 2086 : gfc_free_expr (e);
3676 : :
3677 : 2377 : gfc_free_namespace (gfc_current_ns);
3678 : 2377 : gfc_current_ns = old_ns;
3679 : : }
3680 : :
3681 : 24747 : cl->length = len;
3682 : : }
3683 : :
3684 : 26979 : ts->u.cl = cl;
3685 : 26979 : ts->kind = kind == 0 ? gfc_default_character_kind : kind;
3686 : 26979 : ts->deferred = deferred;
3687 : :
3688 : : /* We have to know if it was a C interoperable kind so we can
3689 : : do accurate type checking of bind(c) procs, etc. */
3690 : 26979 : if (kind != 0)
3691 : : /* Mark this as C interoperable if being declared with one
3692 : : of the named constants from iso_c_binding. */
3693 : 3993 : ts->is_c_interop = is_iso_c;
3694 : 22986 : else if (len != NULL)
3695 : : /* Here, we might have parsed something such as: character(c_char)
3696 : : In this case, the parsing code above grabs the c_char when
3697 : : looking for the length (line 1690, roughly). it's the last
3698 : : testcase for parsing the kind params of a character variable.
3699 : : However, it's not actually the length. this seems like it
3700 : : could be an error.
3701 : : To see if the user used a C interop kind, test the expr
3702 : : of the so called length, and see if it's C interoperable. */
3703 : 14965 : ts->is_c_interop = len->ts.is_iso_c;
3704 : :
3705 : : return MATCH_YES;
3706 : : }
3707 : :
3708 : :
3709 : : /* Matches a RECORD declaration. */
3710 : :
3711 : : static match
3712 : 832847 : match_record_decl (char *name)
3713 : : {
3714 : 832847 : locus old_loc;
3715 : 832847 : old_loc = gfc_current_locus;
3716 : 832847 : match m;
3717 : :
3718 : 832847 : m = gfc_match (" record /");
3719 : 832847 : if (m == MATCH_YES)
3720 : : {
3721 : 353 : if (!flag_dec_structure)
3722 : : {
3723 : 6 : gfc_current_locus = old_loc;
3724 : 6 : gfc_error ("RECORD at %C is an extension, enable it with "
3725 : : "%<-fdec-structure%>");
3726 : 6 : return MATCH_ERROR;
3727 : : }
3728 : 347 : m = gfc_match (" %n/", name);
3729 : 347 : if (m == MATCH_YES)
3730 : : return MATCH_YES;
3731 : : }
3732 : :
3733 : 832497 : gfc_current_locus = old_loc;
3734 : 832497 : if (flag_dec_structure
3735 : 832497 : && (gfc_match (" record% ") == MATCH_YES
3736 : 8026 : || gfc_match (" record%t") == MATCH_YES))
3737 : 6 : gfc_error ("Structure name expected after RECORD at %C");
3738 : 832497 : if (m == MATCH_NO)
3739 : : return MATCH_NO;
3740 : :
3741 : : return MATCH_ERROR;
3742 : : }
3743 : :
3744 : :
3745 : : /* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
3746 : : of expressions to substitute into the possibly parameterized expression
3747 : : 'e'. Using a list is inefficient but should not be too bad since the
3748 : : number of type parameters is not likely to be large. */
3749 : : static bool
3750 : 1592 : insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
3751 : : int* f)
3752 : : {
3753 : 1592 : gfc_actual_arglist *param;
3754 : 1592 : gfc_expr *copy;
3755 : :
3756 : 1592 : if (e->expr_type != EXPR_VARIABLE)
3757 : : return false;
3758 : :
3759 : 799 : gcc_assert (e->symtree);
3760 : 799 : if (e->symtree->n.sym->attr.pdt_kind
3761 : 656 : || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
3762 : : {
3763 : 812 : for (param = type_param_spec_list; param; param = param->next)
3764 : 812 : if (strcmp (e->symtree->n.sym->name, param->name) == 0)
3765 : : break;
3766 : :
3767 : 502 : if (param)
3768 : : {
3769 : 502 : copy = gfc_copy_expr (param->expr);
3770 : 502 : *e = *copy;
3771 : 502 : free (copy);
3772 : : }
3773 : : }
3774 : :
3775 : : return false;
3776 : : }
3777 : :
3778 : :
3779 : : static bool
3780 : 585 : gfc_insert_kind_parameter_exprs (gfc_expr *e)
3781 : : {
3782 : 585 : return gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 0);
3783 : : }
3784 : :
3785 : :
3786 : : bool
3787 : 646 : gfc_insert_parameter_exprs (gfc_expr *e, gfc_actual_arglist *param_list)
3788 : : {
3789 : 646 : gfc_actual_arglist *old_param_spec_list = type_param_spec_list;
3790 : 646 : type_param_spec_list = param_list;
3791 : 646 : bool res = gfc_traverse_expr (e, NULL, &insert_parameter_exprs, 1);
3792 : 646 : type_param_spec_list = old_param_spec_list;
3793 : 646 : return res;
3794 : : }
3795 : :
3796 : : /* Determines the instance of a parameterized derived type to be used by
3797 : : matching determining the values of the kind parameters and using them
3798 : : in the name of the instance. If the instance exists, it is used, otherwise
3799 : : a new derived type is created. */
3800 : : match
3801 : 565 : gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
3802 : : gfc_actual_arglist **ext_param_list)
3803 : : {
3804 : : /* The PDT template symbol. */
3805 : 565 : gfc_symbol *pdt = *sym;
3806 : : /* The symbol for the parameter in the template f2k_namespace. */
3807 : 565 : gfc_symbol *param;
3808 : : /* The hoped for instance of the PDT. */
3809 : 565 : gfc_symbol *instance;
3810 : : /* The list of parameters appearing in the PDT declaration. */
3811 : 565 : gfc_formal_arglist *type_param_name_list;
3812 : : /* Used to store the parameter specification list during recursive calls. */
3813 : 565 : gfc_actual_arglist *old_param_spec_list;
3814 : : /* Pointers to the parameter specification being used. */
3815 : 565 : gfc_actual_arglist *actual_param;
3816 : 565 : gfc_actual_arglist *tail = NULL;
3817 : : /* Used to build up the name of the PDT instance. The prefix uses 4
3818 : : characters and each KIND parameter 2 more. Allow 8 of the latter. */
3819 : 565 : char name[GFC_MAX_SYMBOL_LEN + 21];
3820 : :
3821 : 565 : bool name_seen = (param_list == NULL);
3822 : 565 : bool assumed_seen = false;
3823 : 565 : bool deferred_seen = false;
3824 : 565 : bool spec_error = false;
3825 : 565 : int kind_value, i;
3826 : 565 : gfc_expr *kind_expr;
3827 : 565 : gfc_component *c1, *c2;
3828 : 565 : match m;
3829 : :
3830 : 565 : type_param_spec_list = NULL;
3831 : :
3832 : 565 : type_param_name_list = pdt->formal;
3833 : 565 : actual_param = param_list;
3834 : 565 : sprintf (name, "Pdt%s", pdt->name);
3835 : :
3836 : : /* Run through the parameter name list and pick up the actual
3837 : : parameter values or use the default values in the PDT declaration. */
3838 : 1559 : for (; type_param_name_list;
3839 : 994 : type_param_name_list = type_param_name_list->next)
3840 : : {
3841 : 1006 : if (actual_param && actual_param->spec_type != SPEC_EXPLICIT)
3842 : : {
3843 : 929 : if (actual_param->spec_type == SPEC_ASSUMED)
3844 : : spec_error = deferred_seen;
3845 : : else
3846 : 929 : spec_error = assumed_seen;
3847 : :
3848 : 929 : if (spec_error)
3849 : : {
3850 : : gfc_error ("The type parameter spec list at %C cannot contain "
3851 : : "both ASSUMED and DEFERRED parameters");
3852 : : goto error_return;
3853 : : }
3854 : : }
3855 : :
3856 : 929 : if (actual_param && actual_param->name)
3857 : 1006 : name_seen = true;
3858 : 1006 : param = type_param_name_list->sym;
3859 : :
3860 : 1006 : if (!param || !param->name)
3861 : 1 : continue;
3862 : :
3863 : 1005 : c1 = gfc_find_component (pdt, param->name, false, true, NULL);
3864 : : /* An error should already have been thrown in resolve.cc
3865 : : (resolve_fl_derived0). */
3866 : 1005 : if (!pdt->attr.use_assoc && !c1)
3867 : 3 : goto error_return;
3868 : :
3869 : 1002 : kind_expr = NULL;
3870 : 1002 : if (!name_seen)
3871 : : {
3872 : 617 : if (!actual_param && !(c1 && c1->initializer))
3873 : : {
3874 : 1 : gfc_error ("The type parameter spec list at %C does not contain "
3875 : : "enough parameter expressions");
3876 : 1 : goto error_return;
3877 : : }
3878 : 616 : else if (!actual_param && c1 && c1->initializer)
3879 : 1 : kind_expr = gfc_copy_expr (c1->initializer);
3880 : 615 : else if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3881 : 462 : kind_expr = gfc_copy_expr (actual_param->expr);
3882 : : }
3883 : : else
3884 : : {
3885 : : actual_param = param_list;
3886 : 526 : for (;actual_param; actual_param = actual_param->next)
3887 : 446 : if (actual_param->name
3888 : 444 : && strcmp (actual_param->name, param->name) == 0)
3889 : : break;
3890 : 385 : if (actual_param && actual_param->spec_type == SPEC_EXPLICIT)
3891 : 245 : kind_expr = gfc_copy_expr (actual_param->expr);
3892 : : else
3893 : : {
3894 : 140 : if (c1->initializer)
3895 : 111 : kind_expr = gfc_copy_expr (c1->initializer);
3896 : 29 : else if (!(actual_param && param->attr.pdt_len))
3897 : : {
3898 : 0 : gfc_error ("The derived parameter %qs at %C does not "
3899 : : "have a default value", param->name);
3900 : 0 : goto error_return;
3901 : : }
3902 : : }
3903 : : }
3904 : :
3905 : : /* Store the current parameter expressions in a temporary actual
3906 : : arglist 'list' so that they can be substituted in the corresponding
3907 : : expressions in the PDT instance. */
3908 : 1001 : if (type_param_spec_list == NULL)
3909 : : {
3910 : 563 : type_param_spec_list = gfc_get_actual_arglist ();
3911 : 563 : tail = type_param_spec_list;
3912 : : }
3913 : : else
3914 : : {
3915 : 438 : tail->next = gfc_get_actual_arglist ();
3916 : 438 : tail = tail->next;
3917 : : }
3918 : 1001 : tail->name = param->name;
3919 : :
3920 : 1001 : if (kind_expr)
3921 : : {
3922 : : /* Try simplification even for LEN expressions. */
3923 : 819 : bool ok;
3924 : 819 : gfc_resolve_expr (kind_expr);
3925 : 819 : ok = gfc_simplify_expr (kind_expr, 1);
3926 : : /* Variable expressions seem to default to BT_PROCEDURE.
3927 : : TODO find out why this is and fix it. */
3928 : 819 : if (kind_expr->ts.type != BT_INTEGER
3929 : 27 : && kind_expr->ts.type != BT_PROCEDURE)
3930 : : {
3931 : 3 : gfc_error ("The parameter expression at %C must be of "
3932 : : "INTEGER type and not %s type",
3933 : : gfc_basic_typename (kind_expr->ts.type));
3934 : 3 : goto error_return;
3935 : : }
3936 : 816 : if (kind_expr->ts.type == BT_INTEGER && !ok)
3937 : : {
3938 : 2 : gfc_error ("The parameter expression at %C does not "
3939 : : "simplify to an INTEGER constant");
3940 : 2 : goto error_return;
3941 : : }
3942 : :
3943 : 814 : tail->expr = gfc_copy_expr (kind_expr);
3944 : : }
3945 : :
3946 : 996 : if (actual_param)
3947 : 915 : tail->spec_type = actual_param->spec_type;
3948 : :
3949 : 996 : if (!param->attr.pdt_kind)
3950 : : {
3951 : 529 : if (!name_seen && actual_param)
3952 : 348 : actual_param = actual_param->next;
3953 : 529 : if (kind_expr)
3954 : : {
3955 : 349 : gfc_free_expr (kind_expr);
3956 : 349 : kind_expr = NULL;
3957 : : }
3958 : 529 : continue;
3959 : : }
3960 : :
3961 : 467 : if (actual_param
3962 : 410 : && (actual_param->spec_type == SPEC_ASSUMED
3963 : 410 : || actual_param->spec_type == SPEC_DEFERRED))
3964 : : {
3965 : 2 : gfc_error ("The KIND parameter %qs at %C cannot either be "
3966 : : "ASSUMED or DEFERRED", param->name);
3967 : 2 : goto error_return;
3968 : : }
3969 : :
3970 : 465 : if (!kind_expr || !gfc_is_constant_expr (kind_expr))
3971 : : {
3972 : 1 : gfc_error ("The value for the KIND parameter %qs at %C does not "
3973 : : "reduce to a constant expression", param->name);
3974 : 1 : goto error_return;
3975 : : }
3976 : :
3977 : 464 : gfc_extract_int (kind_expr, &kind_value);
3978 : 464 : sprintf (name + strlen (name), "_%d", kind_value);
3979 : :
3980 : 464 : if (!name_seen && actual_param)
3981 : 259 : actual_param = actual_param->next;
3982 : 464 : gfc_free_expr (kind_expr);
3983 : : }
3984 : :
3985 : 553 : if (!name_seen && actual_param)
3986 : : {
3987 : 1 : gfc_error ("The type parameter spec list at %C contains too many "
3988 : : "parameter expressions");
3989 : 1 : goto error_return;
3990 : : }
3991 : :
3992 : : /* Now we search for the PDT instance 'name'. If it doesn't exist, we
3993 : : build it, using 'pdt' as a template. */
3994 : 552 : if (gfc_get_symbol (name, pdt->ns, &instance))
3995 : : {
3996 : 0 : gfc_error ("Parameterized derived type at %C is ambiguous");
3997 : 0 : goto error_return;
3998 : : }
3999 : :
4000 : 552 : m = MATCH_YES;
4001 : :
4002 : 552 : if (instance->attr.flavor == FL_DERIVED
4003 : 552 : && instance->attr.pdt_type)
4004 : : {
4005 : 325 : instance->refs++;
4006 : 325 : if (ext_param_list)
4007 : 62 : *ext_param_list = type_param_spec_list;
4008 : 325 : *sym = instance;
4009 : 325 : gfc_commit_symbols ();
4010 : 325 : return m;
4011 : : }
4012 : :
4013 : : /* Start building the new instance of the parameterized type. */
4014 : 227 : gfc_copy_attr (&instance->attr, &pdt->attr, &pdt->declared_at);
4015 : 227 : instance->attr.pdt_template = 0;
4016 : 227 : instance->attr.pdt_type = 1;
4017 : 227 : instance->declared_at = gfc_current_locus;
4018 : :
4019 : : /* Add the components, replacing the parameters in all expressions
4020 : : with the expressions for their values in 'type_param_spec_list'. */
4021 : 227 : c1 = pdt->components;
4022 : 227 : tail = type_param_spec_list;
4023 : 918 : for (; c1; c1 = c1->next)
4024 : : {
4025 : 692 : gfc_add_component (instance, c1->name, &c2);
4026 : :
4027 : 692 : c2->ts = c1->ts;
4028 : 692 : c2->attr = c1->attr;
4029 : :
4030 : : /* The order of declaration of the type_specs might not be the
4031 : : same as that of the components. */
4032 : 692 : if (c1->attr.pdt_kind || c1->attr.pdt_len)
4033 : : {
4034 : 605 : for (tail = type_param_spec_list; tail; tail = tail->next)
4035 : 605 : if (strcmp (c1->name, tail->name) == 0)
4036 : : break;
4037 : : }
4038 : :
4039 : : /* Deal with type extension by recursively calling this function
4040 : : to obtain the instance of the extended type. */
4041 : 692 : if (gfc_current_state () != COMP_DERIVED
4042 : 692 : && c1 == pdt->components
4043 : 227 : && (c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4044 : 29 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template
4045 : 721 : && gfc_get_derived_super_type (*sym) == c2->ts.u.derived)
4046 : : {
4047 : 29 : gfc_formal_arglist *f;
4048 : :
4049 : 29 : old_param_spec_list = type_param_spec_list;
4050 : :
4051 : : /* Obtain a spec list appropriate to the extended type..*/
4052 : 29 : actual_param = gfc_copy_actual_arglist (type_param_spec_list);
4053 : 29 : type_param_spec_list = actual_param;
4054 : 67 : for (f = c1->ts.u.derived->formal; f && f->next; f = f->next)
4055 : 38 : actual_param = actual_param->next;
4056 : 29 : if (actual_param)
4057 : : {
4058 : 29 : gfc_free_actual_arglist (actual_param->next);
4059 : 29 : actual_param->next = NULL;
4060 : : }
4061 : :
4062 : : /* Now obtain the PDT instance for the extended type. */
4063 : 29 : c2->param_list = type_param_spec_list;
4064 : 29 : m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
4065 : : NULL);
4066 : 29 : type_param_spec_list = old_param_spec_list;
4067 : :
4068 : 29 : c2->ts.u.derived->refs++;
4069 : 29 : gfc_set_sym_referenced (c2->ts.u.derived);
4070 : :
4071 : : /* Set extension level. */
4072 : 29 : if (c2->ts.u.derived->attr.extension == 255)
4073 : : {
4074 : : /* Since the extension field is 8 bit wide, we can only have
4075 : : up to 255 extension levels. */
4076 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
4077 : : c2->ts.u.derived->name,
4078 : : &c2->ts.u.derived->declared_at);
4079 : 0 : goto error_return;
4080 : : }
4081 : 29 : instance->attr.extension = c2->ts.u.derived->attr.extension + 1;
4082 : :
4083 : 29 : continue;
4084 : 29 : }
4085 : :
4086 : : /* Addressing PR82943, this will fix the issue where a function or
4087 : : subroutine is declared as not a member of the PDT instance.
4088 : : The reason for this is because the PDT instance did not have access
4089 : : to its template's f2k_derived namespace in order to find the
4090 : : typebound procedures.
4091 : :
4092 : : The number of references to the PDT template's f2k_derived will
4093 : : ensure that f2k_derived is properly freed later on. */
4094 : :
4095 : 663 : if (!instance->f2k_derived && pdt->f2k_derived)
4096 : : {
4097 : 226 : instance->f2k_derived = pdt->f2k_derived;
4098 : 226 : instance->f2k_derived->refs++;
4099 : : }
4100 : :
4101 : : /* Set the component kind using the parameterized expression. */
4102 : 663 : if ((c1->ts.kind == 0 || c1->ts.type == BT_CHARACTER)
4103 : 211 : && c1->kind_expr != NULL)
4104 : : {
4105 : 130 : gfc_expr *e = gfc_copy_expr (c1->kind_expr);
4106 : 130 : gfc_insert_kind_parameter_exprs (e);
4107 : 130 : gfc_simplify_expr (e, 1);
4108 : 130 : gfc_extract_int (e, &c2->ts.kind);
4109 : 130 : gfc_free_expr (e);
4110 : 130 : if (gfc_validate_kind (c2->ts.type, c2->ts.kind, true) < 0)
4111 : : {
4112 : 1 : gfc_error ("Kind %d not supported for type %s at %C",
4113 : : c2->ts.kind, gfc_basic_typename (c2->ts.type));
4114 : 1 : goto error_return;
4115 : : }
4116 : : }
4117 : :
4118 : : /* Similarly, set the string length if parameterized. */
4119 : 662 : if (c1->ts.type == BT_CHARACTER
4120 : 67 : && c1->ts.u.cl->length
4121 : 729 : && gfc_derived_parameter_expr (c1->ts.u.cl->length))
4122 : : {
4123 : 67 : gfc_expr *e;
4124 : 67 : e = gfc_copy_expr (c1->ts.u.cl->length);
4125 : 67 : gfc_insert_kind_parameter_exprs (e);
4126 : 67 : gfc_simplify_expr (e, 1);
4127 : 67 : c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4128 : 67 : c2->ts.u.cl->length = e;
4129 : 67 : c2->attr.pdt_string = 1;
4130 : : }
4131 : :
4132 : : /* Set up either the KIND/LEN initializer, if constant,
4133 : : or the parameterized expression. Use the template
4134 : : initializer if one is not already set in this instance. */
4135 : 662 : if (c2->attr.pdt_kind || c2->attr.pdt_len)
4136 : : {
4137 : 370 : if (tail && tail->expr && gfc_is_constant_expr (tail->expr))
4138 : 301 : c2->initializer = gfc_copy_expr (tail->expr);
4139 : 69 : else if (tail && tail->expr)
4140 : : {
4141 : 4 : c2->param_list = gfc_get_actual_arglist ();
4142 : 4 : c2->param_list->name = tail->name;
4143 : 4 : c2->param_list->expr = gfc_copy_expr (tail->expr);
4144 : 4 : c2->param_list->next = NULL;
4145 : : }
4146 : :
4147 : 370 : if (!c2->initializer && c1->initializer)
4148 : 17 : c2->initializer = gfc_copy_expr (c1->initializer);
4149 : : }
4150 : :
4151 : : /* Copy the array spec. */
4152 : 662 : c2->as = gfc_copy_array_spec (c1->as);
4153 : 662 : if (c1->ts.type == BT_CLASS)
4154 : 0 : CLASS_DATA (c2)->as = gfc_copy_array_spec (CLASS_DATA (c1)->as);
4155 : :
4156 : : /* Determine if an array spec is parameterized. If so, substitute
4157 : : in the parameter expressions for the bounds and set the pdt_array
4158 : : attribute. Notice that this attribute must be unconditionally set
4159 : : if this is an array of parameterized character length. */
4160 : 662 : if (c1->as && c1->as->type == AS_EXPLICIT)
4161 : : {
4162 : : bool pdt_array = false;
4163 : :
4164 : : /* Are the bounds of the array parameterized? */
4165 : 327 : for (i = 0; i < c1->as->rank; i++)
4166 : : {
4167 : 202 : if (gfc_derived_parameter_expr (c1->as->lower[i]))
4168 : 0 : pdt_array = true;
4169 : 202 : if (gfc_derived_parameter_expr (c1->as->upper[i]))
4170 : 188 : pdt_array = true;
4171 : : }
4172 : :
4173 : : /* If they are, free the expressions for the bounds and
4174 : : replace them with the template expressions with substitute
4175 : : values. */
4176 : 313 : for (i = 0; pdt_array && i < c1->as->rank; i++)
4177 : : {
4178 : 188 : gfc_expr *e;
4179 : 188 : e = gfc_copy_expr (c1->as->lower[i]);
4180 : 188 : gfc_insert_kind_parameter_exprs (e);
4181 : 188 : gfc_simplify_expr (e, 1);
4182 : 188 : gfc_free_expr (c2->as->lower[i]);
4183 : 188 : c2->as->lower[i] = e;
4184 : 188 : e = gfc_copy_expr (c1->as->upper[i]);
4185 : 188 : gfc_insert_kind_parameter_exprs (e);
4186 : 188 : gfc_simplify_expr (e, 1);
4187 : 188 : gfc_free_expr (c2->as->upper[i]);
4188 : 188 : c2->as->upper[i] = e;
4189 : : }
4190 : 125 : c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
4191 : 125 : if (c1->initializer)
4192 : : {
4193 : 12 : c2->initializer = gfc_copy_expr (c1->initializer);
4194 : 12 : gfc_insert_kind_parameter_exprs (c2->initializer);
4195 : 12 : gfc_simplify_expr (c2->initializer, 1);
4196 : : }
4197 : : }
4198 : :
4199 : : /* Recurse into this function for PDT components. */
4200 : 662 : if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
4201 : 39 : && c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
4202 : : {
4203 : 39 : gfc_actual_arglist *params;
4204 : : /* The component in the template has a list of specification
4205 : : expressions derived from its declaration. */
4206 : 39 : params = gfc_copy_actual_arglist (c1->param_list);
4207 : 39 : actual_param = params;
4208 : : /* Substitute the template parameters with the expressions
4209 : : from the specification list. */
4210 : 118 : for (;actual_param; actual_param = actual_param->next)
4211 : 40 : gfc_insert_parameter_exprs (actual_param->expr,
4212 : : type_param_spec_list);
4213 : :
4214 : : /* Now obtain the PDT instance for the component. */
4215 : 39 : old_param_spec_list = type_param_spec_list;
4216 : 39 : m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
4217 : 39 : type_param_spec_list = old_param_spec_list;
4218 : :
4219 : 39 : c2->param_list = params;
4220 : 39 : if (!(c2->attr.pointer || c2->attr.allocatable))
4221 : 26 : c2->initializer = gfc_default_initializer (&c2->ts);
4222 : :
4223 : 39 : if (c2->attr.allocatable)
4224 : 7 : instance->attr.alloc_comp = 1;
4225 : : }
4226 : : }
4227 : :
4228 : 226 : gfc_commit_symbol (instance);
4229 : 226 : if (ext_param_list)
4230 : 7 : *ext_param_list = type_param_spec_list;
4231 : 226 : *sym = instance;
4232 : 226 : return m;
4233 : :
4234 : 14 : error_return:
4235 : 14 : gfc_free_actual_arglist (type_param_spec_list);
4236 : 14 : return MATCH_ERROR;
4237 : : }
4238 : :
4239 : :
4240 : : /* Match a legacy nonstandard BYTE type-spec. */
4241 : :
4242 : : static match
4243 : 1021152 : match_byte_typespec (gfc_typespec *ts)
4244 : : {
4245 : 1021152 : if (gfc_match (" byte") == MATCH_YES)
4246 : : {
4247 : 33 : if (!gfc_notify_std (GFC_STD_GNU, "BYTE type at %C"))
4248 : : return MATCH_ERROR;
4249 : :
4250 : 31 : if (gfc_current_form == FORM_FREE)
4251 : : {
4252 : 19 : char c = gfc_peek_ascii_char ();
4253 : 19 : if (!gfc_is_whitespace (c) && c != ',')
4254 : : return MATCH_NO;
4255 : : }
4256 : :
4257 : 29 : if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
4258 : : {
4259 : 0 : gfc_error ("BYTE type used at %C "
4260 : : "is not available on the target machine");
4261 : 0 : return MATCH_ERROR;
4262 : : }
4263 : :
4264 : 29 : ts->type = BT_INTEGER;
4265 : 29 : ts->kind = 1;
4266 : 29 : return MATCH_YES;
4267 : : }
4268 : : return MATCH_NO;
4269 : : }
4270 : :
4271 : :
4272 : : /* Matches a declaration-type-spec (F03:R502). If successful, sets the ts
4273 : : structure to the matched specification. This is necessary for FUNCTION and
4274 : : IMPLICIT statements.
4275 : :
4276 : : If implicit_flag is nonzero, then we don't check for the optional
4277 : : kind specification. Not doing so is needed for matching an IMPLICIT
4278 : : statement correctly. */
4279 : :
4280 : : match
4281 : 1021152 : gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
4282 : : {
4283 : : /* Provide sufficient space to hold "pdtsymbol". */
4284 : 1021152 : char *name = XALLOCAVEC (char, GFC_MAX_SYMBOL_LEN + 1);
4285 : 1021152 : gfc_symbol *sym, *dt_sym;
4286 : 1021152 : match m;
4287 : 1021152 : char c;
4288 : 1021152 : bool seen_deferred_kind, matched_type;
4289 : 1021152 : const char *dt_name;
4290 : :
4291 : 1021152 : decl_type_param_list = NULL;
4292 : :
4293 : : /* A belt and braces check that the typespec is correctly being treated
4294 : : as a deferred characteristic association. */
4295 : 2042304 : seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
4296 : 71287 : && (gfc_current_block ()->result->ts.kind == -1)
4297 : 1031409 : && (ts->kind == -1);
4298 : 1021152 : gfc_clear_ts (ts);
4299 : 1021152 : if (seen_deferred_kind)
4300 : 8282 : ts->kind = -1;
4301 : :
4302 : : /* Clear the current binding label, in case one is given. */
4303 : 1021152 : curr_binding_label = NULL;
4304 : :
4305 : : /* Match BYTE type-spec. */
4306 : 1021152 : m = match_byte_typespec (ts);
4307 : 1021152 : if (m != MATCH_NO)
4308 : : return m;
4309 : :
4310 : 1021121 : m = gfc_match (" type (");
4311 : 1021121 : matched_type = (m == MATCH_YES);
4312 : 1021121 : if (matched_type)
4313 : : {
4314 : 26090 : gfc_gobble_whitespace ();
4315 : 26090 : if (gfc_peek_ascii_char () == '*')
4316 : : {
4317 : 4393 : if ((m = gfc_match ("* ) ")) != MATCH_YES)
4318 : : return m;
4319 : 4393 : if (gfc_comp_struct (gfc_current_state ()))
4320 : : {
4321 : 2 : gfc_error ("Assumed type at %C is not allowed for components");
4322 : 2 : return MATCH_ERROR;
4323 : : }
4324 : 4391 : if (!gfc_notify_std (GFC_STD_F2018, "Assumed type at %C"))
4325 : : return MATCH_ERROR;
4326 : 4389 : ts->type = BT_ASSUMED;
4327 : 4389 : return MATCH_YES;
4328 : : }
4329 : :
4330 : 21697 : m = gfc_match ("%n", name);
4331 : 21697 : matched_type = (m == MATCH_YES);
4332 : : }
4333 : :
4334 : 21697 : if ((matched_type && strcmp ("integer", name) == 0)
4335 : 1016728 : || (!matched_type && gfc_match (" integer") == MATCH_YES))
4336 : : {
4337 : 92243 : ts->type = BT_INTEGER;
4338 : 92243 : ts->kind = gfc_default_integer_kind;
4339 : 92243 : goto get_kind;
4340 : : }
4341 : :
4342 : 21692 : if ((matched_type && strcmp ("character", name) == 0)
4343 : 924485 : || (!matched_type && gfc_match (" character") == MATCH_YES))
4344 : : {
4345 : 26419 : if (matched_type
4346 : 26419 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4347 : : "intrinsic-type-spec at %C"))
4348 : : return MATCH_ERROR;
4349 : :
4350 : 26418 : ts->type = BT_CHARACTER;
4351 : 26418 : if (implicit_flag == 0)
4352 : 26313 : m = gfc_match_char_spec (ts);
4353 : : else
4354 : : m = MATCH_YES;
4355 : :
4356 : 26418 : if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
4357 : : {
4358 : 1 : gfc_error ("Malformed type-spec at %C");
4359 : 1 : return MATCH_ERROR;
4360 : : }
4361 : :
4362 : 26417 : return m;
4363 : : }
4364 : :
4365 : 21688 : if ((matched_type && strcmp ("real", name) == 0)
4366 : 898066 : || (!matched_type && gfc_match (" real") == MATCH_YES))
4367 : : {
4368 : 27646 : ts->type = BT_REAL;
4369 : 27646 : ts->kind = gfc_default_real_kind;
4370 : 27646 : goto get_kind;
4371 : : }
4372 : :
4373 : 870420 : if ((matched_type
4374 : 21685 : && (strcmp ("doubleprecision", name) == 0
4375 : 21684 : || (strcmp ("double", name) == 0
4376 : 5 : && gfc_match (" precision") == MATCH_YES)))
4377 : 870420 : || (!matched_type && gfc_match (" double precision") == MATCH_YES))
4378 : : {
4379 : 2520 : if (matched_type
4380 : 2520 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4381 : : "intrinsic-type-spec at %C"))
4382 : : return MATCH_ERROR;
4383 : :
4384 : 2519 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4385 : : {
4386 : 2 : gfc_error ("Malformed type-spec at %C");
4387 : 2 : return MATCH_ERROR;
4388 : : }
4389 : :
4390 : 2517 : ts->type = BT_REAL;
4391 : 2517 : ts->kind = gfc_default_double_kind;
4392 : 2517 : return MATCH_YES;
4393 : : }
4394 : :
4395 : 21681 : if ((matched_type && strcmp ("complex", name) == 0)
4396 : 867900 : || (!matched_type && gfc_match (" complex") == MATCH_YES))
4397 : : {
4398 : 3833 : ts->type = BT_COMPLEX;
4399 : 3833 : ts->kind = gfc_default_complex_kind;
4400 : 3833 : goto get_kind;
4401 : : }
4402 : :
4403 : 864067 : if ((matched_type
4404 : 21681 : && (strcmp ("doublecomplex", name) == 0
4405 : 21680 : || (strcmp ("double", name) == 0
4406 : 2 : && gfc_match (" complex") == MATCH_YES)))
4407 : 864067 : || (!matched_type && gfc_match (" double complex") == MATCH_YES))
4408 : : {
4409 : 201 : if (!gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C"))
4410 : : return MATCH_ERROR;
4411 : :
4412 : 200 : if (matched_type
4413 : 200 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4414 : : "intrinsic-type-spec at %C"))
4415 : : return MATCH_ERROR;
4416 : :
4417 : 200 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4418 : : {
4419 : 2 : gfc_error ("Malformed type-spec at %C");
4420 : 2 : return MATCH_ERROR;
4421 : : }
4422 : :
4423 : 198 : ts->type = BT_COMPLEX;
4424 : 198 : ts->kind = gfc_default_double_kind;
4425 : 198 : return MATCH_YES;
4426 : : }
4427 : :
4428 : 21678 : if ((matched_type && strcmp ("logical", name) == 0)
4429 : 863866 : || (!matched_type && gfc_match (" logical") == MATCH_YES))
4430 : : {
4431 : 9344 : ts->type = BT_LOGICAL;
4432 : 9344 : ts->kind = gfc_default_logical_kind;
4433 : 9344 : goto get_kind;
4434 : : }
4435 : :
4436 : 854522 : if (matched_type)
4437 : : {
4438 : 21675 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4439 : 21675 : if (m == MATCH_ERROR)
4440 : : return m;
4441 : :
4442 : 21675 : gfc_gobble_whitespace ();
4443 : 21675 : if (gfc_peek_ascii_char () != ')')
4444 : : {
4445 : 1 : gfc_error ("Malformed type-spec at %C");
4446 : 1 : return MATCH_ERROR;
4447 : : }
4448 : 21674 : m = gfc_match_char (')'); /* Burn closing ')'. */
4449 : : }
4450 : :
4451 : 854521 : if (m != MATCH_YES)
4452 : 832847 : m = match_record_decl (name);
4453 : :
4454 : 854521 : if (matched_type || m == MATCH_YES)
4455 : : {
4456 : 22018 : ts->type = BT_DERIVED;
4457 : : /* We accept record/s/ or type(s) where s is a structure, but we
4458 : : * don't need all the extra derived-type stuff for structures. */
4459 : 22018 : if (gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &sym))
4460 : : {
4461 : 1 : gfc_error ("Type name %qs at %C is ambiguous", name);
4462 : 1 : return MATCH_ERROR;
4463 : : }
4464 : :
4465 : 22017 : if (sym && sym->attr.flavor == FL_DERIVED
4466 : 21701 : && sym->attr.pdt_template
4467 : 406 : && gfc_current_state () != COMP_DERIVED)
4468 : : {
4469 : 367 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4470 : 367 : if (m != MATCH_YES)
4471 : : return m;
4472 : 354 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4473 : 354 : ts->u.derived = sym;
4474 : 354 : const char* lower = gfc_dt_lower_string (sym->name);
4475 : 354 : size_t len = strlen (lower);
4476 : : /* Reallocate with sufficient size. */
4477 : 354 : if (len > GFC_MAX_SYMBOL_LEN)
4478 : 2 : name = XALLOCAVEC (char, len + 1);
4479 : 354 : memcpy (name, lower, len);
4480 : 354 : name[len] = '\0';
4481 : : }
4482 : :
4483 : 22004 : if (sym && sym->attr.flavor == FL_STRUCT)
4484 : : {
4485 : 361 : ts->u.derived = sym;
4486 : 361 : return MATCH_YES;
4487 : : }
4488 : : /* Actually a derived type. */
4489 : : }
4490 : :
4491 : : else
4492 : : {
4493 : : /* Match nested STRUCTURE declarations; only valid within another
4494 : : structure declaration. */
4495 : 832503 : if (flag_dec_structure
4496 : 8032 : && (gfc_current_state () == COMP_STRUCTURE
4497 : 7570 : || gfc_current_state () == COMP_MAP))
4498 : : {
4499 : 732 : m = gfc_match (" structure");
4500 : 732 : if (m == MATCH_YES)
4501 : : {
4502 : 27 : m = gfc_match_structure_decl ();
4503 : 27 : if (m == MATCH_YES)
4504 : : {
4505 : : /* gfc_new_block is updated by match_structure_decl. */
4506 : 26 : ts->type = BT_DERIVED;
4507 : 26 : ts->u.derived = gfc_new_block;
4508 : 26 : return MATCH_YES;
4509 : : }
4510 : : }
4511 : 706 : if (m == MATCH_ERROR)
4512 : : return MATCH_ERROR;
4513 : : }
4514 : :
4515 : : /* Match CLASS declarations. */
4516 : 832476 : m = gfc_match (" class ( * )");
4517 : 832476 : if (m == MATCH_ERROR)
4518 : : return MATCH_ERROR;
4519 : 832476 : else if (m == MATCH_YES)
4520 : : {
4521 : 1521 : gfc_symbol *upe;
4522 : 1521 : gfc_symtree *st;
4523 : 1521 : ts->type = BT_CLASS;
4524 : 1521 : gfc_find_symbol ("STAR", gfc_current_ns, 1, &upe);
4525 : 1521 : if (upe == NULL)
4526 : : {
4527 : 933 : upe = gfc_new_symbol ("STAR", gfc_current_ns);
4528 : 933 : st = gfc_new_symtree (&gfc_current_ns->sym_root, "STAR");
4529 : 933 : st->n.sym = upe;
4530 : 933 : gfc_set_sym_referenced (upe);
4531 : 933 : upe->refs++;
4532 : 933 : upe->ts.type = BT_VOID;
4533 : 933 : upe->attr.unlimited_polymorphic = 1;
4534 : : /* This is essential to force the construction of
4535 : : unlimited polymorphic component class containers. */
4536 : 933 : upe->attr.zero_comp = 1;
4537 : 933 : if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL,
4538 : : &gfc_current_locus))
4539 : : return MATCH_ERROR;
4540 : : }
4541 : : else
4542 : : {
4543 : 588 : st = gfc_get_tbp_symtree (&gfc_current_ns->sym_root, "STAR");
4544 : 588 : st->n.sym = upe;
4545 : 588 : upe->refs++;
4546 : : }
4547 : 1521 : ts->u.derived = upe;
4548 : 1521 : return m;
4549 : : }
4550 : :
4551 : 830955 : m = gfc_match (" class (");
4552 : :
4553 : 830955 : if (m == MATCH_YES)
4554 : 7981 : m = gfc_match ("%n", name);
4555 : : else
4556 : : return m;
4557 : :
4558 : 7981 : if (m != MATCH_YES)
4559 : : return m;
4560 : 7981 : ts->type = BT_CLASS;
4561 : :
4562 : 7981 : if (!gfc_notify_std (GFC_STD_F2003, "CLASS statement at %C"))
4563 : : return MATCH_ERROR;
4564 : :
4565 : 7980 : m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
4566 : 7980 : if (m == MATCH_ERROR)
4567 : : return m;
4568 : :
4569 : 7980 : m = gfc_match_char (')');
4570 : 7980 : if (m != MATCH_YES)
4571 : : return m;
4572 : : }
4573 : :
4574 : : /* Defer association of the derived type until the end of the
4575 : : specification block. However, if the derived type can be
4576 : : found, add it to the typespec. */
4577 : 29623 : if (gfc_matching_function)
4578 : : {
4579 : 913 : ts->u.derived = NULL;
4580 : 913 : if (gfc_current_state () != COMP_INTERFACE
4581 : 913 : && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
4582 : : {
4583 : 471 : sym = gfc_find_dt_in_generic (sym);
4584 : 471 : ts->u.derived = sym;
4585 : : }
4586 : 913 : return MATCH_YES;
4587 : : }
4588 : :
4589 : : /* Search for the name but allow the components to be defined later. If
4590 : : type = -1, this typespec has been seen in a function declaration but
4591 : : the type could not be accessed at that point. The actual derived type is
4592 : : stored in a symtree with the first letter of the name capitalized; the
4593 : : symtree with the all lower-case name contains the associated
4594 : : generic function. */
4595 : 28710 : dt_name = gfc_dt_upper_string (name);
4596 : 28710 : sym = NULL;
4597 : 28710 : dt_sym = NULL;
4598 : 28710 : if (ts->kind != -1)
4599 : : {
4600 : 27649 : gfc_get_ha_symbol (name, &sym);
4601 : 27649 : if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
4602 : : {
4603 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4604 : 0 : return MATCH_ERROR;
4605 : : }
4606 : 27649 : if (sym->generic && !dt_sym)
4607 : 11347 : dt_sym = gfc_find_dt_in_generic (sym);
4608 : :
4609 : : /* Host associated PDTs can get confused with their constructors
4610 : : because they ar instantiated in the template's namespace. */
4611 : 27649 : if (!dt_sym)
4612 : : {
4613 : 465 : if (gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4614 : : {
4615 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4616 : 0 : return MATCH_ERROR;
4617 : : }
4618 : 465 : if (dt_sym && !dt_sym->attr.pdt_type)
4619 : 0 : dt_sym = NULL;
4620 : : }
4621 : : }
4622 : 1061 : else if (ts->kind == -1)
4623 : : {
4624 : 2122 : int iface = gfc_state_stack->previous->state != COMP_INTERFACE
4625 : 1061 : || gfc_current_ns->has_import_set;
4626 : 1061 : gfc_find_symbol (name, NULL, iface, &sym);
4627 : 1061 : if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
4628 : : {
4629 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
4630 : 0 : return MATCH_ERROR;
4631 : : }
4632 : 1061 : if (sym && sym->generic && !dt_sym)
4633 : 0 : dt_sym = gfc_find_dt_in_generic (sym);
4634 : :
4635 : 1061 : ts->kind = 0;
4636 : 1061 : if (sym == NULL)
4637 : : return MATCH_NO;
4638 : : }
4639 : :
4640 : 28701 : if ((sym->attr.flavor != FL_UNKNOWN && sym->attr.flavor != FL_STRUCT
4641 : 28358 : && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
4642 : 28699 : || sym->attr.subroutine)
4643 : : {
4644 : 2 : gfc_error ("Type name %qs at %C conflicts with previously declared "
4645 : : "entity at %L, which has the same name", name,
4646 : : &sym->declared_at);
4647 : 2 : return MATCH_ERROR;
4648 : : }
4649 : :
4650 : 28699 : if (sym && sym->attr.flavor == FL_DERIVED
4651 : 28699 : && sym->attr.pdt_template
4652 : 0 : && gfc_current_state () != COMP_DERIVED)
4653 : : {
4654 : 0 : m = gfc_get_pdt_instance (decl_type_param_list, &sym, NULL);
4655 : 0 : if (m != MATCH_YES)
4656 : : return m;
4657 : 0 : gcc_assert (!sym->attr.pdt_template && sym->attr.pdt_type);
4658 : 0 : ts->u.derived = sym;
4659 : 0 : strcpy (name, gfc_dt_lower_string (sym->name));
4660 : : }
4661 : :
4662 : 28699 : gfc_save_symbol_data (sym);
4663 : 28699 : gfc_set_sym_referenced (sym);
4664 : 28699 : if (!sym->attr.generic
4665 : 28699 : && !gfc_add_generic (&sym->attr, sym->name, NULL))
4666 : : return MATCH_ERROR;
4667 : :
4668 : 28699 : if (!sym->attr.function
4669 : 28699 : && !gfc_add_function (&sym->attr, sym->name, NULL))
4670 : : return MATCH_ERROR;
4671 : :
4672 : 28699 : if (dt_sym && dt_sym->attr.flavor == FL_DERIVED
4673 : 28587 : && dt_sym->attr.pdt_template
4674 : 81 : && gfc_current_state () != COMP_DERIVED)
4675 : : {
4676 : 42 : m = gfc_get_pdt_instance (decl_type_param_list, &dt_sym, NULL);
4677 : 42 : if (m != MATCH_YES)
4678 : : return m;
4679 : 42 : gcc_assert (!dt_sym->attr.pdt_template && dt_sym->attr.pdt_type);
4680 : : }
4681 : :
4682 : 28699 : if (!dt_sym)
4683 : : {
4684 : 112 : gfc_interface *intr, *head;
4685 : :
4686 : : /* Use upper case to save the actual derived-type symbol. */
4687 : 112 : gfc_get_symbol (dt_name, NULL, &dt_sym);
4688 : 112 : dt_sym->name = gfc_get_string ("%s", sym->name);
4689 : 112 : head = sym->generic;
4690 : 112 : intr = gfc_get_interface ();
4691 : 112 : intr->sym = dt_sym;
4692 : 112 : intr->where = gfc_current_locus;
4693 : 112 : intr->next = head;
4694 : 112 : sym->generic = intr;
4695 : 112 : sym->attr.if_source = IFSRC_DECL;
4696 : : }
4697 : : else
4698 : 28587 : gfc_save_symbol_data (dt_sym);
4699 : :
4700 : 28699 : gfc_set_sym_referenced (dt_sym);
4701 : :
4702 : 112 : if (dt_sym->attr.flavor != FL_DERIVED && dt_sym->attr.flavor != FL_STRUCT
4703 : 28811 : && !gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL))
4704 : : return MATCH_ERROR;
4705 : :
4706 : 28699 : ts->u.derived = dt_sym;
4707 : :
4708 : 28699 : return MATCH_YES;
4709 : :
4710 : 133066 : get_kind:
4711 : 133066 : if (matched_type
4712 : 133066 : && !gfc_notify_std (GFC_STD_F2008, "TYPE with "
4713 : : "intrinsic-type-spec at %C"))
4714 : : return MATCH_ERROR;
4715 : :
4716 : : /* For all types except double, derived and character, look for an
4717 : : optional kind specifier. MATCH_NO is actually OK at this point. */
4718 : 133063 : if (implicit_flag == 1)
4719 : : {
4720 : 241 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4721 : : return MATCH_ERROR;
4722 : :
4723 : 241 : return MATCH_YES;
4724 : : }
4725 : :
4726 : 132822 : if (gfc_current_form == FORM_FREE)
4727 : : {
4728 : 122434 : c = gfc_peek_ascii_char ();
4729 : 122434 : if (!gfc_is_whitespace (c) && c != '*' && c != '('
4730 : 61529 : && c != ':' && c != ',')
4731 : : {
4732 : 165 : if (matched_type && c == ')')
4733 : : {
4734 : 2 : gfc_next_ascii_char ();
4735 : 2 : return MATCH_YES;
4736 : : }
4737 : 163 : gfc_error ("Malformed type-spec at %C");
4738 : 163 : return MATCH_NO;
4739 : : }
4740 : : }
4741 : :
4742 : 132657 : m = gfc_match_kind_spec (ts, false);
4743 : 132657 : if (m == MATCH_ERROR)
4744 : : return MATCH_ERROR;
4745 : :
4746 : 132623 : if (m == MATCH_NO && ts->type != BT_CHARACTER)
4747 : : {
4748 : 91921 : m = gfc_match_old_kind_spec (ts);
4749 : 91921 : if (gfc_validate_kind (ts->type, ts->kind, true) == -1)
4750 : : return MATCH_ERROR;
4751 : : }
4752 : :
4753 : 132615 : if (matched_type && gfc_match_char (')') != MATCH_YES)
4754 : : {
4755 : 0 : gfc_error ("Malformed type-spec at %C");
4756 : 0 : return MATCH_ERROR;
4757 : : }
4758 : :
4759 : : /* Defer association of the KIND expression of function results
4760 : : until after USE and IMPORT statements. */
4761 : 4474 : if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
4762 : 137054 : || gfc_matching_function)
4763 : 6586 : return MATCH_YES;
4764 : :
4765 : 126029 : if (m == MATCH_NO)
4766 : 129590 : m = MATCH_YES; /* No kind specifier found. */
4767 : :
4768 : : return m;
4769 : : }
4770 : :
4771 : :
4772 : : /* Match an IMPLICIT NONE statement. Actually, this statement is
4773 : : already matched in parse.cc, or we would not end up here in the
4774 : : first place. So the only thing we need to check, is if there is
4775 : : trailing garbage. If not, the match is successful. */
4776 : :
4777 : : match
4778 : 20868 : gfc_match_implicit_none (void)
4779 : : {
4780 : 20868 : char c;
4781 : 20868 : match m;
4782 : 20868 : char name[GFC_MAX_SYMBOL_LEN + 1];
4783 : 20868 : bool type = false;
4784 : 20868 : bool external = false;
4785 : 20868 : locus cur_loc = gfc_current_locus;
4786 : :
4787 : 20868 : if (gfc_current_ns->seen_implicit_none
4788 : 20866 : || gfc_current_ns->has_implicit_none_export)
4789 : : {
4790 : 4 : gfc_error ("Duplicate IMPLICIT NONE statement at %C");
4791 : 4 : return MATCH_ERROR;
4792 : : }
4793 : :
4794 : 20864 : gfc_gobble_whitespace ();
4795 : 20864 : c = gfc_peek_ascii_char ();
4796 : 20864 : if (c == '(')
4797 : : {
4798 : 944 : (void) gfc_next_ascii_char ();
4799 : 944 : if (!gfc_notify_std (GFC_STD_F2018, "IMPLICIT NONE with spec list at %C"))
4800 : : return MATCH_ERROR;
4801 : :
4802 : 943 : gfc_gobble_whitespace ();
4803 : 943 : if (gfc_peek_ascii_char () == ')')
4804 : : {
4805 : 1 : (void) gfc_next_ascii_char ();
4806 : 1 : type = true;
4807 : : }
4808 : : else
4809 : 2806 : for(;;)
4810 : : {
4811 : 1874 : m = gfc_match (" %n", name);
4812 : 1874 : if (m != MATCH_YES)
4813 : : return MATCH_ERROR;
4814 : :
4815 : 1874 : if (strcmp (name, "type") == 0)
4816 : : type = true;
4817 : 942 : else if (strcmp (name, "external") == 0)
4818 : : external = true;
4819 : : else
4820 : : return MATCH_ERROR;
4821 : :
4822 : 1874 : gfc_gobble_whitespace ();
4823 : 1874 : c = gfc_next_ascii_char ();
4824 : 1874 : if (c == ',')
4825 : 932 : continue;
4826 : 942 : if (c == ')')
4827 : : break;
4828 : : return MATCH_ERROR;
4829 : : }
4830 : : }
4831 : : else
4832 : : type = true;
4833 : :
4834 : 20863 : if (gfc_match_eos () != MATCH_YES)
4835 : : return MATCH_ERROR;
4836 : :
4837 : 20863 : gfc_set_implicit_none (type, external, &cur_loc);
4838 : :
4839 : 20863 : return MATCH_YES;
4840 : : }
4841 : :
4842 : :
4843 : : /* Match the letter range(s) of an IMPLICIT statement. */
4844 : :
4845 : : static match
4846 : 632 : match_implicit_range (void)
4847 : : {
4848 : 632 : char c, c1, c2;
4849 : 632 : int inner;
4850 : 632 : locus cur_loc;
4851 : :
4852 : 632 : cur_loc = gfc_current_locus;
4853 : :
4854 : 632 : gfc_gobble_whitespace ();
4855 : 632 : c = gfc_next_ascii_char ();
4856 : 632 : if (c != '(')
4857 : : {
4858 : 59 : gfc_error ("Missing character range in IMPLICIT at %C");
4859 : 59 : goto bad;
4860 : : }
4861 : :
4862 : : inner = 1;
4863 : 1243 : while (inner)
4864 : : {
4865 : 753 : gfc_gobble_whitespace ();
4866 : 753 : c1 = gfc_next_ascii_char ();
4867 : 753 : if (!ISALPHA (c1))
4868 : 48 : goto bad;
4869 : :
4870 : 705 : gfc_gobble_whitespace ();
4871 : 705 : c = gfc_next_ascii_char ();
4872 : :
4873 : 705 : switch (c)
4874 : : {
4875 : 199 : case ')':
4876 : 199 : inner = 0; /* Fall through. */
4877 : :
4878 : : case ',':
4879 : : c2 = c1;
4880 : : break;
4881 : :
4882 : 457 : case '-':
4883 : 457 : gfc_gobble_whitespace ();
4884 : 457 : c2 = gfc_next_ascii_char ();
4885 : 457 : if (!ISALPHA (c2))
4886 : 0 : goto bad;
4887 : :
4888 : 457 : gfc_gobble_whitespace ();
4889 : 457 : c = gfc_next_ascii_char ();
4890 : :
4891 : 457 : if ((c != ',') && (c != ')'))
4892 : 0 : goto bad;
4893 : 457 : if (c == ')')
4894 : 291 : inner = 0;
4895 : :
4896 : : break;
4897 : :
4898 : 35 : default:
4899 : 35 : goto bad;
4900 : : }
4901 : :
4902 : 670 : if (c1 > c2)
4903 : : {
4904 : 0 : gfc_error ("Letters must be in alphabetic order in "
4905 : : "IMPLICIT statement at %C");
4906 : 0 : goto bad;
4907 : : }
4908 : :
4909 : : /* See if we can add the newly matched range to the pending
4910 : : implicits from this IMPLICIT statement. We do not check for
4911 : : conflicts with whatever earlier IMPLICIT statements may have
4912 : : set. This is done when we've successfully finished matching
4913 : : the current one. */
4914 : 670 : if (!gfc_add_new_implicit_range (c1, c2))
4915 : 0 : goto bad;
4916 : : }
4917 : :
4918 : : return MATCH_YES;
4919 : :
4920 : 142 : bad:
4921 : 142 : gfc_syntax_error (ST_IMPLICIT);
4922 : :
4923 : 142 : gfc_current_locus = cur_loc;
4924 : 142 : return MATCH_ERROR;
4925 : : }
4926 : :
4927 : :
4928 : : /* Match an IMPLICIT statement, storing the types for
4929 : : gfc_set_implicit() if the statement is accepted by the parser.
4930 : : There is a strange looking, but legal syntactic construction
4931 : : possible. It looks like:
4932 : :
4933 : : IMPLICIT INTEGER (a-b) (c-d)
4934 : :
4935 : : This is legal if "a-b" is a constant expression that happens to
4936 : : equal one of the legal kinds for integers. The real problem
4937 : : happens with an implicit specification that looks like:
4938 : :
4939 : : IMPLICIT INTEGER (a-b)
4940 : :
4941 : : In this case, a typespec matcher that is "greedy" (as most of the
4942 : : matchers are) gobbles the character range as a kindspec, leaving
4943 : : nothing left. We therefore have to go a bit more slowly in the
4944 : : matching process by inhibiting the kindspec checking during
4945 : : typespec matching and checking for a kind later. */
4946 : :
4947 : : match
4948 : 21311 : gfc_match_implicit (void)
4949 : : {
4950 : 21311 : gfc_typespec ts;
4951 : 21311 : locus cur_loc;
4952 : 21311 : char c;
4953 : 21311 : match m;
4954 : :
4955 : 21311 : if (gfc_current_ns->seen_implicit_none)
4956 : : {
4957 : 4 : gfc_error ("IMPLICIT statement at %C following an IMPLICIT NONE (type) "
4958 : : "statement");
4959 : 4 : return MATCH_ERROR;
4960 : : }
4961 : :
4962 : 21307 : gfc_clear_ts (&ts);
4963 : :
4964 : : /* We don't allow empty implicit statements. */
4965 : 21307 : if (gfc_match_eos () == MATCH_YES)
4966 : : {
4967 : 0 : gfc_error ("Empty IMPLICIT statement at %C");
4968 : 0 : return MATCH_ERROR;
4969 : : }
4970 : :
4971 : 21336 : do
4972 : : {
4973 : : /* First cleanup. */
4974 : 21336 : gfc_clear_new_implicit ();
4975 : :
4976 : : /* A basic type is mandatory here. */
4977 : 21336 : m = gfc_match_decl_type_spec (&ts, 1);
4978 : 21336 : if (m == MATCH_ERROR)
4979 : 0 : goto error;
4980 : 21336 : if (m == MATCH_NO)
4981 : 20866 : goto syntax;
4982 : :
4983 : 470 : cur_loc = gfc_current_locus;
4984 : 470 : m = match_implicit_range ();
4985 : :
4986 : 470 : if (m == MATCH_YES)
4987 : : {
4988 : : /* We may have <TYPE> (<RANGE>). */
4989 : 328 : gfc_gobble_whitespace ();
4990 : 328 : c = gfc_peek_ascii_char ();
4991 : 328 : if (c == ',' || c == '\n' || c == ';' || c == '!')
4992 : : {
4993 : : /* Check for CHARACTER with no length parameter. */
4994 : 301 : if (ts.type == BT_CHARACTER && !ts.u.cl)
4995 : : {
4996 : 31 : ts.kind = gfc_default_character_kind;
4997 : 31 : ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
4998 : 31 : ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4999 : : NULL, 1);
5000 : : }
5001 : :
5002 : : /* Record the Successful match. */
5003 : 301 : if (!gfc_merge_new_implicit (&ts))
5004 : : return MATCH_ERROR;
5005 : 299 : if (c == ',')
5006 : 28 : c = gfc_next_ascii_char ();
5007 : 271 : else if (gfc_match_eos () == MATCH_ERROR)
5008 : 0 : goto error;
5009 : 299 : continue;
5010 : : }
5011 : :
5012 : 27 : gfc_current_locus = cur_loc;
5013 : : }
5014 : :
5015 : : /* Discard the (incorrectly) matched range. */
5016 : 169 : gfc_clear_new_implicit ();
5017 : :
5018 : : /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>). */
5019 : 169 : if (ts.type == BT_CHARACTER)
5020 : 74 : m = gfc_match_char_spec (&ts);
5021 : 95 : else if (gfc_numeric_ts(&ts) || ts.type == BT_LOGICAL)
5022 : : {
5023 : 91 : m = gfc_match_kind_spec (&ts, false);
5024 : 91 : if (m == MATCH_NO)
5025 : : {
5026 : 40 : m = gfc_match_old_kind_spec (&ts);
5027 : 40 : if (m == MATCH_ERROR)
5028 : 0 : goto error;
5029 : 40 : if (m == MATCH_NO)
5030 : 0 : goto syntax;
5031 : : }
5032 : : }
5033 : 169 : if (m == MATCH_ERROR)
5034 : 7 : goto error;
5035 : :
5036 : 162 : m = match_implicit_range ();
5037 : 162 : if (m == MATCH_ERROR)
5038 : 0 : goto error;
5039 : 162 : if (m == MATCH_NO)
5040 : 0 : goto syntax;
5041 : :
5042 : 162 : gfc_gobble_whitespace ();
5043 : 162 : c = gfc_next_ascii_char ();
5044 : 162 : if (c != ',' && gfc_match_eos () != MATCH_YES)
5045 : 0 : goto syntax;
5046 : :
5047 : 162 : if (!gfc_merge_new_implicit (&ts))
5048 : : return MATCH_ERROR;
5049 : : }
5050 : 461 : while (c == ',');
5051 : :
5052 : : return MATCH_YES;
5053 : :
5054 : 20866 : syntax:
5055 : 20866 : gfc_syntax_error (ST_IMPLICIT);
5056 : :
5057 : : error:
5058 : : return MATCH_ERROR;
5059 : : }
5060 : :
5061 : :
5062 : : match
5063 : 2868 : gfc_match_import (void)
5064 : : {
5065 : 2868 : char name[GFC_MAX_SYMBOL_LEN + 1];
5066 : 2868 : match m;
5067 : 2868 : gfc_symbol *sym;
5068 : 2868 : gfc_symtree *st;
5069 : :
5070 : 2868 : if (gfc_current_ns->proc_name == NULL
5071 : 2867 : || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
5072 : : {
5073 : 3 : gfc_error ("IMPORT statement at %C only permitted in "
5074 : : "an INTERFACE body");
5075 : 3 : return MATCH_ERROR;
5076 : : }
5077 : :
5078 : 2865 : if (gfc_current_ns->proc_name->attr.module_procedure)
5079 : : {
5080 : 1 : gfc_error ("F2008: C1210 IMPORT statement at %C is not permitted "
5081 : : "in a module procedure interface body");
5082 : 1 : return MATCH_ERROR;
5083 : : }
5084 : :
5085 : 2864 : if (!gfc_notify_std (GFC_STD_F2003, "IMPORT statement at %C"))
5086 : : return MATCH_ERROR;
5087 : :
5088 : 2860 : if (gfc_match_eos () == MATCH_YES)
5089 : : {
5090 : : /* All host variables should be imported. */
5091 : 201 : gfc_current_ns->has_import_set = 1;
5092 : 201 : return MATCH_YES;
5093 : : }
5094 : :
5095 : 2659 : if (gfc_match (" ::") == MATCH_YES)
5096 : : {
5097 : 776 : if (gfc_match_eos () == MATCH_YES)
5098 : : {
5099 : 1 : gfc_error ("Expecting list of named entities at %C");
5100 : 1 : return MATCH_ERROR;
5101 : : }
5102 : : }
5103 : :
5104 : 3309 : for(;;)
5105 : : {
5106 : 3309 : sym = NULL;
5107 : 3309 : m = gfc_match (" %n", name);
5108 : 3309 : switch (m)
5109 : : {
5110 : 3309 : case MATCH_YES:
5111 : 3309 : if (gfc_current_ns->parent != NULL
5112 : 3309 : && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
5113 : : {
5114 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5115 : 0 : return MATCH_ERROR;
5116 : : }
5117 : 1 : else if (!sym && gfc_current_ns->proc_name->ns->parent != NULL
5118 : 3309 : && gfc_find_symbol (name,
5119 : : gfc_current_ns->proc_name->ns->parent,
5120 : : 1, &sym))
5121 : : {
5122 : 0 : gfc_error ("Type name %qs at %C is ambiguous", name);
5123 : 0 : return MATCH_ERROR;
5124 : : }
5125 : :
5126 : 3309 : if (sym == NULL)
5127 : : {
5128 : 1 : gfc_error ("Cannot IMPORT %qs from host scoping unit "
5129 : : "at %C - does not exist.", name);
5130 : 1 : return MATCH_ERROR;
5131 : : }
5132 : :
5133 : 3308 : if (gfc_find_symtree (gfc_current_ns->sym_root, name))
5134 : : {
5135 : 6 : gfc_warning (0, "%qs is already IMPORTed from host scoping unit "
5136 : : "at %C", name);
5137 : 6 : goto next_item;
5138 : : }
5139 : :
5140 : 3302 : st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
5141 : 3302 : st->n.sym = sym;
5142 : 3302 : sym->refs++;
5143 : 3302 : sym->attr.imported = 1;
5144 : :
5145 : 3302 : if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
5146 : : {
5147 : : /* The actual derived type is stored in a symtree with the first
5148 : : letter of the name capitalized; the symtree with the all
5149 : : lower-case name contains the associated generic function. */
5150 : 535 : st = gfc_new_symtree (&gfc_current_ns->sym_root,
5151 : : gfc_dt_upper_string (name));
5152 : 535 : st->n.sym = sym;
5153 : 535 : sym->refs++;
5154 : 535 : sym->attr.imported = 1;
5155 : : }
5156 : :
5157 : 3302 : goto next_item;
5158 : :
5159 : : case MATCH_NO:
5160 : : break;
5161 : :
5162 : : case MATCH_ERROR:
5163 : : return MATCH_ERROR;
5164 : : }
5165 : :
5166 : 3308 : next_item:
5167 : 3308 : if (gfc_match_eos () == MATCH_YES)
5168 : : break;
5169 : 651 : if (gfc_match_char (',') != MATCH_YES)
5170 : 0 : goto syntax;
5171 : : }
5172 : :
5173 : : return MATCH_YES;
5174 : :
5175 : 0 : syntax:
5176 : 0 : gfc_error ("Syntax error in IMPORT statement at %C");
5177 : 0 : return MATCH_ERROR;
5178 : : }
5179 : :
5180 : :
5181 : : /* A minimal implementation of gfc_match without whitespace, escape
5182 : : characters or variable arguments. Returns true if the next
5183 : : characters match the TARGET template exactly. */
5184 : :
5185 : : static bool
5186 : 123730 : match_string_p (const char *target)
5187 : : {
5188 : 123730 : const char *p;
5189 : :
5190 : 777811 : for (p = target; *p; p++)
5191 : 654082 : if ((char) gfc_next_ascii_char () != *p)
5192 : : return false;
5193 : : return true;
5194 : : }
5195 : :
5196 : : /* Matches an attribute specification including array specs. If
5197 : : successful, leaves the variables current_attr and current_as
5198 : : holding the specification. Also sets the colon_seen variable for
5199 : : later use by matchers associated with initializations.
5200 : :
5201 : : This subroutine is a little tricky in the sense that we don't know
5202 : : if we really have an attr-spec until we hit the double colon.
5203 : : Until that time, we can only return MATCH_NO. This forces us to
5204 : : check for duplicate specification at this level. */
5205 : :
5206 : : static match
5207 : 184021 : match_attr_spec (void)
5208 : : {
5209 : : /* Modifiers that can exist in a type statement. */
5210 : 184021 : enum
5211 : : { GFC_DECL_BEGIN = 0, DECL_ALLOCATABLE = GFC_DECL_BEGIN,
5212 : : DECL_IN = INTENT_IN, DECL_OUT = INTENT_OUT, DECL_INOUT = INTENT_INOUT,
5213 : : DECL_DIMENSION, DECL_EXTERNAL,
5214 : : DECL_INTRINSIC, DECL_OPTIONAL,
5215 : : DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
5216 : : DECL_STATIC, DECL_AUTOMATIC,
5217 : : DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
5218 : : DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
5219 : : DECL_LEN, DECL_KIND, DECL_NONE, GFC_DECL_END /* Sentinel */
5220 : : };
5221 : :
5222 : : /* GFC_DECL_END is the sentinel, index starts at 0. */
5223 : : #define NUM_DECL GFC_DECL_END
5224 : :
5225 : : /* Make sure that values from sym_intent are safe to be used here. */
5226 : 184021 : gcc_assert (INTENT_IN > 0);
5227 : :
5228 : 184021 : locus start, seen_at[NUM_DECL];
5229 : 184021 : int seen[NUM_DECL];
5230 : 184021 : unsigned int d;
5231 : 184021 : const char *attr;
5232 : 184021 : match m;
5233 : 184021 : bool t;
5234 : :
5235 : 184021 : gfc_clear_attr (¤t_attr);
5236 : 184021 : start = gfc_current_locus;
5237 : :
5238 : 184021 : current_as = NULL;
5239 : 184021 : colon_seen = 0;
5240 : 184021 : attr_seen = 0;
5241 : :
5242 : : /* See if we get all of the keywords up to the final double colon. */
5243 : 4968567 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5244 : 4784546 : seen[d] = 0;
5245 : :
5246 : 284222 : for (;;)
5247 : : {
5248 : 284222 : char ch;
5249 : :
5250 : 284222 : d = DECL_NONE;
5251 : 284222 : gfc_gobble_whitespace ();
5252 : :
5253 : 284222 : ch = gfc_next_ascii_char ();
5254 : 284222 : if (ch == ':')
5255 : : {
5256 : : /* This is the successful exit condition for the loop. */
5257 : 155148 : if (gfc_next_ascii_char () == ':')
5258 : : break;
5259 : : }
5260 : 129074 : else if (ch == ',')
5261 : : {
5262 : 100213 : gfc_gobble_whitespace ();
5263 : 100213 : switch (gfc_peek_ascii_char ())
5264 : : {
5265 : 13680 : case 'a':
5266 : 13680 : gfc_next_ascii_char ();
5267 : 13680 : switch (gfc_next_ascii_char ())
5268 : : {
5269 : 13616 : case 'l':
5270 : 13616 : if (match_string_p ("locatable"))
5271 : : {
5272 : : /* Matched "allocatable". */
5273 : : d = DECL_ALLOCATABLE;
5274 : : }
5275 : : break;
5276 : :
5277 : 23 : case 's':
5278 : 23 : if (match_string_p ("ynchronous"))
5279 : : {
5280 : : /* Matched "asynchronous". */
5281 : : d = DECL_ASYNCHRONOUS;
5282 : : }
5283 : : break;
5284 : :
5285 : 41 : case 'u':
5286 : 41 : if (match_string_p ("tomatic"))
5287 : : {
5288 : : /* Matched "automatic". */
5289 : : d = DECL_AUTOMATIC;
5290 : : }
5291 : : break;
5292 : : }
5293 : : break;
5294 : :
5295 : 144 : case 'b':
5296 : : /* Try and match the bind(c). */
5297 : 144 : m = gfc_match_bind_c (NULL, true);
5298 : 144 : if (m == MATCH_YES)
5299 : : d = DECL_IS_BIND_C;
5300 : 0 : else if (m == MATCH_ERROR)
5301 : 0 : goto cleanup;
5302 : : break;
5303 : :
5304 : 1809 : case 'c':
5305 : 1809 : gfc_next_ascii_char ();
5306 : 1809 : if ('o' != gfc_next_ascii_char ())
5307 : : break;
5308 : 1808 : switch (gfc_next_ascii_char ())
5309 : : {
5310 : 46 : case 'd':
5311 : 46 : if (match_string_p ("imension"))
5312 : : {
5313 : : d = DECL_CODIMENSION;
5314 : : break;
5315 : : }
5316 : : /* FALLTHRU */
5317 : 1762 : case 'n':
5318 : 1762 : if (match_string_p ("tiguous"))
5319 : : {
5320 : : d = DECL_CONTIGUOUS;
5321 : : break;
5322 : : }
5323 : : }
5324 : : break;
5325 : :
5326 : 17895 : case 'd':
5327 : 17895 : if (match_string_p ("dimension"))
5328 : : d = DECL_DIMENSION;
5329 : : break;
5330 : :
5331 : 167 : case 'e':
5332 : 167 : if (match_string_p ("external"))
5333 : : d = DECL_EXTERNAL;
5334 : : break;
5335 : :
5336 : 23662 : case 'i':
5337 : 23662 : if (match_string_p ("int"))
5338 : : {
5339 : 23662 : ch = gfc_next_ascii_char ();
5340 : 23662 : if (ch == 'e')
5341 : : {
5342 : 23656 : if (match_string_p ("nt"))
5343 : : {
5344 : : /* Matched "intent". */
5345 : 23655 : d = match_intent_spec ();
5346 : 23655 : if (d == INTENT_UNKNOWN)
5347 : : {
5348 : 2 : m = MATCH_ERROR;
5349 : 2 : goto cleanup;
5350 : : }
5351 : : }
5352 : : }
5353 : 6 : else if (ch == 'r')
5354 : : {
5355 : 6 : if (match_string_p ("insic"))
5356 : : {
5357 : : /* Matched "intrinsic". */
5358 : : d = DECL_INTRINSIC;
5359 : : }
5360 : : }
5361 : : }
5362 : : break;
5363 : :
5364 : 136 : case 'k':
5365 : 136 : if (match_string_p ("kind"))
5366 : : d = DECL_KIND;
5367 : : break;
5368 : :
5369 : 179 : case 'l':
5370 : 179 : if (match_string_p ("len"))
5371 : : d = DECL_LEN;
5372 : : break;
5373 : :
5374 : 4194 : case 'o':
5375 : 4194 : if (match_string_p ("optional"))
5376 : : d = DECL_OPTIONAL;
5377 : : break;
5378 : :
5379 : 24141 : case 'p':
5380 : 24141 : gfc_next_ascii_char ();
5381 : 24141 : switch (gfc_next_ascii_char ())
5382 : : {
5383 : 12336 : case 'a':
5384 : 12336 : if (match_string_p ("rameter"))
5385 : : {
5386 : : /* Matched "parameter". */
5387 : : d = DECL_PARAMETER;
5388 : : }
5389 : : break;
5390 : :
5391 : 11337 : case 'o':
5392 : 11337 : if (match_string_p ("inter"))
5393 : : {
5394 : : /* Matched "pointer". */
5395 : : d = DECL_POINTER;
5396 : : }
5397 : : break;
5398 : :
5399 : 231 : case 'r':
5400 : 231 : ch = gfc_next_ascii_char ();
5401 : 231 : if (ch == 'i')
5402 : : {
5403 : 183 : if (match_string_p ("vate"))
5404 : : {
5405 : : /* Matched "private". */
5406 : : d = DECL_PRIVATE;
5407 : : }
5408 : : }
5409 : 48 : else if (ch == 'o')
5410 : : {
5411 : 48 : if (match_string_p ("tected"))
5412 : : {
5413 : : /* Matched "protected". */
5414 : : d = DECL_PROTECTED;
5415 : : }
5416 : : }
5417 : : break;
5418 : :
5419 : 237 : case 'u':
5420 : 237 : if (match_string_p ("blic"))
5421 : : {
5422 : : /* Matched "public". */
5423 : : d = DECL_PUBLIC;
5424 : : }
5425 : : break;
5426 : : }
5427 : : break;
5428 : :
5429 : 1116 : case 's':
5430 : 1116 : gfc_next_ascii_char ();
5431 : 1116 : switch (gfc_next_ascii_char ())
5432 : : {
5433 : 1103 : case 'a':
5434 : 1103 : if (match_string_p ("ve"))
5435 : : {
5436 : : /* Matched "save". */
5437 : : d = DECL_SAVE;
5438 : : }
5439 : : break;
5440 : :
5441 : 13 : case 't':
5442 : 13 : if (match_string_p ("atic"))
5443 : : {
5444 : : /* Matched "static". */
5445 : : d = DECL_STATIC;
5446 : : }
5447 : : break;
5448 : : }
5449 : : break;
5450 : :
5451 : 4980 : case 't':
5452 : 4980 : if (match_string_p ("target"))
5453 : : d = DECL_TARGET;
5454 : : break;
5455 : :
5456 : 8110 : case 'v':
5457 : 8110 : gfc_next_ascii_char ();
5458 : 8110 : ch = gfc_next_ascii_char ();
5459 : 8110 : if (ch == 'a')
5460 : : {
5461 : 7612 : if (match_string_p ("lue"))
5462 : : {
5463 : : /* Matched "value". */
5464 : : d = DECL_VALUE;
5465 : : }
5466 : : }
5467 : 498 : else if (ch == 'o')
5468 : : {
5469 : 498 : if (match_string_p ("latile"))
5470 : : {
5471 : : /* Matched "volatile". */
5472 : : d = DECL_VOLATILE;
5473 : : }
5474 : : }
5475 : : break;
5476 : : }
5477 : : }
5478 : :
5479 : : /* No double colon and no recognizable decl_type, so assume that
5480 : : we've been looking at something else the whole time. */
5481 : 23653 : if (d == DECL_NONE)
5482 : : {
5483 : 28864 : m = MATCH_NO;
5484 : 28864 : goto cleanup;
5485 : : }
5486 : :
5487 : : /* Check to make sure any parens are paired up correctly. */
5488 : 100209 : if (gfc_match_parens () == MATCH_ERROR)
5489 : : {
5490 : 1 : m = MATCH_ERROR;
5491 : 1 : goto cleanup;
5492 : : }
5493 : :
5494 : 100208 : seen[d]++;
5495 : 100208 : seen_at[d] = gfc_current_locus;
5496 : :
5497 : 100208 : if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
5498 : : {
5499 : 17940 : gfc_array_spec *as = NULL;
5500 : :
5501 : 17940 : m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
5502 : : d == DECL_CODIMENSION);
5503 : :
5504 : 17940 : if (current_as == NULL)
5505 : 17922 : current_as = as;
5506 : 18 : else if (m == MATCH_YES)
5507 : : {
5508 : 18 : if (!merge_array_spec (as, current_as, false))
5509 : 2 : m = MATCH_ERROR;
5510 : 18 : free (as);
5511 : : }
5512 : :
5513 : 17940 : if (m == MATCH_NO)
5514 : : {
5515 : 0 : if (d == DECL_CODIMENSION)
5516 : 0 : gfc_error ("Missing codimension specification at %C");
5517 : : else
5518 : 0 : gfc_error ("Missing dimension specification at %C");
5519 : : m = MATCH_ERROR;
5520 : : }
5521 : :
5522 : 17940 : if (m == MATCH_ERROR)
5523 : 7 : goto cleanup;
5524 : : }
5525 : : }
5526 : :
5527 : : /* Since we've seen a double colon, we have to be looking at an
5528 : : attr-spec. This means that we can now issue errors. */
5529 : 4188948 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5530 : 4033803 : if (seen[d] > 1)
5531 : : {
5532 : 2 : switch (d)
5533 : : {
5534 : : case DECL_ALLOCATABLE:
5535 : : attr = "ALLOCATABLE";
5536 : : break;
5537 : 0 : case DECL_ASYNCHRONOUS:
5538 : 0 : attr = "ASYNCHRONOUS";
5539 : 0 : break;
5540 : 0 : case DECL_CODIMENSION:
5541 : 0 : attr = "CODIMENSION";
5542 : 0 : break;
5543 : 0 : case DECL_CONTIGUOUS:
5544 : 0 : attr = "CONTIGUOUS";
5545 : 0 : break;
5546 : 0 : case DECL_DIMENSION:
5547 : 0 : attr = "DIMENSION";
5548 : 0 : break;
5549 : 0 : case DECL_EXTERNAL:
5550 : 0 : attr = "EXTERNAL";
5551 : 0 : break;
5552 : 0 : case DECL_IN:
5553 : 0 : attr = "INTENT (IN)";
5554 : 0 : break;
5555 : 0 : case DECL_OUT:
5556 : 0 : attr = "INTENT (OUT)";
5557 : 0 : break;
5558 : 0 : case DECL_INOUT:
5559 : 0 : attr = "INTENT (IN OUT)";
5560 : 0 : break;
5561 : 0 : case DECL_INTRINSIC:
5562 : 0 : attr = "INTRINSIC";
5563 : 0 : break;
5564 : 0 : case DECL_OPTIONAL:
5565 : 0 : attr = "OPTIONAL";
5566 : 0 : break;
5567 : 0 : case DECL_KIND:
5568 : 0 : attr = "KIND";
5569 : 0 : break;
5570 : 0 : case DECL_LEN:
5571 : 0 : attr = "LEN";
5572 : 0 : break;
5573 : 0 : case DECL_PARAMETER:
5574 : 0 : attr = "PARAMETER";
5575 : 0 : break;
5576 : 0 : case DECL_POINTER:
5577 : 0 : attr = "POINTER";
5578 : 0 : break;
5579 : 0 : case DECL_PROTECTED:
5580 : 0 : attr = "PROTECTED";
5581 : 0 : break;
5582 : 0 : case DECL_PRIVATE:
5583 : 0 : attr = "PRIVATE";
5584 : 0 : break;
5585 : 0 : case DECL_PUBLIC:
5586 : 0 : attr = "PUBLIC";
5587 : 0 : break;
5588 : 0 : case DECL_SAVE:
5589 : 0 : attr = "SAVE";
5590 : 0 : break;
5591 : 0 : case DECL_STATIC:
5592 : 0 : attr = "STATIC";
5593 : 0 : break;
5594 : 1 : case DECL_AUTOMATIC:
5595 : 1 : attr = "AUTOMATIC";
5596 : 1 : break;
5597 : 0 : case DECL_TARGET:
5598 : 0 : attr = "TARGET";
5599 : 0 : break;
5600 : 0 : case DECL_IS_BIND_C:
5601 : 0 : attr = "IS_BIND_C";
5602 : 0 : break;
5603 : 0 : case DECL_VALUE:
5604 : 0 : attr = "VALUE";
5605 : 0 : break;
5606 : 1 : case DECL_VOLATILE:
5607 : 1 : attr = "VOLATILE";
5608 : 1 : break;
5609 : 0 : default:
5610 : 0 : attr = NULL; /* This shouldn't happen. */
5611 : : }
5612 : :
5613 : 2 : gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
5614 : 2 : m = MATCH_ERROR;
5615 : 2 : goto cleanup;
5616 : : }
5617 : :
5618 : : /* Now that we've dealt with duplicate attributes, add the attributes
5619 : : to the current attribute. */
5620 : 4188128 : for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
5621 : : {
5622 : 4033056 : if (seen[d] == 0)
5623 : 3932864 : continue;
5624 : : else
5625 : 100192 : attr_seen = 1;
5626 : :
5627 : 100192 : if ((d == DECL_STATIC || d == DECL_AUTOMATIC)
5628 : 52 : && !flag_dec_static)
5629 : : {
5630 : 3 : gfc_error ("%s at %L is a DEC extension, enable with "
5631 : : "%<-fdec-static%>",
5632 : : d == DECL_STATIC ? "STATIC" : "AUTOMATIC", &seen_at[d]);
5633 : 2 : m = MATCH_ERROR;
5634 : 2 : goto cleanup;
5635 : : }
5636 : : /* Allow SAVE with STATIC, but don't complain. */
5637 : 50 : if (d == DECL_STATIC && seen[DECL_SAVE])
5638 : 0 : continue;
5639 : :
5640 : 100190 : if (gfc_comp_struct (gfc_current_state ())
5641 : 5663 : && d != DECL_DIMENSION && d != DECL_CODIMENSION
5642 : 4734 : && d != DECL_POINTER && d != DECL_PRIVATE
5643 : 3224 : && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
5644 : : {
5645 : 3181 : bool is_derived = gfc_current_state () == COMP_DERIVED;
5646 : 3181 : if (d == DECL_ALLOCATABLE)
5647 : : {
5648 : 2853 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5649 : : ? G_("ALLOCATABLE attribute at %C in a "
5650 : : "TYPE definition")
5651 : : : G_("ALLOCATABLE attribute at %C in a "
5652 : : "STRUCTURE definition")))
5653 : : {
5654 : 2 : m = MATCH_ERROR;
5655 : 2 : goto cleanup;
5656 : : }
5657 : : }
5658 : 328 : else if (d == DECL_KIND)
5659 : : {
5660 : 134 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5661 : : ? G_("KIND attribute at %C in a "
5662 : : "TYPE definition")
5663 : : : G_("KIND attribute at %C in a "
5664 : : "STRUCTURE definition")))
5665 : : {
5666 : 1 : m = MATCH_ERROR;
5667 : 1 : goto cleanup;
5668 : : }
5669 : 133 : if (current_ts.type != BT_INTEGER)
5670 : : {
5671 : 2 : gfc_error ("Component with KIND attribute at %C must be "
5672 : : "INTEGER");
5673 : 2 : m = MATCH_ERROR;
5674 : 2 : goto cleanup;
5675 : : }
5676 : : }
5677 : 194 : else if (d == DECL_LEN)
5678 : : {
5679 : 178 : if (!gfc_notify_std (GFC_STD_F2003, is_derived
5680 : : ? G_("LEN attribute at %C in a "
5681 : : "TYPE definition")
5682 : : : G_("LEN attribute at %C in a "
5683 : : "STRUCTURE definition")))
5684 : : {
5685 : 0 : m = MATCH_ERROR;
5686 : 0 : goto cleanup;
5687 : : }
5688 : 178 : if (current_ts.type != BT_INTEGER)
5689 : : {
5690 : 1 : gfc_error ("Component with LEN attribute at %C must be "
5691 : : "INTEGER");
5692 : 1 : m = MATCH_ERROR;
5693 : 1 : goto cleanup;
5694 : : }
5695 : : }
5696 : : else
5697 : : {
5698 : 32 : gfc_error (is_derived ? G_("Attribute at %L is not allowed in a "
5699 : : "TYPE definition")
5700 : : : G_("Attribute at %L is not allowed in a "
5701 : : "STRUCTURE definition"), &seen_at[d]);
5702 : 16 : m = MATCH_ERROR;
5703 : 16 : goto cleanup;
5704 : : }
5705 : : }
5706 : :
5707 : 100168 : if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
5708 : 420 : && gfc_current_state () != COMP_MODULE)
5709 : : {
5710 : 102 : if (d == DECL_PRIVATE)
5711 : : attr = "PRIVATE";
5712 : : else
5713 : 30 : attr = "PUBLIC";
5714 : 102 : if (gfc_current_state () == COMP_DERIVED
5715 : 96 : && gfc_state_stack->previous
5716 : 96 : && gfc_state_stack->previous->state == COMP_MODULE)
5717 : : {
5718 : 93 : if (!gfc_notify_std (GFC_STD_F2003, "Attribute %s "
5719 : : "at %L in a TYPE definition", attr,
5720 : : &seen_at[d]))
5721 : : {
5722 : 2 : m = MATCH_ERROR;
5723 : 2 : goto cleanup;
5724 : : }
5725 : : }
5726 : : else
5727 : : {
5728 : 9 : gfc_error ("%s attribute at %L is not allowed outside of the "
5729 : : "specification part of a module", attr, &seen_at[d]);
5730 : 9 : m = MATCH_ERROR;
5731 : 9 : goto cleanup;
5732 : : }
5733 : : }
5734 : :
5735 : 100157 : if (gfc_current_state () != COMP_DERIVED
5736 : 94525 : && (d == DECL_KIND || d == DECL_LEN))
5737 : : {
5738 : 3 : gfc_error ("Attribute at %L is not allowed outside a TYPE "
5739 : : "definition", &seen_at[d]);
5740 : 3 : m = MATCH_ERROR;
5741 : 3 : goto cleanup;
5742 : : }
5743 : :
5744 : 100154 : switch (d)
5745 : : {
5746 : 13614 : case DECL_ALLOCATABLE:
5747 : 13614 : t = gfc_add_allocatable (¤t_attr, &seen_at[d]);
5748 : 13614 : break;
5749 : :
5750 : 22 : case DECL_ASYNCHRONOUS:
5751 : 22 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS attribute at %C"))
5752 : : t = false;
5753 : : else
5754 : 22 : t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]);
5755 : : break;
5756 : :
5757 : 44 : case DECL_CODIMENSION:
5758 : 44 : t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]);
5759 : 44 : break;
5760 : :
5761 : 1762 : case DECL_CONTIGUOUS:
5762 : 1762 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS attribute at %C"))
5763 : : t = false;
5764 : : else
5765 : 1761 : t = gfc_add_contiguous (¤t_attr, NULL, &seen_at[d]);
5766 : : break;
5767 : :
5768 : 17887 : case DECL_DIMENSION:
5769 : 17887 : t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]);
5770 : 17887 : break;
5771 : :
5772 : 166 : case DECL_EXTERNAL:
5773 : 166 : t = gfc_add_external (¤t_attr, &seen_at[d]);
5774 : 166 : break;
5775 : :
5776 : 17797 : case DECL_IN:
5777 : 17797 : t = gfc_add_intent (¤t_attr, INTENT_IN, &seen_at[d]);
5778 : 17797 : break;
5779 : :
5780 : 3223 : case DECL_OUT:
5781 : 3223 : t = gfc_add_intent (¤t_attr, INTENT_OUT, &seen_at[d]);
5782 : 3223 : break;
5783 : :
5784 : 2629 : case DECL_INOUT:
5785 : 2629 : t = gfc_add_intent (¤t_attr, INTENT_INOUT, &seen_at[d]);
5786 : 2629 : break;
5787 : :
5788 : 5 : case DECL_INTRINSIC:
5789 : 5 : t = gfc_add_intrinsic (¤t_attr, &seen_at[d]);
5790 : 5 : break;
5791 : :
5792 : 4193 : case DECL_OPTIONAL:
5793 : 4193 : t = gfc_add_optional (¤t_attr, &seen_at[d]);
5794 : 4193 : break;
5795 : :
5796 : 131 : case DECL_KIND:
5797 : 131 : t = gfc_add_kind (¤t_attr, &seen_at[d]);
5798 : 131 : break;
5799 : :
5800 : 177 : case DECL_LEN:
5801 : 177 : t = gfc_add_len (¤t_attr, &seen_at[d]);
5802 : 177 : break;
5803 : :
5804 : 12335 : case DECL_PARAMETER:
5805 : 12335 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, &seen_at[d]);
5806 : 12335 : break;
5807 : :
5808 : 11336 : case DECL_POINTER:
5809 : 11336 : t = gfc_add_pointer (¤t_attr, &seen_at[d]);
5810 : 11336 : break;
5811 : :
5812 : 47 : case DECL_PROTECTED:
5813 : 47 : if (gfc_current_state () != COMP_MODULE
5814 : 45 : || (gfc_current_ns->proc_name
5815 : 45 : && gfc_current_ns->proc_name->attr.flavor != FL_MODULE))
5816 : : {
5817 : 2 : gfc_error ("PROTECTED at %C only allowed in specification "
5818 : : "part of a module");
5819 : 2 : t = false;
5820 : 2 : break;
5821 : : }
5822 : :
5823 : 45 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED attribute at %C"))
5824 : : t = false;
5825 : : else
5826 : 41 : t = gfc_add_protected (¤t_attr, NULL, &seen_at[d]);
5827 : : break;
5828 : :
5829 : 180 : case DECL_PRIVATE:
5830 : 180 : t = gfc_add_access (¤t_attr, ACCESS_PRIVATE, NULL,
5831 : : &seen_at[d]);
5832 : 180 : break;
5833 : :
5834 : 229 : case DECL_PUBLIC:
5835 : 229 : t = gfc_add_access (¤t_attr, ACCESS_PUBLIC, NULL,
5836 : : &seen_at[d]);
5837 : 229 : break;
5838 : :
5839 : 1113 : case DECL_STATIC:
5840 : 1113 : case DECL_SAVE:
5841 : 1113 : t = gfc_add_save (¤t_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
5842 : 1113 : break;
5843 : :
5844 : 37 : case DECL_AUTOMATIC:
5845 : 37 : t = gfc_add_automatic (¤t_attr, NULL, &seen_at[d]);
5846 : 37 : break;
5847 : :
5848 : 4978 : case DECL_TARGET:
5849 : 4978 : t = gfc_add_target (¤t_attr, &seen_at[d]);
5850 : 4978 : break;
5851 : :
5852 : 143 : case DECL_IS_BIND_C:
5853 : 143 : t = gfc_add_is_bind_c(¤t_attr, NULL, &seen_at[d], 0);
5854 : 143 : break;
5855 : :
5856 : 7611 : case DECL_VALUE:
5857 : 7611 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE attribute at %C"))
5858 : : t = false;
5859 : : else
5860 : 7611 : t = gfc_add_value (¤t_attr, NULL, &seen_at[d]);
5861 : : break;
5862 : :
5863 : 495 : case DECL_VOLATILE:
5864 : 495 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE attribute at %C"))
5865 : : t = false;
5866 : : else
5867 : 494 : t = gfc_add_volatile (¤t_attr, NULL, &seen_at[d]);
5868 : : break;
5869 : :
5870 : 0 : default:
5871 : 0 : gfc_internal_error ("match_attr_spec(): Bad attribute");
5872 : : }
5873 : :
5874 : 100148 : if (!t)
5875 : : {
5876 : 35 : m = MATCH_ERROR;
5877 : 35 : goto cleanup;
5878 : : }
5879 : : }
5880 : :
5881 : : /* Since Fortran 2008 module variables implicitly have the SAVE attribute. */
5882 : 155072 : if ((gfc_current_state () == COMP_MODULE
5883 : 155072 : || gfc_current_state () == COMP_SUBMODULE)
5884 : 5021 : && !current_attr.save
5885 : 4845 : && (gfc_option.allow_std & GFC_STD_F2008) != 0)
5886 : 4752 : current_attr.save = SAVE_IMPLICIT;
5887 : :
5888 : 155072 : colon_seen = 1;
5889 : 155072 : return MATCH_YES;
5890 : :
5891 : 28949 : cleanup:
5892 : 28949 : gfc_current_locus = start;
5893 : 28949 : gfc_free_array_spec (current_as);
5894 : 28949 : current_as = NULL;
5895 : 28949 : attr_seen = 0;
5896 : 28949 : return m;
5897 : : }
5898 : :
5899 : :
5900 : : /* Set the binding label, dest_label, either with the binding label
5901 : : stored in the given gfc_typespec, ts, or if none was provided, it
5902 : : will be the symbol name in all lower case, as required by the draft
5903 : : (J3/04-007, section 15.4.1). If a binding label was given and
5904 : : there is more than one argument (num_idents), it is an error. */
5905 : :
5906 : : static bool
5907 : 290 : set_binding_label (const char **dest_label, const char *sym_name,
5908 : : int num_idents)
5909 : : {
5910 : 290 : if (num_idents > 1 && has_name_equals)
5911 : : {
5912 : 4 : gfc_error ("Multiple identifiers provided with "
5913 : : "single NAME= specifier at %C");
5914 : 4 : return false;
5915 : : }
5916 : :
5917 : 286 : if (curr_binding_label)
5918 : : /* Binding label given; store in temp holder till have sym. */
5919 : 106 : *dest_label = curr_binding_label;
5920 : : else
5921 : : {
5922 : : /* No binding label given, and the NAME= specifier did not exist,
5923 : : which means there was no NAME="". */
5924 : 180 : if (sym_name != NULL && has_name_equals == 0)
5925 : 150 : *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
5926 : : }
5927 : :
5928 : : return true;
5929 : : }
5930 : :
5931 : :
5932 : : /* Set the status of the given common block as being BIND(C) or not,
5933 : : depending on the given parameter, is_bind_c. */
5934 : :
5935 : : static void
5936 : 76 : set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
5937 : : {
5938 : 76 : com_block->is_bind_c = is_bind_c;
5939 : 76 : return;
5940 : : }
5941 : :
5942 : :
5943 : : /* Verify that the given gfc_typespec is for a C interoperable type. */
5944 : :
5945 : : bool
5946 : 16918 : gfc_verify_c_interop (gfc_typespec *ts)
5947 : : {
5948 : 16918 : if (ts->type == BT_DERIVED && ts->u.derived != NULL)
5949 : 3545 : return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
5950 : 7071 : ? true : false;
5951 : 13381 : else if (ts->type == BT_CLASS)
5952 : : return false;
5953 : 13373 : else if (ts->is_c_interop != 1 && ts->type != BT_ASSUMED)
5954 : 3512 : return false;
5955 : :
5956 : : return true;
5957 : : }
5958 : :
5959 : :
5960 : : /* Verify that the variables of a given common block, which has been
5961 : : defined with the attribute specifier bind(c), to be of a C
5962 : : interoperable type. Errors will be reported here, if
5963 : : encountered. */
5964 : :
5965 : : bool
5966 : 1 : verify_com_block_vars_c_interop (gfc_common_head *com_block)
5967 : : {
5968 : 1 : gfc_symbol *curr_sym = NULL;
5969 : 1 : bool retval = true;
5970 : :
5971 : 1 : curr_sym = com_block->head;
5972 : :
5973 : : /* Make sure we have at least one symbol. */
5974 : 1 : if (curr_sym == NULL)
5975 : : return retval;
5976 : :
5977 : : /* Here we know we have a symbol, so we'll execute this loop
5978 : : at least once. */
5979 : 1 : do
5980 : : {
5981 : : /* The second to last param, 1, says this is in a common block. */
5982 : 1 : retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
5983 : 1 : curr_sym = curr_sym->common_next;
5984 : 1 : } while (curr_sym != NULL);
5985 : :
5986 : : return retval;
5987 : : }
5988 : :
5989 : :
5990 : : /* Verify that a given BIND(C) symbol is C interoperable. If it is not,
5991 : : an appropriate error message is reported. */
5992 : :
5993 : : bool
5994 : 5710 : verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
5995 : : int is_in_common, gfc_common_head *com_block)
5996 : : {
5997 : 5710 : bool bind_c_function = false;
5998 : 5710 : bool retval = true;
5999 : :
6000 : 5710 : if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
6001 : 2212 : bind_c_function = true;
6002 : :
6003 : 5710 : if (tmp_sym->attr.function && tmp_sym->result != NULL)
6004 : : {
6005 : 2212 : tmp_sym = tmp_sym->result;
6006 : : /* Make sure it wasn't an implicitly typed result. */
6007 : 2212 : if (tmp_sym->attr.implicit_type && warn_c_binding_type)
6008 : : {
6009 : 1 : gfc_warning (OPT_Wc_binding_type,
6010 : : "Implicitly declared BIND(C) function %qs at "
6011 : : "%L may not be C interoperable", tmp_sym->name,
6012 : : &tmp_sym->declared_at);
6013 : 1 : tmp_sym->ts.f90_type = tmp_sym->ts.type;
6014 : : /* Mark it as C interoperable to prevent duplicate warnings. */
6015 : 1 : tmp_sym->ts.is_c_interop = 1;
6016 : 1 : tmp_sym->attr.is_c_interop = 1;
6017 : : }
6018 : : }
6019 : :
6020 : : /* Here, we know we have the bind(c) attribute, so if we have
6021 : : enough type info, then verify that it's a C interop kind.
6022 : : The info could be in the symbol already, or possibly still in
6023 : : the given ts (current_ts), so look in both. */
6024 : 5710 : if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN)
6025 : : {
6026 : 2352 : if (!gfc_verify_c_interop (&(tmp_sym->ts)))
6027 : : {
6028 : : /* See if we're dealing with a sym in a common block or not. */
6029 : 160 : if (is_in_common == 1 && warn_c_binding_type)
6030 : : {
6031 : 0 : gfc_warning (OPT_Wc_binding_type,
6032 : : "Variable %qs in common block %qs at %L "
6033 : : "may not be a C interoperable "
6034 : : "kind though common block %qs is BIND(C)",
6035 : : tmp_sym->name, com_block->name,
6036 : 0 : &(tmp_sym->declared_at), com_block->name);
6037 : : }
6038 : : else
6039 : : {
6040 : 160 : if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED
6041 : 158 : || tmp_sym->ts.type == BT_CLASS || ts->type == BT_CLASS)
6042 : : {
6043 : 3 : gfc_error ("Type declaration %qs at %L is not C "
6044 : : "interoperable but it is BIND(C)",
6045 : : tmp_sym->name, &(tmp_sym->declared_at));
6046 : 3 : retval = false;
6047 : : }
6048 : 157 : else if (warn_c_binding_type)
6049 : 3 : gfc_warning (OPT_Wc_binding_type, "Variable %qs at %L "
6050 : : "may not be a C interoperable "
6051 : : "kind but it is BIND(C)",
6052 : : tmp_sym->name, &(tmp_sym->declared_at));
6053 : : }
6054 : : }
6055 : :
6056 : : /* Variables declared w/in a common block can't be bind(c)
6057 : : since there's no way for C to see these variables, so there's
6058 : : semantically no reason for the attribute. */
6059 : 2352 : if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
6060 : : {
6061 : 1 : gfc_error ("Variable %qs in common block %qs at "
6062 : : "%L cannot be declared with BIND(C) "
6063 : : "since it is not a global",
6064 : 1 : tmp_sym->name, com_block->name,
6065 : : &(tmp_sym->declared_at));
6066 : 1 : retval = false;
6067 : : }
6068 : :
6069 : : /* Scalar variables that are bind(c) cannot have the pointer
6070 : : or allocatable attributes. */
6071 : 2352 : if (tmp_sym->attr.is_bind_c == 1)
6072 : : {
6073 : 1834 : if (tmp_sym->attr.pointer == 1)
6074 : : {
6075 : 1 : gfc_error ("Variable %qs at %L cannot have both the "
6076 : : "POINTER and BIND(C) attributes",
6077 : : tmp_sym->name, &(tmp_sym->declared_at));
6078 : 1 : retval = false;
6079 : : }
6080 : :
6081 : 1834 : if (tmp_sym->attr.allocatable == 1)
6082 : : {
6083 : 1 : gfc_error ("Variable %qs at %L cannot have both the "
6084 : : "ALLOCATABLE and BIND(C) attributes",
6085 : : tmp_sym->name, &(tmp_sym->declared_at));
6086 : 1 : retval = false;
6087 : : }
6088 : :
6089 : : }
6090 : :
6091 : : /* If it is a BIND(C) function, make sure the return value is a
6092 : : scalar value. The previous tests in this function made sure
6093 : : the type is interoperable. */
6094 : 2352 : if (bind_c_function && tmp_sym->as != NULL)
6095 : 2 : gfc_error ("Return type of BIND(C) function %qs at %L cannot "
6096 : : "be an array", tmp_sym->name, &(tmp_sym->declared_at));
6097 : :
6098 : : /* BIND(C) functions cannot return a character string. */
6099 : 2212 : if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
6100 : 68 : if (!gfc_length_one_character_type_p (&tmp_sym->ts))
6101 : 4 : gfc_error ("Return type of BIND(C) function %qs of character "
6102 : : "type at %L must have length 1", tmp_sym->name,
6103 : : &(tmp_sym->declared_at));
6104 : : }
6105 : :
6106 : : /* See if the symbol has been marked as private. If it has, make sure
6107 : : there is no binding label and warn the user if there is one. */
6108 : 5710 : if (tmp_sym->attr.access == ACCESS_PRIVATE
6109 : 10 : && tmp_sym->binding_label)
6110 : : /* Use gfc_warning_now because we won't say that the symbol fails
6111 : : just because of this. */
6112 : 7 : gfc_warning_now (0, "Symbol %qs at %L is marked PRIVATE but has been "
6113 : : "given the binding label %qs", tmp_sym->name,
6114 : : &(tmp_sym->declared_at), tmp_sym->binding_label);
6115 : :
6116 : 5710 : return retval;
6117 : : }
6118 : :
6119 : :
6120 : : /* Set the appropriate fields for a symbol that's been declared as
6121 : : BIND(C) (the is_bind_c flag and the binding label), and verify that
6122 : : the type is C interoperable. Errors are reported by the functions
6123 : : used to set/test these fields. */
6124 : :
6125 : : static bool
6126 : 47 : set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
6127 : : {
6128 : 47 : bool retval = true;
6129 : :
6130 : : /* TODO: Do we need to make sure the vars aren't marked private? */
6131 : :
6132 : : /* Set the is_bind_c bit in symbol_attribute. */
6133 : 47 : gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
6134 : :
6135 : 47 : if (!set_binding_label (&tmp_sym->binding_label, tmp_sym->name, num_idents))
6136 : : return false;
6137 : :
6138 : : return retval;
6139 : : }
6140 : :
6141 : :
6142 : : /* Set the fields marking the given common block as BIND(C), including
6143 : : a binding label, and report any errors encountered. */
6144 : :
6145 : : static bool
6146 : 76 : set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
6147 : : {
6148 : 76 : bool retval = true;
6149 : :
6150 : : /* destLabel, common name, typespec (which may have binding label). */
6151 : 76 : if (!set_binding_label (&com_block->binding_label, com_block->name,
6152 : : num_idents))
6153 : : return false;
6154 : :
6155 : : /* Set the given common block (com_block) to being bind(c) (1). */
6156 : 76 : set_com_block_bind_c (com_block, 1);
6157 : :
6158 : 76 : return retval;
6159 : : }
6160 : :
6161 : :
6162 : : /* Retrieve the list of one or more identifiers that the given bind(c)
6163 : : attribute applies to. */
6164 : :
6165 : : static bool
6166 : 102 : get_bind_c_idents (void)
6167 : : {
6168 : 102 : char name[GFC_MAX_SYMBOL_LEN + 1];
6169 : 102 : int num_idents = 0;
6170 : 102 : gfc_symbol *tmp_sym = NULL;
6171 : 102 : match found_id;
6172 : 102 : gfc_common_head *com_block = NULL;
6173 : :
6174 : 102 : if (gfc_match_name (name) == MATCH_YES)
6175 : : {
6176 : 38 : found_id = MATCH_YES;
6177 : 38 : gfc_get_ha_symbol (name, &tmp_sym);
6178 : : }
6179 : 64 : else if (gfc_match_common_name (name) == MATCH_YES)
6180 : : {
6181 : 64 : found_id = MATCH_YES;
6182 : 64 : com_block = gfc_get_common (name, 0);
6183 : : }
6184 : : else
6185 : : {
6186 : 0 : gfc_error ("Need either entity or common block name for "
6187 : : "attribute specification statement at %C");
6188 : 0 : return false;
6189 : : }
6190 : :
6191 : : /* Save the current identifier and look for more. */
6192 : 123 : do
6193 : : {
6194 : : /* Increment the number of identifiers found for this spec stmt. */
6195 : 123 : num_idents++;
6196 : :
6197 : : /* Make sure we have a sym or com block, and verify that it can
6198 : : be bind(c). Set the appropriate field(s) and look for more
6199 : : identifiers. */
6200 : 123 : if (tmp_sym != NULL || com_block != NULL)
6201 : : {
6202 : 123 : if (tmp_sym != NULL)
6203 : : {
6204 : 47 : if (!set_verify_bind_c_sym (tmp_sym, num_idents))
6205 : : return false;
6206 : : }
6207 : : else
6208 : : {
6209 : 76 : if (!set_verify_bind_c_com_block (com_block, num_idents))
6210 : : return false;
6211 : : }
6212 : :
6213 : : /* Look to see if we have another identifier. */
6214 : 122 : tmp_sym = NULL;
6215 : 122 : if (gfc_match_eos () == MATCH_YES)
6216 : : found_id = MATCH_NO;
6217 : 21 : else if (gfc_match_char (',') != MATCH_YES)
6218 : : found_id = MATCH_NO;
6219 : 21 : else if (gfc_match_name (name) == MATCH_YES)
6220 : : {
6221 : 9 : found_id = MATCH_YES;
6222 : 9 : gfc_get_ha_symbol (name, &tmp_sym);
6223 : : }
6224 : 12 : else if (gfc_match_common_name (name) == MATCH_YES)
6225 : : {
6226 : 12 : found_id = MATCH_YES;
6227 : 12 : com_block = gfc_get_common (name, 0);
6228 : : }
6229 : : else
6230 : : {
6231 : 0 : gfc_error ("Missing entity or common block name for "
6232 : : "attribute specification statement at %C");
6233 : 0 : return false;
6234 : : }
6235 : : }
6236 : : else
6237 : : {
6238 : 0 : gfc_internal_error ("Missing symbol");
6239 : : }
6240 : 122 : } while (found_id == MATCH_YES);
6241 : :
6242 : : /* if we get here we were successful */
6243 : : return true;
6244 : : }
6245 : :
6246 : :
6247 : : /* Try and match a BIND(C) attribute specification statement. */
6248 : :
6249 : : match
6250 : 140 : gfc_match_bind_c_stmt (void)
6251 : : {
6252 : 140 : match found_match = MATCH_NO;
6253 : 140 : gfc_typespec *ts;
6254 : :
6255 : 140 : ts = ¤t_ts;
6256 : :
6257 : : /* This may not be necessary. */
6258 : 140 : gfc_clear_ts (ts);
6259 : : /* Clear the temporary binding label holder. */
6260 : 140 : curr_binding_label = NULL;
6261 : :
6262 : : /* Look for the bind(c). */
6263 : 140 : found_match = gfc_match_bind_c (NULL, true);
6264 : :
6265 : 140 : if (found_match == MATCH_YES)
6266 : : {
6267 : 103 : if (!gfc_notify_std (GFC_STD_F2003, "BIND(C) statement at %C"))
6268 : : return MATCH_ERROR;
6269 : :
6270 : : /* Look for the :: now, but it is not required. */
6271 : 102 : gfc_match (" :: ");
6272 : :
6273 : : /* Get the identifier(s) that needs to be updated. This may need to
6274 : : change to hand the flag(s) for the attr specified so all identifiers
6275 : : found can have all appropriate parts updated (assuming that the same
6276 : : spec stmt can have multiple attrs, such as both bind(c) and
6277 : : allocatable...). */
6278 : 102 : if (!get_bind_c_idents ())
6279 : : /* Error message should have printed already. */
6280 : : return MATCH_ERROR;
6281 : : }
6282 : :
6283 : : return found_match;
6284 : : }
6285 : :
6286 : :
6287 : : /* Match a data declaration statement. */
6288 : :
6289 : : match
6290 : 881963 : gfc_match_data_decl (void)
6291 : : {
6292 : 881963 : gfc_symbol *sym;
6293 : 881963 : match m;
6294 : 881963 : int elem;
6295 : :
6296 : 881963 : type_param_spec_list = NULL;
6297 : 881963 : decl_type_param_list = NULL;
6298 : :
6299 : 881963 : num_idents_on_line = 0;
6300 : :
6301 : 881963 : m = gfc_match_decl_type_spec (¤t_ts, 0);
6302 : 881963 : if (m != MATCH_YES)
6303 : : return m;
6304 : :
6305 : 182949 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6306 : 29654 : && !gfc_comp_struct (gfc_current_state ()))
6307 : : {
6308 : 26827 : sym = gfc_use_derived (current_ts.u.derived);
6309 : :
6310 : 26827 : if (sym == NULL)
6311 : : {
6312 : 15 : m = MATCH_ERROR;
6313 : 15 : goto cleanup;
6314 : : }
6315 : :
6316 : 26812 : current_ts.u.derived = sym;
6317 : : }
6318 : :
6319 : 182934 : m = match_attr_spec ();
6320 : 182934 : if (m == MATCH_ERROR)
6321 : : {
6322 : 84 : m = MATCH_NO;
6323 : 84 : goto cleanup;
6324 : : }
6325 : :
6326 : : /* F2018:C708. */
6327 : 182850 : if (current_ts.type == BT_CLASS && current_attr.flavor == FL_PARAMETER)
6328 : : {
6329 : 6 : gfc_error ("CLASS entity at %C cannot have the PARAMETER attribute");
6330 : 6 : m = MATCH_ERROR;
6331 : 6 : goto cleanup;
6332 : : }
6333 : :
6334 : 182844 : if (current_ts.type == BT_CLASS
6335 : 9429 : && current_ts.u.derived->attr.unlimited_polymorphic)
6336 : 1494 : goto ok;
6337 : :
6338 : 181350 : if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
6339 : 28138 : && current_ts.u.derived->components == NULL
6340 : 2403 : && !current_ts.u.derived->attr.zero_comp)
6341 : : {
6342 : :
6343 : 191 : if (current_attr.pointer && gfc_comp_struct (gfc_current_state ()))
6344 : 140 : goto ok;
6345 : :
6346 : 51 : if (current_attr.allocatable && gfc_current_state () == COMP_DERIVED)
6347 : 24 : goto ok;
6348 : :
6349 : 27 : gfc_find_symbol (current_ts.u.derived->name,
6350 : : current_ts.u.derived->ns, 1, &sym);
6351 : :
6352 : : /* Any symbol that we find had better be a type definition
6353 : : which has its components defined, or be a structure definition
6354 : : actively being parsed. */
6355 : 27 : if (sym != NULL && gfc_fl_struct (sym->attr.flavor)
6356 : 26 : && (current_ts.u.derived->components != NULL
6357 : 26 : || current_ts.u.derived->attr.zero_comp
6358 : 26 : || current_ts.u.derived == gfc_new_block))
6359 : 26 : goto ok;
6360 : :
6361 : 1 : gfc_error ("Derived type at %C has not been previously defined "
6362 : : "and so cannot appear in a derived type definition");
6363 : 1 : m = MATCH_ERROR;
6364 : 1 : goto cleanup;
6365 : : }
6366 : :
6367 : 181159 : ok:
6368 : : /* If we have an old-style character declaration, and no new-style
6369 : : attribute specifications, then there a comma is optional between
6370 : : the type specification and the variable list. */
6371 : 182843 : if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
6372 : 1441 : gfc_match_char (',');
6373 : :
6374 : : /* Give the types/attributes to symbols that follow. Give the element
6375 : : a number so that repeat character length expressions can be copied. */
6376 : : elem = 1;
6377 : 242825 : for (;;)
6378 : : {
6379 : 242825 : num_idents_on_line++;
6380 : 242825 : m = variable_decl (elem++);
6381 : 242823 : if (m == MATCH_ERROR)
6382 : 399 : goto cleanup;
6383 : 242424 : if (m == MATCH_NO)
6384 : : break;
6385 : :
6386 : 242413 : if (gfc_match_eos () == MATCH_YES)
6387 : 182410 : goto cleanup;
6388 : 60003 : if (gfc_match_char (',') != MATCH_YES)
6389 : : break;
6390 : : }
6391 : :
6392 : 32 : if (!gfc_error_flag_test ())
6393 : : {
6394 : : /* An anonymous structure declaration is unambiguous; if we matched one
6395 : : according to gfc_match_structure_decl, we need to return MATCH_YES
6396 : : here to avoid confusing the remaining matchers, even if there was an
6397 : : error during variable_decl. We must flush any such errors. Note this
6398 : : causes the parser to gracefully continue parsing the remaining input
6399 : : as a structure body, which likely follows. */
6400 : 8 : if (current_ts.type == BT_DERIVED && current_ts.u.derived
6401 : 1 : && gfc_fl_struct (current_ts.u.derived->attr.flavor))
6402 : : {
6403 : 1 : gfc_error_now ("Syntax error in anonymous structure declaration"
6404 : : " at %C");
6405 : : /* Skip the bad variable_decl and line up for the start of the
6406 : : structure body. */
6407 : 1 : gfc_error_recovery ();
6408 : 1 : m = MATCH_YES;
6409 : 1 : goto cleanup;
6410 : : }
6411 : :
6412 : 7 : gfc_error ("Syntax error in data declaration at %C");
6413 : : }
6414 : :
6415 : 31 : m = MATCH_ERROR;
6416 : :
6417 : 31 : gfc_free_data_all (gfc_current_ns);
6418 : :
6419 : 182947 : cleanup:
6420 : 182947 : if (saved_kind_expr)
6421 : 91 : gfc_free_expr (saved_kind_expr);
6422 : 182947 : if (type_param_spec_list)
6423 : 396 : gfc_free_actual_arglist (type_param_spec_list);
6424 : 182947 : if (decl_type_param_list)
6425 : 423 : gfc_free_actual_arglist (decl_type_param_list);
6426 : 182947 : saved_kind_expr = NULL;
6427 : 182947 : gfc_free_array_spec (current_as);
6428 : 182947 : current_as = NULL;
6429 : 182947 : return m;
6430 : : }
6431 : :
6432 : : static bool
6433 : 21502 : in_module_or_interface(void)
6434 : : {
6435 : 21502 : if (gfc_current_state () == COMP_MODULE
6436 : 21502 : || gfc_current_state () == COMP_SUBMODULE
6437 : 21502 : || gfc_current_state () == COMP_INTERFACE)
6438 : : return true;
6439 : :
6440 : 18154 : if (gfc_state_stack->state == COMP_CONTAINS
6441 : 17528 : || gfc_state_stack->state == COMP_FUNCTION
6442 : 17450 : || gfc_state_stack->state == COMP_SUBROUTINE)
6443 : : {
6444 : 704 : gfc_state_data *p;
6445 : 739 : for (p = gfc_state_stack->previous; p ; p = p->previous)
6446 : : {
6447 : 735 : if (p->state == COMP_MODULE || p->state == COMP_SUBMODULE
6448 : 90 : || p->state == COMP_INTERFACE)
6449 : : return true;
6450 : : }
6451 : : }
6452 : : return false;
6453 : : }
6454 : :
6455 : : /* Match a prefix associated with a function or subroutine
6456 : : declaration. If the typespec pointer is nonnull, then a typespec
6457 : : can be matched. Note that if nothing matches, MATCH_YES is
6458 : : returned (the null string was matched). */
6459 : :
6460 : : match
6461 : 208370 : gfc_match_prefix (gfc_typespec *ts)
6462 : : {
6463 : 208370 : bool seen_type;
6464 : 208370 : bool seen_impure;
6465 : 208370 : bool found_prefix;
6466 : :
6467 : 208370 : gfc_clear_attr (¤t_attr);
6468 : 208370 : seen_type = false;
6469 : 208370 : seen_impure = false;
6470 : :
6471 : 208370 : gcc_assert (!gfc_matching_prefix);
6472 : 208370 : gfc_matching_prefix = true;
6473 : :
6474 : 215711 : do
6475 : : {
6476 : 233467 : found_prefix = false;
6477 : :
6478 : : /* MODULE is a prefix like PURE, ELEMENTAL, etc., having a
6479 : : corresponding attribute seems natural and distinguishes these
6480 : : procedures from procedure types of PROC_MODULE, which these are
6481 : : as well. */
6482 : 233467 : if (gfc_match ("module% ") == MATCH_YES)
6483 : : {
6484 : 21779 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE prefix at %C"))
6485 : 277 : goto error;
6486 : :
6487 : 21502 : if (!in_module_or_interface ())
6488 : : {
6489 : 17454 : gfc_error ("MODULE prefix at %C found outside of a module, "
6490 : : "submodule, or interface");
6491 : 17454 : goto error;
6492 : : }
6493 : :
6494 : 4048 : current_attr.module_procedure = 1;
6495 : 4048 : found_prefix = true;
6496 : : }
6497 : :
6498 : 215736 : if (!seen_type && ts != NULL)
6499 : : {
6500 : 116371 : match m;
6501 : 116371 : m = gfc_match_decl_type_spec (ts, 0);
6502 : 116371 : if (m == MATCH_ERROR)
6503 : 15 : goto error;
6504 : 116356 : if (m == MATCH_YES && gfc_match_space () == MATCH_YES)
6505 : : {
6506 : : seen_type = true;
6507 : : found_prefix = true;
6508 : : }
6509 : : }
6510 : :
6511 : 215721 : if (gfc_match ("elemental% ") == MATCH_YES)
6512 : : {
6513 : 4525 : if (!gfc_add_elemental (¤t_attr, NULL))
6514 : 2 : goto error;
6515 : :
6516 : : found_prefix = true;
6517 : : }
6518 : :
6519 : 215719 : if (gfc_match ("pure% ") == MATCH_YES)
6520 : : {
6521 : 2055 : if (!gfc_add_pure (¤t_attr, NULL))
6522 : 2 : goto error;
6523 : :
6524 : : found_prefix = true;
6525 : : }
6526 : :
6527 : 215717 : if (gfc_match ("recursive% ") == MATCH_YES)
6528 : : {
6529 : 447 : if (!gfc_add_recursive (¤t_attr, NULL))
6530 : 2 : goto error;
6531 : :
6532 : : found_prefix = true;
6533 : : }
6534 : :
6535 : : /* IMPURE is a somewhat special case, as it needs not set an actual
6536 : : attribute but rather only prevents ELEMENTAL routines from being
6537 : : automatically PURE. */
6538 : 215715 : if (gfc_match ("impure% ") == MATCH_YES)
6539 : : {
6540 : 546 : if (!gfc_notify_std (GFC_STD_F2008, "IMPURE procedure at %C"))
6541 : 4 : goto error;
6542 : :
6543 : : seen_impure = true;
6544 : : found_prefix = true;
6545 : : }
6546 : : }
6547 : : while (found_prefix);
6548 : :
6549 : : /* IMPURE and PURE must not both appear, of course. */
6550 : 190614 : if (seen_impure && current_attr.pure)
6551 : : {
6552 : 4 : gfc_error ("PURE and IMPURE must not appear both at %C");
6553 : 4 : goto error;
6554 : : }
6555 : :
6556 : : /* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
6557 : 190072 : if (!seen_impure && current_attr.elemental && !current_attr.pure)
6558 : : {
6559 : 3974 : if (!gfc_add_pure (¤t_attr, NULL))
6560 : 0 : goto error;
6561 : : }
6562 : :
6563 : : /* At this point, the next item is not a prefix. */
6564 : 190610 : gcc_assert (gfc_matching_prefix);
6565 : :
6566 : 190610 : gfc_matching_prefix = false;
6567 : 190610 : return MATCH_YES;
6568 : :
6569 : 17760 : error:
6570 : 17760 : gcc_assert (gfc_matching_prefix);
6571 : 17760 : gfc_matching_prefix = false;
6572 : 17760 : return MATCH_ERROR;
6573 : : }
6574 : :
6575 : :
6576 : : /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol. */
6577 : :
6578 : : static bool
6579 : 52436 : copy_prefix (symbol_attribute *dest, locus *where)
6580 : : {
6581 : 52436 : if (dest->module_procedure)
6582 : : {
6583 : 541 : if (current_attr.elemental)
6584 : 4 : dest->elemental = 1;
6585 : :
6586 : 541 : if (current_attr.pure)
6587 : 12 : dest->pure = 1;
6588 : :
6589 : 541 : if (current_attr.recursive)
6590 : 8 : dest->recursive = 1;
6591 : :
6592 : : /* Module procedures are unusual in that the 'dest' is copied from
6593 : : the interface declaration. However, this is an oportunity to
6594 : : check that the submodule declaration is compliant with the
6595 : : interface. */
6596 : 541 : if (dest->elemental && !current_attr.elemental)
6597 : : {
6598 : 1 : gfc_error ("ELEMENTAL prefix in MODULE PROCEDURE interface is "
6599 : : "missing at %L", where);
6600 : 1 : return false;
6601 : : }
6602 : :
6603 : 540 : if (dest->pure && !current_attr.pure)
6604 : : {
6605 : 1 : gfc_error ("PURE prefix in MODULE PROCEDURE interface is "
6606 : : "missing at %L", where);
6607 : 1 : return false;
6608 : : }
6609 : :
6610 : 539 : if (dest->recursive && !current_attr.recursive)
6611 : : {
6612 : 1 : gfc_error ("RECURSIVE prefix in MODULE PROCEDURE interface is "
6613 : : "missing at %L", where);
6614 : 1 : return false;
6615 : : }
6616 : :
6617 : : return true;
6618 : : }
6619 : :
6620 : 51895 : if (current_attr.elemental && !gfc_add_elemental (dest, where))
6621 : : return false;
6622 : :
6623 : 51893 : if (current_attr.pure && !gfc_add_pure (dest, where))
6624 : : return false;
6625 : :
6626 : 51893 : if (current_attr.recursive && !gfc_add_recursive (dest, where))
6627 : : return false;
6628 : :
6629 : : return true;
6630 : : }
6631 : :
6632 : :
6633 : : /* Match a formal argument list or, if typeparam is true, a
6634 : : type_param_name_list. */
6635 : :
6636 : : match
6637 : 416311 : gfc_match_formal_arglist (gfc_symbol *progname, int st_flag,
6638 : : int null_flag, bool typeparam)
6639 : : {
6640 : 416311 : gfc_formal_arglist *head, *tail, *p, *q;
6641 : 416311 : char name[GFC_MAX_SYMBOL_LEN + 1];
6642 : 416311 : gfc_symbol *sym;
6643 : 416311 : match m;
6644 : 416311 : gfc_formal_arglist *formal = NULL;
6645 : :
6646 : 416311 : head = tail = NULL;
6647 : :
6648 : : /* Keep the interface formal argument list and null it so that the
6649 : : matching for the new declaration can be done. The numbers and
6650 : : names of the arguments are checked here. The interface formal
6651 : : arguments are retained in formal_arglist and the characteristics
6652 : : are compared in resolve.cc(resolve_fl_procedure). See the remark
6653 : : in get_proc_name about the eventual need to copy the formal_arglist
6654 : : and populate the formal namespace of the interface symbol. */
6655 : 416311 : if (progname->attr.module_procedure
6656 : 545 : && progname->attr.host_assoc)
6657 : : {
6658 : 158 : formal = progname->formal;
6659 : 158 : progname->formal = NULL;
6660 : : }
6661 : :
6662 : 416311 : if (gfc_match_char ('(') != MATCH_YES)
6663 : : {
6664 : 248123 : if (null_flag)
6665 : 5120 : goto ok;
6666 : : return MATCH_NO;
6667 : : }
6668 : :
6669 : 168188 : if (gfc_match_char (')') == MATCH_YES)
6670 : : {
6671 : 7851 : if (typeparam)
6672 : : {
6673 : 1 : gfc_error_now ("A type parameter list is required at %C");
6674 : 1 : m = MATCH_ERROR;
6675 : 1 : goto cleanup;
6676 : : }
6677 : : else
6678 : 7850 : goto ok;
6679 : : }
6680 : :
6681 : 214675 : for (;;)
6682 : : {
6683 : 214675 : if (gfc_match_char ('*') == MATCH_YES)
6684 : : {
6685 : 8477 : sym = NULL;
6686 : 8477 : if (!typeparam && !gfc_notify_std (GFC_STD_F95_OBS,
6687 : : "Alternate-return argument at %C"))
6688 : : {
6689 : 1 : m = MATCH_ERROR;
6690 : 1 : goto cleanup;
6691 : : }
6692 : 8476 : else if (typeparam)
6693 : 2 : gfc_error_now ("A parameter name is required at %C");
6694 : : }
6695 : : else
6696 : : {
6697 : 206198 : m = gfc_match_name (name);
6698 : 206198 : if (m != MATCH_YES)
6699 : : {
6700 : 15377 : if(typeparam)
6701 : 1 : gfc_error_now ("A parameter name is required at %C");
6702 : 15377 : goto cleanup;
6703 : : }
6704 : :
6705 : 190821 : if (!typeparam && gfc_get_symbol (name, NULL, &sym))
6706 : 4 : goto cleanup;
6707 : 190817 : else if (typeparam
6708 : 190817 : && gfc_get_symbol (name, progname->f2k_derived, &sym))
6709 : 0 : goto cleanup;
6710 : : }
6711 : :
6712 : 199293 : p = gfc_get_formal_arglist ();
6713 : :
6714 : 199293 : if (head == NULL)
6715 : : head = tail = p;
6716 : : else
6717 : : {
6718 : 53636 : tail->next = p;
6719 : 53636 : tail = p;
6720 : : }
6721 : :
6722 : 199293 : tail->sym = sym;
6723 : :
6724 : : /* We don't add the VARIABLE flavor because the name could be a
6725 : : dummy procedure. We don't apply these attributes to formal
6726 : : arguments of statement functions. */
6727 : 190817 : if (sym != NULL && !st_flag
6728 : 286759 : && (!gfc_add_dummy(&sym->attr, sym->name, NULL)
6729 : 87466 : || !gfc_missing_attr (&sym->attr, NULL)))
6730 : : {
6731 : 0 : m = MATCH_ERROR;
6732 : 0 : goto cleanup;
6733 : : }
6734 : :
6735 : : /* The name of a program unit can be in a different namespace,
6736 : : so check for it explicitly. After the statement is accepted,
6737 : : the name is checked for especially in gfc_get_symbol(). */
6738 : 199293 : if (gfc_new_block != NULL && sym != NULL && !typeparam
6739 : 86502 : && strcmp (sym->name, gfc_new_block->name) == 0)
6740 : : {
6741 : 0 : gfc_error ("Name %qs at %C is the name of the procedure",
6742 : : sym->name);
6743 : 0 : m = MATCH_ERROR;
6744 : 0 : goto cleanup;
6745 : : }
6746 : :
6747 : 199293 : if (gfc_match_char (')') == MATCH_YES)
6748 : 102277 : goto ok;
6749 : :
6750 : 97016 : m = gfc_match_char (',');
6751 : 97016 : if (m != MATCH_YES)
6752 : : {
6753 : 42678 : if (typeparam)
6754 : 1 : gfc_error_now ("Expected parameter list in type declaration "
6755 : : "at %C");
6756 : : else
6757 : 42677 : gfc_error ("Unexpected junk in formal argument list at %C");
6758 : 42678 : goto cleanup;
6759 : : }
6760 : : }
6761 : :
6762 : 115247 : ok:
6763 : : /* Check for duplicate symbols in the formal argument list. */
6764 : 115247 : if (head != NULL)
6765 : : {
6766 : 154439 : for (p = head; p->next; p = p->next)
6767 : : {
6768 : 52210 : if (p->sym == NULL)
6769 : 323 : continue;
6770 : :
6771 : 216399 : for (q = p->next; q; q = q->next)
6772 : 164560 : if (p->sym == q->sym)
6773 : : {
6774 : 48 : if (typeparam)
6775 : 1 : gfc_error_now ("Duplicate name %qs in parameter "
6776 : : "list at %C", p->sym->name);
6777 : : else
6778 : 47 : gfc_error ("Duplicate symbol %qs in formal argument "
6779 : : "list at %C", p->sym->name);
6780 : :
6781 : 48 : m = MATCH_ERROR;
6782 : 48 : goto cleanup;
6783 : : }
6784 : : }
6785 : : }
6786 : :
6787 : 115199 : if (!gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL))
6788 : : {
6789 : 0 : m = MATCH_ERROR;
6790 : 0 : goto cleanup;
6791 : : }
6792 : :
6793 : : /* gfc_error_now used in following and return with MATCH_YES because
6794 : : doing otherwise results in a cascade of extraneous errors and in
6795 : : some cases an ICE in symbol.cc(gfc_release_symbol). */
6796 : 115199 : if (progname->attr.module_procedure && progname->attr.host_assoc)
6797 : : {
6798 : 157 : bool arg_count_mismatch = false;
6799 : :
6800 : 157 : if (!formal && head)
6801 : : arg_count_mismatch = true;
6802 : :
6803 : : /* Abbreviated module procedure declaration is not meant to have any
6804 : : formal arguments! */
6805 : 157 : if (!progname->abr_modproc_decl && formal && !head)
6806 : 1 : arg_count_mismatch = true;
6807 : :
6808 : 302 : for (p = formal, q = head; p && q; p = p->next, q = q->next)
6809 : : {
6810 : 145 : if ((p->next != NULL && q->next == NULL)
6811 : 144 : || (p->next == NULL && q->next != NULL))
6812 : : arg_count_mismatch = true;
6813 : 143 : else if ((p->sym == NULL && q->sym == NULL)
6814 : 143 : || (p->sym && q->sym
6815 : 141 : && strcmp (p->sym->name, q->sym->name) == 0))
6816 : 139 : continue;
6817 : : else
6818 : : {
6819 : 4 : if (q->sym == NULL)
6820 : 1 : gfc_error_now ("MODULE PROCEDURE formal argument %qs "
6821 : : "conflicts with alternate return at %C",
6822 : : p->sym->name);
6823 : 3 : else if (p->sym == NULL)
6824 : 1 : gfc_error_now ("MODULE PROCEDURE formal argument is "
6825 : : "alternate return and conflicts with "
6826 : : "%qs in the separate declaration at %C",
6827 : : q->sym->name);
6828 : : else
6829 : 2 : gfc_error_now ("Mismatch in MODULE PROCEDURE formal "
6830 : : "argument names (%s/%s) at %C",
6831 : : p->sym->name, q->sym->name);
6832 : : }
6833 : : }
6834 : :
6835 : 157 : if (arg_count_mismatch)
6836 : 4 : gfc_error_now ("Mismatch in number of MODULE PROCEDURE "
6837 : : "formal arguments at %C");
6838 : : }
6839 : :
6840 : : return MATCH_YES;
6841 : :
6842 : 58109 : cleanup:
6843 : 58109 : gfc_free_formal_arglist (head);
6844 : 58109 : return m;
6845 : : }
6846 : :
6847 : :
6848 : : /* Match a RESULT specification following a function declaration or
6849 : : ENTRY statement. Also matches the end-of-statement. */
6850 : :
6851 : : static match
6852 : 6864 : match_result (gfc_symbol *function, gfc_symbol **result)
6853 : : {
6854 : 6864 : char name[GFC_MAX_SYMBOL_LEN + 1];
6855 : 6864 : gfc_symbol *r;
6856 : 6864 : match m;
6857 : :
6858 : 6864 : if (gfc_match (" result (") != MATCH_YES)
6859 : : return MATCH_NO;
6860 : :
6861 : 5189 : m = gfc_match_name (name);
6862 : 5189 : if (m != MATCH_YES)
6863 : : return m;
6864 : :
6865 : : /* Get the right paren, and that's it because there could be the
6866 : : bind(c) attribute after the result clause. */
6867 : 5189 : if (gfc_match_char (')') != MATCH_YES)
6868 : : {
6869 : : /* TODO: should report the missing right paren here. */
6870 : : return MATCH_ERROR;
6871 : : }
6872 : :
6873 : 5189 : if (strcmp (function->name, name) == 0)
6874 : : {
6875 : 1 : gfc_error ("RESULT variable at %C must be different than function name");
6876 : 1 : return MATCH_ERROR;
6877 : : }
6878 : :
6879 : 5188 : if (gfc_get_symbol (name, NULL, &r))
6880 : : return MATCH_ERROR;
6881 : :
6882 : 5188 : if (!gfc_add_result (&r->attr, r->name, NULL))
6883 : : return MATCH_ERROR;
6884 : :
6885 : 5188 : *result = r;
6886 : :
6887 : 5188 : return MATCH_YES;
6888 : : }
6889 : :
6890 : :
6891 : : /* Match a function suffix, which could be a combination of a result
6892 : : clause and BIND(C), either one, or neither. The draft does not
6893 : : require them to come in a specific order. */
6894 : :
6895 : : static match
6896 : 6868 : gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
6897 : : {
6898 : 6868 : match is_bind_c; /* Found bind(c). */
6899 : 6868 : match is_result; /* Found result clause. */
6900 : 6868 : match found_match; /* Status of whether we've found a good match. */
6901 : 6868 : char peek_char; /* Character we're going to peek at. */
6902 : 6868 : bool allow_binding_name;
6903 : :
6904 : : /* Initialize to having found nothing. */
6905 : 6868 : found_match = MATCH_NO;
6906 : 6868 : is_bind_c = MATCH_NO;
6907 : 6868 : is_result = MATCH_NO;
6908 : :
6909 : : /* Get the next char to narrow between result and bind(c). */
6910 : 6868 : gfc_gobble_whitespace ();
6911 : 6868 : peek_char = gfc_peek_ascii_char ();
6912 : :
6913 : : /* C binding names are not allowed for internal procedures. */
6914 : 6868 : if (gfc_current_state () == COMP_CONTAINS
6915 : 4046 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
6916 : : allow_binding_name = false;
6917 : : else
6918 : 5391 : allow_binding_name = true;
6919 : :
6920 : 6868 : switch (peek_char)
6921 : : {
6922 : 4820 : case 'r':
6923 : : /* Look for result clause. */
6924 : 4820 : is_result = match_result (sym, result);
6925 : 4820 : if (is_result == MATCH_YES)
6926 : : {
6927 : : /* Now see if there is a bind(c) after it. */
6928 : 4819 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6929 : : /* We've found the result clause and possibly bind(c). */
6930 : 4819 : found_match = MATCH_YES;
6931 : : }
6932 : : else
6933 : : /* This should only be MATCH_ERROR. */
6934 : : found_match = is_result;
6935 : : break;
6936 : 2048 : case 'b':
6937 : : /* Look for bind(c) first. */
6938 : 2048 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
6939 : 2048 : if (is_bind_c == MATCH_YES)
6940 : : {
6941 : : /* Now see if a result clause followed it. */
6942 : 2044 : is_result = match_result (sym, result);
6943 : 2044 : found_match = MATCH_YES;
6944 : : }
6945 : : else
6946 : : {
6947 : : /* Should only be a MATCH_ERROR if we get here after seeing 'b'. */
6948 : : found_match = MATCH_ERROR;
6949 : : }
6950 : : break;
6951 : 0 : default:
6952 : 0 : gfc_error ("Unexpected junk after function declaration at %C");
6953 : 0 : found_match = MATCH_ERROR;
6954 : 0 : break;
6955 : : }
6956 : :
6957 : 6863 : if (is_bind_c == MATCH_YES)
6958 : : {
6959 : : /* Fortran 2008 draft allows BIND(C) for internal procedures. */
6960 : 2193 : if (gfc_current_state () == COMP_CONTAINS
6961 : 414 : && sym->ns->proc_name->attr.flavor != FL_MODULE
6962 : 2205 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
6963 : : "at %L may not be specified for an internal "
6964 : : "procedure", &gfc_current_locus))
6965 : : return MATCH_ERROR;
6966 : :
6967 : 2190 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1))
6968 : : return MATCH_ERROR;
6969 : : }
6970 : :
6971 : : return found_match;
6972 : : }
6973 : :
6974 : :
6975 : : /* Procedure pointer return value without RESULT statement:
6976 : : Add "hidden" result variable named "ppr@". */
6977 : :
6978 : : static bool
6979 : 63106 : add_hidden_procptr_result (gfc_symbol *sym)
6980 : : {
6981 : 63106 : bool case1,case2;
6982 : :
6983 : 63106 : if (gfc_notification_std (GFC_STD_F2003) == ERROR)
6984 : : return false;
6985 : :
6986 : : /* First usage case: PROCEDURE and EXTERNAL statements. */
6987 : 1150 : case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
6988 : 1150 : && strcmp (gfc_current_block ()->name, sym->name) == 0
6989 : 63139 : && sym->attr.external;
6990 : : /* Second usage case: INTERFACE statements. */
6991 : 11519 : case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
6992 : 11519 : && gfc_state_stack->previous->state == COMP_FUNCTION
6993 : 63158 : && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
6994 : :
6995 : 62951 : if (case1 || case2)
6996 : : {
6997 : 123 : gfc_symtree *stree;
6998 : 123 : if (case1)
6999 : 93 : gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
7000 : : else
7001 : : {
7002 : 30 : gfc_symtree *st2;
7003 : 30 : gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
7004 : 30 : st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
7005 : 30 : st2->n.sym = stree->n.sym;
7006 : 30 : stree->n.sym->refs++;
7007 : : }
7008 : 123 : sym->result = stree->n.sym;
7009 : :
7010 : 123 : sym->result->attr.proc_pointer = sym->attr.proc_pointer;
7011 : 123 : sym->result->attr.pointer = sym->attr.pointer;
7012 : 123 : sym->result->attr.external = sym->attr.external;
7013 : 123 : sym->result->attr.referenced = sym->attr.referenced;
7014 : 123 : sym->result->ts = sym->ts;
7015 : 123 : sym->attr.proc_pointer = 0;
7016 : 123 : sym->attr.pointer = 0;
7017 : 123 : sym->attr.external = 0;
7018 : 123 : if (sym->result->attr.external && sym->result->attr.pointer)
7019 : : {
7020 : 4 : sym->result->attr.pointer = 0;
7021 : 4 : sym->result->attr.proc_pointer = 1;
7022 : : }
7023 : :
7024 : 123 : return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
7025 : : }
7026 : : /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement. */
7027 : 62828 : else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
7028 : 69 : && sym->result && sym->result != sym && sym->result->attr.external
7029 : 28 : && sym == gfc_current_ns->proc_name
7030 : 28 : && sym == sym->result->ns->proc_name
7031 : 28 : && strcmp ("ppr@", sym->result->name) == 0)
7032 : : {
7033 : 28 : sym->result->attr.proc_pointer = 1;
7034 : 28 : sym->attr.pointer = 0;
7035 : 28 : return true;
7036 : : }
7037 : : else
7038 : : return false;
7039 : : }
7040 : :
7041 : :
7042 : : /* Match the interface for a PROCEDURE declaration,
7043 : : including brackets (R1212). */
7044 : :
7045 : : static match
7046 : 1483 : match_procedure_interface (gfc_symbol **proc_if)
7047 : : {
7048 : 1483 : match m;
7049 : 1483 : gfc_symtree *st;
7050 : 1483 : locus old_loc, entry_loc;
7051 : 1483 : gfc_namespace *old_ns = gfc_current_ns;
7052 : 1483 : char name[GFC_MAX_SYMBOL_LEN + 1];
7053 : :
7054 : 1483 : old_loc = entry_loc = gfc_current_locus;
7055 : 1483 : gfc_clear_ts (¤t_ts);
7056 : :
7057 : 1483 : if (gfc_match (" (") != MATCH_YES)
7058 : : {
7059 : 1 : gfc_current_locus = entry_loc;
7060 : 1 : return MATCH_NO;
7061 : : }
7062 : :
7063 : : /* Get the type spec. for the procedure interface. */
7064 : 1482 : old_loc = gfc_current_locus;
7065 : 1482 : m = gfc_match_decl_type_spec (¤t_ts, 0);
7066 : 1482 : gfc_gobble_whitespace ();
7067 : 1482 : if (m == MATCH_YES || (m == MATCH_NO && gfc_peek_ascii_char () == ')'))
7068 : 382 : goto got_ts;
7069 : :
7070 : 1100 : if (m == MATCH_ERROR)
7071 : : return m;
7072 : :
7073 : : /* Procedure interface is itself a procedure. */
7074 : 1100 : gfc_current_locus = old_loc;
7075 : 1100 : m = gfc_match_name (name);
7076 : :
7077 : : /* First look to see if it is already accessible in the current
7078 : : namespace because it is use associated or contained. */
7079 : 1100 : st = NULL;
7080 : 1100 : if (gfc_find_sym_tree (name, NULL, 0, &st))
7081 : : return MATCH_ERROR;
7082 : :
7083 : : /* If it is still not found, then try the parent namespace, if it
7084 : : exists and create the symbol there if it is still not found. */
7085 : 1100 : if (gfc_current_ns->parent)
7086 : 360 : gfc_current_ns = gfc_current_ns->parent;
7087 : 1100 : if (st == NULL && gfc_get_ha_sym_tree (name, &st))
7088 : : return MATCH_ERROR;
7089 : :
7090 : 1100 : gfc_current_ns = old_ns;
7091 : 1100 : *proc_if = st->n.sym;
7092 : :
7093 : 1100 : if (*proc_if)
7094 : : {
7095 : 1100 : (*proc_if)->refs++;
7096 : : /* Resolve interface if possible. That way, attr.procedure is only set
7097 : : if it is declared by a later procedure-declaration-stmt, which is
7098 : : invalid per F08:C1216 (cf. resolve_procedure_interface). */
7099 : 1100 : while ((*proc_if)->ts.interface
7100 : 1107 : && *proc_if != (*proc_if)->ts.interface)
7101 : 7 : *proc_if = (*proc_if)->ts.interface;
7102 : :
7103 : 1100 : if ((*proc_if)->attr.flavor == FL_UNKNOWN
7104 : 374 : && (*proc_if)->ts.type == BT_UNKNOWN
7105 : 1474 : && !gfc_add_flavor (&(*proc_if)->attr, FL_PROCEDURE,
7106 : : (*proc_if)->name, NULL))
7107 : : return MATCH_ERROR;
7108 : : }
7109 : :
7110 : 0 : got_ts:
7111 : 1482 : if (gfc_match (" )") != MATCH_YES)
7112 : : {
7113 : 0 : gfc_current_locus = entry_loc;
7114 : 0 : return MATCH_NO;
7115 : : }
7116 : :
7117 : : return MATCH_YES;
7118 : : }
7119 : :
7120 : :
7121 : : /* Match a PROCEDURE declaration (R1211). */
7122 : :
7123 : : static match
7124 : 1087 : match_procedure_decl (void)
7125 : : {
7126 : 1087 : match m;
7127 : 1087 : gfc_symbol *sym, *proc_if = NULL;
7128 : 1087 : int num;
7129 : 1087 : gfc_expr *initializer = NULL;
7130 : :
7131 : : /* Parse interface (with brackets). */
7132 : 1087 : m = match_procedure_interface (&proc_if);
7133 : 1087 : if (m != MATCH_YES)
7134 : : return m;
7135 : :
7136 : : /* Parse attributes (with colons). */
7137 : 1087 : m = match_attr_spec();
7138 : 1087 : if (m == MATCH_ERROR)
7139 : : return MATCH_ERROR;
7140 : :
7141 : 1086 : if (proc_if && proc_if->attr.is_bind_c && !current_attr.is_bind_c)
7142 : : {
7143 : 16 : current_attr.is_bind_c = 1;
7144 : 16 : has_name_equals = 0;
7145 : 16 : curr_binding_label = NULL;
7146 : : }
7147 : :
7148 : : /* Get procedure symbols. */
7149 : 79 : for(num=1;;num++)
7150 : : {
7151 : 1165 : m = gfc_match_symbol (&sym, 0);
7152 : 1165 : if (m == MATCH_NO)
7153 : 1 : goto syntax;
7154 : 1164 : else if (m == MATCH_ERROR)
7155 : : return m;
7156 : :
7157 : : /* Add current_attr to the symbol attributes. */
7158 : 1164 : if (!gfc_copy_attr (&sym->attr, ¤t_attr, NULL))
7159 : : return MATCH_ERROR;
7160 : :
7161 : 1163 : if (sym->attr.is_bind_c)
7162 : : {
7163 : : /* Check for C1218. */
7164 : 52 : if (!proc_if || !proc_if->attr.is_bind_c)
7165 : : {
7166 : 1 : gfc_error ("BIND(C) attribute at %C requires "
7167 : : "an interface with BIND(C)");
7168 : 1 : return MATCH_ERROR;
7169 : : }
7170 : : /* Check for C1217. */
7171 : 51 : if (has_name_equals && sym->attr.pointer)
7172 : : {
7173 : 1 : gfc_error ("BIND(C) procedure with NAME may not have "
7174 : : "POINTER attribute at %C");
7175 : 1 : return MATCH_ERROR;
7176 : : }
7177 : 50 : if (has_name_equals && sym->attr.dummy)
7178 : : {
7179 : 1 : gfc_error ("Dummy procedure at %C may not have "
7180 : : "BIND(C) attribute with NAME");
7181 : 1 : return MATCH_ERROR;
7182 : : }
7183 : : /* Set binding label for BIND(C). */
7184 : 49 : if (!set_binding_label (&sym->binding_label, sym->name, num))
7185 : : return MATCH_ERROR;
7186 : : }
7187 : :
7188 : 1159 : if (!gfc_add_external (&sym->attr, NULL))
7189 : : return MATCH_ERROR;
7190 : :
7191 : 1155 : if (add_hidden_procptr_result (sym))
7192 : 66 : sym = sym->result;
7193 : :
7194 : 1155 : if (!gfc_add_proc (&sym->attr, sym->name, NULL))
7195 : : return MATCH_ERROR;
7196 : :
7197 : : /* Set interface. */
7198 : 1154 : if (proc_if != NULL)
7199 : : {
7200 : 815 : if (sym->ts.type != BT_UNKNOWN)
7201 : : {
7202 : 1 : gfc_error ("Procedure %qs at %L already has basic type of %s",
7203 : : sym->name, &gfc_current_locus,
7204 : : gfc_basic_typename (sym->ts.type));
7205 : 1 : return MATCH_ERROR;
7206 : : }
7207 : 814 : sym->ts.interface = proc_if;
7208 : 814 : sym->attr.untyped = 1;
7209 : 814 : sym->attr.if_source = IFSRC_IFBODY;
7210 : : }
7211 : 339 : else if (current_ts.type != BT_UNKNOWN)
7212 : : {
7213 : 199 : if (!gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7214 : : return MATCH_ERROR;
7215 : 198 : sym->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7216 : 198 : sym->ts.interface->ts = current_ts;
7217 : 198 : sym->ts.interface->attr.flavor = FL_PROCEDURE;
7218 : 198 : sym->ts.interface->attr.function = 1;
7219 : 198 : sym->attr.function = 1;
7220 : 198 : sym->attr.if_source = IFSRC_UNKNOWN;
7221 : : }
7222 : :
7223 : 1152 : if (gfc_match (" =>") == MATCH_YES)
7224 : : {
7225 : 84 : if (!current_attr.pointer)
7226 : : {
7227 : 0 : gfc_error ("Initialization at %C isn't for a pointer variable");
7228 : 0 : m = MATCH_ERROR;
7229 : 0 : goto cleanup;
7230 : : }
7231 : :
7232 : 84 : m = match_pointer_init (&initializer, 1);
7233 : 84 : if (m != MATCH_YES)
7234 : 1 : goto cleanup;
7235 : :
7236 : 83 : if (!add_init_expr_to_sym (sym->name, &initializer, &gfc_current_locus))
7237 : 0 : goto cleanup;
7238 : :
7239 : : }
7240 : :
7241 : 1151 : if (gfc_match_eos () == MATCH_YES)
7242 : : return MATCH_YES;
7243 : 79 : if (gfc_match_char (',') != MATCH_YES)
7244 : 0 : goto syntax;
7245 : : }
7246 : :
7247 : 1 : syntax:
7248 : 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7249 : 1 : return MATCH_ERROR;
7250 : :
7251 : 1 : cleanup:
7252 : : /* Free stuff up and return. */
7253 : 1 : gfc_free_expr (initializer);
7254 : 1 : return m;
7255 : : }
7256 : :
7257 : :
7258 : : static match
7259 : : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc);
7260 : :
7261 : :
7262 : : /* Match a procedure pointer component declaration (R445). */
7263 : :
7264 : : static match
7265 : 396 : match_ppc_decl (void)
7266 : : {
7267 : 396 : match m;
7268 : 396 : gfc_symbol *proc_if = NULL;
7269 : 396 : gfc_typespec ts;
7270 : 396 : int num;
7271 : 396 : gfc_component *c;
7272 : 396 : gfc_expr *initializer = NULL;
7273 : 396 : gfc_typebound_proc* tb;
7274 : 396 : char name[GFC_MAX_SYMBOL_LEN + 1];
7275 : :
7276 : : /* Parse interface (with brackets). */
7277 : 396 : m = match_procedure_interface (&proc_if);
7278 : 396 : if (m != MATCH_YES)
7279 : 1 : goto syntax;
7280 : :
7281 : : /* Parse attributes. */
7282 : 395 : tb = XCNEW (gfc_typebound_proc);
7283 : 395 : tb->where = gfc_current_locus;
7284 : 395 : m = match_binding_attributes (tb, false, true);
7285 : 395 : if (m == MATCH_ERROR)
7286 : : return m;
7287 : :
7288 : 392 : gfc_clear_attr (¤t_attr);
7289 : 392 : current_attr.procedure = 1;
7290 : 392 : current_attr.proc_pointer = 1;
7291 : 392 : current_attr.access = tb->access;
7292 : 392 : current_attr.flavor = FL_PROCEDURE;
7293 : :
7294 : : /* Match the colons (required). */
7295 : 392 : if (gfc_match (" ::") != MATCH_YES)
7296 : : {
7297 : 1 : gfc_error ("Expected %<::%> after binding-attributes at %C");
7298 : 1 : return MATCH_ERROR;
7299 : : }
7300 : :
7301 : : /* Check for C450. */
7302 : 391 : if (!tb->nopass && proc_if == NULL)
7303 : : {
7304 : 2 : gfc_error("NOPASS or explicit interface required at %C");
7305 : 2 : return MATCH_ERROR;
7306 : : }
7307 : :
7308 : 389 : if (!gfc_notify_std (GFC_STD_F2003, "Procedure pointer component at %C"))
7309 : : return MATCH_ERROR;
7310 : :
7311 : : /* Match PPC names. */
7312 : 388 : ts = current_ts;
7313 : 388 : for(num=1;;num++)
7314 : : {
7315 : 389 : m = gfc_match_name (name);
7316 : 389 : if (m == MATCH_NO)
7317 : 0 : goto syntax;
7318 : 389 : else if (m == MATCH_ERROR)
7319 : : return m;
7320 : :
7321 : 389 : if (!gfc_add_component (gfc_current_block(), name, &c))
7322 : : return MATCH_ERROR;
7323 : :
7324 : : /* Add current_attr to the symbol attributes. */
7325 : 389 : if (!gfc_copy_attr (&c->attr, ¤t_attr, NULL))
7326 : : return MATCH_ERROR;
7327 : :
7328 : 389 : if (!gfc_add_external (&c->attr, NULL))
7329 : : return MATCH_ERROR;
7330 : :
7331 : 389 : if (!gfc_add_proc (&c->attr, name, NULL))
7332 : : return MATCH_ERROR;
7333 : :
7334 : 389 : if (num == 1)
7335 : 388 : c->tb = tb;
7336 : : else
7337 : : {
7338 : 1 : c->tb = XCNEW (gfc_typebound_proc);
7339 : 1 : c->tb->where = gfc_current_locus;
7340 : 1 : *c->tb = *tb;
7341 : : }
7342 : :
7343 : : /* Set interface. */
7344 : 389 : if (proc_if != NULL)
7345 : : {
7346 : 331 : c->ts.interface = proc_if;
7347 : 331 : c->attr.untyped = 1;
7348 : 331 : c->attr.if_source = IFSRC_IFBODY;
7349 : : }
7350 : 58 : else if (ts.type != BT_UNKNOWN)
7351 : : {
7352 : 23 : c->ts = ts;
7353 : 23 : c->ts.interface = gfc_new_symbol ("", gfc_current_ns);
7354 : 23 : c->ts.interface->result = c->ts.interface;
7355 : 23 : c->ts.interface->ts = ts;
7356 : 23 : c->ts.interface->attr.flavor = FL_PROCEDURE;
7357 : 23 : c->ts.interface->attr.function = 1;
7358 : 23 : c->attr.function = 1;
7359 : 23 : c->attr.if_source = IFSRC_UNKNOWN;
7360 : : }
7361 : :
7362 : 389 : if (gfc_match (" =>") == MATCH_YES)
7363 : : {
7364 : 60 : m = match_pointer_init (&initializer, 1);
7365 : 60 : if (m != MATCH_YES)
7366 : : {
7367 : 0 : gfc_free_expr (initializer);
7368 : 0 : return m;
7369 : : }
7370 : 60 : c->initializer = initializer;
7371 : : }
7372 : :
7373 : 389 : if (gfc_match_eos () == MATCH_YES)
7374 : : return MATCH_YES;
7375 : 1 : if (gfc_match_char (',') != MATCH_YES)
7376 : 0 : goto syntax;
7377 : : }
7378 : :
7379 : 1 : syntax:
7380 : 1 : gfc_error ("Syntax error in procedure pointer component at %C");
7381 : 1 : return MATCH_ERROR;
7382 : : }
7383 : :
7384 : :
7385 : : /* Match a PROCEDURE declaration inside an interface (R1206). */
7386 : :
7387 : : static match
7388 : 1486 : match_procedure_in_interface (void)
7389 : : {
7390 : 1486 : match m;
7391 : 1486 : gfc_symbol *sym;
7392 : 1486 : char name[GFC_MAX_SYMBOL_LEN + 1];
7393 : 1486 : locus old_locus;
7394 : :
7395 : 1486 : if (current_interface.type == INTERFACE_NAMELESS
7396 : 1486 : || current_interface.type == INTERFACE_ABSTRACT)
7397 : : {
7398 : 1 : gfc_error ("PROCEDURE at %C must be in a generic interface");
7399 : 1 : return MATCH_ERROR;
7400 : : }
7401 : :
7402 : : /* Check if the F2008 optional double colon appears. */
7403 : 1485 : gfc_gobble_whitespace ();
7404 : 1485 : old_locus = gfc_current_locus;
7405 : 1485 : if (gfc_match ("::") == MATCH_YES)
7406 : : {
7407 : 800 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
7408 : : "MODULE PROCEDURE statement at %L", &old_locus))
7409 : : return MATCH_ERROR;
7410 : : }
7411 : : else
7412 : 685 : gfc_current_locus = old_locus;
7413 : :
7414 : 2139 : for(;;)
7415 : : {
7416 : 2139 : m = gfc_match_name (name);
7417 : 2139 : if (m == MATCH_NO)
7418 : 0 : goto syntax;
7419 : 2139 : else if (m == MATCH_ERROR)
7420 : : return m;
7421 : 2139 : if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
7422 : : return MATCH_ERROR;
7423 : :
7424 : 2139 : if (!gfc_add_interface (sym))
7425 : : return MATCH_ERROR;
7426 : :
7427 : 2138 : if (gfc_match_eos () == MATCH_YES)
7428 : : break;
7429 : 655 : if (gfc_match_char (',') != MATCH_YES)
7430 : 0 : goto syntax;
7431 : : }
7432 : :
7433 : : return MATCH_YES;
7434 : :
7435 : 0 : syntax:
7436 : 0 : gfc_error ("Syntax error in PROCEDURE statement at %C");
7437 : 0 : return MATCH_ERROR;
7438 : : }
7439 : :
7440 : :
7441 : : /* General matcher for PROCEDURE declarations. */
7442 : :
7443 : : static match match_procedure_in_type (void);
7444 : :
7445 : : match
7446 : 5841 : gfc_match_procedure (void)
7447 : : {
7448 : 5841 : match m;
7449 : :
7450 : 5841 : switch (gfc_current_state ())
7451 : : {
7452 : 1087 : case COMP_NONE:
7453 : 1087 : case COMP_PROGRAM:
7454 : 1087 : case COMP_MODULE:
7455 : 1087 : case COMP_SUBMODULE:
7456 : 1087 : case COMP_SUBROUTINE:
7457 : 1087 : case COMP_FUNCTION:
7458 : 1087 : case COMP_BLOCK:
7459 : 1087 : m = match_procedure_decl ();
7460 : 1087 : break;
7461 : 1486 : case COMP_INTERFACE:
7462 : 1486 : m = match_procedure_in_interface ();
7463 : 1486 : break;
7464 : 396 : case COMP_DERIVED:
7465 : 396 : m = match_ppc_decl ();
7466 : 396 : break;
7467 : 2872 : case COMP_DERIVED_CONTAINS:
7468 : 2872 : m = match_procedure_in_type ();
7469 : 2872 : break;
7470 : : default:
7471 : : return MATCH_NO;
7472 : : }
7473 : :
7474 : 5841 : if (m != MATCH_YES)
7475 : : return m;
7476 : :
7477 : 5786 : if (!gfc_notify_std (GFC_STD_F2003, "PROCEDURE statement at %C"))
7478 : 4 : return MATCH_ERROR;
7479 : :
7480 : : return m;
7481 : : }
7482 : :
7483 : :
7484 : : /* Warn if a matched procedure has the same name as an intrinsic; this is
7485 : : simply a wrapper around gfc_warn_intrinsic_shadow that interprets the current
7486 : : parser-state-stack to find out whether we're in a module. */
7487 : :
7488 : : static void
7489 : 52433 : do_warn_intrinsic_shadow (const gfc_symbol* sym, bool func)
7490 : : {
7491 : 52433 : bool in_module;
7492 : :
7493 : 104866 : in_module = (gfc_state_stack->previous
7494 : 52433 : && (gfc_state_stack->previous->state == COMP_MODULE
7495 : 41528 : || gfc_state_stack->previous->state == COMP_SUBMODULE));
7496 : :
7497 : 52433 : gfc_warn_intrinsic_shadow (sym, in_module, func);
7498 : 52433 : }
7499 : :
7500 : :
7501 : : /* Match a function declaration. */
7502 : :
7503 : : match
7504 : 111201 : gfc_match_function_decl (void)
7505 : : {
7506 : 111201 : char name[GFC_MAX_SYMBOL_LEN + 1];
7507 : 111201 : gfc_symbol *sym, *result;
7508 : 111201 : locus old_loc;
7509 : 111201 : match m;
7510 : 111201 : match suffix_match;
7511 : 111201 : match found_match; /* Status returned by match func. */
7512 : :
7513 : 111201 : if (gfc_current_state () != COMP_NONE
7514 : 67057 : && gfc_current_state () != COMP_INTERFACE
7515 : 43686 : && gfc_current_state () != COMP_CONTAINS)
7516 : : return MATCH_NO;
7517 : :
7518 : 111201 : gfc_clear_ts (¤t_ts);
7519 : :
7520 : 111201 : old_loc = gfc_current_locus;
7521 : :
7522 : 111201 : m = gfc_match_prefix (¤t_ts);
7523 : 111201 : if (m != MATCH_YES)
7524 : : {
7525 : 8882 : gfc_current_locus = old_loc;
7526 : 8882 : return m;
7527 : : }
7528 : :
7529 : 102319 : if (gfc_match ("function% %n", name) != MATCH_YES)
7530 : : {
7531 : 85423 : gfc_current_locus = old_loc;
7532 : 85423 : return MATCH_NO;
7533 : : }
7534 : :
7535 : 16896 : if (get_proc_name (name, &sym, false))
7536 : : return MATCH_ERROR;
7537 : :
7538 : 16891 : if (add_hidden_procptr_result (sym))
7539 : 20 : sym = sym->result;
7540 : :
7541 : 16891 : if (current_attr.module_procedure)
7542 : 193 : sym->attr.module_procedure = 1;
7543 : :
7544 : 16891 : gfc_new_block = sym;
7545 : :
7546 : 16891 : m = gfc_match_formal_arglist (sym, 0, 0);
7547 : 16891 : if (m == MATCH_NO)
7548 : : {
7549 : 6 : gfc_error ("Expected formal argument list in function "
7550 : : "definition at %C");
7551 : 6 : m = MATCH_ERROR;
7552 : 6 : goto cleanup;
7553 : : }
7554 : 16885 : else if (m == MATCH_ERROR)
7555 : 0 : goto cleanup;
7556 : :
7557 : 16885 : result = NULL;
7558 : :
7559 : : /* According to the draft, the bind(c) and result clause can
7560 : : come in either order after the formal_arg_list (i.e., either
7561 : : can be first, both can exist together or by themselves or neither
7562 : : one). Therefore, the match_result can't match the end of the
7563 : : string, and check for the bind(c) or result clause in either order. */
7564 : 16885 : found_match = gfc_match_eos ();
7565 : :
7566 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
7567 : : must have been marked BIND(C) with a BIND(C) attribute and that is
7568 : : not allowed for procedures. */
7569 : 16885 : if (sym->attr.is_bind_c == 1)
7570 : : {
7571 : 3 : sym->attr.is_bind_c = 0;
7572 : :
7573 : 3 : if (gfc_state_stack->previous
7574 : 3 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
7575 : : {
7576 : 1 : locus loc;
7577 : 2 : loc = sym->old_symbol != NULL
7578 : 1 : ? sym->old_symbol->declared_at : gfc_current_locus;
7579 : 1 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
7580 : : "variables or common blocks", &loc);
7581 : : }
7582 : : }
7583 : :
7584 : 16885 : if (found_match != MATCH_YES)
7585 : : {
7586 : : /* If we haven't found the end-of-statement, look for a suffix. */
7587 : 6637 : suffix_match = gfc_match_suffix (sym, &result);
7588 : 6637 : if (suffix_match == MATCH_YES)
7589 : : /* Need to get the eos now. */
7590 : 6629 : found_match = gfc_match_eos ();
7591 : : else
7592 : : found_match = suffix_match;
7593 : : }
7594 : :
7595 : : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
7596 : : subprogram and a binding label is specified, it shall be the
7597 : : same as the binding label specified in the corresponding module
7598 : : procedure interface body. */
7599 : 16885 : if (sym->attr.is_bind_c && sym->attr.module_procedure && sym->old_symbol
7600 : 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
7601 : 3 : && sym->binding_label && sym->old_symbol->binding_label
7602 : 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
7603 : : {
7604 : 1 : const char *null = "NULL", *s1, *s2;
7605 : 1 : s1 = sym->binding_label;
7606 : 1 : if (!s1) s1 = null;
7607 : 1 : s2 = sym->old_symbol->binding_label;
7608 : 1 : if (!s2) s2 = null;
7609 : 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
7610 : 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
7611 : 1 : return MATCH_ERROR;
7612 : : }
7613 : :
7614 : 16884 : if(found_match != MATCH_YES)
7615 : : m = MATCH_ERROR;
7616 : : else
7617 : : {
7618 : : /* Make changes to the symbol. */
7619 : 16876 : m = MATCH_ERROR;
7620 : :
7621 : 16876 : if (!gfc_add_function (&sym->attr, sym->name, NULL))
7622 : 0 : goto cleanup;
7623 : :
7624 : 16876 : if (!gfc_missing_attr (&sym->attr, NULL))
7625 : 0 : goto cleanup;
7626 : :
7627 : 16876 : if (!copy_prefix (&sym->attr, &sym->declared_at))
7628 : : {
7629 : 1 : if(!sym->attr.module_procedure)
7630 : 1 : goto cleanup;
7631 : : else
7632 : 0 : gfc_error_check ();
7633 : : }
7634 : :
7635 : : /* Delay matching the function characteristics until after the
7636 : : specification block by signalling kind=-1. */
7637 : 16875 : sym->declared_at = old_loc;
7638 : 16875 : if (current_ts.type != BT_UNKNOWN)
7639 : 5779 : current_ts.kind = -1;
7640 : : else
7641 : 11096 : current_ts.kind = 0;
7642 : :
7643 : 16875 : if (result == NULL)
7644 : : {
7645 : 11899 : if (current_ts.type != BT_UNKNOWN
7646 : 11899 : && !gfc_add_type (sym, ¤t_ts, &gfc_current_locus))
7647 : 1 : goto cleanup;
7648 : 11898 : sym->result = sym;
7649 : : }
7650 : : else
7651 : : {
7652 : 4976 : if (current_ts.type != BT_UNKNOWN
7653 : 4976 : && !gfc_add_type (result, ¤t_ts, &gfc_current_locus))
7654 : 0 : goto cleanup;
7655 : 4976 : sym->result = result;
7656 : : }
7657 : :
7658 : : /* Warn if this procedure has the same name as an intrinsic. */
7659 : 16874 : do_warn_intrinsic_shadow (sym, true);
7660 : :
7661 : 16874 : return MATCH_YES;
7662 : : }
7663 : :
7664 : 16 : cleanup:
7665 : 16 : gfc_current_locus = old_loc;
7666 : 16 : return m;
7667 : : }
7668 : :
7669 : :
7670 : : /* This is mostly a copy of parse.cc(add_global_procedure) but modified to
7671 : : pass the name of the entry, rather than the gfc_current_block name, and
7672 : : to return false upon finding an existing global entry. */
7673 : :
7674 : : static bool
7675 : 503 : add_global_entry (const char *name, const char *binding_label, bool sub,
7676 : : locus *where)
7677 : : {
7678 : 503 : gfc_gsymbol *s;
7679 : 503 : enum gfc_symbol_type type;
7680 : :
7681 : 503 : type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
7682 : :
7683 : : /* Only in Fortran 2003: For procedures with a binding label also the Fortran
7684 : : name is a global identifier. */
7685 : 503 : if (!binding_label || gfc_notification_std (GFC_STD_F2008))
7686 : : {
7687 : 498 : s = gfc_get_gsymbol (name, false);
7688 : :
7689 : 498 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7690 : : {
7691 : 2 : gfc_global_used (s, where);
7692 : 2 : return false;
7693 : : }
7694 : : else
7695 : : {
7696 : 496 : s->type = type;
7697 : 496 : s->sym_name = name;
7698 : 496 : s->where = *where;
7699 : 496 : s->defined = 1;
7700 : 496 : s->ns = gfc_current_ns;
7701 : : }
7702 : : }
7703 : :
7704 : : /* Don't add the symbol multiple times. */
7705 : 501 : if (binding_label
7706 : 501 : && (!gfc_notification_std (GFC_STD_F2008)
7707 : 0 : || strcmp (name, binding_label) != 0))
7708 : : {
7709 : 5 : s = gfc_get_gsymbol (binding_label, true);
7710 : :
7711 : 5 : if (s->defined || (s->type != GSYM_UNKNOWN && s->type != type))
7712 : : {
7713 : 1 : gfc_global_used (s, where);
7714 : 1 : return false;
7715 : : }
7716 : : else
7717 : : {
7718 : 4 : s->type = type;
7719 : 4 : s->sym_name = name;
7720 : 4 : s->binding_label = binding_label;
7721 : 4 : s->where = *where;
7722 : 4 : s->defined = 1;
7723 : 4 : s->ns = gfc_current_ns;
7724 : : }
7725 : : }
7726 : :
7727 : : return true;
7728 : : }
7729 : :
7730 : :
7731 : : /* Match an ENTRY statement. */
7732 : :
7733 : : match
7734 : 768 : gfc_match_entry (void)
7735 : : {
7736 : 768 : gfc_symbol *proc;
7737 : 768 : gfc_symbol *result;
7738 : 768 : gfc_symbol *entry;
7739 : 768 : char name[GFC_MAX_SYMBOL_LEN + 1];
7740 : 768 : gfc_compile_state state;
7741 : 768 : match m;
7742 : 768 : gfc_entry_list *el;
7743 : 768 : locus old_loc;
7744 : 768 : bool module_procedure;
7745 : 768 : char peek_char;
7746 : 768 : match is_bind_c;
7747 : :
7748 : 768 : m = gfc_match_name (name);
7749 : 768 : if (m != MATCH_YES)
7750 : : return m;
7751 : :
7752 : 768 : if (!gfc_notify_std (GFC_STD_F2008_OBS, "ENTRY statement at %C"))
7753 : : return MATCH_ERROR;
7754 : :
7755 : 768 : state = gfc_current_state ();
7756 : 768 : if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
7757 : : {
7758 : 3 : switch (state)
7759 : : {
7760 : 0 : case COMP_PROGRAM:
7761 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
7762 : 0 : break;
7763 : 0 : case COMP_MODULE:
7764 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
7765 : 0 : break;
7766 : 0 : case COMP_SUBMODULE:
7767 : 0 : gfc_error ("ENTRY statement at %C cannot appear within a SUBMODULE");
7768 : 0 : break;
7769 : 0 : case COMP_BLOCK_DATA:
7770 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7771 : : "a BLOCK DATA");
7772 : 0 : break;
7773 : 0 : case COMP_INTERFACE:
7774 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7775 : : "an INTERFACE");
7776 : 0 : break;
7777 : 1 : case COMP_STRUCTURE:
7778 : 1 : gfc_error ("ENTRY statement at %C cannot appear within "
7779 : : "a STRUCTURE block");
7780 : 1 : break;
7781 : 0 : case COMP_DERIVED:
7782 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7783 : : "a DERIVED TYPE block");
7784 : 0 : break;
7785 : 0 : case COMP_IF:
7786 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7787 : : "an IF-THEN block");
7788 : 0 : break;
7789 : 0 : case COMP_DO:
7790 : 0 : case COMP_DO_CONCURRENT:
7791 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7792 : : "a DO block");
7793 : 0 : break;
7794 : 0 : case COMP_SELECT:
7795 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7796 : : "a SELECT block");
7797 : 0 : break;
7798 : 0 : case COMP_FORALL:
7799 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7800 : : "a FORALL block");
7801 : 0 : break;
7802 : 0 : case COMP_WHERE:
7803 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7804 : : "a WHERE block");
7805 : 0 : break;
7806 : 0 : case COMP_CONTAINS:
7807 : 0 : gfc_error ("ENTRY statement at %C cannot appear within "
7808 : : "a contained subprogram");
7809 : 0 : break;
7810 : 2 : default:
7811 : 2 : gfc_error ("Unexpected ENTRY statement at %C");
7812 : : }
7813 : 3 : return MATCH_ERROR;
7814 : : }
7815 : :
7816 : 765 : if ((state == COMP_SUBROUTINE || state == COMP_FUNCTION)
7817 : 765 : && gfc_state_stack->previous->state == COMP_INTERFACE)
7818 : : {
7819 : 1 : gfc_error ("ENTRY statement at %C cannot appear within an INTERFACE");
7820 : 1 : return MATCH_ERROR;
7821 : : }
7822 : :
7823 : 1528 : module_procedure = gfc_current_ns->parent != NULL
7824 : 259 : && gfc_current_ns->parent->proc_name
7825 : 764 : && gfc_current_ns->parent->proc_name->attr.flavor
7826 : 259 : == FL_MODULE;
7827 : :
7828 : 764 : if (gfc_current_ns->parent != NULL
7829 : 259 : && gfc_current_ns->parent->proc_name
7830 : 259 : && !module_procedure)
7831 : : {
7832 : 0 : gfc_error("ENTRY statement at %C cannot appear in a "
7833 : : "contained procedure");
7834 : 0 : return MATCH_ERROR;
7835 : : }
7836 : :
7837 : : /* Module function entries need special care in get_proc_name
7838 : : because previous references within the function will have
7839 : : created symbols attached to the current namespace. */
7840 : 764 : if (get_proc_name (name, &entry,
7841 : : gfc_current_ns->parent != NULL
7842 : 764 : && module_procedure))
7843 : : return MATCH_ERROR;
7844 : :
7845 : 762 : proc = gfc_current_block ();
7846 : :
7847 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
7848 : : must have been marked BIND(C) with a BIND(C) attribute and that is
7849 : : not allowed for procedures. */
7850 : 762 : if (entry->attr.is_bind_c == 1)
7851 : : {
7852 : 0 : locus loc;
7853 : :
7854 : 0 : entry->attr.is_bind_c = 0;
7855 : :
7856 : 0 : loc = entry->old_symbol != NULL
7857 : 0 : ? entry->old_symbol->declared_at : gfc_current_locus;
7858 : 0 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
7859 : : "variables or common blocks", &loc);
7860 : : }
7861 : :
7862 : : /* Check what next non-whitespace character is so we can tell if there
7863 : : is the required parens if we have a BIND(C). */
7864 : 762 : old_loc = gfc_current_locus;
7865 : 762 : gfc_gobble_whitespace ();
7866 : 762 : peek_char = gfc_peek_ascii_char ();
7867 : :
7868 : 762 : if (state == COMP_SUBROUTINE)
7869 : : {
7870 : 134 : m = gfc_match_formal_arglist (entry, 0, 1);
7871 : 134 : if (m != MATCH_YES)
7872 : : return MATCH_ERROR;
7873 : :
7874 : : /* Call gfc_match_bind_c with allow_binding_name = true as ENTRY can
7875 : : never be an internal procedure. */
7876 : 134 : is_bind_c = gfc_match_bind_c (entry, true);
7877 : 134 : if (is_bind_c == MATCH_ERROR)
7878 : : return MATCH_ERROR;
7879 : 134 : if (is_bind_c == MATCH_YES)
7880 : : {
7881 : 22 : if (peek_char != '(')
7882 : : {
7883 : 0 : gfc_error ("Missing required parentheses before BIND(C) at %C");
7884 : 0 : return MATCH_ERROR;
7885 : : }
7886 : :
7887 : 22 : if (!gfc_add_is_bind_c (&(entry->attr), entry->name,
7888 : 22 : &(entry->declared_at), 1))
7889 : : return MATCH_ERROR;
7890 : :
7891 : : }
7892 : :
7893 : 134 : if (!gfc_current_ns->parent
7894 : 134 : && !add_global_entry (name, entry->binding_label, true,
7895 : : &old_loc))
7896 : : return MATCH_ERROR;
7897 : :
7898 : : /* An entry in a subroutine. */
7899 : 131 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7900 : 131 : || !gfc_add_subroutine (&entry->attr, entry->name, NULL))
7901 : 3 : return MATCH_ERROR;
7902 : : }
7903 : : else
7904 : : {
7905 : : /* An entry in a function.
7906 : : We need to take special care because writing
7907 : : ENTRY f()
7908 : : as
7909 : : ENTRY f
7910 : : is allowed, whereas
7911 : : ENTRY f() RESULT (r)
7912 : : can't be written as
7913 : : ENTRY f RESULT (r). */
7914 : 628 : if (gfc_match_eos () == MATCH_YES)
7915 : : {
7916 : 24 : gfc_current_locus = old_loc;
7917 : : /* Match the empty argument list, and add the interface to
7918 : : the symbol. */
7919 : 24 : m = gfc_match_formal_arglist (entry, 0, 1);
7920 : : }
7921 : : else
7922 : 604 : m = gfc_match_formal_arglist (entry, 0, 0);
7923 : :
7924 : 628 : if (m != MATCH_YES)
7925 : : return MATCH_ERROR;
7926 : :
7927 : 627 : result = NULL;
7928 : :
7929 : 627 : if (gfc_match_eos () == MATCH_YES)
7930 : : {
7931 : 396 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7932 : 396 : || !gfc_add_function (&entry->attr, entry->name, NULL))
7933 : 2 : return MATCH_ERROR;
7934 : :
7935 : 394 : entry->result = entry;
7936 : : }
7937 : : else
7938 : : {
7939 : 231 : m = gfc_match_suffix (entry, &result);
7940 : 231 : if (m == MATCH_NO)
7941 : 0 : gfc_syntax_error (ST_ENTRY);
7942 : 231 : if (m != MATCH_YES)
7943 : : return MATCH_ERROR;
7944 : :
7945 : 231 : if (result)
7946 : : {
7947 : 212 : if (!gfc_add_result (&result->attr, result->name, NULL)
7948 : 212 : || !gfc_add_entry (&entry->attr, result->name, NULL)
7949 : 424 : || !gfc_add_function (&entry->attr, result->name, NULL))
7950 : 0 : return MATCH_ERROR;
7951 : 212 : entry->result = result;
7952 : : }
7953 : : else
7954 : : {
7955 : 19 : if (!gfc_add_entry (&entry->attr, entry->name, NULL)
7956 : 19 : || !gfc_add_function (&entry->attr, entry->name, NULL))
7957 : 0 : return MATCH_ERROR;
7958 : 19 : entry->result = entry;
7959 : : }
7960 : : }
7961 : :
7962 : 625 : if (!gfc_current_ns->parent
7963 : 625 : && !add_global_entry (name, entry->binding_label, false,
7964 : : &old_loc))
7965 : : return MATCH_ERROR;
7966 : : }
7967 : :
7968 : 753 : if (gfc_match_eos () != MATCH_YES)
7969 : : {
7970 : 0 : gfc_syntax_error (ST_ENTRY);
7971 : 0 : return MATCH_ERROR;
7972 : : }
7973 : :
7974 : : /* F2018:C1546 An elemental procedure shall not have the BIND attribute. */
7975 : 753 : if (proc->attr.elemental && entry->attr.is_bind_c)
7976 : : {
7977 : 2 : gfc_error ("ENTRY statement at %L with BIND(C) prohibited in an "
7978 : : "elemental procedure", &entry->declared_at);
7979 : 2 : return MATCH_ERROR;
7980 : : }
7981 : :
7982 : 751 : entry->attr.recursive = proc->attr.recursive;
7983 : 751 : entry->attr.elemental = proc->attr.elemental;
7984 : 751 : entry->attr.pure = proc->attr.pure;
7985 : :
7986 : 751 : el = gfc_get_entry_list ();
7987 : 751 : el->sym = entry;
7988 : 751 : el->next = gfc_current_ns->entries;
7989 : 751 : gfc_current_ns->entries = el;
7990 : 751 : if (el->next)
7991 : 84 : el->id = el->next->id + 1;
7992 : : else
7993 : 667 : el->id = 1;
7994 : :
7995 : 751 : new_st.op = EXEC_ENTRY;
7996 : 751 : new_st.ext.entry = el;
7997 : :
7998 : 751 : return MATCH_YES;
7999 : : }
8000 : :
8001 : :
8002 : : /* Match a subroutine statement, including optional prefixes. */
8003 : :
8004 : : match
8005 : 698177 : gfc_match_subroutine (void)
8006 : : {
8007 : 698177 : char name[GFC_MAX_SYMBOL_LEN + 1];
8008 : 698177 : gfc_symbol *sym;
8009 : 698177 : match m;
8010 : 698177 : match is_bind_c;
8011 : 698177 : char peek_char;
8012 : 698177 : bool allow_binding_name;
8013 : 698177 : locus loc;
8014 : :
8015 : 698177 : if (gfc_current_state () != COMP_NONE
8016 : 659766 : && gfc_current_state () != COMP_INTERFACE
8017 : 641204 : && gfc_current_state () != COMP_CONTAINS)
8018 : : return MATCH_NO;
8019 : :
8020 : 91392 : m = gfc_match_prefix (NULL);
8021 : 91392 : if (m != MATCH_YES)
8022 : : return m;
8023 : :
8024 : 82520 : m = gfc_match ("subroutine% %n", name);
8025 : 82520 : if (m != MATCH_YES)
8026 : : return m;
8027 : :
8028 : 35593 : if (get_proc_name (name, &sym, false))
8029 : : return MATCH_ERROR;
8030 : :
8031 : : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
8032 : : the symbol existed before. */
8033 : 35582 : sym->declared_at = gfc_current_locus;
8034 : :
8035 : 35582 : if (current_attr.module_procedure)
8036 : 340 : sym->attr.module_procedure = 1;
8037 : :
8038 : 35582 : if (add_hidden_procptr_result (sym))
8039 : 9 : sym = sym->result;
8040 : :
8041 : 35582 : gfc_new_block = sym;
8042 : :
8043 : : /* Check what next non-whitespace character is so we can tell if there
8044 : : is the required parens if we have a BIND(C). */
8045 : 35582 : gfc_gobble_whitespace ();
8046 : 35582 : peek_char = gfc_peek_ascii_char ();
8047 : :
8048 : 35582 : if (!gfc_add_subroutine (&sym->attr, sym->name, NULL))
8049 : : return MATCH_ERROR;
8050 : :
8051 : 35581 : if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
8052 : : return MATCH_ERROR;
8053 : :
8054 : : /* Make sure that it isn't already declared as BIND(C). If it is, it
8055 : : must have been marked BIND(C) with a BIND(C) attribute and that is
8056 : : not allowed for procedures. */
8057 : 35581 : if (sym->attr.is_bind_c == 1)
8058 : : {
8059 : 4 : sym->attr.is_bind_c = 0;
8060 : :
8061 : 4 : if (gfc_state_stack->previous
8062 : 4 : && gfc_state_stack->previous->state != COMP_SUBMODULE)
8063 : : {
8064 : 2 : locus loc;
8065 : 4 : loc = sym->old_symbol != NULL
8066 : 2 : ? sym->old_symbol->declared_at : gfc_current_locus;
8067 : 2 : gfc_error_now ("BIND(C) attribute at %L can only be used for "
8068 : : "variables or common blocks", &loc);
8069 : : }
8070 : : }
8071 : :
8072 : : /* C binding names are not allowed for internal procedures. */
8073 : 35581 : if (gfc_current_state () == COMP_CONTAINS
8074 : 20767 : && sym->ns->proc_name->attr.flavor != FL_MODULE)
8075 : : allow_binding_name = false;
8076 : : else
8077 : 24587 : allow_binding_name = true;
8078 : :
8079 : : /* Here, we are just checking if it has the bind(c) attribute, and if
8080 : : so, then we need to make sure it's all correct. If it doesn't,
8081 : : we still need to continue matching the rest of the subroutine line. */
8082 : 35581 : gfc_gobble_whitespace ();
8083 : 35581 : loc = gfc_current_locus;
8084 : 35581 : is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
8085 : 35581 : if (is_bind_c == MATCH_ERROR)
8086 : : {
8087 : : /* There was an attempt at the bind(c), but it was wrong. An
8088 : : error message should have been printed w/in the gfc_match_bind_c
8089 : : so here we'll just return the MATCH_ERROR. */
8090 : : return MATCH_ERROR;
8091 : : }
8092 : :
8093 : 35568 : if (is_bind_c == MATCH_YES)
8094 : : {
8095 : 3324 : gfc_formal_arglist *arg;
8096 : :
8097 : : /* The following is allowed in the Fortran 2008 draft. */
8098 : 3324 : if (gfc_current_state () == COMP_CONTAINS
8099 : 1285 : && sym->ns->proc_name->attr.flavor != FL_MODULE
8100 : 3734 : && !gfc_notify_std (GFC_STD_F2008, "BIND(C) attribute "
8101 : : "at %L may not be specified for an internal "
8102 : : "procedure", &gfc_current_locus))
8103 : : return MATCH_ERROR;
8104 : :
8105 : 3321 : if (peek_char != '(')
8106 : : {
8107 : 1 : gfc_error ("Missing required parentheses before BIND(C) at %C");
8108 : 1 : return MATCH_ERROR;
8109 : : }
8110 : :
8111 : : /* F2018 C1550 (R1526) If MODULE appears in the prefix of a module
8112 : : subprogram and a binding label is specified, it shall be the
8113 : : same as the binding label specified in the corresponding module
8114 : : procedure interface body. */
8115 : 3320 : if (sym->attr.module_procedure && sym->old_symbol
8116 : 3 : && strcmp (sym->name, sym->old_symbol->name) == 0
8117 : 3 : && sym->binding_label && sym->old_symbol->binding_label
8118 : 2 : && strcmp (sym->binding_label, sym->old_symbol->binding_label) != 0)
8119 : : {
8120 : 1 : const char *null = "NULL", *s1, *s2;
8121 : 1 : s1 = sym->binding_label;
8122 : 1 : if (!s1) s1 = null;
8123 : 1 : s2 = sym->old_symbol->binding_label;
8124 : 1 : if (!s2) s2 = null;
8125 : 1 : gfc_error ("Mismatch in BIND(C) names (%qs/%qs) at %C", s1, s2);
8126 : 1 : sym->refs++; /* Needed to avoid an ICE in gfc_release_symbol */
8127 : 1 : return MATCH_ERROR;
8128 : : }
8129 : :
8130 : : /* Scan the dummy arguments for an alternate return. */
8131 : 10288 : for (arg = sym->formal; arg; arg = arg->next)
8132 : 6970 : if (!arg->sym)
8133 : : {
8134 : 1 : gfc_error ("Alternate return dummy argument cannot appear in a "
8135 : : "SUBROUTINE with the BIND(C) attribute at %L", &loc);
8136 : 1 : return MATCH_ERROR;
8137 : : }
8138 : :
8139 : 3318 : if (!gfc_add_is_bind_c (&(sym->attr), sym->name, &(sym->declared_at), 1))
8140 : : return MATCH_ERROR;
8141 : : }
8142 : :
8143 : 35561 : if (gfc_match_eos () != MATCH_YES)
8144 : : {
8145 : 1 : gfc_syntax_error (ST_SUBROUTINE);
8146 : 1 : return MATCH_ERROR;
8147 : : }
8148 : :
8149 : 35560 : if (!copy_prefix (&sym->attr, &sym->declared_at))
8150 : : {
8151 : 4 : if(!sym->attr.module_procedure)
8152 : : return MATCH_ERROR;
8153 : : else
8154 : 3 : gfc_error_check ();
8155 : : }
8156 : :
8157 : : /* Warn if it has the same name as an intrinsic. */
8158 : 35559 : do_warn_intrinsic_shadow (sym, false);
8159 : :
8160 : 35559 : return MATCH_YES;
8161 : : }
8162 : :
8163 : :
8164 : : /* Check that the NAME identifier in a BIND attribute or statement
8165 : : is conform to C identifier rules. */
8166 : :
8167 : : match
8168 : 1138 : check_bind_name_identifier (char **name)
8169 : : {
8170 : 1138 : char *n = *name, *p;
8171 : :
8172 : : /* Remove leading spaces. */
8173 : 1164 : while (*n == ' ')
8174 : 26 : n++;
8175 : :
8176 : : /* On an empty string, free memory and set name to NULL. */
8177 : 1138 : if (*n == '\0')
8178 : : {
8179 : 42 : free (*name);
8180 : 42 : *name = NULL;
8181 : 42 : return MATCH_YES;
8182 : : }
8183 : :
8184 : : /* Remove trailing spaces. */
8185 : 1096 : p = n + strlen(n) - 1;
8186 : 1112 : while (*p == ' ')
8187 : 16 : *(p--) = '\0';
8188 : :
8189 : : /* Insert the identifier into the symbol table. */
8190 : 1096 : p = xstrdup (n);
8191 : 1096 : free (*name);
8192 : 1096 : *name = p;
8193 : :
8194 : : /* Now check that identifier is valid under C rules. */
8195 : 1096 : if (ISDIGIT (*p))
8196 : : {
8197 : 2 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8198 : 2 : return MATCH_ERROR;
8199 : : }
8200 : :
8201 : 12020 : for (; *p; p++)
8202 : 10929 : if (!(ISALNUM (*p) || *p == '_' || *p == '$'))
8203 : : {
8204 : 3 : gfc_error ("Invalid C identifier in NAME= specifier at %C");
8205 : 3 : return MATCH_ERROR;
8206 : : }
8207 : :
8208 : : return MATCH_YES;
8209 : : }
8210 : :
8211 : :
8212 : : /* Match a BIND(C) specifier, with the optional 'name=' specifier if
8213 : : given, and set the binding label in either the given symbol (if not
8214 : : NULL), or in the current_ts. The symbol may be NULL because we may
8215 : : encounter the BIND(C) before the declaration itself. Return
8216 : : MATCH_NO if what we're looking at isn't a BIND(C) specifier,
8217 : : MATCH_ERROR if it is a BIND(C) clause but an error was encountered,
8218 : : or MATCH_YES if the specifier was correct and the binding label and
8219 : : bind(c) fields were set correctly for the given symbol or the
8220 : : current_ts. If allow_binding_name is false, no binding name may be
8221 : : given. */
8222 : :
8223 : : match
8224 : 42866 : gfc_match_bind_c (gfc_symbol *sym, bool allow_binding_name)
8225 : : {
8226 : 42866 : char *binding_label = NULL;
8227 : 42866 : gfc_expr *e = NULL;
8228 : :
8229 : : /* Initialize the flag that specifies whether we encountered a NAME=
8230 : : specifier or not. */
8231 : 42866 : has_name_equals = 0;
8232 : :
8233 : : /* This much we have to be able to match, in this order, if
8234 : : there is a bind(c) label. */
8235 : 42866 : if (gfc_match (" bind ( c ") != MATCH_YES)
8236 : : return MATCH_NO;
8237 : :
8238 : : /* Now see if there is a binding label, or if we've reached the
8239 : : end of the bind(c) attribute without one. */
8240 : 5808 : if (gfc_match_char (',') == MATCH_YES)
8241 : : {
8242 : 1145 : if (gfc_match (" name = ") != MATCH_YES)
8243 : : {
8244 : 1 : gfc_error ("Syntax error in NAME= specifier for binding label "
8245 : : "at %C");
8246 : : /* should give an error message here */
8247 : 1 : return MATCH_ERROR;
8248 : : }
8249 : :
8250 : 1144 : has_name_equals = 1;
8251 : :
8252 : 1144 : if (gfc_match_init_expr (&e) != MATCH_YES)
8253 : : {
8254 : 2 : gfc_free_expr (e);
8255 : 2 : return MATCH_ERROR;
8256 : : }
8257 : :
8258 : 1142 : if (!gfc_simplify_expr(e, 0))
8259 : : {
8260 : 0 : gfc_error ("NAME= specifier at %C should be a constant expression");
8261 : 0 : gfc_free_expr (e);
8262 : 0 : return MATCH_ERROR;
8263 : : }
8264 : :
8265 : 1142 : if (e->expr_type != EXPR_CONSTANT || e->ts.type != BT_CHARACTER
8266 : 1139 : || e->ts.kind != gfc_default_character_kind || e->rank != 0)
8267 : : {
8268 : 4 : gfc_error ("NAME= specifier at %C should be a scalar of "
8269 : : "default character kind");
8270 : 4 : gfc_free_expr(e);
8271 : 4 : return MATCH_ERROR;
8272 : : }
8273 : :
8274 : : // Get a C string from the Fortran string constant
8275 : 2276 : binding_label = gfc_widechar_to_char (e->value.character.string,
8276 : 1138 : e->value.character.length);
8277 : 1138 : gfc_free_expr(e);
8278 : :
8279 : : // Check that it is valid (old gfc_match_name_C)
8280 : 1138 : if (check_bind_name_identifier (&binding_label) != MATCH_YES)
8281 : : return MATCH_ERROR;
8282 : : }
8283 : :
8284 : : /* Get the required right paren. */
8285 : 5796 : if (gfc_match_char (')') != MATCH_YES)
8286 : : {
8287 : 1 : gfc_error ("Missing closing paren for binding label at %C");
8288 : 1 : return MATCH_ERROR;
8289 : : }
8290 : :
8291 : 5795 : if (has_name_equals && !allow_binding_name)
8292 : : {
8293 : 6 : gfc_error ("No binding name is allowed in BIND(C) at %C");
8294 : 6 : return MATCH_ERROR;
8295 : : }
8296 : :
8297 : 5789 : if (has_name_equals && sym != NULL && sym->attr.dummy)
8298 : : {
8299 : 2 : gfc_error ("For dummy procedure %s, no binding name is "
8300 : : "allowed in BIND(C) at %C", sym->name);
8301 : 2 : return MATCH_ERROR;
8302 : : }
8303 : :
8304 : :
8305 : : /* Save the binding label to the symbol. If sym is null, we're
8306 : : probably matching the typespec attributes of a declaration and
8307 : : haven't gotten the name yet, and therefore, no symbol yet. */
8308 : 5787 : if (binding_label)
8309 : : {
8310 : 1084 : if (sym != NULL)
8311 : 976 : sym->binding_label = binding_label;
8312 : : else
8313 : 108 : curr_binding_label = binding_label;
8314 : : }
8315 : 4703 : else if (allow_binding_name)
8316 : : {
8317 : : /* No binding label, but if symbol isn't null, we
8318 : : can set the label for it here.
8319 : : If name="" or allow_binding_name is false, no C binding name is
8320 : : created. */
8321 : 4281 : if (sym != NULL && sym->name != NULL && has_name_equals == 0)
8322 : 4132 : sym->binding_label = IDENTIFIER_POINTER (get_identifier (sym->name));
8323 : : }
8324 : :
8325 : 5787 : if (has_name_equals && gfc_current_state () == COMP_INTERFACE
8326 : 695 : && current_interface.type == INTERFACE_ABSTRACT)
8327 : : {
8328 : 1 : gfc_error ("NAME not allowed on BIND(C) for ABSTRACT INTERFACE at %C");
8329 : 1 : return MATCH_ERROR;
8330 : : }
8331 : :
8332 : : return MATCH_YES;
8333 : : }
8334 : :
8335 : :
8336 : : /* Return nonzero if we're currently compiling a contained procedure. */
8337 : :
8338 : : static int
8339 : 52636 : contained_procedure (void)
8340 : : {
8341 : 52636 : gfc_state_data *s = gfc_state_stack;
8342 : :
8343 : 52636 : if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
8344 : 51878 : && s->previous != NULL && s->previous->state == COMP_CONTAINS)
8345 : 29902 : return 1;
8346 : :
8347 : : return 0;
8348 : : }
8349 : :
8350 : : /* Set the kind of each enumerator. The kind is selected such that it is
8351 : : interoperable with the corresponding C enumeration type, making
8352 : : sure that -fshort-enums is honored. */
8353 : :
8354 : : static void
8355 : 158 : set_enum_kind(void)
8356 : : {
8357 : 158 : enumerator_history *current_history = NULL;
8358 : 158 : int kind;
8359 : 158 : int i;
8360 : :
8361 : 158 : if (max_enum == NULL || enum_history == NULL)
8362 : : return;
8363 : :
8364 : 150 : if (!flag_short_enums)
8365 : : return;
8366 : :
8367 : : i = 0;
8368 : 48 : do
8369 : : {
8370 : 48 : kind = gfc_integer_kinds[i++].kind;
8371 : : }
8372 : 48 : while (kind < gfc_c_int_kind
8373 : 72 : && gfc_check_integer_range (max_enum->initializer->value.integer,
8374 : : kind) != ARITH_OK);
8375 : :
8376 : 24 : current_history = enum_history;
8377 : 96 : while (current_history != NULL)
8378 : : {
8379 : 72 : current_history->sym->ts.kind = kind;
8380 : 72 : current_history = current_history->next;
8381 : : }
8382 : : }
8383 : :
8384 : :
8385 : : /* Match any of the various end-block statements. Returns the type of
8386 : : END to the caller. The END INTERFACE, END IF, END DO, END SELECT
8387 : : and END BLOCK statements cannot be replaced by a single END statement. */
8388 : :
8389 : : match
8390 : 162521 : gfc_match_end (gfc_statement *st)
8391 : : {
8392 : 162521 : char name[GFC_MAX_SYMBOL_LEN + 1];
8393 : 162521 : gfc_compile_state state;
8394 : 162521 : locus old_loc;
8395 : 162521 : const char *block_name;
8396 : 162521 : const char *target;
8397 : 162521 : int eos_ok;
8398 : 162521 : match m;
8399 : 162521 : gfc_namespace *parent_ns, *ns, *prev_ns;
8400 : 162521 : gfc_namespace **nsp;
8401 : 162521 : bool abbreviated_modproc_decl = false;
8402 : 162521 : bool got_matching_end = false;
8403 : :
8404 : 162521 : old_loc = gfc_current_locus;
8405 : 162521 : if (gfc_match ("end") != MATCH_YES)
8406 : : return MATCH_NO;
8407 : :
8408 : 157734 : state = gfc_current_state ();
8409 : 315468 : block_name = gfc_current_block () == NULL
8410 : 157734 : ? NULL : gfc_current_block ()->name;
8411 : :
8412 : 157734 : switch (state)
8413 : : {
8414 : 2356 : case COMP_ASSOCIATE:
8415 : 2356 : case COMP_BLOCK:
8416 : 2356 : if (startswith (block_name, "block@"))
8417 : 157734 : block_name = NULL;
8418 : : break;
8419 : :
8420 : 15423 : case COMP_CONTAINS:
8421 : 15423 : case COMP_DERIVED_CONTAINS:
8422 : 15423 : state = gfc_state_stack->previous->state;
8423 : 30846 : block_name = gfc_state_stack->previous->sym == NULL
8424 : 15423 : ? NULL : gfc_state_stack->previous->sym->name;
8425 : 15423 : abbreviated_modproc_decl = gfc_state_stack->previous->sym
8426 : 15423 : && gfc_state_stack->previous->sym->abr_modproc_decl;
8427 : : break;
8428 : :
8429 : : default:
8430 : : break;
8431 : : }
8432 : :
8433 : 157734 : if (!abbreviated_modproc_decl)
8434 : 157733 : abbreviated_modproc_decl = gfc_current_block ()
8435 : 157733 : && gfc_current_block ()->abr_modproc_decl;
8436 : :
8437 : 157734 : switch (state)
8438 : : {
8439 : 26024 : case COMP_NONE:
8440 : 26024 : case COMP_PROGRAM:
8441 : 26024 : *st = ST_END_PROGRAM;
8442 : 26024 : target = " program";
8443 : 26024 : eos_ok = 1;
8444 : 26024 : break;
8445 : :
8446 : 35700 : case COMP_SUBROUTINE:
8447 : 35700 : *st = ST_END_SUBROUTINE;
8448 : 35700 : if (!abbreviated_modproc_decl)
8449 : : target = " subroutine";
8450 : : else
8451 : 124 : target = " procedure";
8452 : 35700 : eos_ok = !contained_procedure ();
8453 : 35700 : break;
8454 : :
8455 : 16936 : case COMP_FUNCTION:
8456 : 16936 : *st = ST_END_FUNCTION;
8457 : 16936 : if (!abbreviated_modproc_decl)
8458 : : target = " function";
8459 : : else
8460 : 53 : target = " procedure";
8461 : 16936 : eos_ok = !contained_procedure ();
8462 : 16936 : break;
8463 : :
8464 : 83 : case COMP_BLOCK_DATA:
8465 : 83 : *st = ST_END_BLOCK_DATA;
8466 : 83 : target = " block data";
8467 : 83 : eos_ok = 1;
8468 : 83 : break;
8469 : :
8470 : 8863 : case COMP_MODULE:
8471 : 8863 : *st = ST_END_MODULE;
8472 : 8863 : target = " module";
8473 : 8863 : eos_ok = 1;
8474 : 8863 : break;
8475 : :
8476 : 195 : case COMP_SUBMODULE:
8477 : 195 : *st = ST_END_SUBMODULE;
8478 : 195 : target = " submodule";
8479 : 195 : eos_ok = 1;
8480 : 195 : break;
8481 : :
8482 : 8958 : case COMP_INTERFACE:
8483 : 8958 : *st = ST_END_INTERFACE;
8484 : 8958 : target = " interface";
8485 : 8958 : eos_ok = 0;
8486 : 8958 : break;
8487 : :
8488 : 257 : case COMP_MAP:
8489 : 257 : *st = ST_END_MAP;
8490 : 257 : target = " map";
8491 : 257 : eos_ok = 0;
8492 : 257 : break;
8493 : :
8494 : 132 : case COMP_UNION:
8495 : 132 : *st = ST_END_UNION;
8496 : 132 : target = " union";
8497 : 132 : eos_ok = 0;
8498 : 132 : break;
8499 : :
8500 : 313 : case COMP_STRUCTURE:
8501 : 313 : *st = ST_END_STRUCTURE;
8502 : 313 : target = " structure";
8503 : 313 : eos_ok = 0;
8504 : 313 : break;
8505 : :
8506 : 11389 : case COMP_DERIVED:
8507 : 11389 : case COMP_DERIVED_CONTAINS:
8508 : 11389 : *st = ST_END_TYPE;
8509 : 11389 : target = " type";
8510 : 11389 : eos_ok = 0;
8511 : 11389 : break;
8512 : :
8513 : 1152 : case COMP_ASSOCIATE:
8514 : 1152 : *st = ST_END_ASSOCIATE;
8515 : 1152 : target = " associate";
8516 : 1152 : eos_ok = 0;
8517 : 1152 : break;
8518 : :
8519 : 1204 : case COMP_BLOCK:
8520 : 1204 : case COMP_OMP_STRICTLY_STRUCTURED_BLOCK:
8521 : 1204 : *st = ST_END_BLOCK;
8522 : 1204 : target = " block";
8523 : 1204 : eos_ok = 0;
8524 : 1204 : break;
8525 : :
8526 : 13432 : case COMP_IF:
8527 : 13432 : *st = ST_ENDIF;
8528 : 13432 : target = " if";
8529 : 13432 : eos_ok = 0;
8530 : 13432 : break;
8531 : :
8532 : 27789 : case COMP_DO:
8533 : 27789 : case COMP_DO_CONCURRENT:
8534 : 27789 : *st = ST_ENDDO;
8535 : 27789 : target = " do";
8536 : 27789 : eos_ok = 0;
8537 : 27789 : break;
8538 : :
8539 : 33 : case COMP_CRITICAL:
8540 : 33 : *st = ST_END_CRITICAL;
8541 : 33 : target = " critical";
8542 : 33 : eos_ok = 0;
8543 : 33 : break;
8544 : :
8545 : 4225 : case COMP_SELECT:
8546 : 4225 : case COMP_SELECT_TYPE:
8547 : 4225 : case COMP_SELECT_RANK:
8548 : 4225 : *st = ST_END_SELECT;
8549 : 4225 : target = " select";
8550 : 4225 : eos_ok = 0;
8551 : 4225 : break;
8552 : :
8553 : 513 : case COMP_FORALL:
8554 : 513 : *st = ST_END_FORALL;
8555 : 513 : target = " forall";
8556 : 513 : eos_ok = 0;
8557 : 513 : break;
8558 : :
8559 : 373 : case COMP_WHERE:
8560 : 373 : *st = ST_END_WHERE;
8561 : 373 : target = " where";
8562 : 373 : eos_ok = 0;
8563 : 373 : break;
8564 : :
8565 : 158 : case COMP_ENUM:
8566 : 158 : *st = ST_END_ENUM;
8567 : 158 : target = " enum";
8568 : 158 : eos_ok = 0;
8569 : 158 : last_initializer = NULL;
8570 : 158 : set_enum_kind ();
8571 : 158 : gfc_free_enum_history ();
8572 : 158 : break;
8573 : :
8574 : 5 : default:
8575 : 5 : gfc_error ("Unexpected END statement at %C");
8576 : 5 : goto cleanup;
8577 : : }
8578 : :
8579 : 157729 : old_loc = gfc_current_locus;
8580 : 157729 : if (gfc_match_eos () == MATCH_YES)
8581 : : {
8582 : 18278 : if (!eos_ok && (*st == ST_END_SUBROUTINE || *st == ST_END_FUNCTION))
8583 : : {
8584 : 5957 : if (!gfc_notify_std (GFC_STD_F2008, "END statement "
8585 : : "instead of %s statement at %L",
8586 : : abbreviated_modproc_decl ? "END PROCEDURE"
8587 : 2978 : : gfc_ascii_statement(*st), &old_loc))
8588 : 4 : goto cleanup;
8589 : : }
8590 : 7 : else if (!eos_ok)
8591 : : {
8592 : : /* We would have required END [something]. */
8593 : 7 : gfc_error ("%s statement expected at %L",
8594 : : gfc_ascii_statement (*st), &old_loc);
8595 : 7 : goto cleanup;
8596 : : }
8597 : :
8598 : 18267 : return MATCH_YES;
8599 : : }
8600 : :
8601 : : /* Verify that we've got the sort of end-block that we're expecting. */
8602 : 139451 : if (gfc_match (target) != MATCH_YES)
8603 : : {
8604 : 281 : gfc_error ("Expecting %s statement at %L", abbreviated_modproc_decl
8605 : 140 : ? "END PROCEDURE" : gfc_ascii_statement(*st), &old_loc);
8606 : 141 : goto cleanup;
8607 : : }
8608 : : else
8609 : 139310 : got_matching_end = true;
8610 : :
8611 : 139310 : old_loc = gfc_current_locus;
8612 : : /* If we're at the end, make sure a block name wasn't required. */
8613 : 139310 : if (gfc_match_eos () == MATCH_YES)
8614 : : {
8615 : :
8616 : 90644 : if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
8617 : : && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK
8618 : : && *st != ST_END_ASSOCIATE && *st != ST_END_CRITICAL)
8619 : : return MATCH_YES;
8620 : :
8621 : 48240 : if (!block_name)
8622 : : return MATCH_YES;
8623 : :
8624 : 7 : gfc_error ("Expected block name of %qs in %s statement at %L",
8625 : : block_name, gfc_ascii_statement (*st), &old_loc);
8626 : :
8627 : 7 : return MATCH_ERROR;
8628 : : }
8629 : :
8630 : : /* END INTERFACE has a special handler for its several possible endings. */
8631 : 48666 : if (*st == ST_END_INTERFACE)
8632 : 495 : return gfc_match_end_interface ();
8633 : :
8634 : : /* We haven't hit the end of statement, so what is left must be an
8635 : : end-name. */
8636 : 48171 : m = gfc_match_space ();
8637 : 48171 : if (m == MATCH_YES)
8638 : 48171 : m = gfc_match_name (name);
8639 : :
8640 : 48171 : if (m == MATCH_NO)
8641 : 0 : gfc_error ("Expected terminating name at %C");
8642 : 48171 : if (m != MATCH_YES)
8643 : 0 : goto cleanup;
8644 : :
8645 : 48171 : if (block_name == NULL)
8646 : 15 : goto syntax;
8647 : :
8648 : : /* We have to pick out the declared submodule name from the composite
8649 : : required by F2008:11.2.3 para 2, which ends in the declared name. */
8650 : 48156 : if (state == COMP_SUBMODULE)
8651 : 107 : block_name = strchr (block_name, '.') + 1;
8652 : :
8653 : 48156 : if (strcmp (name, block_name) != 0 && strcmp (block_name, "ppr@") != 0)
8654 : : {
8655 : 8 : gfc_error ("Expected label %qs for %s statement at %C", block_name,
8656 : : gfc_ascii_statement (*st));
8657 : 8 : goto cleanup;
8658 : : }
8659 : : /* Procedure pointer as function result. */
8660 : 48148 : else if (strcmp (block_name, "ppr@") == 0
8661 : 21 : && strcmp (name, gfc_current_block ()->ns->proc_name->name) != 0)
8662 : : {
8663 : 0 : gfc_error ("Expected label %qs for %s statement at %C",
8664 : 0 : gfc_current_block ()->ns->proc_name->name,
8665 : : gfc_ascii_statement (*st));
8666 : 0 : goto cleanup;
8667 : : }
8668 : :
8669 : 48148 : if (gfc_match_eos () == MATCH_YES)
8670 : : return MATCH_YES;
8671 : :
8672 : 0 : syntax:
8673 : 15 : gfc_syntax_error (*st);
8674 : :
8675 : 180 : cleanup:
8676 : 180 : gfc_current_locus = old_loc;
8677 : :
8678 : : /* If we are missing an END BLOCK, we created a half-ready namespace.
8679 : : Remove it from the parent namespace's sibling list. */
8680 : :
8681 : 188 : while (state == COMP_BLOCK && !got_matching_end)
8682 : : {
8683 : 8 : parent_ns = gfc_current_ns->parent;
8684 : :
8685 : 8 : nsp = &(gfc_state_stack->previous->tail->ext.block.ns);
8686 : :
8687 : 8 : prev_ns = NULL;
8688 : 8 : ns = *nsp;
8689 : 16 : while (ns)
8690 : : {
8691 : 8 : if (ns == gfc_current_ns)
8692 : : {
8693 : 8 : if (prev_ns == NULL)
8694 : 8 : *nsp = NULL;
8695 : : else
8696 : 0 : prev_ns->sibling = ns->sibling;
8697 : : }
8698 : 8 : prev_ns = ns;
8699 : 8 : ns = ns->sibling;
8700 : : }
8701 : :
8702 : 8 : gfc_free_namespace (gfc_current_ns);
8703 : 8 : gfc_current_ns = parent_ns;
8704 : 8 : gfc_state_stack = gfc_state_stack->previous;
8705 : 8 : state = gfc_current_state ();
8706 : : }
8707 : :
8708 : : return MATCH_ERROR;
8709 : : }
8710 : :
8711 : :
8712 : :
8713 : : /***************** Attribute declaration statements ****************/
8714 : :
8715 : : /* Set the attribute of a single variable. */
8716 : :
8717 : : static match
8718 : 9528 : attr_decl1 (void)
8719 : : {
8720 : 9528 : char name[GFC_MAX_SYMBOL_LEN + 1];
8721 : 9528 : gfc_array_spec *as;
8722 : :
8723 : : /* Workaround -Wmaybe-uninitialized false positive during
8724 : : profiledbootstrap by initializing them. */
8725 : 9528 : gfc_symbol *sym = NULL;
8726 : 9528 : locus var_locus;
8727 : 9528 : match m;
8728 : :
8729 : 9528 : as = NULL;
8730 : :
8731 : 9528 : m = gfc_match_name (name);
8732 : 9528 : if (m != MATCH_YES)
8733 : 0 : goto cleanup;
8734 : :
8735 : 9528 : if (find_special (name, &sym, false))
8736 : : return MATCH_ERROR;
8737 : :
8738 : 9528 : if (!check_function_name (name))
8739 : : {
8740 : 7 : m = MATCH_ERROR;
8741 : 7 : goto cleanup;
8742 : : }
8743 : :
8744 : 9521 : var_locus = gfc_current_locus;
8745 : :
8746 : : /* Deal with possible array specification for certain attributes. */
8747 : 9521 : if (current_attr.dimension
8748 : : || current_attr.codimension
8749 : : || current_attr.allocatable
8750 : : || current_attr.pointer
8751 : 9521 : || current_attr.target)
8752 : : {
8753 : 5160 : m = gfc_match_array_spec (&as, !current_attr.codimension,
8754 : : !current_attr.dimension
8755 : : && !current_attr.pointer
8756 : 2580 : && !current_attr.target);
8757 : 2580 : if (m == MATCH_ERROR)
8758 : 2 : goto cleanup;
8759 : :
8760 : 2578 : if (current_attr.dimension && m == MATCH_NO)
8761 : : {
8762 : 0 : gfc_error ("Missing array specification at %L in DIMENSION "
8763 : : "statement", &var_locus);
8764 : 0 : m = MATCH_ERROR;
8765 : 0 : goto cleanup;
8766 : : }
8767 : :
8768 : 2578 : if (current_attr.dimension && sym->value)
8769 : : {
8770 : 1 : gfc_error ("Dimensions specified for %s at %L after its "
8771 : : "initialization", sym->name, &var_locus);
8772 : 1 : m = MATCH_ERROR;
8773 : 1 : goto cleanup;
8774 : : }
8775 : :
8776 : 2577 : if (current_attr.codimension && m == MATCH_NO)
8777 : : {
8778 : 0 : gfc_error ("Missing array specification at %L in CODIMENSION "
8779 : : "statement", &var_locus);
8780 : 0 : m = MATCH_ERROR;
8781 : 0 : goto cleanup;
8782 : : }
8783 : :
8784 : 2577 : if ((current_attr.allocatable || current_attr.pointer)
8785 : 760 : && (m == MATCH_YES) && (as->type != AS_DEFERRED))
8786 : : {
8787 : 0 : gfc_error ("Array specification must be deferred at %L", &var_locus);
8788 : 0 : m = MATCH_ERROR;
8789 : 0 : goto cleanup;
8790 : : }
8791 : : }
8792 : :
8793 : 9518 : if (sym->ts.type == BT_CLASS
8794 : 199 : && sym->ts.u.derived
8795 : 199 : && sym->ts.u.derived->attr.is_class)
8796 : : {
8797 : 177 : sym->attr.pointer = CLASS_DATA(sym)->attr.class_pointer;
8798 : 177 : sym->attr.allocatable = CLASS_DATA(sym)->attr.allocatable;
8799 : 177 : sym->attr.dimension = CLASS_DATA(sym)->attr.dimension;
8800 : 177 : sym->attr.codimension = CLASS_DATA(sym)->attr.codimension;
8801 : 177 : if (CLASS_DATA (sym)->as)
8802 : 123 : sym->as = gfc_copy_array_spec (CLASS_DATA (sym)->as);
8803 : : }
8804 : 9518 : if (current_attr.dimension == 0 && current_attr.codimension == 0
8805 : 9518 : && !gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus))
8806 : : {
8807 : 22 : m = MATCH_ERROR;
8808 : 22 : goto cleanup;
8809 : : }
8810 : 9496 : if (!gfc_set_array_spec (sym, as, &var_locus))
8811 : : {
8812 : 18 : m = MATCH_ERROR;
8813 : 18 : goto cleanup;
8814 : : }
8815 : :
8816 : 9478 : if (sym->attr.cray_pointee && sym->as != NULL)
8817 : : {
8818 : : /* Fix the array spec. */
8819 : 2 : m = gfc_mod_pointee_as (sym->as);
8820 : 2 : if (m == MATCH_ERROR)
8821 : 0 : goto cleanup;
8822 : : }
8823 : :
8824 : 9478 : if (!gfc_add_attribute (&sym->attr, &var_locus))
8825 : : {
8826 : 0 : m = MATCH_ERROR;
8827 : 0 : goto cleanup;
8828 : : }
8829 : :
8830 : 9478 : if ((current_attr.external || current_attr.intrinsic)
8831 : 5813 : && sym->attr.flavor != FL_PROCEDURE
8832 : 15259 : && !gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL))
8833 : : {
8834 : 0 : m = MATCH_ERROR;
8835 : 0 : goto cleanup;
8836 : : }
8837 : :
8838 : 9478 : if (sym->ts.type == BT_CLASS && sym->ts.u.derived->attr.is_class
8839 : 169 : && !as && !current_attr.pointer && !current_attr.allocatable
8840 : 151 : && !current_attr.external)
8841 : : {
8842 : 136 : sym->attr.pointer = 0;
8843 : 136 : sym->attr.allocatable = 0;
8844 : 136 : sym->attr.dimension = 0;
8845 : 136 : sym->attr.codimension = 0;
8846 : 136 : gfc_free_array_spec (sym->as);
8847 : 136 : sym->as = NULL;
8848 : : }
8849 : 9342 : else if (sym->ts.type == BT_CLASS
8850 : 9342 : && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
8851 : : {
8852 : 0 : m = MATCH_ERROR;
8853 : 0 : goto cleanup;
8854 : : }
8855 : :
8856 : 9478 : add_hidden_procptr_result (sym);
8857 : :
8858 : 9478 : return MATCH_YES;
8859 : :
8860 : 50 : cleanup:
8861 : 50 : gfc_free_array_spec (as);
8862 : 50 : return m;
8863 : : }
8864 : :
8865 : :
8866 : : /* Generic attribute declaration subroutine. Used for attributes that
8867 : : just have a list of names. */
8868 : :
8869 : : static match
8870 : 5976 : attr_decl (void)
8871 : : {
8872 : 5976 : match m;
8873 : :
8874 : : /* Gobble the optional double colon, by simply ignoring the result
8875 : : of gfc_match(). */
8876 : 5976 : gfc_match (" ::");
8877 : :
8878 : 9528 : for (;;)
8879 : : {
8880 : 9528 : m = attr_decl1 ();
8881 : 9528 : if (m != MATCH_YES)
8882 : : break;
8883 : :
8884 : 9478 : if (gfc_match_eos () == MATCH_YES)
8885 : : {
8886 : : m = MATCH_YES;
8887 : : break;
8888 : : }
8889 : :
8890 : 3552 : if (gfc_match_char (',') != MATCH_YES)
8891 : : {
8892 : 0 : gfc_error ("Unexpected character in variable list at %C");
8893 : 0 : m = MATCH_ERROR;
8894 : 0 : break;
8895 : : }
8896 : : }
8897 : :
8898 : 5976 : return m;
8899 : : }
8900 : :
8901 : :
8902 : : /* This routine matches Cray Pointer declarations of the form:
8903 : : pointer ( <pointer>, <pointee> )
8904 : : or
8905 : : pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
8906 : : The pointer, if already declared, should be an integer. Otherwise, we
8907 : : set it as BT_INTEGER with kind gfc_index_integer_kind. The pointee may
8908 : : be either a scalar, or an array declaration. No space is allocated for
8909 : : the pointee. For the statement
8910 : : pointer (ipt, ar(10))
8911 : : any subsequent uses of ar will be translated (in C-notation) as
8912 : : ar(i) => ((<type> *) ipt)(i)
8913 : : After gimplification, pointee variable will disappear in the code. */
8914 : :
8915 : : static match
8916 : 310 : cray_pointer_decl (void)
8917 : : {
8918 : 310 : match m;
8919 : 310 : gfc_array_spec *as = NULL;
8920 : 310 : gfc_symbol *cptr; /* Pointer symbol. */
8921 : 310 : gfc_symbol *cpte; /* Pointee symbol. */
8922 : 310 : locus var_locus;
8923 : 310 : bool done = false;
8924 : :
8925 : 612 : while (!done)
8926 : : {
8927 : 323 : if (gfc_match_char ('(') != MATCH_YES)
8928 : : {
8929 : 1 : gfc_error ("Expected %<(%> at %C");
8930 : 1 : return MATCH_ERROR;
8931 : : }
8932 : :
8933 : : /* Match pointer. */
8934 : 322 : var_locus = gfc_current_locus;
8935 : 322 : gfc_clear_attr (¤t_attr);
8936 : 322 : gfc_add_cray_pointer (¤t_attr, &var_locus);
8937 : 322 : current_ts.type = BT_INTEGER;
8938 : 322 : current_ts.kind = gfc_index_integer_kind;
8939 : :
8940 : 322 : m = gfc_match_symbol (&cptr, 0);
8941 : 322 : if (m != MATCH_YES)
8942 : : {
8943 : 2 : gfc_error ("Expected variable name at %C");
8944 : 2 : return m;
8945 : : }
8946 : :
8947 : 320 : if (!gfc_add_cray_pointer (&cptr->attr, &var_locus))
8948 : : return MATCH_ERROR;
8949 : :
8950 : 317 : gfc_set_sym_referenced (cptr);
8951 : :
8952 : 317 : if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary. */
8953 : : {
8954 : 303 : cptr->ts.type = BT_INTEGER;
8955 : 303 : cptr->ts.kind = gfc_index_integer_kind;
8956 : : }
8957 : 14 : else if (cptr->ts.type != BT_INTEGER)
8958 : : {
8959 : 1 : gfc_error ("Cray pointer at %C must be an integer");
8960 : 1 : return MATCH_ERROR;
8961 : : }
8962 : 13 : else if (cptr->ts.kind < gfc_index_integer_kind)
8963 : 0 : gfc_warning (0, "Cray pointer at %C has %d bytes of precision;"
8964 : : " memory addresses require %d bytes",
8965 : : cptr->ts.kind, gfc_index_integer_kind);
8966 : :
8967 : 316 : if (gfc_match_char (',') != MATCH_YES)
8968 : : {
8969 : 2 : gfc_error ("Expected \",\" at %C");
8970 : 2 : return MATCH_ERROR;
8971 : : }
8972 : :
8973 : : /* Match Pointee. */
8974 : 314 : var_locus = gfc_current_locus;
8975 : 314 : gfc_clear_attr (¤t_attr);
8976 : 314 : gfc_add_cray_pointee (¤t_attr, &var_locus);
8977 : 314 : current_ts.type = BT_UNKNOWN;
8978 : 314 : current_ts.kind = 0;
8979 : :
8980 : 314 : m = gfc_match_symbol (&cpte, 0);
8981 : 314 : if (m != MATCH_YES)
8982 : : {
8983 : 2 : gfc_error ("Expected variable name at %C");
8984 : 2 : return m;
8985 : : }
8986 : :
8987 : : /* Check for an optional array spec. */
8988 : 312 : m = gfc_match_array_spec (&as, true, false);
8989 : 312 : if (m == MATCH_ERROR)
8990 : : {
8991 : 0 : gfc_free_array_spec (as);
8992 : 0 : return m;
8993 : : }
8994 : 312 : else if (m == MATCH_NO)
8995 : : {
8996 : 202 : gfc_free_array_spec (as);
8997 : 202 : as = NULL;
8998 : : }
8999 : :
9000 : 312 : if (!gfc_add_cray_pointee (&cpte->attr, &var_locus))
9001 : : return MATCH_ERROR;
9002 : :
9003 : 305 : gfc_set_sym_referenced (cpte);
9004 : :
9005 : 305 : if (cpte->as == NULL)
9006 : : {
9007 : 223 : if (!gfc_set_array_spec (cpte, as, &var_locus))
9008 : 0 : gfc_internal_error ("Cannot set Cray pointee array spec.");
9009 : : }
9010 : 82 : else if (as != NULL)
9011 : : {
9012 : 1 : gfc_error ("Duplicate array spec for Cray pointee at %C");
9013 : 1 : gfc_free_array_spec (as);
9014 : 1 : return MATCH_ERROR;
9015 : : }
9016 : :
9017 : 304 : as = NULL;
9018 : :
9019 : 304 : if (cpte->as != NULL)
9020 : : {
9021 : : /* Fix array spec. */
9022 : 190 : m = gfc_mod_pointee_as (cpte->as);
9023 : 190 : if (m == MATCH_ERROR)
9024 : : return m;
9025 : : }
9026 : :
9027 : : /* Point the Pointee at the Pointer. */
9028 : 304 : cpte->cp_pointer = cptr;
9029 : :
9030 : 304 : if (gfc_match_char (')') != MATCH_YES)
9031 : : {
9032 : 2 : gfc_error ("Expected \")\" at %C");
9033 : 2 : return MATCH_ERROR;
9034 : : }
9035 : 302 : m = gfc_match_char (',');
9036 : 302 : if (m != MATCH_YES)
9037 : 289 : done = true; /* Stop searching for more declarations. */
9038 : :
9039 : : }
9040 : :
9041 : 289 : if (m == MATCH_ERROR /* Failed when trying to find ',' above. */
9042 : 289 : || gfc_match_eos () != MATCH_YES)
9043 : : {
9044 : 0 : gfc_error ("Expected %<,%> or end of statement at %C");
9045 : 0 : return MATCH_ERROR;
9046 : : }
9047 : : return MATCH_YES;
9048 : : }
9049 : :
9050 : :
9051 : : match
9052 : 2898 : gfc_match_external (void)
9053 : : {
9054 : :
9055 : 2898 : gfc_clear_attr (¤t_attr);
9056 : 2898 : current_attr.external = 1;
9057 : :
9058 : 2898 : return attr_decl ();
9059 : : }
9060 : :
9061 : :
9062 : : match
9063 : 205 : gfc_match_intent (void)
9064 : : {
9065 : 205 : sym_intent intent;
9066 : :
9067 : : /* This is not allowed within a BLOCK construct! */
9068 : 205 : if (gfc_current_state () == COMP_BLOCK)
9069 : : {
9070 : 2 : gfc_error ("INTENT is not allowed inside of BLOCK at %C");
9071 : 2 : return MATCH_ERROR;
9072 : : }
9073 : :
9074 : 203 : intent = match_intent_spec ();
9075 : 203 : if (intent == INTENT_UNKNOWN)
9076 : : return MATCH_ERROR;
9077 : :
9078 : 203 : gfc_clear_attr (¤t_attr);
9079 : 203 : current_attr.intent = intent;
9080 : :
9081 : 203 : return attr_decl ();
9082 : : }
9083 : :
9084 : :
9085 : : match
9086 : 1454 : gfc_match_intrinsic (void)
9087 : : {
9088 : :
9089 : 1454 : gfc_clear_attr (¤t_attr);
9090 : 1454 : current_attr.intrinsic = 1;
9091 : :
9092 : 1454 : return attr_decl ();
9093 : : }
9094 : :
9095 : :
9096 : : match
9097 : 205 : gfc_match_optional (void)
9098 : : {
9099 : : /* This is not allowed within a BLOCK construct! */
9100 : 205 : if (gfc_current_state () == COMP_BLOCK)
9101 : : {
9102 : 2 : gfc_error ("OPTIONAL is not allowed inside of BLOCK at %C");
9103 : 2 : return MATCH_ERROR;
9104 : : }
9105 : :
9106 : 203 : gfc_clear_attr (¤t_attr);
9107 : 203 : current_attr.optional = 1;
9108 : :
9109 : 203 : return attr_decl ();
9110 : : }
9111 : :
9112 : :
9113 : : match
9114 : 548 : gfc_match_pointer (void)
9115 : : {
9116 : 548 : gfc_gobble_whitespace ();
9117 : 548 : if (gfc_peek_ascii_char () == '(')
9118 : : {
9119 : 311 : if (!flag_cray_pointer)
9120 : : {
9121 : 1 : gfc_error ("Cray pointer declaration at %C requires "
9122 : : "%<-fcray-pointer%> flag");
9123 : 1 : return MATCH_ERROR;
9124 : : }
9125 : 310 : return cray_pointer_decl ();
9126 : : }
9127 : : else
9128 : : {
9129 : 237 : gfc_clear_attr (¤t_attr);
9130 : 237 : current_attr.pointer = 1;
9131 : :
9132 : 237 : return attr_decl ();
9133 : : }
9134 : : }
9135 : :
9136 : :
9137 : : match
9138 : 136 : gfc_match_allocatable (void)
9139 : : {
9140 : 136 : gfc_clear_attr (¤t_attr);
9141 : 136 : current_attr.allocatable = 1;
9142 : :
9143 : 136 : return attr_decl ();
9144 : : }
9145 : :
9146 : :
9147 : : match
9148 : 22 : gfc_match_codimension (void)
9149 : : {
9150 : 22 : gfc_clear_attr (¤t_attr);
9151 : 22 : current_attr.codimension = 1;
9152 : :
9153 : 22 : return attr_decl ();
9154 : : }
9155 : :
9156 : :
9157 : : match
9158 : 80 : gfc_match_contiguous (void)
9159 : : {
9160 : 80 : if (!gfc_notify_std (GFC_STD_F2008, "CONTIGUOUS statement at %C"))
9161 : : return MATCH_ERROR;
9162 : :
9163 : 79 : gfc_clear_attr (¤t_attr);
9164 : 79 : current_attr.contiguous = 1;
9165 : :
9166 : 79 : return attr_decl ();
9167 : : }
9168 : :
9169 : :
9170 : : match
9171 : 645 : gfc_match_dimension (void)
9172 : : {
9173 : 645 : gfc_clear_attr (¤t_attr);
9174 : 645 : current_attr.dimension = 1;
9175 : :
9176 : 645 : return attr_decl ();
9177 : : }
9178 : :
9179 : :
9180 : : match
9181 : 99 : gfc_match_target (void)
9182 : : {
9183 : 99 : gfc_clear_attr (¤t_attr);
9184 : 99 : current_attr.target = 1;
9185 : :
9186 : 99 : return attr_decl ();
9187 : : }
9188 : :
9189 : :
9190 : : /* Match the list of entities being specified in a PUBLIC or PRIVATE
9191 : : statement. */
9192 : :
9193 : : static match
9194 : 1535 : access_attr_decl (gfc_statement st)
9195 : : {
9196 : 1535 : char name[GFC_MAX_SYMBOL_LEN + 1];
9197 : 1535 : interface_type type;
9198 : 1535 : gfc_user_op *uop;
9199 : 1535 : gfc_symbol *sym, *dt_sym;
9200 : 1535 : gfc_intrinsic_op op;
9201 : 1535 : match m;
9202 : 1535 : gfc_access access = (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
9203 : :
9204 : 1535 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9205 : 0 : goto done;
9206 : :
9207 : 2596 : for (;;)
9208 : : {
9209 : 2596 : m = gfc_match_generic_spec (&type, name, &op);
9210 : 2596 : if (m == MATCH_NO)
9211 : 0 : goto syntax;
9212 : 2596 : if (m == MATCH_ERROR)
9213 : 0 : goto done;
9214 : :
9215 : 2596 : switch (type)
9216 : : {
9217 : 0 : case INTERFACE_NAMELESS:
9218 : 0 : case INTERFACE_ABSTRACT:
9219 : 0 : goto syntax;
9220 : :
9221 : 2529 : case INTERFACE_GENERIC:
9222 : 2529 : case INTERFACE_DTIO:
9223 : :
9224 : 2529 : if (gfc_get_symbol (name, NULL, &sym))
9225 : 0 : goto done;
9226 : :
9227 : 2529 : if (type == INTERFACE_DTIO
9228 : 20 : && gfc_current_ns->proc_name
9229 : 20 : && gfc_current_ns->proc_name->attr.flavor == FL_MODULE
9230 : 20 : && sym->attr.flavor == FL_UNKNOWN)
9231 : 2 : sym->attr.flavor = FL_PROCEDURE;
9232 : :
9233 : 2529 : if (!gfc_add_access (&sym->attr, access, sym->name, NULL))
9234 : 4 : goto done;
9235 : :
9236 : 313 : if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
9237 : 2575 : && !gfc_add_access (&dt_sym->attr, access, sym->name, NULL))
9238 : 0 : goto done;
9239 : :
9240 : : break;
9241 : :
9242 : 63 : case INTERFACE_INTRINSIC_OP:
9243 : 63 : if (gfc_current_ns->operator_access[op] == ACCESS_UNKNOWN)
9244 : : {
9245 : 63 : gfc_intrinsic_op other_op;
9246 : :
9247 : 63 : gfc_current_ns->operator_access[op] = access;
9248 : :
9249 : : /* Handle the case if there is another op with the same
9250 : : function, for INTRINSIC_EQ vs. INTRINSIC_EQ_OS and so on. */
9251 : 63 : other_op = gfc_equivalent_op (op);
9252 : :
9253 : 63 : if (other_op != INTRINSIC_NONE)
9254 : 21 : gfc_current_ns->operator_access[other_op] = access;
9255 : : }
9256 : : else
9257 : : {
9258 : 0 : gfc_error ("Access specification of the %s operator at %C has "
9259 : : "already been specified", gfc_op2string (op));
9260 : 0 : goto done;
9261 : : }
9262 : :
9263 : : break;
9264 : :
9265 : 4 : case INTERFACE_USER_OP:
9266 : 4 : uop = gfc_get_uop (name);
9267 : :
9268 : 4 : if (uop->access == ACCESS_UNKNOWN)
9269 : : {
9270 : 3 : uop->access = access;
9271 : : }
9272 : : else
9273 : : {
9274 : 1 : gfc_error ("Access specification of the .%s. operator at %C "
9275 : : "has already been specified", uop->name);
9276 : 1 : goto done;
9277 : : }
9278 : :
9279 : 3 : break;
9280 : : }
9281 : :
9282 : 2591 : if (gfc_match_char (',') == MATCH_NO)
9283 : : break;
9284 : : }
9285 : :
9286 : 1530 : if (gfc_match_eos () != MATCH_YES)
9287 : 0 : goto syntax;
9288 : : return MATCH_YES;
9289 : :
9290 : 0 : syntax:
9291 : 0 : gfc_syntax_error (st);
9292 : :
9293 : : done:
9294 : : return MATCH_ERROR;
9295 : : }
9296 : :
9297 : :
9298 : : match
9299 : 23 : gfc_match_protected (void)
9300 : : {
9301 : 23 : gfc_symbol *sym;
9302 : 23 : match m;
9303 : 23 : char c;
9304 : :
9305 : : /* PROTECTED has already been seen, but must be followed by whitespace
9306 : : or ::. */
9307 : 23 : c = gfc_peek_ascii_char ();
9308 : 23 : if (!gfc_is_whitespace (c) && c != ':')
9309 : : return MATCH_NO;
9310 : :
9311 : 22 : if (!gfc_current_ns->proc_name
9312 : 20 : || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
9313 : : {
9314 : 3 : gfc_error ("PROTECTED at %C only allowed in specification "
9315 : : "part of a module");
9316 : 3 : return MATCH_ERROR;
9317 : :
9318 : : }
9319 : :
9320 : 19 : gfc_match (" ::");
9321 : :
9322 : 19 : if (!gfc_notify_std (GFC_STD_F2003, "PROTECTED statement at %C"))
9323 : : return MATCH_ERROR;
9324 : :
9325 : : /* PROTECTED has an entity-list. */
9326 : 18 : if (gfc_match_eos () == MATCH_YES)
9327 : 0 : goto syntax;
9328 : :
9329 : 26 : for(;;)
9330 : : {
9331 : 26 : m = gfc_match_symbol (&sym, 0);
9332 : 26 : switch (m)
9333 : : {
9334 : 26 : case MATCH_YES:
9335 : 26 : if (!gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus))
9336 : : return MATCH_ERROR;
9337 : 25 : goto next_item;
9338 : :
9339 : : case MATCH_NO:
9340 : : break;
9341 : :
9342 : : case MATCH_ERROR:
9343 : : return MATCH_ERROR;
9344 : : }
9345 : :
9346 : 25 : next_item:
9347 : 25 : if (gfc_match_eos () == MATCH_YES)
9348 : : break;
9349 : 8 : if (gfc_match_char (',') != MATCH_YES)
9350 : 0 : goto syntax;
9351 : : }
9352 : :
9353 : : return MATCH_YES;
9354 : :
9355 : 0 : syntax:
9356 : 0 : gfc_error ("Syntax error in PROTECTED statement at %C");
9357 : 0 : return MATCH_ERROR;
9358 : : }
9359 : :
9360 : :
9361 : : /* The PRIVATE statement is a bit weird in that it can be an attribute
9362 : : declaration, but also works as a standalone statement inside of a
9363 : : type declaration or a module. */
9364 : :
9365 : : match
9366 : 26473 : gfc_match_private (gfc_statement *st)
9367 : : {
9368 : 26473 : gfc_state_data *prev;
9369 : :
9370 : 26473 : if (gfc_match ("private") != MATCH_YES)
9371 : : return MATCH_NO;
9372 : :
9373 : : /* Try matching PRIVATE without an access-list. */
9374 : 1405 : if (gfc_match_eos () == MATCH_YES)
9375 : : {
9376 : 1118 : prev = gfc_state_stack->previous;
9377 : 1118 : if (gfc_current_state () != COMP_MODULE
9378 : 342 : && !(gfc_current_state () == COMP_DERIVED
9379 : 309 : && prev && prev->state == COMP_MODULE)
9380 : 34 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9381 : 32 : && prev->previous && prev->previous->state == COMP_MODULE))
9382 : : {
9383 : 2 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9384 : : "specification part of a module");
9385 : 2 : return MATCH_ERROR;
9386 : : }
9387 : :
9388 : 1116 : *st = ST_PRIVATE;
9389 : 1116 : return MATCH_YES;
9390 : : }
9391 : :
9392 : : /* At this point in free-form source code, PRIVATE must be followed
9393 : : by whitespace or ::. */
9394 : 287 : if (gfc_current_form == FORM_FREE)
9395 : : {
9396 : 285 : char c = gfc_peek_ascii_char ();
9397 : 285 : if (!gfc_is_whitespace (c) && c != ':')
9398 : : return MATCH_NO;
9399 : : }
9400 : :
9401 : 286 : prev = gfc_state_stack->previous;
9402 : 286 : if (gfc_current_state () != COMP_MODULE
9403 : 1 : && !(gfc_current_state () == COMP_DERIVED
9404 : 0 : && prev && prev->state == COMP_MODULE)
9405 : 1 : && !(gfc_current_state () == COMP_DERIVED_CONTAINS
9406 : 0 : && prev->previous && prev->previous->state == COMP_MODULE))
9407 : : {
9408 : 1 : gfc_error ("PRIVATE statement at %C is only allowed in the "
9409 : : "specification part of a module");
9410 : 1 : return MATCH_ERROR;
9411 : : }
9412 : :
9413 : 285 : *st = ST_ATTR_DECL;
9414 : 285 : return access_attr_decl (ST_PRIVATE);
9415 : : }
9416 : :
9417 : :
9418 : : match
9419 : 1597 : gfc_match_public (gfc_statement *st)
9420 : : {
9421 : 1597 : if (gfc_match ("public") != MATCH_YES)
9422 : : return MATCH_NO;
9423 : :
9424 : : /* Try matching PUBLIC without an access-list. */
9425 : 1284 : if (gfc_match_eos () == MATCH_YES)
9426 : : {
9427 : 32 : if (gfc_current_state () != COMP_MODULE)
9428 : : {
9429 : 2 : gfc_error ("PUBLIC statement at %C is only allowed in the "
9430 : : "specification part of a module");
9431 : 2 : return MATCH_ERROR;
9432 : : }
9433 : :
9434 : 30 : *st = ST_PUBLIC;
9435 : 30 : return MATCH_YES;
9436 : : }
9437 : :
9438 : : /* At this point in free-form source code, PUBLIC must be followed
9439 : : by whitespace or ::. */
9440 : 1252 : if (gfc_current_form == FORM_FREE)
9441 : : {
9442 : 1250 : char c = gfc_peek_ascii_char ();
9443 : 1250 : if (!gfc_is_whitespace (c) && c != ':')
9444 : : return MATCH_NO;
9445 : : }
9446 : :
9447 : 1251 : if (gfc_current_state () != COMP_MODULE)
9448 : : {
9449 : 1 : gfc_error ("PUBLIC statement at %C is only allowed in the "
9450 : : "specification part of a module");
9451 : 1 : return MATCH_ERROR;
9452 : : }
9453 : :
9454 : 1250 : *st = ST_ATTR_DECL;
9455 : 1250 : return access_attr_decl (ST_PUBLIC);
9456 : : }
9457 : :
9458 : :
9459 : : /* Workhorse for gfc_match_parameter. */
9460 : :
9461 : : static match
9462 : 5464 : do_parm (void)
9463 : : {
9464 : 5464 : gfc_symbol *sym;
9465 : 5464 : gfc_expr *init;
9466 : 5464 : match m;
9467 : 5464 : bool t;
9468 : :
9469 : 5464 : m = gfc_match_symbol (&sym, 0);
9470 : 5464 : if (m == MATCH_NO)
9471 : 0 : gfc_error ("Expected variable name at %C in PARAMETER statement");
9472 : :
9473 : 5464 : if (m != MATCH_YES)
9474 : : return m;
9475 : :
9476 : 5464 : if (gfc_match_char ('=') == MATCH_NO)
9477 : : {
9478 : 0 : gfc_error ("Expected = sign in PARAMETER statement at %C");
9479 : 0 : return MATCH_ERROR;
9480 : : }
9481 : :
9482 : 5464 : m = gfc_match_init_expr (&init);
9483 : 5464 : if (m == MATCH_NO)
9484 : 0 : gfc_error ("Expected expression at %C in PARAMETER statement");
9485 : 5464 : if (m != MATCH_YES)
9486 : : return m;
9487 : :
9488 : 5463 : if (sym->ts.type == BT_UNKNOWN
9489 : 5463 : && !gfc_set_default_type (sym, 1, NULL))
9490 : : {
9491 : 1 : m = MATCH_ERROR;
9492 : 1 : goto cleanup;
9493 : : }
9494 : :
9495 : 5462 : if (!gfc_check_assign_symbol (sym, NULL, init)
9496 : 5462 : || !gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL))
9497 : : {
9498 : 1 : m = MATCH_ERROR;
9499 : 1 : goto cleanup;
9500 : : }
9501 : :
9502 : 5461 : if (sym->value)
9503 : : {
9504 : 1 : gfc_error ("Initializing already initialized variable at %C");
9505 : 1 : m = MATCH_ERROR;
9506 : 1 : goto cleanup;
9507 : : }
9508 : :
9509 : 5460 : t = add_init_expr_to_sym (sym->name, &init, &gfc_current_locus);
9510 : 5460 : return (t) ? MATCH_YES : MATCH_ERROR;
9511 : :
9512 : 3 : cleanup:
9513 : 3 : gfc_free_expr (init);
9514 : 3 : return m;
9515 : : }
9516 : :
9517 : :
9518 : : /* Match a parameter statement, with the weird syntax that these have. */
9519 : :
9520 : : match
9521 : 4754 : gfc_match_parameter (void)
9522 : : {
9523 : 4754 : const char *term = " )%t";
9524 : 4754 : match m;
9525 : :
9526 : 4754 : if (gfc_match_char ('(') == MATCH_NO)
9527 : : {
9528 : : /* With legacy PARAMETER statements, don't expect a terminating ')'. */
9529 : 28 : if (!gfc_notify_std (GFC_STD_LEGACY, "PARAMETER without '()' at %C"))
9530 : : return MATCH_NO;
9531 : 4753 : term = " %t";
9532 : : }
9533 : :
9534 : 5464 : for (;;)
9535 : : {
9536 : 5464 : m = do_parm ();
9537 : 5464 : if (m != MATCH_YES)
9538 : : break;
9539 : :
9540 : 5460 : if (gfc_match (term) == MATCH_YES)
9541 : : break;
9542 : :
9543 : 711 : if (gfc_match_char (',') != MATCH_YES)
9544 : : {
9545 : 0 : gfc_error ("Unexpected characters in PARAMETER statement at %C");
9546 : 0 : m = MATCH_ERROR;
9547 : 0 : break;
9548 : : }
9549 : : }
9550 : :
9551 : : return m;
9552 : : }
9553 : :
9554 : :
9555 : : match
9556 : 13 : gfc_match_automatic (void)
9557 : : {
9558 : 13 : gfc_symbol *sym;
9559 : 13 : match m;
9560 : 13 : bool seen_symbol = false;
9561 : :
9562 : 13 : if (!flag_dec_static)
9563 : : {
9564 : 2 : gfc_error ("%s at %C is a DEC extension, enable with "
9565 : : "%<-fdec-static%>",
9566 : : "AUTOMATIC"
9567 : : );
9568 : 2 : return MATCH_ERROR;
9569 : : }
9570 : :
9571 : 11 : gfc_match (" ::");
9572 : :
9573 : 11 : for (;;)
9574 : : {
9575 : 11 : m = gfc_match_symbol (&sym, 0);
9576 : 11 : switch (m)
9577 : : {
9578 : : case MATCH_NO:
9579 : : break;
9580 : :
9581 : : case MATCH_ERROR:
9582 : : return MATCH_ERROR;
9583 : :
9584 : 9 : case MATCH_YES:
9585 : 9 : if (!gfc_add_automatic (&sym->attr, sym->name, &gfc_current_locus))
9586 : : return MATCH_ERROR;
9587 : : seen_symbol = true;
9588 : : break;
9589 : : }
9590 : :
9591 : 9 : if (gfc_match_eos () == MATCH_YES)
9592 : : break;
9593 : 0 : if (gfc_match_char (',') != MATCH_YES)
9594 : 0 : goto syntax;
9595 : : }
9596 : :
9597 : 9 : if (!seen_symbol)
9598 : : {
9599 : 2 : gfc_error ("Expected entity-list in AUTOMATIC statement at %C");
9600 : 2 : return MATCH_ERROR;
9601 : : }
9602 : :
9603 : : return MATCH_YES;
9604 : :
9605 : 0 : syntax:
9606 : 0 : gfc_error ("Syntax error in AUTOMATIC statement at %C");
9607 : 0 : return MATCH_ERROR;
9608 : : }
9609 : :
9610 : :
9611 : : match
9612 : 7 : gfc_match_static (void)
9613 : : {
9614 : 7 : gfc_symbol *sym;
9615 : 7 : match m;
9616 : 7 : bool seen_symbol = false;
9617 : :
9618 : 7 : if (!flag_dec_static)
9619 : : {
9620 : 2 : gfc_error ("%s at %C is a DEC extension, enable with "
9621 : : "%<-fdec-static%>",
9622 : : "STATIC");
9623 : 2 : return MATCH_ERROR;
9624 : : }
9625 : :
9626 : 5 : gfc_match (" ::");
9627 : :
9628 : 5 : for (;;)
9629 : : {
9630 : 5 : m = gfc_match_symbol (&sym, 0);
9631 : 5 : switch (m)
9632 : : {
9633 : : case MATCH_NO:
9634 : : break;
9635 : :
9636 : : case MATCH_ERROR:
9637 : : return MATCH_ERROR;
9638 : :
9639 : 3 : case MATCH_YES:
9640 : 3 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9641 : : &gfc_current_locus))
9642 : : return MATCH_ERROR;
9643 : : seen_symbol = true;
9644 : : break;
9645 : : }
9646 : :
9647 : 3 : if (gfc_match_eos () == MATCH_YES)
9648 : : break;
9649 : 0 : if (gfc_match_char (',') != MATCH_YES)
9650 : 0 : goto syntax;
9651 : : }
9652 : :
9653 : 3 : if (!seen_symbol)
9654 : : {
9655 : 2 : gfc_error ("Expected entity-list in STATIC statement at %C");
9656 : 2 : return MATCH_ERROR;
9657 : : }
9658 : :
9659 : : return MATCH_YES;
9660 : :
9661 : 0 : syntax:
9662 : 0 : gfc_error ("Syntax error in STATIC statement at %C");
9663 : 0 : return MATCH_ERROR;
9664 : : }
9665 : :
9666 : :
9667 : : /* Save statements have a special syntax. */
9668 : :
9669 : : match
9670 : 266 : gfc_match_save (void)
9671 : : {
9672 : 266 : char n[GFC_MAX_SYMBOL_LEN+1];
9673 : 266 : gfc_common_head *c;
9674 : 266 : gfc_symbol *sym;
9675 : 266 : match m;
9676 : :
9677 : 266 : if (gfc_match_eos () == MATCH_YES)
9678 : : {
9679 : 142 : if (gfc_current_ns->seen_save)
9680 : : {
9681 : 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
9682 : : "follows previous SAVE statement"))
9683 : : return MATCH_ERROR;
9684 : : }
9685 : :
9686 : 141 : gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
9687 : 141 : return MATCH_YES;
9688 : : }
9689 : :
9690 : 124 : if (gfc_current_ns->save_all)
9691 : : {
9692 : 7 : if (!gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
9693 : : "blanket SAVE statement"))
9694 : : return MATCH_ERROR;
9695 : : }
9696 : :
9697 : 123 : gfc_match (" ::");
9698 : :
9699 : 183 : for (;;)
9700 : : {
9701 : 183 : m = gfc_match_symbol (&sym, 0);
9702 : 183 : switch (m)
9703 : : {
9704 : 183 : case MATCH_YES:
9705 : 183 : if (!gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name,
9706 : : &gfc_current_locus))
9707 : : return MATCH_ERROR;
9708 : 181 : goto next_item;
9709 : :
9710 : : case MATCH_NO:
9711 : : break;
9712 : :
9713 : : case MATCH_ERROR:
9714 : : return MATCH_ERROR;
9715 : : }
9716 : :
9717 : 0 : m = gfc_match (" / %n /", &n);
9718 : 0 : if (m == MATCH_ERROR)
9719 : : return MATCH_ERROR;
9720 : 0 : if (m == MATCH_NO)
9721 : 0 : goto syntax;
9722 : :
9723 : 0 : c = gfc_get_common (n, 0);
9724 : 0 : c->saved = 1;
9725 : :
9726 : 0 : gfc_current_ns->seen_save = 1;
9727 : :
9728 : 181 : next_item:
9729 : 181 : if (gfc_match_eos () == MATCH_YES)
9730 : : break;
9731 : 60 : if (gfc_match_char (',') != MATCH_YES)
9732 : 0 : goto syntax;
9733 : : }
9734 : :
9735 : : return MATCH_YES;
9736 : :
9737 : 0 : syntax:
9738 : 0 : if (gfc_current_ns->seen_save)
9739 : : {
9740 : 0 : gfc_error ("Syntax error in SAVE statement at %C");
9741 : 0 : return MATCH_ERROR;
9742 : : }
9743 : : else
9744 : : return MATCH_NO;
9745 : : }
9746 : :
9747 : :
9748 : : match
9749 : 81 : gfc_match_value (void)
9750 : : {
9751 : 81 : gfc_symbol *sym;
9752 : 81 : match m;
9753 : :
9754 : : /* This is not allowed within a BLOCK construct! */
9755 : 81 : if (gfc_current_state () == COMP_BLOCK)
9756 : : {
9757 : 2 : gfc_error ("VALUE is not allowed inside of BLOCK at %C");
9758 : 2 : return MATCH_ERROR;
9759 : : }
9760 : :
9761 : 79 : if (!gfc_notify_std (GFC_STD_F2003, "VALUE statement at %C"))
9762 : : return MATCH_ERROR;
9763 : :
9764 : 78 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9765 : : {
9766 : : return MATCH_ERROR;
9767 : : }
9768 : :
9769 : 78 : if (gfc_match_eos () == MATCH_YES)
9770 : 0 : goto syntax;
9771 : :
9772 : 96 : for(;;)
9773 : : {
9774 : 96 : m = gfc_match_symbol (&sym, 0);
9775 : 96 : switch (m)
9776 : : {
9777 : 96 : case MATCH_YES:
9778 : 96 : if (!gfc_add_value (&sym->attr, sym->name, &gfc_current_locus))
9779 : : return MATCH_ERROR;
9780 : 89 : goto next_item;
9781 : :
9782 : : case MATCH_NO:
9783 : : break;
9784 : :
9785 : : case MATCH_ERROR:
9786 : : return MATCH_ERROR;
9787 : : }
9788 : :
9789 : 89 : next_item:
9790 : 89 : if (gfc_match_eos () == MATCH_YES)
9791 : : break;
9792 : 18 : if (gfc_match_char (',') != MATCH_YES)
9793 : 0 : goto syntax;
9794 : : }
9795 : :
9796 : : return MATCH_YES;
9797 : :
9798 : 0 : syntax:
9799 : 0 : gfc_error ("Syntax error in VALUE statement at %C");
9800 : 0 : return MATCH_ERROR;
9801 : : }
9802 : :
9803 : :
9804 : : match
9805 : 85 : gfc_match_volatile (void)
9806 : : {
9807 : 85 : gfc_symbol *sym;
9808 : 85 : char *name;
9809 : 85 : match m;
9810 : :
9811 : 85 : if (!gfc_notify_std (GFC_STD_F2003, "VOLATILE statement at %C"))
9812 : : return MATCH_ERROR;
9813 : :
9814 : 84 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9815 : : {
9816 : : return MATCH_ERROR;
9817 : : }
9818 : :
9819 : 84 : if (gfc_match_eos () == MATCH_YES)
9820 : 1 : goto syntax;
9821 : :
9822 : 108 : for(;;)
9823 : : {
9824 : : /* VOLATILE is special because it can be added to host-associated
9825 : : symbols locally. Except for coarrays. */
9826 : 108 : m = gfc_match_symbol (&sym, 1);
9827 : 108 : switch (m)
9828 : : {
9829 : 108 : case MATCH_YES:
9830 : 108 : name = XCNEWVAR (char, strlen (sym->name) + 1);
9831 : 108 : strcpy (name, sym->name);
9832 : 108 : if (!check_function_name (name))
9833 : : return MATCH_ERROR;
9834 : : /* F2008, C560+C561. VOLATILE for host-/use-associated variable or
9835 : : for variable in a BLOCK which is defined outside of the BLOCK. */
9836 : 107 : if (sym->ns != gfc_current_ns && sym->attr.codimension)
9837 : : {
9838 : 2 : gfc_error ("Specifying VOLATILE for coarray variable %qs at "
9839 : : "%C, which is use-/host-associated", sym->name);
9840 : 2 : return MATCH_ERROR;
9841 : : }
9842 : 105 : if (!gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus))
9843 : : return MATCH_ERROR;
9844 : 102 : goto next_item;
9845 : :
9846 : : case MATCH_NO:
9847 : : break;
9848 : :
9849 : : case MATCH_ERROR:
9850 : : return MATCH_ERROR;
9851 : : }
9852 : :
9853 : 102 : next_item:
9854 : 102 : if (gfc_match_eos () == MATCH_YES)
9855 : : break;
9856 : 25 : if (gfc_match_char (',') != MATCH_YES)
9857 : 0 : goto syntax;
9858 : : }
9859 : :
9860 : : return MATCH_YES;
9861 : :
9862 : 1 : syntax:
9863 : 1 : gfc_error ("Syntax error in VOLATILE statement at %C");
9864 : 1 : return MATCH_ERROR;
9865 : : }
9866 : :
9867 : :
9868 : : match
9869 : 11 : gfc_match_asynchronous (void)
9870 : : {
9871 : 11 : gfc_symbol *sym;
9872 : 11 : char *name;
9873 : 11 : match m;
9874 : :
9875 : 11 : if (!gfc_notify_std (GFC_STD_F2003, "ASYNCHRONOUS statement at %C"))
9876 : : return MATCH_ERROR;
9877 : :
9878 : 10 : if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
9879 : : {
9880 : : return MATCH_ERROR;
9881 : : }
9882 : :
9883 : 10 : if (gfc_match_eos () == MATCH_YES)
9884 : 0 : goto syntax;
9885 : :
9886 : 10 : for(;;)
9887 : : {
9888 : : /* ASYNCHRONOUS is special because it can be added to host-associated
9889 : : symbols locally. */
9890 : 10 : m = gfc_match_symbol (&sym, 1);
9891 : 10 : switch (m)
9892 : : {
9893 : 10 : case MATCH_YES:
9894 : 10 : name = XCNEWVAR (char, strlen (sym->name) + 1);
9895 : 10 : strcpy (name, sym->name);
9896 : 10 : if (!check_function_name (name))
9897 : : return MATCH_ERROR;
9898 : 9 : if (!gfc_add_asynchronous (&sym->attr, sym->name, &gfc_current_locus))
9899 : : return MATCH_ERROR;
9900 : 7 : goto next_item;
9901 : :
9902 : : case MATCH_NO:
9903 : : break;
9904 : :
9905 : : case MATCH_ERROR:
9906 : : return MATCH_ERROR;
9907 : : }
9908 : :
9909 : 7 : next_item:
9910 : 7 : if (gfc_match_eos () == MATCH_YES)
9911 : : break;
9912 : 0 : if (gfc_match_char (',') != MATCH_YES)
9913 : 0 : goto syntax;
9914 : : }
9915 : :
9916 : : return MATCH_YES;
9917 : :
9918 : 0 : syntax:
9919 : 0 : gfc_error ("Syntax error in ASYNCHRONOUS statement at %C");
9920 : 0 : return MATCH_ERROR;
9921 : : }
9922 : :
9923 : :
9924 : : /* Match a module procedure statement in a submodule. */
9925 : :
9926 : : match
9927 : 662618 : gfc_match_submod_proc (void)
9928 : : {
9929 : 662618 : char name[GFC_MAX_SYMBOL_LEN + 1];
9930 : 662618 : gfc_symbol *sym, *fsym;
9931 : 662618 : match m;
9932 : 662618 : gfc_formal_arglist *formal, *head, *tail;
9933 : :
9934 : 662618 : if (gfc_current_state () != COMP_CONTAINS
9935 : 13667 : || !(gfc_state_stack->previous
9936 : 13667 : && (gfc_state_stack->previous->state == COMP_SUBMODULE
9937 : 13667 : || gfc_state_stack->previous->state == COMP_MODULE)))
9938 : : return MATCH_NO;
9939 : :
9940 : 6839 : m = gfc_match (" module% procedure% %n", name);
9941 : 6839 : if (m != MATCH_YES)
9942 : : return m;
9943 : :
9944 : 179 : if (!gfc_notify_std (GFC_STD_F2008, "MODULE PROCEDURE declaration "
9945 : : "at %C"))
9946 : : return MATCH_ERROR;
9947 : :
9948 : 179 : if (get_proc_name (name, &sym, false))
9949 : : return MATCH_ERROR;
9950 : :
9951 : : /* Make sure that the result field is appropriately filled. */
9952 : 179 : if (sym->tlink && sym->tlink->attr.function)
9953 : : {
9954 : 53 : if (sym->tlink->result && sym->tlink->result != sym->tlink)
9955 : : {
9956 : 22 : sym->result = sym->tlink->result;
9957 : 22 : if (!sym->result->attr.use_assoc)
9958 : : {
9959 : 7 : gfc_symtree *st = gfc_new_symtree (&gfc_current_ns->sym_root,
9960 : : sym->result->name);
9961 : 7 : st->n.sym = sym->result;
9962 : 7 : sym->result->refs++;
9963 : : }
9964 : : }
9965 : : else
9966 : 31 : sym->result = sym;
9967 : : }
9968 : :
9969 : : /* Set declared_at as it might point to, e.g., a PUBLIC statement, if
9970 : : the symbol existed before. */
9971 : 179 : sym->declared_at = gfc_current_locus;
9972 : :
9973 : 179 : if (!sym->attr.module_procedure)
9974 : : return MATCH_ERROR;
9975 : :
9976 : : /* Signal match_end to expect "end procedure". */
9977 : 177 : sym->abr_modproc_decl = 1;
9978 : :
9979 : : /* Change from IFSRC_IFBODY coming from the interface declaration. */
9980 : 177 : sym->attr.if_source = IFSRC_DECL;
9981 : :
9982 : 177 : gfc_new_block = sym;
9983 : :
9984 : : /* Make a new formal arglist with the symbols in the procedure
9985 : : namespace. */
9986 : 177 : head = tail = NULL;
9987 : 386 : for (formal = sym->formal; formal && formal->sym; formal = formal->next)
9988 : : {
9989 : 209 : if (formal == sym->formal)
9990 : 152 : head = tail = gfc_get_formal_arglist ();
9991 : : else
9992 : : {
9993 : 57 : tail->next = gfc_get_formal_arglist ();
9994 : 57 : tail = tail->next;
9995 : : }
9996 : :
9997 : 209 : if (gfc_copy_dummy_sym (&fsym, formal->sym, 0))
9998 : 0 : goto cleanup;
9999 : :
10000 : 209 : tail->sym = fsym;
10001 : 209 : gfc_set_sym_referenced (fsym);
10002 : : }
10003 : :
10004 : : /* The dummy symbols get cleaned up, when the formal_namespace of the
10005 : : interface declaration is cleared. This allows us to add the
10006 : : explicit interface as is done for other type of procedure. */
10007 : 177 : if (!gfc_add_explicit_interface (sym, IFSRC_DECL, head,
10008 : : &gfc_current_locus))
10009 : : return MATCH_ERROR;
10010 : :
10011 : 177 : if (gfc_match_eos () != MATCH_YES)
10012 : : {
10013 : : /* Unset st->n.sym. Note: in reject_statement (), the symbol changes are
10014 : : undone, such that the st->n.sym->formal points to the original symbol;
10015 : : if now this namespace is finalized, the formal namespace is freed,
10016 : : but it might be still needed in the parent namespace. */
10017 : 1 : gfc_symtree *st = gfc_find_symtree (gfc_current_ns->sym_root, sym->name);
10018 : 1 : st->n.sym = NULL;
10019 : 1 : gfc_free_symbol (sym->tlink);
10020 : 1 : sym->tlink = NULL;
10021 : 1 : sym->refs--;
10022 : 1 : gfc_syntax_error (ST_MODULE_PROC);
10023 : 1 : return MATCH_ERROR;
10024 : : }
10025 : :
10026 : : return MATCH_YES;
10027 : :
10028 : 0 : cleanup:
10029 : 0 : gfc_free_formal_arglist (head);
10030 : 0 : return MATCH_ERROR;
10031 : : }
10032 : :
10033 : :
10034 : : /* Match a module procedure statement. Note that we have to modify
10035 : : symbols in the parent's namespace because the current one was there
10036 : : to receive symbols that are in an interface's formal argument list. */
10037 : :
10038 : : match
10039 : 1393 : gfc_match_modproc (void)
10040 : : {
10041 : 1393 : char name[GFC_MAX_SYMBOL_LEN + 1];
10042 : 1393 : gfc_symbol *sym;
10043 : 1393 : match m;
10044 : 1393 : locus old_locus;
10045 : 1393 : gfc_namespace *module_ns;
10046 : 1393 : gfc_interface *old_interface_head, *interface;
10047 : :
10048 : 1393 : if (gfc_state_stack->previous == NULL
10049 : 1392 : || (gfc_state_stack->state != COMP_INTERFACE
10050 : 4 : && (gfc_state_stack->state != COMP_CONTAINS
10051 : 4 : || gfc_state_stack->previous->state != COMP_INTERFACE))
10052 : 1388 : || current_interface.type == INTERFACE_NAMELESS
10053 : 1388 : || current_interface.type == INTERFACE_ABSTRACT)
10054 : : {
10055 : 6 : gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
10056 : : "interface");
10057 : 6 : return MATCH_ERROR;
10058 : : }
10059 : :
10060 : 1387 : module_ns = gfc_current_ns->parent;
10061 : 1393 : for (; module_ns; module_ns = module_ns->parent)
10062 : 1393 : if (module_ns->proc_name->attr.flavor == FL_MODULE
10063 : 29 : || module_ns->proc_name->attr.flavor == FL_PROGRAM
10064 : 12 : || (module_ns->proc_name->attr.flavor == FL_PROCEDURE
10065 : 12 : && !module_ns->proc_name->attr.contained))
10066 : : break;
10067 : :
10068 : 1387 : if (module_ns == NULL)
10069 : : return MATCH_ERROR;
10070 : :
10071 : : /* Store the current state of the interface. We will need it if we
10072 : : end up with a syntax error and need to recover. */
10073 : 1387 : old_interface_head = gfc_current_interface_head ();
10074 : :
10075 : : /* Check if the F2008 optional double colon appears. */
10076 : 1387 : gfc_gobble_whitespace ();
10077 : 1387 : old_locus = gfc_current_locus;
10078 : 1387 : if (gfc_match ("::") == MATCH_YES)
10079 : : {
10080 : 25 : if (!gfc_notify_std (GFC_STD_F2008, "double colon in "
10081 : : "MODULE PROCEDURE statement at %L", &old_locus))
10082 : : return MATCH_ERROR;
10083 : : }
10084 : : else
10085 : 1362 : gfc_current_locus = old_locus;
10086 : :
10087 : 1758 : for (;;)
10088 : : {
10089 : 1758 : bool last = false;
10090 : 1758 : old_locus = gfc_current_locus;
10091 : :
10092 : 1758 : m = gfc_match_name (name);
10093 : 1758 : if (m == MATCH_NO)
10094 : 1 : goto syntax;
10095 : 1757 : if (m != MATCH_YES)
10096 : : return MATCH_ERROR;
10097 : :
10098 : : /* Check for syntax error before starting to add symbols to the
10099 : : current namespace. */
10100 : 1757 : if (gfc_match_eos () == MATCH_YES)
10101 : : last = true;
10102 : :
10103 : 376 : if (!last && gfc_match_char (',') != MATCH_YES)
10104 : 2 : goto syntax;
10105 : :
10106 : : /* Now we're sure the syntax is valid, we process this item
10107 : : further. */
10108 : 1755 : if (gfc_get_symbol (name, module_ns, &sym))
10109 : : return MATCH_ERROR;
10110 : :
10111 : 1755 : if (sym->attr.intrinsic)
10112 : : {
10113 : 1 : gfc_error ("Intrinsic procedure at %L cannot be a MODULE "
10114 : : "PROCEDURE", &old_locus);
10115 : 1 : return MATCH_ERROR;
10116 : : }
10117 : :
10118 : 1754 : if (sym->attr.proc != PROC_MODULE
10119 : 1754 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
10120 : : return MATCH_ERROR;
10121 : :
10122 : 1751 : if (!gfc_add_interface (sym))
10123 : : return MATCH_ERROR;
10124 : :
10125 : 1748 : sym->attr.mod_proc = 1;
10126 : 1748 : sym->declared_at = old_locus;
10127 : :
10128 : 1748 : if (last)
10129 : : break;
10130 : : }
10131 : :
10132 : : return MATCH_YES;
10133 : :
10134 : 3 : syntax:
10135 : : /* Restore the previous state of the interface. */
10136 : 3 : interface = gfc_current_interface_head ();
10137 : 3 : gfc_set_current_interface_head (old_interface_head);
10138 : :
10139 : : /* Free the new interfaces. */
10140 : 10 : while (interface != old_interface_head)
10141 : : {
10142 : 4 : gfc_interface *i = interface->next;
10143 : 4 : free (interface);
10144 : 4 : interface = i;
10145 : : }
10146 : :
10147 : : /* And issue a syntax error. */
10148 : 3 : gfc_syntax_error (ST_MODULE_PROC);
10149 : 3 : return MATCH_ERROR;
10150 : : }
10151 : :
10152 : :
10153 : : /* Check a derived type that is being extended. */
10154 : :
10155 : : static gfc_symbol*
10156 : 1331 : check_extended_derived_type (char *name)
10157 : : {
10158 : 1331 : gfc_symbol *extended;
10159 : :
10160 : 1331 : if (gfc_find_symbol (name, gfc_current_ns, 1, &extended))
10161 : : {
10162 : 0 : gfc_error ("Ambiguous symbol in TYPE definition at %C");
10163 : 0 : return NULL;
10164 : : }
10165 : :
10166 : 1331 : extended = gfc_find_dt_in_generic (extended);
10167 : :
10168 : : /* F08:C428. */
10169 : 1331 : if (!extended)
10170 : : {
10171 : 2 : gfc_error ("Symbol %qs at %C has not been previously defined", name);
10172 : 2 : return NULL;
10173 : : }
10174 : :
10175 : 1329 : if (extended->attr.flavor != FL_DERIVED)
10176 : : {
10177 : 0 : gfc_error ("%qs in EXTENDS expression at %C is not a "
10178 : : "derived type", name);
10179 : 0 : return NULL;
10180 : : }
10181 : :
10182 : 1329 : if (extended->attr.is_bind_c)
10183 : : {
10184 : 1 : gfc_error ("%qs cannot be extended at %C because it "
10185 : : "is BIND(C)", extended->name);
10186 : 1 : return NULL;
10187 : : }
10188 : :
10189 : 1328 : if (extended->attr.sequence)
10190 : : {
10191 : 1 : gfc_error ("%qs cannot be extended at %C because it "
10192 : : "is a SEQUENCE type", extended->name);
10193 : 1 : return NULL;
10194 : : }
10195 : :
10196 : : return extended;
10197 : : }
10198 : :
10199 : :
10200 : : /* Match the optional attribute specifiers for a type declaration.
10201 : : Return MATCH_ERROR if an error is encountered in one of the handled
10202 : : attributes (public, private, bind(c)), MATCH_NO if what's found is
10203 : : not a handled attribute, and MATCH_YES otherwise. TODO: More error
10204 : : checking on attribute conflicts needs to be done. */
10205 : :
10206 : : static match
10207 : 17064 : gfc_get_type_attr_spec (symbol_attribute *attr, char *name)
10208 : : {
10209 : : /* See if the derived type is marked as private. */
10210 : 17064 : if (gfc_match (" , private") == MATCH_YES)
10211 : : {
10212 : 9 : if (gfc_current_state () != COMP_MODULE)
10213 : : {
10214 : 1 : gfc_error ("Derived type at %C can only be PRIVATE in the "
10215 : : "specification part of a module");
10216 : 1 : return MATCH_ERROR;
10217 : : }
10218 : :
10219 : 8 : if (!gfc_add_access (attr, ACCESS_PRIVATE, NULL, NULL))
10220 : : return MATCH_ERROR;
10221 : : }
10222 : 17055 : else if (gfc_match (" , public") == MATCH_YES)
10223 : : {
10224 : 492 : if (gfc_current_state () != COMP_MODULE)
10225 : : {
10226 : 0 : gfc_error ("Derived type at %C can only be PUBLIC in the "
10227 : : "specification part of a module");
10228 : 0 : return MATCH_ERROR;
10229 : : }
10230 : :
10231 : 492 : if (!gfc_add_access (attr, ACCESS_PUBLIC, NULL, NULL))
10232 : : return MATCH_ERROR;
10233 : : }
10234 : 16563 : else if (gfc_match (" , bind ( c )") == MATCH_YES)
10235 : : {
10236 : : /* If the type is defined to be bind(c) it then needs to make
10237 : : sure that all fields are interoperable. This will
10238 : : need to be a semantic check on the finished derived type.
10239 : : See 15.2.3 (lines 9-12) of F2003 draft. */
10240 : 400 : if (!gfc_add_is_bind_c (attr, NULL, &gfc_current_locus, 0))
10241 : : return MATCH_ERROR;
10242 : :
10243 : : /* TODO: attr conflicts need to be checked, probably in symbol.cc. */
10244 : : }
10245 : 16163 : else if (gfc_match (" , abstract") == MATCH_YES)
10246 : : {
10247 : 240 : if (!gfc_notify_std (GFC_STD_F2003, "ABSTRACT type at %C"))
10248 : : return MATCH_ERROR;
10249 : :
10250 : 239 : if (!gfc_add_abstract (attr, &gfc_current_locus))
10251 : : return MATCH_ERROR;
10252 : : }
10253 : 15923 : else if (name && gfc_match (" , extends ( %n )", name) == MATCH_YES)
10254 : : {
10255 : 1332 : if (!gfc_add_extension (attr, &gfc_current_locus))
10256 : : return MATCH_ERROR;
10257 : : }
10258 : : else
10259 : 14591 : return MATCH_NO;
10260 : :
10261 : : /* If we get here, something matched. */
10262 : : return MATCH_YES;
10263 : : }
10264 : :
10265 : :
10266 : : /* Common function for type declaration blocks similar to derived types, such
10267 : : as STRUCTURES and MAPs. Unlike derived types, a structure type
10268 : : does NOT have a generic symbol matching the name given by the user.
10269 : : STRUCTUREs can share names with variables and PARAMETERs so we must allow
10270 : : for the creation of an independent symbol.
10271 : : Other parameters are a message to prefix errors with, the name of the new
10272 : : type to be created, and the flavor to add to the resulting symbol. */
10273 : :
10274 : : static bool
10275 : 717 : get_struct_decl (const char *name, sym_flavor fl, locus *decl,
10276 : : gfc_symbol **result)
10277 : : {
10278 : 717 : gfc_symbol *sym;
10279 : 717 : locus where;
10280 : :
10281 : 717 : gcc_assert (name[0] == (char) TOUPPER (name[0]));
10282 : :
10283 : 717 : if (decl)
10284 : 717 : where = *decl;
10285 : : else
10286 : 0 : where = gfc_current_locus;
10287 : :
10288 : 717 : if (gfc_get_symbol (name, NULL, &sym))
10289 : : return false;
10290 : :
10291 : 717 : if (!sym)
10292 : : {
10293 : 0 : gfc_internal_error ("Failed to create structure type '%s' at %C", name);
10294 : : return false;
10295 : : }
10296 : :
10297 : 717 : if (sym->components != NULL || sym->attr.zero_comp)
10298 : : {
10299 : 3 : gfc_error ("Type definition of %qs at %C was already defined at %L",
10300 : : sym->name, &sym->declared_at);
10301 : 3 : return false;
10302 : : }
10303 : :
10304 : 714 : sym->declared_at = where;
10305 : :
10306 : 714 : if (sym->attr.flavor != fl
10307 : 714 : && !gfc_add_flavor (&sym->attr, fl, sym->name, NULL))
10308 : : return false;
10309 : :
10310 : 714 : if (!sym->hash_value)
10311 : : /* Set the hash for the compound name for this type. */
10312 : 713 : sym->hash_value = gfc_hash_value (sym);
10313 : :
10314 : : /* Normally the type is expected to have been completely parsed by the time
10315 : : a field declaration with this type is seen. For unions, maps, and nested
10316 : : structure declarations, we need to indicate that it is okay that we
10317 : : haven't seen any components yet. This will be updated after the structure
10318 : : is fully parsed. */
10319 : 714 : sym->attr.zero_comp = 0;
10320 : :
10321 : : /* Structures always act like derived-types with the SEQUENCE attribute */
10322 : 714 : gfc_add_sequence (&sym->attr, sym->name, NULL);
10323 : :
10324 : 714 : if (result) *result = sym;
10325 : :
10326 : : return true;
10327 : : }
10328 : :
10329 : :
10330 : : /* Match the opening of a MAP block. Like a struct within a union in C;
10331 : : behaves identical to STRUCTURE blocks. */
10332 : :
10333 : : match
10334 : 259 : gfc_match_map (void)
10335 : : {
10336 : : /* Counter used to give unique internal names to map structures. */
10337 : 259 : static unsigned int gfc_map_id = 0;
10338 : 259 : char name[GFC_MAX_SYMBOL_LEN + 1];
10339 : 259 : gfc_symbol *sym;
10340 : 259 : locus old_loc;
10341 : :
10342 : 259 : old_loc = gfc_current_locus;
10343 : :
10344 : 259 : if (gfc_match_eos () != MATCH_YES)
10345 : : {
10346 : 1 : gfc_error ("Junk after MAP statement at %C");
10347 : 1 : gfc_current_locus = old_loc;
10348 : 1 : return MATCH_ERROR;
10349 : : }
10350 : :
10351 : : /* Map blocks are anonymous so we make up unique names for the symbol table
10352 : : which are invalid Fortran identifiers. */
10353 : 258 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "MM$%u", gfc_map_id++);
10354 : :
10355 : 258 : if (!get_struct_decl (name, FL_STRUCT, &old_loc, &sym))
10356 : : return MATCH_ERROR;
10357 : :
10358 : 258 : gfc_new_block = sym;
10359 : :
10360 : 258 : return MATCH_YES;
10361 : : }
10362 : :
10363 : :
10364 : : /* Match the opening of a UNION block. */
10365 : :
10366 : : match
10367 : 133 : gfc_match_union (void)
10368 : : {
10369 : : /* Counter used to give unique internal names to union types. */
10370 : 133 : static unsigned int gfc_union_id = 0;
10371 : 133 : char name[GFC_MAX_SYMBOL_LEN + 1];
10372 : 133 : gfc_symbol *sym;
10373 : 133 : locus old_loc;
10374 : :
10375 : 133 : old_loc = gfc_current_locus;
10376 : :
10377 : 133 : if (gfc_match_eos () != MATCH_YES)
10378 : : {
10379 : 1 : gfc_error ("Junk after UNION statement at %C");
10380 : 1 : gfc_current_locus = old_loc;
10381 : 1 : return MATCH_ERROR;
10382 : : }
10383 : :
10384 : : /* Unions are anonymous so we make up unique names for the symbol table
10385 : : which are invalid Fortran identifiers. */
10386 : 132 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "UU$%u", gfc_union_id++);
10387 : :
10388 : 132 : if (!get_struct_decl (name, FL_UNION, &old_loc, &sym))
10389 : : return MATCH_ERROR;
10390 : :
10391 : 132 : gfc_new_block = sym;
10392 : :
10393 : 132 : return MATCH_YES;
10394 : : }
10395 : :
10396 : :
10397 : : /* Match the beginning of a STRUCTURE declaration. This is similar to
10398 : : matching the beginning of a derived type declaration with a few
10399 : : twists. The resulting type symbol has no access control or other
10400 : : interesting attributes. */
10401 : :
10402 : : match
10403 : 336 : gfc_match_structure_decl (void)
10404 : : {
10405 : : /* Counter used to give unique internal names to anonymous structures. */
10406 : 336 : static unsigned int gfc_structure_id = 0;
10407 : 336 : char name[GFC_MAX_SYMBOL_LEN + 1];
10408 : 336 : gfc_symbol *sym;
10409 : 336 : match m;
10410 : 336 : locus where;
10411 : :
10412 : 336 : if (!flag_dec_structure)
10413 : : {
10414 : 3 : gfc_error ("%s at %C is a DEC extension, enable with "
10415 : : "%<-fdec-structure%>",
10416 : : "STRUCTURE");
10417 : 3 : return MATCH_ERROR;
10418 : : }
10419 : :
10420 : 333 : name[0] = '\0';
10421 : :
10422 : 333 : m = gfc_match (" /%n/", name);
10423 : 333 : if (m != MATCH_YES)
10424 : : {
10425 : : /* Non-nested structure declarations require a structure name. */
10426 : 24 : if (!gfc_comp_struct (gfc_current_state ()))
10427 : : {
10428 : 4 : gfc_error ("Structure name expected in non-nested structure "
10429 : : "declaration at %C");
10430 : 4 : return MATCH_ERROR;
10431 : : }
10432 : : /* This is an anonymous structure; make up a unique name for it
10433 : : (upper-case letters never make it to symbol names from the source).
10434 : : The important thing is initializing the type variable
10435 : : and setting gfc_new_symbol, which is immediately used by
10436 : : parse_structure () and variable_decl () to add components of
10437 : : this type. */
10438 : 20 : snprintf (name, GFC_MAX_SYMBOL_LEN + 1, "SS$%u", gfc_structure_id++);
10439 : : }
10440 : :
10441 : 329 : where = gfc_current_locus;
10442 : : /* No field list allowed after non-nested structure declaration. */
10443 : 329 : if (!gfc_comp_struct (gfc_current_state ())
10444 : 296 : && gfc_match_eos () != MATCH_YES)
10445 : : {
10446 : 1 : gfc_error ("Junk after non-nested STRUCTURE statement at %C");
10447 : 1 : return MATCH_ERROR;
10448 : : }
10449 : :
10450 : : /* Make sure the name is not the name of an intrinsic type. */
10451 : 328 : if (gfc_is_intrinsic_typename (name))
10452 : : {
10453 : 1 : gfc_error ("Structure name %qs at %C cannot be the same as an"
10454 : : " intrinsic type", name);
10455 : 1 : return MATCH_ERROR;
10456 : : }
10457 : :
10458 : : /* Store the actual type symbol for the structure with an upper-case first
10459 : : letter (an invalid Fortran identifier). */
10460 : :
10461 : 327 : if (!get_struct_decl (gfc_dt_upper_string (name), FL_STRUCT, &where, &sym))
10462 : : return MATCH_ERROR;
10463 : :
10464 : 324 : gfc_new_block = sym;
10465 : 324 : return MATCH_YES;
10466 : : }
10467 : :
10468 : :
10469 : : /* This function does some work to determine which matcher should be used to
10470 : : * match a statement beginning with "TYPE". This is used to disambiguate TYPE
10471 : : * as an alias for PRINT from derived type declarations, TYPE IS statements,
10472 : : * and [parameterized] derived type declarations. */
10473 : :
10474 : : match
10475 : 467970 : gfc_match_type (gfc_statement *st)
10476 : : {
10477 : 467970 : char name[GFC_MAX_SYMBOL_LEN + 1];
10478 : 467970 : match m;
10479 : 467970 : locus old_loc;
10480 : :
10481 : : /* Requires -fdec. */
10482 : 467970 : if (!flag_dec)
10483 : : return MATCH_NO;
10484 : :
10485 : 2483 : m = gfc_match ("type");
10486 : 2483 : if (m != MATCH_YES)
10487 : : return m;
10488 : : /* If we already have an error in the buffer, it is probably from failing to
10489 : : * match a derived type data declaration. Let it happen. */
10490 : 20 : else if (gfc_error_flag_test ())
10491 : : return MATCH_NO;
10492 : :
10493 : 20 : old_loc = gfc_current_locus;
10494 : 20 : *st = ST_NONE;
10495 : :
10496 : : /* If we see an attribute list before anything else it's definitely a derived
10497 : : * type declaration. */
10498 : 20 : if (gfc_match (" ,") == MATCH_YES || gfc_match (" ::") == MATCH_YES)
10499 : 8 : goto derived;
10500 : :
10501 : : /* By now "TYPE" has already been matched. If we do not see a name, this may
10502 : : * be something like "TYPE *" or "TYPE <fmt>". */
10503 : 12 : m = gfc_match_name (name);
10504 : 12 : if (m != MATCH_YES)
10505 : : {
10506 : : /* Let print match if it can, otherwise throw an error from
10507 : : * gfc_match_derived_decl. */
10508 : 7 : gfc_current_locus = old_loc;
10509 : 7 : if (gfc_match_print () == MATCH_YES)
10510 : : {
10511 : 7 : *st = ST_WRITE;
10512 : 7 : return MATCH_YES;
10513 : : }
10514 : 0 : goto derived;
10515 : : }
10516 : :
10517 : : /* Check for EOS. */
10518 : 5 : if (gfc_match_eos () == MATCH_YES)
10519 : : {
10520 : : /* By now we have "TYPE <name> <EOS>". Check first if the name is an
10521 : : * intrinsic typename - if so let gfc_match_derived_decl dump an error.
10522 : : * Otherwise if gfc_match_derived_decl fails it's probably an existing
10523 : : * symbol which can be printed. */
10524 : 3 : gfc_current_locus = old_loc;
10525 : 3 : m = gfc_match_derived_decl ();
10526 : 3 : if (gfc_is_intrinsic_typename (name) || m == MATCH_YES)
10527 : : {
10528 : 2 : *st = ST_DERIVED_DECL;
10529 : 2 : return m;
10530 : : }
10531 : : }
10532 : : else
10533 : : {
10534 : : /* Here we have "TYPE <name>". Check for <TYPE IS (> or a PDT declaration
10535 : : like <type name(parameter)>. */
10536 : 2 : gfc_gobble_whitespace ();
10537 : 2 : bool paren = gfc_peek_ascii_char () == '(';
10538 : 2 : if (paren)
10539 : : {
10540 : 1 : if (strcmp ("is", name) == 0)
10541 : 1 : goto typeis;
10542 : : else
10543 : 0 : goto derived;
10544 : : }
10545 : : }
10546 : :
10547 : : /* Treat TYPE... like PRINT... */
10548 : 2 : gfc_current_locus = old_loc;
10549 : 2 : *st = ST_WRITE;
10550 : 2 : return gfc_match_print ();
10551 : :
10552 : 8 : derived:
10553 : 8 : gfc_current_locus = old_loc;
10554 : 8 : *st = ST_DERIVED_DECL;
10555 : 8 : return gfc_match_derived_decl ();
10556 : :
10557 : 1 : typeis:
10558 : 1 : gfc_current_locus = old_loc;
10559 : 1 : *st = ST_TYPE_IS;
10560 : 1 : return gfc_match_type_is ();
10561 : : }
10562 : :
10563 : :
10564 : : /* Match the beginning of a derived type declaration. If a type name
10565 : : was the result of a function, then it is possible to have a symbol
10566 : : already to be known as a derived type yet have no components. */
10567 : :
10568 : : match
10569 : 14598 : gfc_match_derived_decl (void)
10570 : : {
10571 : 14598 : char name[GFC_MAX_SYMBOL_LEN + 1];
10572 : 14598 : char parent[GFC_MAX_SYMBOL_LEN + 1];
10573 : 14598 : symbol_attribute attr;
10574 : 14598 : gfc_symbol *sym, *gensym;
10575 : 14598 : gfc_symbol *extended;
10576 : 14598 : match m;
10577 : 14598 : match is_type_attr_spec = MATCH_NO;
10578 : 14598 : bool seen_attr = false;
10579 : 14598 : gfc_interface *intr = NULL, *head;
10580 : 14598 : bool parameterized_type = false;
10581 : 14598 : bool seen_colons = false;
10582 : :
10583 : 14598 : if (gfc_comp_struct (gfc_current_state ()))
10584 : : return MATCH_NO;
10585 : :
10586 : 14594 : name[0] = '\0';
10587 : 14594 : parent[0] = '\0';
10588 : 14594 : gfc_clear_attr (&attr);
10589 : 14594 : extended = NULL;
10590 : :
10591 : 17064 : do
10592 : : {
10593 : 17064 : is_type_attr_spec = gfc_get_type_attr_spec (&attr, parent);
10594 : 17064 : if (is_type_attr_spec == MATCH_ERROR)
10595 : : return MATCH_ERROR;
10596 : 17061 : if (is_type_attr_spec == MATCH_YES)
10597 : 2470 : seen_attr = true;
10598 : 17061 : } while (is_type_attr_spec == MATCH_YES);
10599 : :
10600 : : /* Deal with derived type extensions. The extension attribute has
10601 : : been added to 'attr' but now the parent type must be found and
10602 : : checked. */
10603 : 14591 : if (parent[0])
10604 : 1331 : extended = check_extended_derived_type (parent);
10605 : :
10606 : 14591 : if (parent[0] && !extended)
10607 : : return MATCH_ERROR;
10608 : :
10609 : 14587 : m = gfc_match (" ::");
10610 : 14587 : if (m == MATCH_YES)
10611 : : {
10612 : : seen_colons = true;
10613 : : }
10614 : 9214 : else if (seen_attr)
10615 : : {
10616 : 5 : gfc_error ("Expected :: in TYPE definition at %C");
10617 : 5 : return MATCH_ERROR;
10618 : : }
10619 : :
10620 : : /* In free source form, need to check for TYPE XXX as oppose to TYPEXXX.
10621 : : But, we need to simply return for TYPE(. */
10622 : 9209 : if (m == MATCH_NO && gfc_current_form == FORM_FREE)
10623 : : {
10624 : 9164 : char c = gfc_peek_ascii_char ();
10625 : 9164 : if (c == '(')
10626 : : return m;
10627 : 9103 : if (!gfc_is_whitespace (c))
10628 : : {
10629 : 4 : gfc_error ("Mangled derived type definition at %C");
10630 : 4 : return MATCH_NO;
10631 : : }
10632 : : }
10633 : :
10634 : 14517 : m = gfc_match (" %n ", name);
10635 : 14517 : if (m != MATCH_YES)
10636 : : return m;
10637 : :
10638 : : /* Make sure that we don't identify TYPE IS (...) as a parameterized
10639 : : derived type named 'is'.
10640 : : TODO Expand the check, when 'name' = "is" by matching " (tname) "
10641 : : and checking if this is a(n intrinsic) typename. This picks up
10642 : : misplaced TYPE IS statements such as in select_type_1.f03. */
10643 : 14507 : if (gfc_peek_ascii_char () == '(')
10644 : : {
10645 : 3289 : if (gfc_current_state () == COMP_SELECT_TYPE
10646 : 207 : || (!seen_colons && !strcmp (name, "is")))
10647 : : return MATCH_NO;
10648 : : parameterized_type = true;
10649 : : }
10650 : :
10651 : 11424 : m = gfc_match_eos ();
10652 : 11424 : if (m != MATCH_YES && !parameterized_type)
10653 : : return m;
10654 : :
10655 : : /* Make sure the name is not the name of an intrinsic type. */
10656 : 11421 : if (gfc_is_intrinsic_typename (name))
10657 : : {
10658 : 18 : gfc_error ("Type name %qs at %C cannot be the same as an intrinsic "
10659 : : "type", name);
10660 : 18 : return MATCH_ERROR;
10661 : : }
10662 : :
10663 : 11403 : if (gfc_get_symbol (name, NULL, &gensym))
10664 : : return MATCH_ERROR;
10665 : :
10666 : 11403 : if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
10667 : : {
10668 : 5 : if (gensym->ts.u.derived)
10669 : 0 : gfc_error ("Derived type name %qs at %C already has a basic type "
10670 : : "of %s", gensym->name, gfc_typename (&gensym->ts));
10671 : : else
10672 : 5 : gfc_error ("Derived type name %qs at %C already has a basic type",
10673 : : gensym->name);
10674 : 5 : return MATCH_ERROR;
10675 : : }
10676 : :
10677 : 11398 : if (!gensym->attr.generic
10678 : 11398 : && !gfc_add_generic (&gensym->attr, gensym->name, NULL))
10679 : : return MATCH_ERROR;
10680 : :
10681 : 11394 : if (!gensym->attr.function
10682 : 11394 : && !gfc_add_function (&gensym->attr, gensym->name, NULL))
10683 : : return MATCH_ERROR;
10684 : :
10685 : 11393 : if (gensym->attr.dummy)
10686 : : {
10687 : 1 : gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C",
10688 : : name, &gensym->declared_at);
10689 : 1 : return MATCH_ERROR;
10690 : : }
10691 : :
10692 : 11392 : sym = gfc_find_dt_in_generic (gensym);
10693 : :
10694 : 11392 : if (sym && (sym->components != NULL || sym->attr.zero_comp))
10695 : : {
10696 : 1 : gfc_error ("Derived type definition of %qs at %C has already been "
10697 : : "defined", sym->name);
10698 : 1 : return MATCH_ERROR;
10699 : : }
10700 : :
10701 : 11391 : if (!sym)
10702 : : {
10703 : : /* Use upper case to save the actual derived-type symbol. */
10704 : 11312 : gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym);
10705 : 11312 : sym->name = gfc_get_string ("%s", gensym->name);
10706 : 11312 : head = gensym->generic;
10707 : 11312 : intr = gfc_get_interface ();
10708 : 11312 : intr->sym = sym;
10709 : 11312 : intr->where = gfc_current_locus;
10710 : 11312 : intr->sym->declared_at = gfc_current_locus;
10711 : 11312 : intr->next = head;
10712 : 11312 : gensym->generic = intr;
10713 : 11312 : gensym->attr.if_source = IFSRC_DECL;
10714 : : }
10715 : :
10716 : : /* The symbol may already have the derived attribute without the
10717 : : components. The ways this can happen is via a function
10718 : : definition, an INTRINSIC statement or a subtype in another
10719 : : derived type that is a pointer. The first part of the AND clause
10720 : : is true if the symbol is not the return value of a function. */
10721 : 11391 : if (sym->attr.flavor != FL_DERIVED
10722 : 11391 : && !gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL))
10723 : : return MATCH_ERROR;
10724 : :
10725 : 11391 : if (attr.access != ACCESS_UNKNOWN
10726 : 11391 : && !gfc_add_access (&sym->attr, attr.access, sym->name, NULL))
10727 : : return MATCH_ERROR;
10728 : 11391 : else if (sym->attr.access == ACCESS_UNKNOWN
10729 : 10895 : && gensym->attr.access != ACCESS_UNKNOWN
10730 : 11672 : && !gfc_add_access (&sym->attr, gensym->attr.access,
10731 : : sym->name, NULL))
10732 : : return MATCH_ERROR;
10733 : :
10734 : 11391 : if (sym->attr.access != ACCESS_UNKNOWN
10735 : 777 : && gensym->attr.access == ACCESS_UNKNOWN)
10736 : 496 : gensym->attr.access = sym->attr.access;
10737 : :
10738 : : /* See if the derived type was labeled as bind(c). */
10739 : 11391 : if (attr.is_bind_c != 0)
10740 : 397 : sym->attr.is_bind_c = attr.is_bind_c;
10741 : :
10742 : : /* Construct the f2k_derived namespace if it is not yet there. */
10743 : 11391 : if (!sym->f2k_derived)
10744 : 11391 : sym->f2k_derived = gfc_get_namespace (NULL, 0);
10745 : :
10746 : 11391 : if (parameterized_type)
10747 : : {
10748 : : /* Ignore error or mismatches by going to the end of the statement
10749 : : in order to avoid the component declarations causing problems. */
10750 : 206 : m = gfc_match_formal_arglist (sym, 0, 0, true);
10751 : 206 : if (m != MATCH_YES)
10752 : 4 : gfc_error_recovery ();
10753 : : else
10754 : 202 : sym->attr.pdt_template = 1;
10755 : 206 : m = gfc_match_eos ();
10756 : 206 : if (m != MATCH_YES)
10757 : : {
10758 : 1 : gfc_error_recovery ();
10759 : 1 : gfc_error_now ("Garbage after PARAMETERIZED TYPE declaration at %C");
10760 : : }
10761 : : }
10762 : :
10763 : 11391 : if (extended && !sym->components)
10764 : : {
10765 : 1327 : gfc_component *p;
10766 : 1327 : gfc_formal_arglist *f, *g, *h;
10767 : :
10768 : : /* Add the extended derived type as the first component. */
10769 : 1327 : gfc_add_component (sym, parent, &p);
10770 : 1327 : extended->refs++;
10771 : 1327 : gfc_set_sym_referenced (extended);
10772 : :
10773 : 1327 : p->ts.type = BT_DERIVED;
10774 : 1327 : p->ts.u.derived = extended;
10775 : 1327 : p->initializer = gfc_default_initializer (&p->ts);
10776 : :
10777 : : /* Set extension level. */
10778 : 1327 : if (extended->attr.extension == 255)
10779 : : {
10780 : : /* Since the extension field is 8 bit wide, we can only have
10781 : : up to 255 extension levels. */
10782 : 0 : gfc_error ("Maximum extension level reached with type %qs at %L",
10783 : : extended->name, &extended->declared_at);
10784 : 0 : return MATCH_ERROR;
10785 : : }
10786 : 1327 : sym->attr.extension = extended->attr.extension + 1;
10787 : :
10788 : : /* Provide the links between the extended type and its extension. */
10789 : 1327 : if (!extended->f2k_derived)
10790 : 1 : extended->f2k_derived = gfc_get_namespace (NULL, 0);
10791 : :
10792 : : /* Copy the extended type-param-name-list from the extended type,
10793 : : append those of the extension and add the whole lot to the
10794 : : extension. */
10795 : 1327 : if (extended->attr.pdt_template)
10796 : : {
10797 : 22 : g = h = NULL;
10798 : 22 : sym->attr.pdt_template = 1;
10799 : 75 : for (f = extended->formal; f; f = f->next)
10800 : : {
10801 : 53 : if (f == extended->formal)
10802 : : {
10803 : 22 : g = gfc_get_formal_arglist ();
10804 : 22 : h = g;
10805 : : }
10806 : : else
10807 : : {
10808 : 31 : g->next = gfc_get_formal_arglist ();
10809 : 31 : g = g->next;
10810 : : }
10811 : 53 : g->sym = f->sym;
10812 : : }
10813 : 22 : g->next = sym->formal;
10814 : 22 : sym->formal = h;
10815 : : }
10816 : : }
10817 : :
10818 : 11391 : if (!sym->hash_value)
10819 : : /* Set the hash for the compound name for this type. */
10820 : 11391 : sym->hash_value = gfc_hash_value (sym);
10821 : :
10822 : : /* Take over the ABSTRACT attribute. */
10823 : 11391 : sym->attr.abstract = attr.abstract;
10824 : :
10825 : 11391 : gfc_new_block = sym;
10826 : :
10827 : 11391 : return MATCH_YES;
10828 : : }
10829 : :
10830 : :
10831 : : /* Cray Pointees can be declared as:
10832 : : pointer (ipt, a (n,m,...,*)) */
10833 : :
10834 : : match
10835 : 240 : gfc_mod_pointee_as (gfc_array_spec *as)
10836 : : {
10837 : 240 : as->cray_pointee = true; /* This will be useful to know later. */
10838 : 240 : if (as->type == AS_ASSUMED_SIZE)
10839 : 72 : as->cp_was_assumed = true;
10840 : 168 : else if (as->type == AS_ASSUMED_SHAPE)
10841 : : {
10842 : 0 : gfc_error ("Cray Pointee at %C cannot be assumed shape array");
10843 : 0 : return MATCH_ERROR;
10844 : : }
10845 : : return MATCH_YES;
10846 : : }
10847 : :
10848 : :
10849 : : /* Match the enum definition statement, here we are trying to match
10850 : : the first line of enum definition statement.
10851 : : Returns MATCH_YES if match is found. */
10852 : :
10853 : : match
10854 : 158 : gfc_match_enum (void)
10855 : : {
10856 : 158 : match m;
10857 : :
10858 : 158 : m = gfc_match_eos ();
10859 : 158 : if (m != MATCH_YES)
10860 : : return m;
10861 : :
10862 : 158 : if (!gfc_notify_std (GFC_STD_F2003, "ENUM and ENUMERATOR at %C"))
10863 : 0 : return MATCH_ERROR;
10864 : :
10865 : : return MATCH_YES;
10866 : : }
10867 : :
10868 : :
10869 : : /* Returns an initializer whose value is one higher than the value of the
10870 : : LAST_INITIALIZER argument. If the argument is NULL, the
10871 : : initializers value will be set to zero. The initializer's kind
10872 : : will be set to gfc_c_int_kind.
10873 : :
10874 : : If -fshort-enums is given, the appropriate kind will be selected
10875 : : later after all enumerators have been parsed. A warning is issued
10876 : : here if an initializer exceeds gfc_c_int_kind. */
10877 : :
10878 : : static gfc_expr *
10879 : 377 : enum_initializer (gfc_expr *last_initializer, locus where)
10880 : : {
10881 : 377 : gfc_expr *result;
10882 : 377 : result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
10883 : :
10884 : 377 : mpz_init (result->value.integer);
10885 : :
10886 : 377 : if (last_initializer != NULL)
10887 : : {
10888 : 266 : mpz_add_ui (result->value.integer, last_initializer->value.integer, 1);
10889 : 266 : result->where = last_initializer->where;
10890 : :
10891 : 266 : if (gfc_check_integer_range (result->value.integer,
10892 : : gfc_c_int_kind) != ARITH_OK)
10893 : : {
10894 : 0 : gfc_error ("Enumerator exceeds the C integer type at %C");
10895 : 0 : return NULL;
10896 : : }
10897 : : }
10898 : : else
10899 : : {
10900 : : /* Control comes here, if it's the very first enumerator and no
10901 : : initializer has been given. It will be initialized to zero. */
10902 : 111 : mpz_set_si (result->value.integer, 0);
10903 : : }
10904 : :
10905 : : return result;
10906 : : }
10907 : :
10908 : :
10909 : : /* Match a variable name with an optional initializer. When this
10910 : : subroutine is called, a variable is expected to be parsed next.
10911 : : Depending on what is happening at the moment, updates either the
10912 : : symbol table or the current interface. */
10913 : :
10914 : : static match
10915 : 549 : enumerator_decl (void)
10916 : : {
10917 : 549 : char name[GFC_MAX_SYMBOL_LEN + 1];
10918 : 549 : gfc_expr *initializer;
10919 : 549 : gfc_array_spec *as = NULL;
10920 : 549 : gfc_symbol *sym;
10921 : 549 : locus var_locus;
10922 : 549 : match m;
10923 : 549 : bool t;
10924 : 549 : locus old_locus;
10925 : :
10926 : 549 : initializer = NULL;
10927 : 549 : old_locus = gfc_current_locus;
10928 : :
10929 : : /* When we get here, we've just matched a list of attributes and
10930 : : maybe a type and a double colon. The next thing we expect to see
10931 : : is the name of the symbol. */
10932 : 549 : m = gfc_match_name (name);
10933 : 549 : if (m != MATCH_YES)
10934 : 1 : goto cleanup;
10935 : :
10936 : 548 : var_locus = gfc_current_locus;
10937 : :
10938 : : /* OK, we've successfully matched the declaration. Now put the
10939 : : symbol in the current namespace. If we fail to create the symbol,
10940 : : bail out. */
10941 : 548 : if (!build_sym (name, NULL, false, &as, &var_locus))
10942 : : {
10943 : 1 : m = MATCH_ERROR;
10944 : 1 : goto cleanup;
10945 : : }
10946 : :
10947 : : /* The double colon must be present in order to have initializers.
10948 : : Otherwise the statement is ambiguous with an assignment statement. */
10949 : 547 : if (colon_seen)
10950 : : {
10951 : 471 : if (gfc_match_char ('=') == MATCH_YES)
10952 : : {
10953 : 170 : m = gfc_match_init_expr (&initializer);
10954 : 170 : if (m == MATCH_NO)
10955 : : {
10956 : 0 : gfc_error ("Expected an initialization expression at %C");
10957 : 0 : m = MATCH_ERROR;
10958 : : }
10959 : :
10960 : 170 : if (m != MATCH_YES)
10961 : 2 : goto cleanup;
10962 : : }
10963 : : }
10964 : :
10965 : : /* If we do not have an initializer, the initialization value of the
10966 : : previous enumerator (stored in last_initializer) is incremented
10967 : : by 1 and is used to initialize the current enumerator. */
10968 : 545 : if (initializer == NULL)
10969 : 377 : initializer = enum_initializer (last_initializer, old_locus);
10970 : :
10971 : 545 : if (initializer == NULL || initializer->ts.type != BT_INTEGER)
10972 : : {
10973 : 2 : gfc_error ("ENUMERATOR %L not initialized with integer expression",
10974 : : &var_locus);
10975 : 2 : m = MATCH_ERROR;
10976 : 2 : goto cleanup;
10977 : : }
10978 : :
10979 : : /* Store this current initializer, for the next enumerator variable
10980 : : to be parsed. add_init_expr_to_sym() zeros initializer, so we
10981 : : use last_initializer below. */
10982 : 543 : last_initializer = initializer;
10983 : 543 : t = add_init_expr_to_sym (name, &initializer, &var_locus);
10984 : :
10985 : : /* Maintain enumerator history. */
10986 : 543 : gfc_find_symbol (name, NULL, 0, &sym);
10987 : 543 : create_enum_history (sym, last_initializer);
10988 : :
10989 : 543 : return (t) ? MATCH_YES : MATCH_ERROR;
10990 : :
10991 : 6 : cleanup:
10992 : : /* Free stuff up and return. */
10993 : 6 : gfc_free_expr (initializer);
10994 : :
10995 : 6 : return m;
10996 : : }
10997 : :
10998 : :
10999 : : /* Match the enumerator definition statement. */
11000 : :
11001 : : match
11002 : 699550 : gfc_match_enumerator_def (void)
11003 : : {
11004 : 699550 : match m;
11005 : 699550 : bool t;
11006 : :
11007 : 699550 : gfc_clear_ts (¤t_ts);
11008 : :
11009 : 699550 : m = gfc_match (" enumerator");
11010 : 699550 : if (m != MATCH_YES)
11011 : : return m;
11012 : :
11013 : 269 : m = gfc_match (" :: ");
11014 : 269 : if (m == MATCH_ERROR)
11015 : : return m;
11016 : :
11017 : 269 : colon_seen = (m == MATCH_YES);
11018 : :
11019 : 269 : if (gfc_current_state () != COMP_ENUM)
11020 : : {
11021 : 4 : gfc_error ("ENUM definition statement expected before %C");
11022 : 4 : gfc_free_enum_history ();
11023 : 4 : return MATCH_ERROR;
11024 : : }
11025 : :
11026 : 265 : (¤t_ts)->type = BT_INTEGER;
11027 : 265 : (¤t_ts)->kind = gfc_c_int_kind;
11028 : :
11029 : 265 : gfc_clear_attr (¤t_attr);
11030 : 265 : t = gfc_add_flavor (¤t_attr, FL_PARAMETER, NULL, NULL);
11031 : 265 : if (!t)
11032 : : {
11033 : 0 : m = MATCH_ERROR;
11034 : 0 : goto cleanup;
11035 : : }
11036 : :
11037 : 549 : for (;;)
11038 : : {
11039 : 549 : m = enumerator_decl ();
11040 : 549 : if (m == MATCH_ERROR)
11041 : : {
11042 : 6 : gfc_free_enum_history ();
11043 : 6 : goto cleanup;
11044 : : }
11045 : 543 : if (m == MATCH_NO)
11046 : : break;
11047 : :
11048 : 542 : if (gfc_match_eos () == MATCH_YES)
11049 : 256 : goto cleanup;
11050 : 286 : if (gfc_match_char (',') != MATCH_YES)
11051 : : break;
11052 : : }
11053 : :
11054 : 3 : if (gfc_current_state () == COMP_ENUM)
11055 : : {
11056 : 3 : gfc_free_enum_history ();
11057 : 3 : gfc_error ("Syntax error in ENUMERATOR definition at %C");
11058 : 3 : m = MATCH_ERROR;
11059 : : }
11060 : :
11061 : 0 : cleanup:
11062 : 265 : gfc_free_array_spec (current_as);
11063 : 265 : current_as = NULL;
11064 : 265 : return m;
11065 : :
11066 : : }
11067 : :
11068 : :
11069 : : /* Match binding attributes. */
11070 : :
11071 : : static match
11072 : 4123 : match_binding_attributes (gfc_typebound_proc* ba, bool generic, bool ppc)
11073 : : {
11074 : 4123 : bool found_passing = false;
11075 : 4123 : bool seen_ptr = false;
11076 : 4123 : match m = MATCH_YES;
11077 : :
11078 : : /* Initialize to defaults. Do so even before the MATCH_NO check so that in
11079 : : this case the defaults are in there. */
11080 : 4123 : ba->access = ACCESS_UNKNOWN;
11081 : 4123 : ba->pass_arg = NULL;
11082 : 4123 : ba->pass_arg_num = 0;
11083 : 4123 : ba->nopass = 0;
11084 : 4123 : ba->non_overridable = 0;
11085 : 4123 : ba->deferred = 0;
11086 : 4123 : ba->ppc = ppc;
11087 : :
11088 : : /* If we find a comma, we believe there are binding attributes. */
11089 : 4123 : m = gfc_match_char (',');
11090 : 4123 : if (m == MATCH_NO)
11091 : 2101 : goto done;
11092 : :
11093 : 2473 : do
11094 : : {
11095 : : /* Access specifier. */
11096 : :
11097 : 2473 : m = gfc_match (" public");
11098 : 2473 : if (m == MATCH_ERROR)
11099 : 0 : goto error;
11100 : 2473 : if (m == MATCH_YES)
11101 : : {
11102 : 219 : if (ba->access != ACCESS_UNKNOWN)
11103 : : {
11104 : 0 : gfc_error ("Duplicate access-specifier at %C");
11105 : 0 : goto error;
11106 : : }
11107 : :
11108 : 219 : ba->access = ACCESS_PUBLIC;
11109 : 219 : continue;
11110 : : }
11111 : :
11112 : 2254 : m = gfc_match (" private");
11113 : 2254 : if (m == MATCH_ERROR)
11114 : 0 : goto error;
11115 : 2254 : if (m == MATCH_YES)
11116 : : {
11117 : 126 : if (ba->access != ACCESS_UNKNOWN)
11118 : : {
11119 : 1 : gfc_error ("Duplicate access-specifier at %C");
11120 : 1 : goto error;
11121 : : }
11122 : :
11123 : 125 : ba->access = ACCESS_PRIVATE;
11124 : 125 : continue;
11125 : : }
11126 : :
11127 : : /* If inside GENERIC, the following is not allowed. */
11128 : 2128 : if (!generic)
11129 : : {
11130 : :
11131 : : /* NOPASS flag. */
11132 : 2127 : m = gfc_match (" nopass");
11133 : 2127 : if (m == MATCH_ERROR)
11134 : 0 : goto error;
11135 : 2127 : if (m == MATCH_YES)
11136 : : {
11137 : 671 : if (found_passing)
11138 : : {
11139 : 1 : gfc_error ("Binding attributes already specify passing,"
11140 : : " illegal NOPASS at %C");
11141 : 1 : goto error;
11142 : : }
11143 : :
11144 : 670 : found_passing = true;
11145 : 670 : ba->nopass = 1;
11146 : 670 : continue;
11147 : : }
11148 : :
11149 : : /* PASS possibly including argument. */
11150 : 1456 : m = gfc_match (" pass");
11151 : 1456 : if (m == MATCH_ERROR)
11152 : 0 : goto error;
11153 : 1456 : if (m == MATCH_YES)
11154 : : {
11155 : 812 : char arg[GFC_MAX_SYMBOL_LEN + 1];
11156 : :
11157 : 812 : if (found_passing)
11158 : : {
11159 : 2 : gfc_error ("Binding attributes already specify passing,"
11160 : : " illegal PASS at %C");
11161 : 2 : goto error;
11162 : : }
11163 : :
11164 : 810 : m = gfc_match (" ( %n )", arg);
11165 : 810 : if (m == MATCH_ERROR)
11166 : 0 : goto error;
11167 : 810 : if (m == MATCH_YES)
11168 : 462 : ba->pass_arg = gfc_get_string ("%s", arg);
11169 : 810 : gcc_assert ((m == MATCH_YES) == (ba->pass_arg != NULL));
11170 : :
11171 : 810 : found_passing = true;
11172 : 810 : ba->nopass = 0;
11173 : 810 : continue;
11174 : 810 : }
11175 : :
11176 : 644 : if (ppc)
11177 : : {
11178 : : /* POINTER flag. */
11179 : 394 : m = gfc_match (" pointer");
11180 : 394 : if (m == MATCH_ERROR)
11181 : 0 : goto error;
11182 : 394 : if (m == MATCH_YES)
11183 : : {
11184 : 394 : if (seen_ptr)
11185 : : {
11186 : 1 : gfc_error ("Duplicate POINTER attribute at %C");
11187 : 1 : goto error;
11188 : : }
11189 : :
11190 : 393 : seen_ptr = true;
11191 : 393 : continue;
11192 : : }
11193 : : }
11194 : : else
11195 : : {
11196 : : /* NON_OVERRIDABLE flag. */
11197 : 250 : m = gfc_match (" non_overridable");
11198 : 250 : if (m == MATCH_ERROR)
11199 : 0 : goto error;
11200 : 250 : if (m == MATCH_YES)
11201 : : {
11202 : 29 : if (ba->non_overridable)
11203 : : {
11204 : 1 : gfc_error ("Duplicate NON_OVERRIDABLE at %C");
11205 : 1 : goto error;
11206 : : }
11207 : :
11208 : 28 : ba->non_overridable = 1;
11209 : 28 : continue;
11210 : : }
11211 : :
11212 : : /* DEFERRED flag. */
11213 : 221 : m = gfc_match (" deferred");
11214 : 221 : if (m == MATCH_ERROR)
11215 : 0 : goto error;
11216 : 221 : if (m == MATCH_YES)
11217 : : {
11218 : 221 : if (ba->deferred)
11219 : : {
11220 : 1 : gfc_error ("Duplicate DEFERRED at %C");
11221 : 1 : goto error;
11222 : : }
11223 : :
11224 : 220 : ba->deferred = 1;
11225 : 220 : continue;
11226 : : }
11227 : : }
11228 : :
11229 : : }
11230 : :
11231 : : /* Nothing matching found. */
11232 : 1 : if (generic)
11233 : 1 : gfc_error ("Expected access-specifier at %C");
11234 : : else
11235 : 0 : gfc_error ("Expected binding attribute at %C");
11236 : 1 : goto error;
11237 : : }
11238 : 2465 : while (gfc_match_char (',') == MATCH_YES);
11239 : :
11240 : : /* NON_OVERRIDABLE and DEFERRED exclude themselves. */
11241 : 2014 : if (ba->non_overridable && ba->deferred)
11242 : : {
11243 : 1 : gfc_error ("NON_OVERRIDABLE and DEFERRED cannot both appear at %C");
11244 : 1 : goto error;
11245 : : }
11246 : :
11247 : : m = MATCH_YES;
11248 : :
11249 : 4114 : done:
11250 : 4114 : if (ba->access == ACCESS_UNKNOWN)
11251 : 3771 : ba->access = ppc ? gfc_current_block()->component_access
11252 : : : gfc_typebound_default_access;
11253 : :
11254 : 4114 : if (ppc && !seen_ptr)
11255 : : {
11256 : 2 : gfc_error ("POINTER attribute is required for procedure pointer component"
11257 : : " at %C");
11258 : 2 : goto error;
11259 : : }
11260 : :
11261 : : return m;
11262 : :
11263 : : error:
11264 : : return MATCH_ERROR;
11265 : : }
11266 : :
11267 : :
11268 : : /* Match a PROCEDURE specific binding inside a derived type. */
11269 : :
11270 : : static match
11271 : 2872 : match_procedure_in_type (void)
11272 : : {
11273 : 2872 : char name[GFC_MAX_SYMBOL_LEN + 1];
11274 : 2872 : char target_buf[GFC_MAX_SYMBOL_LEN + 1];
11275 : 2872 : char* target = NULL, *ifc = NULL;
11276 : 2872 : gfc_typebound_proc tb;
11277 : 2872 : bool seen_colons;
11278 : 2872 : bool seen_attrs;
11279 : 2872 : match m;
11280 : 2872 : gfc_symtree* stree;
11281 : 2872 : gfc_namespace* ns;
11282 : 2872 : gfc_symbol* block;
11283 : 2872 : int num;
11284 : :
11285 : : /* Check current state. */
11286 : 2872 : gcc_assert (gfc_state_stack->state == COMP_DERIVED_CONTAINS);
11287 : 2872 : block = gfc_state_stack->previous->sym;
11288 : 2872 : gcc_assert (block);
11289 : :
11290 : : /* Try to match PROCEDURE(interface). */
11291 : 2872 : if (gfc_match (" (") == MATCH_YES)
11292 : : {
11293 : 222 : m = gfc_match_name (target_buf);
11294 : 222 : if (m == MATCH_ERROR)
11295 : : return m;
11296 : 222 : if (m != MATCH_YES)
11297 : : {
11298 : 1 : gfc_error ("Interface-name expected after %<(%> at %C");
11299 : 1 : return MATCH_ERROR;
11300 : : }
11301 : :
11302 : 221 : if (gfc_match (" )") != MATCH_YES)
11303 : : {
11304 : 1 : gfc_error ("%<)%> expected at %C");
11305 : 1 : return MATCH_ERROR;
11306 : : }
11307 : :
11308 : : ifc = target_buf;
11309 : : }
11310 : :
11311 : : /* Construct the data structure. */
11312 : 2870 : memset (&tb, 0, sizeof (tb));
11313 : 2870 : tb.where = gfc_current_locus;
11314 : :
11315 : : /* Match binding attributes. */
11316 : 2870 : m = match_binding_attributes (&tb, false, false);
11317 : 2870 : if (m == MATCH_ERROR)
11318 : : return m;
11319 : 2863 : seen_attrs = (m == MATCH_YES);
11320 : :
11321 : : /* Check that attribute DEFERRED is given if an interface is specified. */
11322 : 2863 : if (tb.deferred && !ifc)
11323 : : {
11324 : 1 : gfc_error ("Interface must be specified for DEFERRED binding at %C");
11325 : 1 : return MATCH_ERROR;
11326 : : }
11327 : 2862 : if (ifc && !tb.deferred)
11328 : : {
11329 : 1 : gfc_error ("PROCEDURE(interface) at %C should be declared DEFERRED");
11330 : 1 : return MATCH_ERROR;
11331 : : }
11332 : :
11333 : : /* Match the colons. */
11334 : 2861 : m = gfc_match (" ::");
11335 : 2861 : if (m == MATCH_ERROR)
11336 : : return m;
11337 : 2861 : seen_colons = (m == MATCH_YES);
11338 : 2861 : if (seen_attrs && !seen_colons)
11339 : : {
11340 : 4 : gfc_error ("Expected %<::%> after binding-attributes at %C");
11341 : 4 : return MATCH_ERROR;
11342 : : }
11343 : :
11344 : : /* Match the binding names. */
11345 : 17 : for(num=1;;num++)
11346 : : {
11347 : 2874 : m = gfc_match_name (name);
11348 : 2874 : if (m == MATCH_ERROR)
11349 : : return m;
11350 : 2874 : if (m == MATCH_NO)
11351 : : {
11352 : 5 : gfc_error ("Expected binding name at %C");
11353 : 5 : return MATCH_ERROR;
11354 : : }
11355 : :
11356 : 2869 : if (num>1 && !gfc_notify_std (GFC_STD_F2008, "PROCEDURE list at %C"))
11357 : : return MATCH_ERROR;
11358 : :
11359 : : /* Try to match the '=> target', if it's there. */
11360 : 2868 : target = ifc;
11361 : 2868 : m = gfc_match (" =>");
11362 : 2868 : if (m == MATCH_ERROR)
11363 : : return m;
11364 : 2868 : if (m == MATCH_YES)
11365 : : {
11366 : 1130 : if (tb.deferred)
11367 : : {
11368 : 1 : gfc_error ("%<=> target%> is invalid for DEFERRED binding at %C");
11369 : 1 : return MATCH_ERROR;
11370 : : }
11371 : :
11372 : 1129 : if (!seen_colons)
11373 : : {
11374 : 1 : gfc_error ("%<::%> needed in PROCEDURE binding with explicit target"
11375 : : " at %C");
11376 : 1 : return MATCH_ERROR;
11377 : : }
11378 : :
11379 : 1128 : m = gfc_match_name (target_buf);
11380 : 1128 : if (m == MATCH_ERROR)
11381 : : return m;
11382 : 1128 : if (m == MATCH_NO)
11383 : : {
11384 : 2 : gfc_error ("Expected binding target after %<=>%> at %C");
11385 : 2 : return MATCH_ERROR;
11386 : : }
11387 : : target = target_buf;
11388 : : }
11389 : :
11390 : : /* If no target was found, it has the same name as the binding. */
11391 : 1738 : if (!target)
11392 : 1522 : target = name;
11393 : :
11394 : : /* Get the namespace to insert the symbols into. */
11395 : 2864 : ns = block->f2k_derived;
11396 : 2864 : gcc_assert (ns);
11397 : :
11398 : : /* If the binding is DEFERRED, check that the containing type is ABSTRACT. */
11399 : 2864 : if (tb.deferred && !block->attr.abstract)
11400 : : {
11401 : 1 : gfc_error ("Type %qs containing DEFERRED binding at %C "
11402 : : "is not ABSTRACT", block->name);
11403 : 1 : return MATCH_ERROR;
11404 : : }
11405 : :
11406 : : /* See if we already have a binding with this name in the symtree which
11407 : : would be an error. If a GENERIC already targeted this binding, it may
11408 : : be already there but then typebound is still NULL. */
11409 : 2863 : stree = gfc_find_symtree (ns->tb_sym_root, name);
11410 : 2863 : if (stree && stree->n.tb)
11411 : : {
11412 : 2 : gfc_error ("There is already a procedure with binding name %qs for "
11413 : : "the derived type %qs at %C", name, block->name);
11414 : 2 : return MATCH_ERROR;
11415 : : }
11416 : :
11417 : : /* Insert it and set attributes. */
11418 : :
11419 : 2787 : if (!stree)
11420 : : {
11421 : 2787 : stree = gfc_new_symtree (&ns->tb_sym_root, name);
11422 : 2787 : gcc_assert (stree);
11423 : : }
11424 : 2861 : stree->n.tb = gfc_get_typebound_proc (&tb);
11425 : :
11426 : 2861 : if (gfc_get_sym_tree (target, gfc_current_ns, &stree->n.tb->u.specific,
11427 : : false))
11428 : : return MATCH_ERROR;
11429 : 2861 : gfc_set_sym_referenced (stree->n.tb->u.specific->n.sym);
11430 : 2861 : gfc_add_flavor(&stree->n.tb->u.specific->n.sym->attr, FL_PROCEDURE,
11431 : 2861 : target, &stree->n.tb->u.specific->n.sym->declared_at);
11432 : :
11433 : 2861 : if (gfc_match_eos () == MATCH_YES)
11434 : : return MATCH_YES;
11435 : 18 : if (gfc_match_char (',') != MATCH_YES)
11436 : 1 : goto syntax;
11437 : : }
11438 : :
11439 : 1 : syntax:
11440 : 1 : gfc_error ("Syntax error in PROCEDURE statement at %C");
11441 : 1 : return MATCH_ERROR;
11442 : : }
11443 : :
11444 : :
11445 : : /* Match a GENERIC procedure binding inside a derived type. */
11446 : :
11447 : : match
11448 : 858 : gfc_match_generic (void)
11449 : : {
11450 : 858 : char name[GFC_MAX_SYMBOL_LEN + 1];
11451 : 858 : char bind_name[GFC_MAX_SYMBOL_LEN + 16]; /* Allow space for OPERATOR(...). */
11452 : 858 : gfc_symbol* block;
11453 : 858 : gfc_typebound_proc tbattr; /* Used for match_binding_attributes. */
11454 : 858 : gfc_typebound_proc* tb;
11455 : 858 : gfc_namespace* ns;
11456 : 858 : interface_type op_type;
11457 : 858 : gfc_intrinsic_op op;
11458 : 858 : match m;
11459 : :
11460 : : /* Check current state. */
11461 : 858 : if (gfc_current_state () == COMP_DERIVED)
11462 : : {
11463 : 0 : gfc_error ("GENERIC at %C must be inside a derived-type CONTAINS");
11464 : 0 : return MATCH_ERROR;
11465 : : }
11466 : 858 : if (gfc_current_state () != COMP_DERIVED_CONTAINS)
11467 : : return MATCH_NO;
11468 : 858 : block = gfc_state_stack->previous->sym;
11469 : 858 : ns = block->f2k_derived;
11470 : 858 : gcc_assert (block && ns);
11471 : :
11472 : 858 : memset (&tbattr, 0, sizeof (tbattr));
11473 : 858 : tbattr.where = gfc_current_locus;
11474 : :
11475 : : /* See if we get an access-specifier. */
11476 : 858 : m = match_binding_attributes (&tbattr, true, false);
11477 : 858 : if (m == MATCH_ERROR)
11478 : 1 : goto error;
11479 : :
11480 : : /* Now the colons, those are required. */
11481 : 857 : if (gfc_match (" ::") != MATCH_YES)
11482 : : {
11483 : 0 : gfc_error ("Expected %<::%> at %C");
11484 : 0 : goto error;
11485 : : }
11486 : :
11487 : : /* Match the binding name; depending on type (operator / generic) format
11488 : : it for future error messages into bind_name. */
11489 : :
11490 : 857 : m = gfc_match_generic_spec (&op_type, name, &op);
11491 : 857 : if (m == MATCH_ERROR)
11492 : : return MATCH_ERROR;
11493 : 857 : if (m == MATCH_NO)
11494 : : {
11495 : 0 : gfc_error ("Expected generic name or operator descriptor at %C");
11496 : 0 : goto error;
11497 : : }
11498 : :
11499 : 857 : switch (op_type)
11500 : : {
11501 : 440 : case INTERFACE_GENERIC:
11502 : 440 : case INTERFACE_DTIO:
11503 : 440 : snprintf (bind_name, sizeof (bind_name), "%s", name);
11504 : 440 : break;
11505 : :
11506 : 21 : case INTERFACE_USER_OP:
11507 : 21 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(.%s.)", name);
11508 : 21 : break;
11509 : :
11510 : 395 : case INTERFACE_INTRINSIC_OP:
11511 : 395 : snprintf (bind_name, sizeof (bind_name), "OPERATOR(%s)",
11512 : : gfc_op2string (op));
11513 : 395 : break;
11514 : :
11515 : 1 : case INTERFACE_NAMELESS:
11516 : 1 : gfc_error ("Malformed GENERIC statement at %C");
11517 : 1 : goto error;
11518 : 0 : break;
11519 : :
11520 : 0 : default:
11521 : 0 : gcc_unreachable ();
11522 : : }
11523 : :
11524 : : /* Match the required =>. */
11525 : 856 : if (gfc_match (" =>") != MATCH_YES)
11526 : : {
11527 : 0 : gfc_error ("Expected %<=>%> at %C");
11528 : 0 : goto error;
11529 : : }
11530 : :
11531 : : /* Try to find existing GENERIC binding with this name / for this operator;
11532 : : if there is something, check that it is another GENERIC and then extend
11533 : : it rather than building a new node. Otherwise, create it and put it
11534 : : at the right position. */
11535 : :
11536 : 856 : switch (op_type)
11537 : : {
11538 : 461 : case INTERFACE_DTIO:
11539 : 461 : case INTERFACE_USER_OP:
11540 : 461 : case INTERFACE_GENERIC:
11541 : 461 : {
11542 : 461 : const bool is_op = (op_type == INTERFACE_USER_OP);
11543 : 461 : gfc_symtree* st;
11544 : :
11545 : 461 : st = gfc_find_symtree (is_op ? ns->tb_uop_root : ns->tb_sym_root, name);
11546 : 461 : tb = st ? st->n.tb : NULL;
11547 : 11 : break;
11548 : : }
11549 : :
11550 : 395 : case INTERFACE_INTRINSIC_OP:
11551 : 395 : tb = ns->tb_op[op];
11552 : 395 : break;
11553 : :
11554 : 0 : default:
11555 : 0 : gcc_unreachable ();
11556 : : }
11557 : :
11558 : 406 : if (tb)
11559 : : {
11560 : 9 : if (!tb->is_generic)
11561 : : {
11562 : 1 : gcc_assert (op_type == INTERFACE_GENERIC);
11563 : 1 : gfc_error ("There's already a non-generic procedure with binding name"
11564 : : " %qs for the derived type %qs at %C",
11565 : : bind_name, block->name);
11566 : 1 : goto error;
11567 : : }
11568 : :
11569 : 8 : if (tb->access != tbattr.access)
11570 : : {
11571 : 2 : gfc_error ("Binding at %C must have the same access as already"
11572 : : " defined binding %qs", bind_name);
11573 : 2 : goto error;
11574 : : }
11575 : : }
11576 : : else
11577 : : {
11578 : 847 : tb = gfc_get_typebound_proc (NULL);
11579 : 847 : tb->where = gfc_current_locus;
11580 : 847 : tb->access = tbattr.access;
11581 : 847 : tb->is_generic = 1;
11582 : 847 : tb->u.generic = NULL;
11583 : :
11584 : 847 : switch (op_type)
11585 : : {
11586 : 452 : case INTERFACE_DTIO:
11587 : 452 : case INTERFACE_GENERIC:
11588 : 452 : case INTERFACE_USER_OP:
11589 : 452 : {
11590 : 452 : const bool is_op = (op_type == INTERFACE_USER_OP);
11591 : 452 : gfc_symtree* st = gfc_get_tbp_symtree (is_op ? &ns->tb_uop_root :
11592 : : &ns->tb_sym_root, name);
11593 : 452 : gcc_assert (st);
11594 : 452 : st->n.tb = tb;
11595 : :
11596 : 452 : break;
11597 : : }
11598 : :
11599 : 395 : case INTERFACE_INTRINSIC_OP:
11600 : 395 : ns->tb_op[op] = tb;
11601 : 395 : break;
11602 : :
11603 : 0 : default:
11604 : 0 : gcc_unreachable ();
11605 : : }
11606 : : }
11607 : :
11608 : : /* Now, match all following names as specific targets. */
11609 : 982 : do
11610 : : {
11611 : 982 : gfc_symtree* target_st;
11612 : 982 : gfc_tbp_generic* target;
11613 : :
11614 : 982 : m = gfc_match_name (name);
11615 : 982 : if (m == MATCH_ERROR)
11616 : 0 : goto error;
11617 : 982 : if (m == MATCH_NO)
11618 : : {
11619 : 1 : gfc_error ("Expected specific binding name at %C");
11620 : 1 : goto error;
11621 : : }
11622 : :
11623 : 981 : target_st = gfc_get_tbp_symtree (&ns->tb_sym_root, name);
11624 : :
11625 : : /* See if this is a duplicate specification. */
11626 : 1170 : for (target = tb->u.generic; target; target = target->next)
11627 : 190 : if (target_st == target->specific_st)
11628 : : {
11629 : 1 : gfc_error ("%qs already defined as specific binding for the"
11630 : : " generic %qs at %C", name, bind_name);
11631 : 1 : goto error;
11632 : : }
11633 : :
11634 : 980 : target = gfc_get_tbp_generic ();
11635 : 980 : target->specific_st = target_st;
11636 : 980 : target->specific = NULL;
11637 : 980 : target->next = tb->u.generic;
11638 : 980 : target->is_operator = ((op_type == INTERFACE_USER_OP)
11639 : 980 : || (op_type == INTERFACE_INTRINSIC_OP));
11640 : 980 : tb->u.generic = target;
11641 : : }
11642 : 980 : while (gfc_match (" ,") == MATCH_YES);
11643 : :
11644 : : /* Here should be the end. */
11645 : 851 : if (gfc_match_eos () != MATCH_YES)
11646 : : {
11647 : 1 : gfc_error ("Junk after GENERIC binding at %C");
11648 : 1 : goto error;
11649 : : }
11650 : :
11651 : : return MATCH_YES;
11652 : :
11653 : : error:
11654 : : return MATCH_ERROR;
11655 : : }
11656 : :
11657 : :
11658 : : /* Match a FINAL declaration inside a derived type. */
11659 : :
11660 : : match
11661 : 371 : gfc_match_final_decl (void)
11662 : : {
11663 : 371 : char name[GFC_MAX_SYMBOL_LEN + 1];
11664 : 371 : gfc_symbol* sym;
11665 : 371 : match m;
11666 : 371 : gfc_namespace* module_ns;
11667 : 371 : bool first, last;
11668 : 371 : gfc_symbol* block;
11669 : :
11670 : 371 : if (gfc_current_form == FORM_FREE)
11671 : : {
11672 : 371 : char c = gfc_peek_ascii_char ();
11673 : 371 : if (!gfc_is_whitespace (c) && c != ':')
11674 : : return MATCH_NO;
11675 : : }
11676 : :
11677 : 370 : if (gfc_state_stack->state != COMP_DERIVED_CONTAINS)
11678 : : {
11679 : 1 : if (gfc_current_form == FORM_FIXED)
11680 : : return MATCH_NO;
11681 : :
11682 : 1 : gfc_error ("FINAL declaration at %C must be inside a derived type "
11683 : : "CONTAINS section");
11684 : 1 : return MATCH_ERROR;
11685 : : }
11686 : :
11687 : 369 : block = gfc_state_stack->previous->sym;
11688 : 369 : gcc_assert (block);
11689 : :
11690 : 369 : if (gfc_state_stack->previous->previous
11691 : 369 : && gfc_state_stack->previous->previous->state != COMP_MODULE
11692 : 6 : && gfc_state_stack->previous->previous->state != COMP_SUBMODULE)
11693 : : {
11694 : 0 : gfc_error ("Derived type declaration with FINAL at %C must be in the"
11695 : : " specification part of a MODULE");
11696 : 0 : return MATCH_ERROR;
11697 : : }
11698 : :
11699 : 369 : module_ns = gfc_current_ns;
11700 : 369 : gcc_assert (module_ns);
11701 : 369 : gcc_assert (module_ns->proc_name->attr.flavor == FL_MODULE);
11702 : :
11703 : : /* Match optional ::, don't care about MATCH_YES or MATCH_NO. */
11704 : 369 : if (gfc_match (" ::") == MATCH_ERROR)
11705 : : return MATCH_ERROR;
11706 : :
11707 : : /* Match the sequence of procedure names. */
11708 : : first = true;
11709 : : last = false;
11710 : 443 : do
11711 : : {
11712 : 443 : gfc_finalizer* f;
11713 : :
11714 : 443 : if (first && gfc_match_eos () == MATCH_YES)
11715 : : {
11716 : 2 : gfc_error ("Empty FINAL at %C");
11717 : 2 : return MATCH_ERROR;
11718 : : }
11719 : :
11720 : 441 : m = gfc_match_name (name);
11721 : 441 : if (m == MATCH_NO)
11722 : : {
11723 : 1 : gfc_error ("Expected module procedure name at %C");
11724 : 1 : return MATCH_ERROR;
11725 : : }
11726 : 440 : else if (m != MATCH_YES)
11727 : : return MATCH_ERROR;
11728 : :
11729 : 440 : if (gfc_match_eos () == MATCH_YES)
11730 : : last = true;
11731 : 75 : if (!last && gfc_match_char (',') != MATCH_YES)
11732 : : {
11733 : 1 : gfc_error ("Expected %<,%> at %C");
11734 : 1 : return MATCH_ERROR;
11735 : : }
11736 : :
11737 : 439 : if (gfc_get_symbol (name, module_ns, &sym))
11738 : : {
11739 : 0 : gfc_error ("Unknown procedure name %qs at %C", name);
11740 : 0 : return MATCH_ERROR;
11741 : : }
11742 : :
11743 : : /* Mark the symbol as module procedure. */
11744 : 439 : if (sym->attr.proc != PROC_MODULE
11745 : 439 : && !gfc_add_procedure (&sym->attr, PROC_MODULE, sym->name, NULL))
11746 : : return MATCH_ERROR;
11747 : :
11748 : : /* Check if we already have this symbol in the list, this is an error. */
11749 : 602 : for (f = block->f2k_derived->finalizers; f; f = f->next)
11750 : 164 : if (f->proc_sym == sym)
11751 : : {
11752 : 1 : gfc_error ("%qs at %C is already defined as FINAL procedure",
11753 : : name);
11754 : 1 : return MATCH_ERROR;
11755 : : }
11756 : :
11757 : : /* Add this symbol to the list of finalizers. */
11758 : 438 : gcc_assert (block->f2k_derived);
11759 : 438 : sym->refs++;
11760 : 438 : f = XCNEW (gfc_finalizer);
11761 : 438 : f->proc_sym = sym;
11762 : 438 : f->proc_tree = NULL;
11763 : 438 : f->where = gfc_current_locus;
11764 : 438 : f->next = block->f2k_derived->finalizers;
11765 : 438 : block->f2k_derived->finalizers = f;
11766 : :
11767 : 438 : first = false;
11768 : : }
11769 : 438 : while (!last);
11770 : :
11771 : : return MATCH_YES;
11772 : : }
11773 : :
11774 : :
11775 : : const ext_attr_t ext_attr_list[] = {
11776 : : { "dllimport", EXT_ATTR_DLLIMPORT, "dllimport" },
11777 : : { "dllexport", EXT_ATTR_DLLEXPORT, "dllexport" },
11778 : : { "cdecl", EXT_ATTR_CDECL, "cdecl" },
11779 : : { "stdcall", EXT_ATTR_STDCALL, "stdcall" },
11780 : : { "fastcall", EXT_ATTR_FASTCALL, "fastcall" },
11781 : : { "no_arg_check", EXT_ATTR_NO_ARG_CHECK, NULL },
11782 : : { "deprecated", EXT_ATTR_DEPRECATED, NULL },
11783 : : { "noinline", EXT_ATTR_NOINLINE, NULL },
11784 : : { "noreturn", EXT_ATTR_NORETURN, NULL },
11785 : : { "weak", EXT_ATTR_WEAK, NULL },
11786 : : { NULL, EXT_ATTR_LAST, NULL }
11787 : : };
11788 : :
11789 : : /* Match a !GCC$ ATTRIBUTES statement of the form:
11790 : : !GCC$ ATTRIBUTES attribute-list :: var-name [, var-name] ...
11791 : : When we come here, we have already matched the !GCC$ ATTRIBUTES string.
11792 : :
11793 : : TODO: We should support all GCC attributes using the same syntax for
11794 : : the attribute list, i.e. the list in C
11795 : : __attributes(( attribute-list ))
11796 : : matches then
11797 : : !GCC$ ATTRIBUTES attribute-list ::
11798 : : Cf. c-parser.cc's c_parser_attributes; the data can then directly be
11799 : : saved into a TREE.
11800 : :
11801 : : As there is absolutely no risk of confusion, we should never return
11802 : : MATCH_NO. */
11803 : : match
11804 : 2456 : gfc_match_gcc_attributes (void)
11805 : : {
11806 : 2456 : symbol_attribute attr;
11807 : 2456 : char name[GFC_MAX_SYMBOL_LEN + 1];
11808 : 2456 : unsigned id;
11809 : 2456 : gfc_symbol *sym;
11810 : 2456 : match m;
11811 : :
11812 : 2456 : gfc_clear_attr (&attr);
11813 : 2456 : for(;;)
11814 : : {
11815 : 2456 : char ch;
11816 : :
11817 : 2456 : if (gfc_match_name (name) != MATCH_YES)
11818 : : return MATCH_ERROR;
11819 : :
11820 : 14809 : for (id = 0; id < EXT_ATTR_LAST; id++)
11821 : 14809 : if (strcmp (name, ext_attr_list[id].name) == 0)
11822 : : break;
11823 : :
11824 : 2456 : if (id == EXT_ATTR_LAST)
11825 : : {
11826 : 0 : gfc_error ("Unknown attribute in !GCC$ ATTRIBUTES statement at %C");
11827 : 0 : return MATCH_ERROR;
11828 : : }
11829 : :
11830 : 2456 : if (!gfc_add_ext_attribute (&attr, (ext_attr_id_t)id, &gfc_current_locus))
11831 : : return MATCH_ERROR;
11832 : :
11833 : 2456 : gfc_gobble_whitespace ();
11834 : 2456 : ch = gfc_next_ascii_char ();
11835 : 2456 : if (ch == ':')
11836 : : {
11837 : : /* This is the successful exit condition for the loop. */
11838 : 2456 : if (gfc_next_ascii_char () == ':')
11839 : : break;
11840 : : }
11841 : :
11842 : 0 : if (ch == ',')
11843 : 0 : continue;
11844 : :
11845 : 0 : goto syntax;
11846 : 0 : }
11847 : :
11848 : 2456 : if (gfc_match_eos () == MATCH_YES)
11849 : 0 : goto syntax;
11850 : :
11851 : 2463 : for(;;)
11852 : : {
11853 : 2463 : m = gfc_match_name (name);
11854 : 2463 : if (m != MATCH_YES)
11855 : 0 : return m;
11856 : :
11857 : 2463 : if (find_special (name, &sym, true))
11858 : : return MATCH_ERROR;
11859 : :
11860 : 2463 : sym->attr.ext_attr |= attr.ext_attr;
11861 : :
11862 : 2463 : if (gfc_match_eos () == MATCH_YES)
11863 : : break;
11864 : :
11865 : 7 : if (gfc_match_char (',') != MATCH_YES)
11866 : 0 : goto syntax;
11867 : : }
11868 : :
11869 : : return MATCH_YES;
11870 : :
11871 : 0 : syntax:
11872 : 0 : gfc_error ("Syntax error in !GCC$ ATTRIBUTES statement at %C");
11873 : 0 : return MATCH_ERROR;
11874 : : }
11875 : :
11876 : :
11877 : : /* Match a !GCC$ UNROLL statement of the form:
11878 : : !GCC$ UNROLL n
11879 : :
11880 : : The parameter n is the number of times we are supposed to unroll.
11881 : :
11882 : : When we come here, we have already matched the !GCC$ UNROLL string. */
11883 : : match
11884 : 19 : gfc_match_gcc_unroll (void)
11885 : : {
11886 : 19 : int value;
11887 : :
11888 : : /* FIXME: use gfc_match_small_literal_int instead, delete small_int */
11889 : 19 : if (gfc_match_small_int (&value) == MATCH_YES)
11890 : : {
11891 : 19 : if (value < 0 || value > USHRT_MAX)
11892 : : {
11893 : 2 : gfc_error ("%<GCC unroll%> directive requires a"
11894 : : " non-negative integral constant"
11895 : : " less than or equal to %u at %C",
11896 : : USHRT_MAX
11897 : : );
11898 : 2 : return MATCH_ERROR;
11899 : : }
11900 : 17 : if (gfc_match_eos () == MATCH_YES)
11901 : : {
11902 : 17 : directive_unroll = value == 0 ? 1 : value;
11903 : 17 : return MATCH_YES;
11904 : : }
11905 : : }
11906 : :
11907 : 0 : gfc_error ("Syntax error in !GCC$ UNROLL directive at %C");
11908 : 0 : return MATCH_ERROR;
11909 : : }
11910 : :
11911 : : /* Match a !GCC$ builtin (b) attributes simd flags if('target') form:
11912 : :
11913 : : The parameter b is name of a middle-end built-in.
11914 : : FLAGS is optional and must be one of:
11915 : : - (inbranch)
11916 : : - (notinbranch)
11917 : :
11918 : : IF('target') is optional and TARGET is a name of a multilib ABI.
11919 : :
11920 : : When we come here, we have already matched the !GCC$ builtin string. */
11921 : :
11922 : : match
11923 : 3190784 : gfc_match_gcc_builtin (void)
11924 : : {
11925 : 3190784 : char builtin[GFC_MAX_SYMBOL_LEN + 1];
11926 : 3190784 : char target[GFC_MAX_SYMBOL_LEN + 1];
11927 : :
11928 : 3190784 : if (gfc_match (" ( %n ) attributes simd", builtin) != MATCH_YES)
11929 : : return MATCH_ERROR;
11930 : :
11931 : 3190784 : gfc_simd_clause clause = SIMD_NONE;
11932 : 3190784 : if (gfc_match (" ( notinbranch ) ") == MATCH_YES)
11933 : : clause = SIMD_NOTINBRANCH;
11934 : 21 : else if (gfc_match (" ( inbranch ) ") == MATCH_YES)
11935 : 15 : clause = SIMD_INBRANCH;
11936 : :
11937 : 3190784 : if (gfc_match (" if ( '%n' ) ", target) == MATCH_YES)
11938 : : {
11939 : 3190755 : const char *abi = targetm.get_multilib_abi_name ();
11940 : 3190755 : if (abi == NULL || strcmp (abi, target) != 0)
11941 : : return MATCH_YES;
11942 : : }
11943 : :
11944 : 1573429 : if (gfc_vectorized_builtins == NULL)
11945 : 29143 : gfc_vectorized_builtins = new hash_map<nofree_string_hash, int> ();
11946 : :
11947 : 1573429 : char *r = XNEWVEC (char, strlen (builtin) + 32);
11948 : 1573429 : sprintf (r, "__builtin_%s", builtin);
11949 : :
11950 : 1573429 : bool existed;
11951 : 1573429 : int &value = gfc_vectorized_builtins->get_or_insert (r, &existed);
11952 : 1573429 : value |= clause;
11953 : 1573429 : if (existed)
11954 : 22 : free (r);
11955 : :
11956 : : return MATCH_YES;
11957 : : }
11958 : :
11959 : : /* Match an !GCC$ IVDEP statement.
11960 : : When we come here, we have already matched the !GCC$ IVDEP string. */
11961 : :
11962 : : match
11963 : 3 : gfc_match_gcc_ivdep (void)
11964 : : {
11965 : 3 : if (gfc_match_eos () == MATCH_YES)
11966 : : {
11967 : 3 : directive_ivdep = true;
11968 : 3 : return MATCH_YES;
11969 : : }
11970 : :
11971 : 0 : gfc_error ("Syntax error in !GCC$ IVDEP directive at %C");
11972 : 0 : return MATCH_ERROR;
11973 : : }
11974 : :
11975 : : /* Match an !GCC$ VECTOR statement.
11976 : : When we come here, we have already matched the !GCC$ VECTOR string. */
11977 : :
11978 : : match
11979 : 3 : gfc_match_gcc_vector (void)
11980 : : {
11981 : 3 : if (gfc_match_eos () == MATCH_YES)
11982 : : {
11983 : 3 : directive_vector = true;
11984 : 3 : directive_novector = false;
11985 : 3 : return MATCH_YES;
11986 : : }
11987 : :
11988 : 0 : gfc_error ("Syntax error in !GCC$ VECTOR directive at %C");
11989 : 0 : return MATCH_ERROR;
11990 : : }
11991 : :
11992 : : /* Match an !GCC$ NOVECTOR statement.
11993 : : When we come here, we have already matched the !GCC$ NOVECTOR string. */
11994 : :
11995 : : match
11996 : 2 : gfc_match_gcc_novector (void)
11997 : : {
11998 : 2 : if (gfc_match_eos () == MATCH_YES)
11999 : : {
12000 : 2 : directive_novector = true;
12001 : 2 : directive_vector = false;
12002 : 2 : return MATCH_YES;
12003 : : }
12004 : :
12005 : 0 : gfc_error ("Syntax error in !GCC$ NOVECTOR directive at %C");
12006 : 0 : return MATCH_ERROR;
12007 : : }
|
