Bug Summary

File:build/gcc/fortran/decl.c
Warning:line 2477, column 3
Value stored to 'm' is never read

Annotated Source Code

Press '?' to see keyboard shortcuts

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