Bug Summary

File:build/gcc/fortran/decl.cc
Warning:line 3267, column 5
Value stored to 'm' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

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