Bug Summary

File:build/gcc/fortran/symbol.c
Warning:line 4700, column 2
Called C++ object pointer is null

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 symbol.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-7qGR5c.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c
1/* Maintain binary trees of symbols.
2 Copyright (C) 2000-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
22#include "config.h"
23#include "system.h"
24#include "coretypes.h"
25#include "options.h"
26#include "gfortran.h"
27#include "parse.h"
28#include "match.h"
29#include "constructor.h"
30
31
32/* Strings for all symbol attributes. We use these for dumping the
33 parse tree, in error messages, and also when reading and writing
34 modules. */
35
36const mstring flavors[] =
37{
38 minit ("UNKNOWN-FL", FL_UNKNOWN){ "UNKNOWN-FL", __null, FL_UNKNOWN }, minit ("PROGRAM", FL_PROGRAM){ "PROGRAM", __null, FL_PROGRAM },
39 minit ("BLOCK-DATA", FL_BLOCK_DATA){ "BLOCK-DATA", __null, FL_BLOCK_DATA }, minit ("MODULE", FL_MODULE){ "MODULE", __null, FL_MODULE },
40 minit ("VARIABLE", FL_VARIABLE){ "VARIABLE", __null, FL_VARIABLE }, minit ("PARAMETER", FL_PARAMETER){ "PARAMETER", __null, FL_PARAMETER },
41 minit ("LABEL", FL_LABEL){ "LABEL", __null, FL_LABEL }, minit ("PROCEDURE", FL_PROCEDURE){ "PROCEDURE", __null, FL_PROCEDURE },
42 minit ("DERIVED", FL_DERIVED){ "DERIVED", __null, FL_DERIVED }, minit ("NAMELIST", FL_NAMELIST){ "NAMELIST", __null, FL_NAMELIST },
43 minit ("UNION", FL_UNION){ "UNION", __null, FL_UNION }, minit ("STRUCTURE", FL_STRUCT){ "STRUCTURE", __null, FL_STRUCT },
44 minit (NULL, -1){ __null, __null, -1 }
45};
46
47const mstring procedures[] =
48{
49 minit ("UNKNOWN-PROC", PROC_UNKNOWN){ "UNKNOWN-PROC", __null, PROC_UNKNOWN },
50 minit ("MODULE-PROC", PROC_MODULE){ "MODULE-PROC", __null, PROC_MODULE },
51 minit ("INTERNAL-PROC", PROC_INTERNAL){ "INTERNAL-PROC", __null, PROC_INTERNAL },
52 minit ("DUMMY-PROC", PROC_DUMMY){ "DUMMY-PROC", __null, PROC_DUMMY },
53 minit ("INTRINSIC-PROC", PROC_INTRINSIC){ "INTRINSIC-PROC", __null, PROC_INTRINSIC },
54 minit ("EXTERNAL-PROC", PROC_EXTERNAL){ "EXTERNAL-PROC", __null, PROC_EXTERNAL },
55 minit ("STATEMENT-PROC", PROC_ST_FUNCTION){ "STATEMENT-PROC", __null, PROC_ST_FUNCTION },
56 minit (NULL, -1){ __null, __null, -1 }
57};
58
59const mstring intents[] =
60{
61 minit ("UNKNOWN-INTENT", INTENT_UNKNOWN){ "UNKNOWN-INTENT", __null, INTENT_UNKNOWN },
62 minit ("IN", INTENT_IN){ "IN", __null, INTENT_IN },
63 minit ("OUT", INTENT_OUT){ "OUT", __null, INTENT_OUT },
64 minit ("INOUT", INTENT_INOUT){ "INOUT", __null, INTENT_INOUT },
65 minit (NULL, -1){ __null, __null, -1 }
66};
67
68const mstring access_types[] =
69{
70 minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN){ "UNKNOWN-ACCESS", __null, ACCESS_UNKNOWN },
71 minit ("PUBLIC", ACCESS_PUBLIC){ "PUBLIC", __null, ACCESS_PUBLIC },
72 minit ("PRIVATE", ACCESS_PRIVATE){ "PRIVATE", __null, ACCESS_PRIVATE },
73 minit (NULL, -1){ __null, __null, -1 }
74};
75
76const mstring ifsrc_types[] =
77{
78 minit ("UNKNOWN", IFSRC_UNKNOWN){ "UNKNOWN", __null, IFSRC_UNKNOWN },
79 minit ("DECL", IFSRC_DECL){ "DECL", __null, IFSRC_DECL },
80 minit ("BODY", IFSRC_IFBODY){ "BODY", __null, IFSRC_IFBODY }
81};
82
83const mstring save_status[] =
84{
85 minit ("UNKNOWN", SAVE_NONE){ "UNKNOWN", __null, SAVE_NONE },
86 minit ("EXPLICIT-SAVE", SAVE_EXPLICIT){ "EXPLICIT-SAVE", __null, SAVE_EXPLICIT },
87 minit ("IMPLICIT-SAVE", SAVE_IMPLICIT){ "IMPLICIT-SAVE", __null, SAVE_IMPLICIT },
88};
89
90/* Set the mstrings for DTIO procedure names. */
91const mstring dtio_procs[] =
92{
93 minit ("_dtio_formatted_read", DTIO_RF){ "_dtio_formatted_read", __null, DTIO_RF },
94 minit ("_dtio_formatted_write", DTIO_WF){ "_dtio_formatted_write", __null, DTIO_WF },
95 minit ("_dtio_unformatted_read", DTIO_RUF){ "_dtio_unformatted_read", __null, DTIO_RUF },
96 minit ("_dtio_unformatted_write", DTIO_WUF){ "_dtio_unformatted_write", __null, DTIO_WUF },
97};
98
99/* This is to make sure the backend generates setup code in the correct
100 order. */
101
102static int next_dummy_order = 1;
103
104
105gfc_namespace *gfc_current_ns;
106gfc_namespace *gfc_global_ns_list;
107
108gfc_gsymbol *gfc_gsym_root = NULL__null;
109
110gfc_symbol *gfc_derived_types;
111
112static gfc_undo_change_set default_undo_chgset_var = { vNULL, vNULL, NULL__null };
113static gfc_undo_change_set *latest_undo_chgset = &default_undo_chgset_var;
114
115
116/*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
117
118/* The following static variable indicates whether a particular element has
119 been explicitly set or not. */
120
121static int new_flag[GFC_LETTERS26];
122
123
124/* Handle a correctly parsed IMPLICIT NONE. */
125
126void
127gfc_set_implicit_none (bool type, bool external, locus *loc)
128{
129 int i;
130
131 if (external)
132 gfc_current_ns->has_implicit_none_export = 1;
133
134 if (type)
135 {
136 gfc_current_ns->seen_implicit_none = 1;
137 for (i = 0; i < GFC_LETTERS26; i++)
138 {
139 if (gfc_current_ns->set_flag[i])
140 {
141 gfc_error_now ("IMPLICIT NONE (type) statement at %L following an "
142 "IMPLICIT statement", loc);
143 return;
144 }
145 gfc_clear_ts (&gfc_current_ns->default_type[i]);
146 gfc_current_ns->set_flag[i] = 1;
147 }
148 }
149}
150
151
152/* Reset the implicit range flags. */
153
154void
155gfc_clear_new_implicit (void)
156{
157 int i;
158
159 for (i = 0; i < GFC_LETTERS26; i++)
160 new_flag[i] = 0;
161}
162
163
164/* Prepare for a new implicit range. Sets flags in new_flag[]. */
165
166bool
167gfc_add_new_implicit_range (int c1, int c2)
168{
169 int i;
170
171 c1 -= 'a';
172 c2 -= 'a';
173
174 for (i = c1; i <= c2; i++)
175 {
176 if (new_flag[i])
177 {
178 gfc_error ("Letter %qc already set in IMPLICIT statement at %C",
179 i + 'A');
180 return false;
181 }
182
183 new_flag[i] = 1;
184 }
185
186 return true;
187}
188
189
190/* Add a matched implicit range for gfc_set_implicit(). Check if merging
191 the new implicit types back into the existing types will work. */
192
193bool
194gfc_merge_new_implicit (gfc_typespec *ts)
195{
196 int i;
197
198 if (gfc_current_ns->seen_implicit_none)
199 {
200 gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
201 return false;
202 }
203
204 for (i = 0; i < GFC_LETTERS26; i++)
205 {
206 if (new_flag[i])
207 {
208 if (gfc_current_ns->set_flag[i])
209 {
210 gfc_error ("Letter %qc already has an IMPLICIT type at %C",
211 i + 'A');
212 return false;
213 }
214
215 gfc_current_ns->default_type[i] = *ts;
216 gfc_current_ns->implicit_loc[i] = gfc_current_locus;
217 gfc_current_ns->set_flag[i] = 1;
218 }
219 }
220 return true;
221}
222
223
224/* Given a symbol, return a pointer to the typespec for its default type. */
225
226gfc_typespec *
227gfc_get_default_type (const char *name, gfc_namespace *ns)
228{
229 char letter;
230
231 letter = name[0];
232
233 if (flag_allow_leading_underscoreglobal_options.x_flag_allow_leading_underscore && letter == '_')
234 gfc_fatal_error ("Option %<-fallow-leading-underscore%> is for use only by "
235 "gfortran developers, and should not be used for "
236 "implicitly typed variables");
237
238 if (letter < 'a' || letter > 'z')
239 gfc_internal_error ("gfc_get_default_type(): Bad symbol %qs", name);
240
241 if (ns == NULL__null)
242 ns = gfc_current_ns;
243
244 return &ns->default_type[letter - 'a'];
245}
246
247
248/* Recursively append candidate SYM to CANDIDATES. Store the number of
249 candidates in CANDIDATES_LEN. */
250
251static void
252lookup_symbol_fuzzy_find_candidates (gfc_symtree *sym,
253 char **&candidates,
254 size_t &candidates_len)
255{
256 gfc_symtree *p;
257
258 if (sym == NULL__null)
259 return;
260
261 if (sym->n.sym->ts.type != BT_UNKNOWN && sym->n.sym->ts.type != BT_PROCEDURE)
262 vec_push (candidates, candidates_len, sym->name);
263 p = sym->left;
264 if (p)
265 lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
266
267 p = sym->right;
268 if (p)
269 lookup_symbol_fuzzy_find_candidates (p, candidates, candidates_len);
270}
271
272
273/* Lookup symbol SYM_NAME fuzzily, taking names in SYMBOL into account. */
274
275static const char*
276lookup_symbol_fuzzy (const char *sym_name, gfc_symbol *symbol)
277{
278 char **candidates = NULL__null;
279 size_t candidates_len = 0;
280 lookup_symbol_fuzzy_find_candidates (symbol->ns->sym_root, candidates,
281 candidates_len);
282 return gfc_closest_fuzzy_match (sym_name, candidates);
283}
284
285
286/* Given a pointer to a symbol, set its type according to the first
287 letter of its name. Fails if the letter in question has no default
288 type. */
289
290bool
291gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
292{
293 gfc_typespec *ts;
294
295 if (sym->ts.type != BT_UNKNOWN)
296 gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
297
298 ts = gfc_get_default_type (sym->name, ns);
299
300 if (ts->type == BT_UNKNOWN)
301 {
302 if (error_flag && !sym->attr.untyped)
303 {
304 const char *guessed = lookup_symbol_fuzzy (sym->name, sym);
305 if (guessed)
306 gfc_error ("Symbol %qs at %L has no IMPLICIT type"
307 "; did you mean %qs?",
308 sym->name, &sym->declared_at, guessed);
309 else
310 gfc_error ("Symbol %qs at %L has no IMPLICIT type",
311 sym->name, &sym->declared_at);
312 sym->attr.untyped = 1; /* Ensure we only give an error once. */
313 }
314
315 return false;
316 }
317
318 sym->ts = *ts;
319 sym->attr.implicit_type = 1;
320
321 if (ts->type == BT_CHARACTER && ts->u.cl)
322 sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
323 else if (ts->type == BT_CLASS
324 && !gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as))
325 return false;
326
327 if (sym->attr.is_bind_c == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
328 {
329 /* BIND(C) variables should not be implicitly declared. */
330 gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared BIND(C) "
331 "variable %qs at %L may not be C interoperable",
332 sym->name, &sym->declared_at);
333 sym->ts.f90_type = sym->ts.type;
334 }
335
336 if (sym->attr.dummy != 0)
337 {
338 if (sym->ns->proc_name != NULL__null
339 && (sym->ns->proc_name->attr.subroutine != 0
340 || sym->ns->proc_name->attr.function != 0)
341 && sym->ns->proc_name->attr.is_bind_c != 0
342 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
343 {
344 /* Dummy args to a BIND(C) routine may not be interoperable if
345 they are implicitly typed. */
346 gfc_warning_now (OPT_Wc_binding_type, "Implicitly declared variable "
347 "%qs at %L may not be C interoperable but it is a "
348 "dummy argument to the BIND(C) procedure %qs at %L",
349 sym->name, &(sym->declared_at),
350 sym->ns->proc_name->name,
351 &(sym->ns->proc_name->declared_at));
352 sym->ts.f90_type = sym->ts.type;
353 }
354 }
355
356 return true;
357}
358
359
360/* This function is called from parse.c(parse_progunit) to check the
361 type of the function is not implicitly typed in the host namespace
362 and to implicitly type the function result, if necessary. */
363
364void
365gfc_check_function_type (gfc_namespace *ns)
366{
367 gfc_symbol *proc = ns->proc_name;
368
369 if (!proc->attr.contained || proc->result->attr.implicit_type)
370 return;
371
372 if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL__null)
373 {
374 if (gfc_set_default_type (proc->result, 0, gfc_current_ns))
375 {
376 if (proc->result != proc)
377 {
378 proc->ts = proc->result->ts;
379 proc->as = gfc_copy_array_spec (proc->result->as);
380 proc->attr.dimension = proc->result->attr.dimension;
381 proc->attr.pointer = proc->result->attr.pointer;
382 proc->attr.allocatable = proc->result->attr.allocatable;
383 }
384 }
385 else if (!proc->result->attr.proc_pointer)
386 {
387 gfc_error ("Function result %qs at %L has no IMPLICIT type",
388 proc->result->name, &proc->result->declared_at);
389 proc->result->attr.untyped = 1;
390 }
391 }
392}
393
394
395/******************** Symbol attribute stuff *********************/
396
397/* This is a generic conflict-checker. We do this to avoid having a
398 single conflict in two places. */
399
400#define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
401#define conf2(a) if (attr->a) { a2 = a; goto conflict; }
402#define conf_std(a, b, std) if (attr->a && attr->b)\
403 {\
404 a1 = a;\
405 a2 = b;\
406 standard = std;\
407 goto conflict_std;\
408 }
409
410bool
411gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where)
412{
413 static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
414 *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
415 *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
416 *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
417 *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
418 *privat = "PRIVATE", *recursive = "RECURSIVE",
419 *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
420 *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
421 *function = "FUNCTION", *subroutine = "SUBROUTINE",
422 *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
423 *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
424 *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
425 *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
426 *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
427 *proc_pointer = "PROCEDURE POINTER", *abstract = "ABSTRACT",
428 *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
429 *contiguous = "CONTIGUOUS", *generic = "GENERIC", *automatic = "AUTOMATIC",
430 *pdt_len = "LEN", *pdt_kind = "KIND";
431 static const char *threadprivate = "THREADPRIVATE";
432 static const char *omp_declare_target = "OMP DECLARE TARGET";
433 static const char *omp_declare_target_link = "OMP DECLARE TARGET LINK";
434 static const char *oacc_declare_copyin = "OACC DECLARE COPYIN";
435 static const char *oacc_declare_create = "OACC DECLARE CREATE";
436 static const char *oacc_declare_deviceptr = "OACC DECLARE DEVICEPTR";
437 static const char *oacc_declare_device_resident =
438 "OACC DECLARE DEVICE_RESIDENT";
439
440 const char *a1, *a2;
441 int standard;
442
443 if (attr->artificial)
444 return true;
445
446 if (where == NULL__null)
447 where = &gfc_current_locus;
448
449 if (attr->pointer && attr->intent != INTENT_UNKNOWN)
450 {
451 a1 = pointer;
452 a2 = intent;
453 standard = GFC_STD_F2003(1<<4);
454 goto conflict_std;
455 }
456
457 if (attr->in_namelist && (attr->allocatable || attr->pointer))
458 {
459 a1 = in_namelist;
460 a2 = attr->allocatable ? allocatable : pointer;
461 standard = GFC_STD_F2003(1<<4);
462 goto conflict_std;
463 }
464
465 /* Check for attributes not allowed in a BLOCK DATA. */
466 if (gfc_current_state ()(gfc_state_stack->state) == COMP_BLOCK_DATA)
467 {
468 a1 = NULL__null;
469
470 if (attr->in_namelist)
471 a1 = in_namelist;
472 if (attr->allocatable)
473 a1 = allocatable;
474 if (attr->external)
475 a1 = external;
476 if (attr->optional)
477 a1 = optional;
478 if (attr->access == ACCESS_PRIVATE)
479 a1 = privat;
480 if (attr->access == ACCESS_PUBLIC)
481 a1 = publik;
482 if (attr->intent != INTENT_UNKNOWN)
483 a1 = intent;
484
485 if (a1 != NULL__null)
486 {
487 gfc_error
488 ("%s attribute not allowed in BLOCK DATA program unit at %L",
489 a1, where);
490 return false;
491 }
492 }
493
494 if (attr->save == SAVE_EXPLICIT)
495 {
496 conf (dummy, save);
497 conf (in_common, save);
498 conf (result, save);
499 conf (automatic, save);
500
501 switch (attr->flavor)
502 {
503 case FL_PROGRAM:
504 case FL_BLOCK_DATA:
505 case FL_MODULE:
506 case FL_LABEL:
507 case_fl_structcase FL_DERIVED: case FL_UNION: case FL_STRUCT:
508 case FL_PARAMETER:
509 a1 = gfc_code2string (flavors, attr->flavor);
510 a2 = save;
511 goto conflict;
512 case FL_NAMELIST:
513 gfc_error ("Namelist group name at %L cannot have the "
514 "SAVE attribute", where);
515 return false;
516 case FL_PROCEDURE:
517 /* Conflicts between SAVE and PROCEDURE will be checked at
518 resolution stage, see "resolve_fl_procedure". */
519 case FL_VARIABLE:
520 default:
521 break;
522 }
523 }
524
525 /* The copying of procedure dummy arguments for module procedures in
526 a submodule occur whilst the current state is COMP_CONTAINS. It
527 is necessary, therefore, to let this through. */
528 if (name && attr->dummy
529 && (attr->function || attr->subroutine)
530 && gfc_current_state ()(gfc_state_stack->state) == COMP_CONTAINS
531 && !(gfc_new_block && gfc_new_block->abr_modproc_decl))
532 gfc_error_now ("internal procedure %qs at %L conflicts with "
533 "DUMMY argument", name, where);
534
535 conf (dummy, entry);
536 conf (dummy, intrinsic);
537 conf (dummy, threadprivate);
538 conf (dummy, omp_declare_target);
539 conf (dummy, omp_declare_target_link);
540 conf (pointer, target);
541 conf (pointer, intrinsic);
542 conf (pointer, elemental);
543 conf (pointer, codimension);
544 conf (allocatable, elemental);
545
546 conf (in_common, automatic);
547 conf (result, automatic);
548 conf (use_assoc, automatic);
549 conf (dummy, automatic);
550
551 conf (target, external);
552 conf (target, intrinsic);
553
554 if (!attr->if_source)
555 conf (external, dimension); /* See Fortran 95's R504. */
556
557 conf (external, intrinsic);
558 conf (entry, intrinsic);
559 conf (abstract, intrinsic);
560
561 if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
562 conf (external, subroutine);
563
564 if (attr->proc_pointer && !gfc_notify_std (GFC_STD_F2003(1<<4),
565 "Procedure pointer at %C"))
566 return false;
567
568 conf (allocatable, pointer);
569 conf_std (allocatable, dummy, GFC_STD_F2003(1<<4));
570 conf_std (allocatable, function, GFC_STD_F2003(1<<4));
571 conf_std (allocatable, result, GFC_STD_F2003(1<<4));
572 conf_std (elemental, recursive, GFC_STD_F2018(1<<9));
573
574 conf (in_common, dummy);
575 conf (in_common, allocatable);
576 conf (in_common, codimension);
577 conf (in_common, result);
578
579 conf (in_equivalence, use_assoc);
580 conf (in_equivalence, codimension);
581 conf (in_equivalence, dummy);
582 conf (in_equivalence, target);
583 conf (in_equivalence, pointer);
584 conf (in_equivalence, function);
585 conf (in_equivalence, result);
586 conf (in_equivalence, entry);
587 conf (in_equivalence, allocatable);
588 conf (in_equivalence, threadprivate);
589 conf (in_equivalence, omp_declare_target);
590 conf (in_equivalence, omp_declare_target_link);
591 conf (in_equivalence, oacc_declare_create);
592 conf (in_equivalence, oacc_declare_copyin);
593 conf (in_equivalence, oacc_declare_deviceptr);
594 conf (in_equivalence, oacc_declare_device_resident);
595 conf (in_equivalence, is_bind_c);
596
597 conf (dummy, result);
598 conf (entry, result);
599 conf (generic, result);
600 conf (generic, omp_declare_target);
601 conf (generic, omp_declare_target_link);
602
603 conf (function, subroutine);
604
605 if (!function && !subroutine)
606 conf (is_bind_c, dummy);
607
608 conf (is_bind_c, cray_pointer);
609 conf (is_bind_c, cray_pointee);
610 conf (is_bind_c, codimension);
611 conf (is_bind_c, allocatable);
612 conf (is_bind_c, elemental);
613
614 /* Need to also get volatile attr, according to 5.1 of F2003 draft.
615 Parameter conflict caught below. Also, value cannot be specified
616 for a dummy procedure. */
617
618 /* Cray pointer/pointee conflicts. */
619 conf (cray_pointer, cray_pointee);
620 conf (cray_pointer, dimension);
621 conf (cray_pointer, codimension);
622 conf (cray_pointer, contiguous);
623 conf (cray_pointer, pointer);
624 conf (cray_pointer, target);
625 conf (cray_pointer, allocatable);
626 conf (cray_pointer, external);
627 conf (cray_pointer, intrinsic);
628 conf (cray_pointer, in_namelist);
629 conf (cray_pointer, function);
630 conf (cray_pointer, subroutine);
631 conf (cray_pointer, entry);
632
633 conf (cray_pointee, allocatable);
634 conf (cray_pointee, contiguous);
635 conf (cray_pointee, codimension);
636 conf (cray_pointee, intent);
637 conf (cray_pointee, optional);
638 conf (cray_pointee, dummy);
639 conf (cray_pointee, target);
640 conf (cray_pointee, intrinsic);
641 conf (cray_pointee, pointer);
642 conf (cray_pointee, entry);
643 conf (cray_pointee, in_common);
644 conf (cray_pointee, in_equivalence);
645 conf (cray_pointee, threadprivate);
646 conf (cray_pointee, omp_declare_target);
647 conf (cray_pointee, omp_declare_target_link);
648 conf (cray_pointee, oacc_declare_create);
649 conf (cray_pointee, oacc_declare_copyin);
650 conf (cray_pointee, oacc_declare_deviceptr);
651 conf (cray_pointee, oacc_declare_device_resident);
652
653 conf (data, dummy);
654 conf (data, function);
655 conf (data, result);
656 conf (data, allocatable);
657
658 conf (value, pointer)
659 conf (value, allocatable)
660 conf (value, subroutine)
661 conf (value, function)
662 conf (value, volatile_)
663 conf (value, dimension)
664 conf (value, codimension)
665 conf (value, external)
666
667 conf (codimension, result)
668
669 if (attr->value
670 && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
671 {
672 a1 = value;
673 a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
674 goto conflict;
675 }
676
677 conf (is_protected, intrinsic)
678 conf (is_protected, in_common)
679
680 conf (asynchronous, intrinsic)
681 conf (asynchronous, external)
682
683 conf (volatile_, intrinsic)
684 conf (volatile_, external)
685
686 if (attr->volatile_ && attr->intent == INTENT_IN)
687 {
688 a1 = volatile_;
689 a2 = intent_in;
690 goto conflict;
691 }
692
693 conf (procedure, allocatable)
694 conf (procedure, dimension)
695 conf (procedure, codimension)
696 conf (procedure, intrinsic)
697 conf (procedure, target)
698 conf (procedure, value)
699 conf (procedure, volatile_)
700 conf (procedure, asynchronous)
701 conf (procedure, entry)
702
703 conf (proc_pointer, abstract)
704 conf (proc_pointer, omp_declare_target)
705 conf (proc_pointer, omp_declare_target_link)
706
707 conf (entry, omp_declare_target)
708 conf (entry, omp_declare_target_link)
709 conf (entry, oacc_declare_create)
710 conf (entry, oacc_declare_copyin)
711 conf (entry, oacc_declare_deviceptr)
712 conf (entry, oacc_declare_device_resident)
713
714 conf (pdt_kind, allocatable)
715 conf (pdt_kind, pointer)
716 conf (pdt_kind, dimension)
717 conf (pdt_kind, codimension)
718
719 conf (pdt_len, allocatable)
720 conf (pdt_len, pointer)
721 conf (pdt_len, dimension)
722 conf (pdt_len, codimension)
723
724 if (attr->access == ACCESS_PRIVATE)
725 {
726 a1 = privat;
727 conf2 (pdt_kind);
728 conf2 (pdt_len);
729 }
730
731 a1 = gfc_code2string (flavors, attr->flavor);
732
733 if (attr->in_namelist
734 && attr->flavor != FL_VARIABLE
735 && attr->flavor != FL_PROCEDURE
736 && attr->flavor != FL_UNKNOWN)
737 {
738 a2 = in_namelist;
739 goto conflict;
740 }
741
742 switch (attr->flavor)
743 {
744 case FL_PROGRAM:
745 case FL_BLOCK_DATA:
746 case FL_MODULE:
747 case FL_LABEL:
748 conf2 (codimension);
749 conf2 (dimension);
750 conf2 (dummy);
751 conf2 (volatile_);
752 conf2 (asynchronous);
753 conf2 (contiguous);
754 conf2 (pointer);
755 conf2 (is_protected);
756 conf2 (target);
757 conf2 (external);
758 conf2 (intrinsic);
759 conf2 (allocatable);
760 conf2 (result);
761 conf2 (in_namelist);
762 conf2 (optional);
763 conf2 (function);
764 conf2 (subroutine);
765 conf2 (threadprivate);
766 conf2 (omp_declare_target);
767 conf2 (omp_declare_target_link);
768 conf2 (oacc_declare_create);
769 conf2 (oacc_declare_copyin);
770 conf2 (oacc_declare_deviceptr);
771 conf2 (oacc_declare_device_resident);
772
773 if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
774 {
775 a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
776 gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
777 name, where);
778 return false;
779 }
780
781 if (attr->is_bind_c)
782 {
783 gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
784 return false;
785 }
786
787 break;
788
789 case FL_VARIABLE:
790 break;
791
792 case FL_NAMELIST:
793 conf2 (result);
794 break;
795
796 case FL_PROCEDURE:
797 /* Conflicts with INTENT, SAVE and RESULT will be checked
798 at resolution stage, see "resolve_fl_procedure". */
799
800 if (attr->subroutine)
801 {
802 a1 = subroutine;
803 conf2 (target);
804 conf2 (allocatable);
805 conf2 (volatile_);
806 conf2 (asynchronous);
807 conf2 (in_namelist);
808 conf2 (codimension);
809 conf2 (dimension);
810 conf2 (function);
811 if (!attr->proc_pointer)
812 conf2 (threadprivate);
813 }
814
815 /* Procedure pointers in COMMON blocks are allowed in F03,
816 * but forbidden per F08:C5100. */
817 if (!attr->proc_pointer || (gfc_option.allow_std & GFC_STD_F2008(1<<7)))
818 conf2 (in_common);
819
820 conf2 (omp_declare_target_link);
821
822 switch (attr->proc)
823 {
824 case PROC_ST_FUNCTION:
825 conf2 (dummy);
826 conf2 (target);
827 break;
828
829 case PROC_MODULE:
830 conf2 (dummy);
831 break;
832
833 case PROC_DUMMY:
834 conf2 (result);
835 conf2 (threadprivate);
836 break;
837
838 default:
839 break;
840 }
841
842 break;
843
844 case_fl_structcase FL_DERIVED: case FL_UNION: case FL_STRUCT:
845 conf2 (dummy);
846 conf2 (pointer);
847 conf2 (target);
848 conf2 (external);
849 conf2 (intrinsic);
850 conf2 (allocatable);
851 conf2 (optional);
852 conf2 (entry);
853 conf2 (function);
854 conf2 (subroutine);
855 conf2 (threadprivate);
856 conf2 (result);
857 conf2 (omp_declare_target);
858 conf2 (omp_declare_target_link);
859 conf2 (oacc_declare_create);
860 conf2 (oacc_declare_copyin);
861 conf2 (oacc_declare_deviceptr);
862 conf2 (oacc_declare_device_resident);
863
864 if (attr->intent != INTENT_UNKNOWN)
865 {
866 a2 = intent;
867 goto conflict;
868 }
869 break;
870
871 case FL_PARAMETER:
872 conf2 (external);
873 conf2 (intrinsic);
874 conf2 (optional);
875 conf2 (allocatable);
876 conf2 (function);
877 conf2 (subroutine);
878 conf2 (entry);
879 conf2 (contiguous);
880 conf2 (pointer);
881 conf2 (is_protected);
882 conf2 (target);
883 conf2 (dummy);
884 conf2 (in_common);
885 conf2 (value);
886 conf2 (volatile_);
887 conf2 (asynchronous);
888 conf2 (threadprivate);
889 conf2 (value);
890 conf2 (codimension);
891 conf2 (result);
892 if (!attr->is_iso_c)
893 conf2 (is_bind_c);
894 break;
895
896 default:
897 break;
898 }
899
900 return true;
901
902conflict:
903 if (name == NULL__null)
904 gfc_error ("%s attribute conflicts with %s attribute at %L",
905 a1, a2, where);
906 else
907 gfc_error ("%s attribute conflicts with %s attribute in %qs at %L",
908 a1, a2, name, where);
909
910 return false;
911
912conflict_std:
913 if (name == NULL__null)
914 {
915 return gfc_notify_std (standard, "%s attribute conflicts "
916 "with %s attribute at %L", a1, a2,
917 where);
918 }
919 else
920 {
921 return gfc_notify_std (standard, "%s attribute conflicts "
922 "with %s attribute in %qs at %L",
923 a1, a2, name, where);
924 }
925}
926
927#undef conf
928#undef conf2
929#undef conf_std
930
931
932/* Mark a symbol as referenced. */
933
934void
935gfc_set_sym_referenced (gfc_symbol *sym)
936{
937
938 if (sym->attr.referenced)
939 return;
940
941 sym->attr.referenced = 1;
942
943 /* Remember which order dummy variables are accessed in. */
944 if (sym->attr.dummy)
945 sym->dummy_order = next_dummy_order++;
946}
947
948
949/* Common subroutine called by attribute changing subroutines in order
950 to prevent them from changing a symbol that has been
951 use-associated. Returns zero if it is OK to change the symbol,
952 nonzero if not. */
953
954static int
955check_used (symbol_attribute *attr, const char *name, locus *where)
956{
957
958 if (attr->use_assoc == 0)
959 return 0;
960
961 if (where == NULL__null)
962 where = &gfc_current_locus;
963
964 if (name == NULL__null)
965 gfc_error ("Cannot change attributes of USE-associated symbol at %L",
966 where);
967 else
968 gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
969 name, where);
970
971 return 1;
972}
973
974
975/* Generate an error because of a duplicate attribute. */
976
977static void
978duplicate_attr (const char *attr, locus *where)
979{
980
981 if (where == NULL__null)
982 where = &gfc_current_locus;
983
984 gfc_error ("Duplicate %s attribute specified at %L", attr, where);
985}
986
987
988bool
989gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
990 locus *where ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
991{
992 attr->ext_attr |= 1 << ext_attr;
993 return true;
994}
995
996
997/* Called from decl.c (attr_decl1) to check attributes, when declared
998 separately. */
999
1000bool
1001gfc_add_attribute (symbol_attribute *attr, locus *where)
1002{
1003 if (check_used (attr, NULL__null, where))
1004 return false;
1005
1006 return gfc_check_conflict (attr, NULL__null, where);
1007}
1008
1009
1010bool
1011gfc_add_allocatable (symbol_attribute *attr, locus *where)
1012{
1013
1014 if (check_used (attr, NULL__null, where))
1015 return false;
1016
1017 if (attr->allocatable && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure)
)
1018 {
1019 duplicate_attr ("ALLOCATABLE", where);
1020 return false;
1021 }
1022
1023 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1024 && !gfc_find_state (COMP_INTERFACE))
1025 {
1026 gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
1027 where);
1028 return false;
1029 }
1030
1031 attr->allocatable = 1;
1032 return gfc_check_conflict (attr, NULL__null, where);
1033}
1034
1035
1036bool
1037gfc_add_automatic (symbol_attribute *attr, const char *name, locus *where)
1038{
1039 if (check_used (attr, name, where))
1040 return false;
1041
1042 if (attr->automatic && !gfc_notify_std (GFC_STD_LEGACY(1<<6),
1043 "Duplicate AUTOMATIC attribute specified at %L", where))
1044 return false;
1045
1046 attr->automatic = 1;
1047 return gfc_check_conflict (attr, name, where);
1048}
1049
1050
1051bool
1052gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
1053{
1054
1055 if (check_used (attr, name, where))
1056 return false;
1057
1058 if (attr->codimension)
1059 {
1060 duplicate_attr ("CODIMENSION", where);
1061 return false;
1062 }
1063
1064 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1065 && !gfc_find_state (COMP_INTERFACE))
1066 {
1067 gfc_error ("CODIMENSION specified for %qs outside its INTERFACE body "
1068 "at %L", name, where);
1069 return false;
1070 }
1071
1072 attr->codimension = 1;
1073 return gfc_check_conflict (attr, name, where);
1074}
1075
1076
1077bool
1078gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
1079{
1080
1081 if (check_used (attr, name, where))
1082 return false;
1083
1084 if (attr->dimension && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure)
)
1085 {
1086 duplicate_attr ("DIMENSION", where);
1087 return false;
1088 }
1089
1090 if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
1091 && !gfc_find_state (COMP_INTERFACE))
1092 {
1093 gfc_error ("DIMENSION specified for %qs outside its INTERFACE body "
1094 "at %L", name, where);
1095 return false;
1096 }
1097
1098 attr->dimension = 1;
1099 return gfc_check_conflict (attr, name, where);
1100}
1101
1102
1103bool
1104gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
1105{
1106
1107 if (check_used (attr, name, where))
1108 return false;
1109
1110 attr->contiguous = 1;
1111 return gfc_check_conflict (attr, name, where);
1112}
1113
1114
1115bool
1116gfc_add_external (symbol_attribute *attr, locus *where)
1117{
1118
1119 if (check_used (attr, NULL__null, where))
1120 return false;
1121
1122 if (attr->external)
1123 {
1124 duplicate_attr ("EXTERNAL", where);
1125 return false;
1126 }
1127
1128 if (attr->pointer && attr->if_source != IFSRC_IFBODY)
1129 {
1130 attr->pointer = 0;
1131 attr->proc_pointer = 1;
1132 }
1133
1134 attr->external = 1;
1135
1136 return gfc_check_conflict (attr, NULL__null, where);
1137}
1138
1139
1140bool
1141gfc_add_intrinsic (symbol_attribute *attr, locus *where)
1142{
1143
1144 if (check_used (attr, NULL__null, where))
1145 return false;
1146
1147 if (attr->intrinsic)
1148 {
1149 duplicate_attr ("INTRINSIC", where);
1150 return false;
1151 }
1152
1153 attr->intrinsic = 1;
1154
1155 return gfc_check_conflict (attr, NULL__null, where);
1156}
1157
1158
1159bool
1160gfc_add_optional (symbol_attribute *attr, locus *where)
1161{
1162
1163 if (check_used (attr, NULL__null, where))
1164 return false;
1165
1166 if (attr->optional)
1167 {
1168 duplicate_attr ("OPTIONAL", where);
1169 return false;
1170 }
1171
1172 attr->optional = 1;
1173 return gfc_check_conflict (attr, NULL__null, where);
1174}
1175
1176bool
1177gfc_add_kind (symbol_attribute *attr, locus *where)
1178{
1179 if (attr->pdt_kind)
1180 {
1181 duplicate_attr ("KIND", where);
1182 return false;
1183 }
1184
1185 attr->pdt_kind = 1;
1186 return gfc_check_conflict (attr, NULL__null, where);
1187}
1188
1189bool
1190gfc_add_len (symbol_attribute *attr, locus *where)
1191{
1192 if (attr->pdt_len)
1193 {
1194 duplicate_attr ("LEN", where);
1195 return false;
1196 }
1197
1198 attr->pdt_len = 1;
1199 return gfc_check_conflict (attr, NULL__null, where);
1200}
1201
1202
1203bool
1204gfc_add_pointer (symbol_attribute *attr, locus *where)
1205{
1206
1207 if (check_used (attr, NULL__null, where))
1208 return false;
1209
1210 if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1211 && !gfc_find_state (COMP_INTERFACE))
1212 && ! gfc_submodule_procedure(attr)(gfc_state_stack->previous && gfc_state_stack->
previous->previous && gfc_state_stack->previous
->previous->state == COMP_SUBMODULE && attr->
module_procedure)
)
1213 {
1214 duplicate_attr ("POINTER", where);
1215 return false;
1216 }
1217
1218 if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1219 || (attr->if_source == IFSRC_IFBODY
1220 && !gfc_find_state (COMP_INTERFACE)))
1221 attr->proc_pointer = 1;
1222 else
1223 attr->pointer = 1;
1224
1225 return gfc_check_conflict (attr, NULL__null, where);
1226}
1227
1228
1229bool
1230gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1231{
1232
1233 if (check_used (attr, NULL__null, where))
1234 return false;
1235
1236 attr->cray_pointer = 1;
1237 return gfc_check_conflict (attr, NULL__null, where);
1238}
1239
1240
1241bool
1242gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1243{
1244
1245 if (check_used (attr, NULL__null, where))
1246 return false;
1247
1248 if (attr->cray_pointee)
1249 {
1250 gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1251 " statements", where);
1252 return false;
1253 }
1254
1255 attr->cray_pointee = 1;
1256 return gfc_check_conflict (attr, NULL__null, where);
1257}
1258
1259
1260bool
1261gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1262{
1263 if (check_used (attr, name, where))
1264 return false;
1265
1266 if (attr->is_protected)
1267 {
1268 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
1269 "Duplicate PROTECTED attribute specified at %L",
1270 where))
1271 return false;
1272 }
1273
1274 attr->is_protected = 1;
1275 return gfc_check_conflict (attr, name, where);
1276}
1277
1278
1279bool
1280gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1281{
1282
1283 if (check_used (attr, name, where))
1284 return false;
1285
1286 attr->result = 1;
1287 return gfc_check_conflict (attr, name, where);
1288}
1289
1290
1291bool
1292gfc_add_save (symbol_attribute *attr, save_state s, const char *name,
1293 locus *where)
1294{
1295
1296 if (check_used (attr, name, where))
1297 return false;
1298
1299 if (s == SAVE_EXPLICIT && gfc_pure (NULL__null))
1300 {
1301 gfc_error
1302 ("SAVE attribute at %L cannot be specified in a PURE procedure",
1303 where);
1304 return false;
1305 }
1306
1307 if (s == SAVE_EXPLICIT)
1308 gfc_unset_implicit_pure (NULL__null);
1309
1310 if (s == SAVE_EXPLICIT && attr->save == SAVE_EXPLICIT
1311 && (flag_automaticglobal_options.x_flag_automatic || pedanticglobal_options.x_pedantic))
1312 {
1313 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
1314 "Duplicate SAVE attribute specified at %L",
1315 where))
1316 return false;
1317 }
1318
1319 attr->save = s;
1320 return gfc_check_conflict (attr, name, where);
1321}
1322
1323
1324bool
1325gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1326{
1327
1328 if (check_used (attr, name, where))
1329 return false;
1330
1331 if (attr->value)
1332 {
1333 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
1334 "Duplicate VALUE attribute specified at %L",
1335 where))
1336 return false;
1337 }
1338
1339 attr->value = 1;
1340 return gfc_check_conflict (attr, name, where);
1341}
1342
1343
1344bool
1345gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1346{
1347 /* No check_used needed as 11.2.1 of the F2003 standard allows
1348 that the local identifier made accessible by a use statement can be
1349 given a VOLATILE attribute - unless it is a coarray (F2008, C560). */
1350
1351 if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1352 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
1353 "Duplicate VOLATILE attribute specified at %L",
1354 where))
1355 return false;
1356
1357 /* F2008: C1282 A designator of a variable with the VOLATILE attribute
1358 shall not appear in a pure subprogram.
1359
1360 F2018: C1588 A local variable of a pure subprogram, or of a BLOCK
1361 construct within a pure subprogram, shall not have the SAVE or
1362 VOLATILE attribute. */
1363 if (gfc_pure (NULL__null))
1364 {
1365 gfc_error ("VOLATILE attribute at %L cannot be specified in a "
1366 "PURE procedure", where);
1367 return false;
1368 }
1369
1370
1371 attr->volatile_ = 1;
1372 attr->volatile_ns = gfc_current_ns;
1373 return gfc_check_conflict (attr, name, where);
1374}
1375
1376
1377bool
1378gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1379{
1380 /* No check_used needed as 11.2.1 of the F2003 standard allows
1381 that the local identifier made accessible by a use statement can be
1382 given a ASYNCHRONOUS attribute. */
1383
1384 if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1385 if (!gfc_notify_std (GFC_STD_LEGACY(1<<6),
1386 "Duplicate ASYNCHRONOUS attribute specified at %L",
1387 where))
1388 return false;
1389
1390 attr->asynchronous = 1;
1391 attr->asynchronous_ns = gfc_current_ns;
1392 return gfc_check_conflict (attr, name, where);
1393}
1394
1395
1396bool
1397gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1398{
1399
1400 if (check_used (attr, name, where))
1401 return false;
1402
1403 if (attr->threadprivate)
1404 {
1405 duplicate_attr ("THREADPRIVATE", where);
1406 return false;
1407 }
1408
1409 attr->threadprivate = 1;
1410 return gfc_check_conflict (attr, name, where);
1411}
1412
1413
1414bool
1415gfc_add_omp_declare_target (symbol_attribute *attr, const char *name,
1416 locus *where)
1417{
1418
1419 if (check_used (attr, name, where))
1420 return false;
1421
1422 if (attr->omp_declare_target)
1423 return true;
1424
1425 attr->omp_declare_target = 1;
1426 return gfc_check_conflict (attr, name, where);
1427}
1428
1429
1430bool
1431gfc_add_omp_declare_target_link (symbol_attribute *attr, const char *name,
1432 locus *where)
1433{
1434
1435 if (check_used (attr, name, where))
1436 return false;
1437
1438 if (attr->omp_declare_target_link)
1439 return true;
1440
1441 attr->omp_declare_target_link = 1;
1442 return gfc_check_conflict (attr, name, where);
1443}
1444
1445
1446bool
1447gfc_add_oacc_declare_create (symbol_attribute *attr, const char *name,
1448 locus *where)
1449{
1450 if (check_used (attr, name, where))
1451 return false;
1452
1453 if (attr->oacc_declare_create)
1454 return true;
1455
1456 attr->oacc_declare_create = 1;
1457 return gfc_check_conflict (attr, name, where);
1458}
1459
1460
1461bool
1462gfc_add_oacc_declare_copyin (symbol_attribute *attr, const char *name,
1463 locus *where)
1464{
1465 if (check_used (attr, name, where))
1466 return false;
1467
1468 if (attr->oacc_declare_copyin)
1469 return true;
1470
1471 attr->oacc_declare_copyin = 1;
1472 return gfc_check_conflict (attr, name, where);
1473}
1474
1475
1476bool
1477gfc_add_oacc_declare_deviceptr (symbol_attribute *attr, const char *name,
1478 locus *where)
1479{
1480 if (check_used (attr, name, where))
1481 return false;
1482
1483 if (attr->oacc_declare_deviceptr)
1484 return true;
1485
1486 attr->oacc_declare_deviceptr = 1;
1487 return gfc_check_conflict (attr, name, where);
1488}
1489
1490
1491bool
1492gfc_add_oacc_declare_device_resident (symbol_attribute *attr, const char *name,
1493 locus *where)
1494{
1495 if (check_used (attr, name, where))
1496 return false;
1497
1498 if (attr->oacc_declare_device_resident)
1499 return true;
1500
1501 attr->oacc_declare_device_resident = 1;
1502 return gfc_check_conflict (attr, name, where);
1503}
1504
1505
1506bool
1507gfc_add_target (symbol_attribute *attr, locus *where)
1508{
1509
1510 if (check_used (attr, NULL__null, where))
1511 return false;
1512
1513 if (attr->target)
1514 {
1515 duplicate_attr ("TARGET", where);
1516 return false;
1517 }
1518
1519 attr->target = 1;
1520 return gfc_check_conflict (attr, NULL__null, where);
1521}
1522
1523
1524bool
1525gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1526{
1527
1528 if (check_used (attr, name, where))
1529 return false;
1530
1531 /* Duplicate dummy arguments are allowed due to ENTRY statements. */
1532 attr->dummy = 1;
1533 return gfc_check_conflict (attr, name, where);
1534}
1535
1536
1537bool
1538gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1539{
1540
1541 if (check_used (attr, name, where))
1542 return false;
1543
1544 /* Duplicate attribute already checked for. */
1545 attr->in_common = 1;
1546 return gfc_check_conflict (attr, name, where);
1547}
1548
1549
1550bool
1551gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1552{
1553
1554 /* Duplicate attribute already checked for. */
1555 attr->in_equivalence = 1;
1556 if (!gfc_check_conflict (attr, name, where))
1557 return false;
1558
1559 if (attr->flavor == FL_VARIABLE)
1560 return true;
1561
1562 return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1563}
1564
1565
1566bool
1567gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1568{
1569
1570 if (check_used (attr, name, where))
1571 return false;
1572
1573 attr->data = 1;
1574 return gfc_check_conflict (attr, name, where);
1575}
1576
1577
1578bool
1579gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1580{
1581
1582 attr->in_namelist = 1;
1583 return gfc_check_conflict (attr, name, where);
1584}
1585
1586
1587bool
1588gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1589{
1590
1591 if (check_used (attr, name, where))
1592 return false;
1593
1594 attr->sequence = 1;
1595 return gfc_check_conflict (attr, name, where);
1596}
1597
1598
1599bool
1600gfc_add_elemental (symbol_attribute *attr, locus *where)
1601{
1602
1603 if (check_used (attr, NULL__null, where))
1604 return false;
1605
1606 if (attr->elemental)
1607 {
1608 duplicate_attr ("ELEMENTAL", where);
1609 return false;
1610 }
1611
1612 attr->elemental = 1;
1613 return gfc_check_conflict (attr, NULL__null, where);
1614}
1615
1616
1617bool
1618gfc_add_pure (symbol_attribute *attr, locus *where)
1619{
1620
1621 if (check_used (attr, NULL__null, where))
1622 return false;
1623
1624 if (attr->pure)
1625 {
1626 duplicate_attr ("PURE", where);
1627 return false;
1628 }
1629
1630 attr->pure = 1;
1631 return gfc_check_conflict (attr, NULL__null, where);
1632}
1633
1634
1635bool
1636gfc_add_recursive (symbol_attribute *attr, locus *where)
1637{
1638
1639 if (check_used (attr, NULL__null, where))
1640 return false;
1641
1642 if (attr->recursive)
1643 {
1644 duplicate_attr ("RECURSIVE", where);
1645 return false;
1646 }
1647
1648 attr->recursive = 1;
1649 return gfc_check_conflict (attr, NULL__null, where);
1650}
1651
1652
1653bool
1654gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1655{
1656
1657 if (check_used (attr, name, where))
1658 return false;
1659
1660 if (attr->entry)
1661 {
1662 duplicate_attr ("ENTRY", where);
1663 return false;
1664 }
1665
1666 attr->entry = 1;
1667 return gfc_check_conflict (attr, name, where);
1668}
1669
1670
1671bool
1672gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1673{
1674
1675 if (attr->flavor != FL_PROCEDURE
1676 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1677 return false;
1678
1679 attr->function = 1;
1680 return gfc_check_conflict (attr, name, where);
1681}
1682
1683
1684bool
1685gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1686{
1687
1688 if (attr->flavor != FL_PROCEDURE
1689 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1690 return false;
1691
1692 attr->subroutine = 1;
1693
1694 /* If we are looking at a BLOCK DATA statement and we encounter a
1695 name with a leading underscore (which must be
1696 compiler-generated), do not check. See PR 84394. */
1697
1698 if (name && *name != '_' && gfc_current_state ()(gfc_state_stack->state) != COMP_BLOCK_DATA)
1699 return gfc_check_conflict (attr, name, where);
1700 else
1701 return true;
1702}
1703
1704
1705bool
1706gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1707{
1708
1709 if (attr->flavor != FL_PROCEDURE
1710 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1711 return false;
1712
1713 attr->generic = 1;
1714 return gfc_check_conflict (attr, name, where);
1715}
1716
1717
1718bool
1719gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1720{
1721
1722 if (check_used (attr, NULL__null, where))
1723 return false;
1724
1725 if (attr->flavor != FL_PROCEDURE
1726 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1727 return false;
1728
1729 if (attr->procedure)
1730 {
1731 duplicate_attr ("PROCEDURE", where);
1732 return false;
1733 }
1734
1735 attr->procedure = 1;
1736
1737 return gfc_check_conflict (attr, NULL__null, where);
1738}
1739
1740
1741bool
1742gfc_add_abstract (symbol_attribute* attr, locus* where)
1743{
1744 if (attr->abstract)
1745 {
1746 duplicate_attr ("ABSTRACT", where);
1747 return false;
1748 }
1749
1750 attr->abstract = 1;
1751
1752 return gfc_check_conflict (attr, NULL__null, where);
1753}
1754
1755
1756/* Flavors are special because some flavors are not what Fortran
1757 considers attributes and can be reaffirmed multiple times. */
1758
1759bool
1760gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1761 locus *where)
1762{
1763
1764 if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1765 || f == FL_PARAMETER || f == FL_LABEL || gfc_fl_struct(f)((f) == FL_DERIVED || (f) == FL_UNION || (f) == FL_STRUCT)
1766 || f == FL_NAMELIST) && check_used (attr, name, where))
1767 return false;
1768
1769 if (attr->flavor == f && f == FL_VARIABLE)
1770 return true;
1771
1772 /* Copying a procedure dummy argument for a module procedure in a
1773 submodule results in the flavor being copied and would result in
1774 an error without this. */
1775 if (gfc_new_block && gfc_new_block->abr_modproc_decl
1776 && attr->flavor == f && f == FL_PROCEDURE)
1777 return true;
1778
1779 if (attr->flavor != FL_UNKNOWN)
1780 {
1781 if (where == NULL__null)
1782 where = &gfc_current_locus;
1783
1784 if (name)
1785 gfc_error ("%s attribute of %qs conflicts with %s attribute at %L",
1786 gfc_code2string (flavors, attr->flavor), name,
1787 gfc_code2string (flavors, f), where);
1788 else
1789 gfc_error ("%s attribute conflicts with %s attribute at %L",
1790 gfc_code2string (flavors, attr->flavor),
1791 gfc_code2string (flavors, f), where);
1792
1793 return false;
1794 }
1795
1796 attr->flavor = f;
1797
1798 return gfc_check_conflict (attr, name, where);
1799}
1800
1801
1802bool
1803gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1804 const char *name, locus *where)
1805{
1806
1807 if (check_used (attr, name, where))
1808 return false;
1809
1810 if (attr->flavor != FL_PROCEDURE
1811 && !gfc_add_flavor (attr, FL_PROCEDURE, name, where))
1812 return false;
1813
1814 if (where == NULL__null)
1815 where = &gfc_current_locus;
1816
1817 if (attr->proc != PROC_UNKNOWN && !attr->module_procedure
1818 && attr->access == ACCESS_UNKNOWN)
1819 {
1820 if (attr->proc == PROC_ST_FUNCTION && t == PROC_INTERNAL
1821 && !gfc_notification_std (GFC_STD_F2008(1<<7)))
1822 gfc_error ("%s procedure at %L is already declared as %s "
1823 "procedure. \nF2008: A pointer function assignment "
1824 "is ambiguous if it is the first executable statement "
1825 "after the specification block. Please add any other "
1826 "kind of executable statement before it. FIXME",
1827 gfc_code2string (procedures, t), where,
1828 gfc_code2string (procedures, attr->proc));
1829 else
1830 gfc_error ("%s procedure at %L is already declared as %s "
1831 "procedure", gfc_code2string (procedures, t), where,
1832 gfc_code2string (procedures, attr->proc));
1833
1834 return false;
1835 }
1836
1837 attr->proc = t;
1838
1839 /* Statement functions are always scalar and functions. */
1840 if (t == PROC_ST_FUNCTION
1841 && ((!attr->function && !gfc_add_function (attr, name, where))
1842 || attr->dimension))
1843 return false;
1844
1845 return gfc_check_conflict (attr, name, where);
1846}
1847
1848
1849bool
1850gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1851{
1852
1853 if (check_used (attr, NULL__null, where))
1854 return false;
1855
1856 if (attr->intent == INTENT_UNKNOWN)
1857 {
1858 attr->intent = intent;
1859 return gfc_check_conflict (attr, NULL__null, where);
1860 }
1861
1862 if (where == NULL__null)
1863 where = &gfc_current_locus;
1864
1865 gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1866 gfc_intent_string (attr->intent),
1867 gfc_intent_string (intent), where);
1868
1869 return false;
1870}
1871
1872
1873/* No checks for use-association in public and private statements. */
1874
1875bool
1876gfc_add_access (symbol_attribute *attr, gfc_access access,
1877 const char *name, locus *where)
1878{
1879
1880 if (attr->access == ACCESS_UNKNOWN
1881 || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1882 {
1883 attr->access = access;
1884 return gfc_check_conflict (attr, name, where);
1885 }
1886
1887 if (where == NULL__null)
1888 where = &gfc_current_locus;
1889 gfc_error ("ACCESS specification at %L was already specified", where);
1890
1891 return false;
1892}
1893
1894
1895/* Set the is_bind_c field for the given symbol_attribute. */
1896
1897bool
1898gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1899 int is_proc_lang_bind_spec)
1900{
1901
1902 if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1903 gfc_error_now ("BIND(C) attribute at %L can only be used for "
1904 "variables or common blocks", where);
1905 else if (attr->is_bind_c)
1906 gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1907 else
1908 attr->is_bind_c = 1;
1909
1910 if (where == NULL__null)
1911 where = &gfc_current_locus;
1912
1913 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "BIND(C) at %L", where))
1914 return false;
1915
1916 return gfc_check_conflict (attr, name, where);
1917}
1918
1919
1920/* Set the extension field for the given symbol_attribute. */
1921
1922bool
1923gfc_add_extension (symbol_attribute *attr, locus *where)
1924{
1925 if (where == NULL__null)
1926 where = &gfc_current_locus;
1927
1928 if (attr->extension)
1929 gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1930 else
1931 attr->extension = 1;
1932
1933 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "EXTENDS at %L", where))
1934 return false;
1935
1936 return true;
1937}
1938
1939
1940bool
1941gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1942 gfc_formal_arglist * formal, locus *where)
1943{
1944 if (check_used (&sym->attr, sym->name, where))
1945 return false;
1946
1947 /* Skip the following checks in the case of a module_procedures in a
1948 submodule since they will manifestly fail. */
1949 if (sym->attr.module_procedure == 1
1950 && source == IFSRC_DECL)
1951 goto finish;
1952
1953 if (where == NULL__null)
1954 where = &gfc_current_locus;
1955
1956 if (sym->attr.if_source != IFSRC_UNKNOWN
1957 && sym->attr.if_source != IFSRC_DECL)
1958 {
1959 gfc_error ("Symbol %qs at %L already has an explicit interface",
1960 sym->name, where);
1961 return false;
1962 }
1963
1964 if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1965 {
1966 gfc_error ("%qs at %L has attributes specified outside its INTERFACE "
1967 "body", sym->name, where);
1968 return false;
1969 }
1970
1971finish:
1972 sym->formal = formal;
1973 sym->attr.if_source = source;
1974
1975 return true;
1976}
1977
1978
1979/* Add a type to a symbol. */
1980
1981bool
1982gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1983{
1984 sym_flavor flavor;
1985 bt type;
1986
1987 if (where == NULL__null)
1988 where = &gfc_current_locus;
1989
1990 if (sym->result)
1991 type = sym->result->ts.type;
1992 else
1993 type = sym->ts.type;
1994
1995 if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1996 type = sym->ns->proc_name->ts.type;
1997
1998 if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type)
1999 && !(gfc_state_stack->previous && gfc_state_stack->previous->previous
2000 && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
2001 && !sym->attr.module_procedure)
2002 {
2003 if (sym->attr.use_assoc)
2004 gfc_error ("Symbol %qs at %L conflicts with symbol from module %qs, "
2005 "use-associated at %L", sym->name, where, sym->module,
2006 &sym->declared_at);
2007 else if (sym->attr.function && sym->attr.result)
2008 gfc_error ("Symbol %qs at %L already has basic type of %s",
2009 sym->ns->proc_name->name, where, gfc_basic_typename (type));
2010 else
2011 gfc_error ("Symbol %qs at %L already has basic type of %s", sym->name,
2012 where, gfc_basic_typename (type));
2013 return false;
2014 }
2015
2016 if (sym->attr.procedure && sym->ts.interface)
2017 {
2018 gfc_error ("Procedure %qs at %L may not have basic type of %s",
2019 sym->name, where, gfc_basic_typename (ts->type));
2020 return false;
2021 }
2022
2023 flavor = sym->attr.flavor;
2024
2025 if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
2026 || flavor == FL_LABEL
2027 || (flavor == FL_PROCEDURE && sym->attr.subroutine)
2028 || flavor == FL_DERIVED || flavor == FL_NAMELIST)
2029 {
2030 gfc_error ("Symbol %qs at %L cannot have a type",
2031 sym->ns->proc_name ? sym->ns->proc_name->name : sym->name,
2032 where);
2033 return false;
2034 }
2035
2036 sym->ts = *ts;
2037 return true;
2038}
2039
2040
2041/* Clears all attributes. */
2042
2043void
2044gfc_clear_attr (symbol_attribute *attr)
2045{
2046 memset (attr, 0, sizeof (symbol_attribute));
2047}
2048
2049
2050/* Check for missing attributes in the new symbol. Currently does
2051 nothing, but it's not clear that it is unnecessary yet. */
2052
2053bool
2054gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
2055 locus *where ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
2056{
2057
2058 return true;
2059}
2060
2061
2062/* Copy an attribute to a symbol attribute, bit by bit. Some
2063 attributes have a lot of side-effects but cannot be present given
2064 where we are called from, so we ignore some bits. */
2065
2066bool
2067gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
2068{
2069 int is_proc_lang_bind_spec;
2070
2071 /* In line with the other attributes, we only add bits but do not remove
2072 them; cf. also PR 41034. */
2073 dest->ext_attr |= src->ext_attr;
2074
2075 if (src->allocatable && !gfc_add_allocatable (dest, where))
2076 goto fail;
2077
2078 if (src->automatic && !gfc_add_automatic (dest, NULL__null, where))
2079 goto fail;
2080 if (src->dimension && !gfc_add_dimension (dest, NULL__null, where))
2081 goto fail;
2082 if (src->codimension && !gfc_add_codimension (dest, NULL__null, where))
2083 goto fail;
2084 if (src->contiguous && !gfc_add_contiguous (dest, NULL__null, where))
2085 goto fail;
2086 if (src->optional && !gfc_add_optional (dest, where))
2087 goto fail;
2088 if (src->pointer && !gfc_add_pointer (dest, where))
2089 goto fail;
2090 if (src->is_protected && !gfc_add_protected (dest, NULL__null, where))
2091 goto fail;
2092 if (src->save && !gfc_add_save (dest, src->save, NULL__null, where))
2093 goto fail;
2094 if (src->value && !gfc_add_value (dest, NULL__null, where))
2095 goto fail;
2096 if (src->volatile_ && !gfc_add_volatile (dest, NULL__null, where))
2097 goto fail;
2098 if (src->asynchronous && !gfc_add_asynchronous (dest, NULL__null, where))
2099 goto fail;
2100 if (src->threadprivate
2101 && !gfc_add_threadprivate (dest, NULL__null, where))
2102 goto fail;
2103 if (src->omp_declare_target
2104 && !gfc_add_omp_declare_target (dest, NULL__null, where))
2105 goto fail;
2106 if (src->omp_declare_target_link
2107 && !gfc_add_omp_declare_target_link (dest, NULL__null, where))
2108 goto fail;
2109 if (src->oacc_declare_create
2110 && !gfc_add_oacc_declare_create (dest, NULL__null, where))
2111 goto fail;
2112 if (src->oacc_declare_copyin
2113 && !gfc_add_oacc_declare_copyin (dest, NULL__null, where))
2114 goto fail;
2115 if (src->oacc_declare_deviceptr
2116 && !gfc_add_oacc_declare_deviceptr (dest, NULL__null, where))
2117 goto fail;
2118 if (src->oacc_declare_device_resident
2119 && !gfc_add_oacc_declare_device_resident (dest, NULL__null, where))
2120 goto fail;
2121 if (src->target && !gfc_add_target (dest, where))
2122 goto fail;
2123 if (src->dummy && !gfc_add_dummy (dest, NULL__null, where))
2124 goto fail;
2125 if (src->result && !gfc_add_result (dest, NULL__null, where))
2126 goto fail;
2127 if (src->entry)
2128 dest->entry = 1;
2129
2130 if (src->in_namelist && !gfc_add_in_namelist (dest, NULL__null, where))
2131 goto fail;
2132
2133 if (src->in_common && !gfc_add_in_common (dest, NULL__null, where))
2134 goto fail;
2135
2136 if (src->generic && !gfc_add_generic (dest, NULL__null, where))
2137 goto fail;
2138 if (src->function && !gfc_add_function (dest, NULL__null, where))
2139 goto fail;
2140 if (src->subroutine && !gfc_add_subroutine (dest, NULL__null, where))
2141 goto fail;
2142
2143 if (src->sequence && !gfc_add_sequence (dest, NULL__null, where))
2144 goto fail;
2145 if (src->elemental && !gfc_add_elemental (dest, where))
2146 goto fail;
2147 if (src->pure && !gfc_add_pure (dest, where))
2148 goto fail;
2149 if (src->recursive && !gfc_add_recursive (dest, where))
2150 goto fail;
2151
2152 if (src->flavor != FL_UNKNOWN
2153 && !gfc_add_flavor (dest, src->flavor, NULL__null, where))
2154 goto fail;
2155
2156 if (src->intent != INTENT_UNKNOWN
2157 && !gfc_add_intent (dest, src->intent, where))
2158 goto fail;
2159
2160 if (src->access != ACCESS_UNKNOWN
2161 && !gfc_add_access (dest, src->access, NULL__null, where))
2162 goto fail;
2163
2164 if (!gfc_missing_attr (dest, where))
2165 goto fail;
2166
2167 if (src->cray_pointer && !gfc_add_cray_pointer (dest, where))
2168 goto fail;
2169 if (src->cray_pointee && !gfc_add_cray_pointee (dest, where))
2170 goto fail;
2171
2172 is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
2173 if (src->is_bind_c
2174 && !gfc_add_is_bind_c (dest, NULL__null, where, is_proc_lang_bind_spec))
2175 return false;
2176
2177 if (src->is_c_interop)
2178 dest->is_c_interop = 1;
2179 if (src->is_iso_c)
2180 dest->is_iso_c = 1;
2181
2182 if (src->external && !gfc_add_external (dest, where))
2183 goto fail;
2184 if (src->intrinsic && !gfc_add_intrinsic (dest, where))
2185 goto fail;
2186 if (src->proc_pointer)
2187 dest->proc_pointer = 1;
2188
2189 return true;
2190
2191fail:
2192 return false;
2193}
2194
2195
2196/* A function to generate a dummy argument symbol using that from the
2197 interface declaration. Can be used for the result symbol as well if
2198 the flag is set. */
2199
2200int
2201gfc_copy_dummy_sym (gfc_symbol **dsym, gfc_symbol *sym, int result)
2202{
2203 int rc;
2204
2205 rc = gfc_get_symbol (sym->name, NULL__null, dsym);
2206 if (rc)
2207 return rc;
2208
2209 if (!gfc_add_type (*dsym, &(sym->ts), &gfc_current_locus))
2210 return 1;
2211
2212 if (!gfc_copy_attr (&(*dsym)->attr, &(sym->attr),
2213 &gfc_current_locus))
2214 return 1;
2215
2216 if ((*dsym)->attr.dimension)
2217 (*dsym)->as = gfc_copy_array_spec (sym->as);
2218
2219 (*dsym)->attr.class_ok = sym->attr.class_ok;
2220
2221 if ((*dsym) != NULL__null && !result
2222 && (!gfc_add_dummy(&(*dsym)->attr, (*dsym)->name, NULL__null)
2223 || !gfc_missing_attr (&(*dsym)->attr, NULL__null)))
2224 return 1;
2225 else if ((*dsym) != NULL__null && result
2226 && (!gfc_add_result(&(*dsym)->attr, (*dsym)->name, NULL__null)
2227 || !gfc_missing_attr (&(*dsym)->attr, NULL__null)))
2228 return 1;
2229
2230 return 0;
2231}
2232
2233
2234/************** Component name management ************/
2235
2236/* Component names of a derived type form their own little namespaces
2237 that are separate from all other spaces. The space is composed of
2238 a singly linked list of gfc_component structures whose head is
2239 located in the parent symbol. */
2240
2241
2242/* Add a component name to a symbol. The call fails if the name is
2243 already present. On success, the component pointer is modified to
2244 point to the additional component structure. */
2245
2246bool
2247gfc_add_component (gfc_symbol *sym, const char *name,
2248 gfc_component **component)
2249{
2250 gfc_component *p, *tail;
2251
2252 /* Check for existing components with the same name, but not for union
2253 components or containers. Unions and maps are anonymous so they have
2254 unique internal names which will never conflict.
2255 Don't use gfc_find_component here because it calls gfc_use_derived,
2256 but the derived type may not be fully defined yet. */
2257 tail = NULL__null;
2258
2259 for (p = sym->components; p; p = p->next)
2260 {
2261 if (strcmp (p->name, name) == 0)
2262 {
2263 gfc_error ("Component %qs at %C already declared at %L",
2264 name, &p->loc);
2265 return false;
2266 }
2267
2268 tail = p;
2269 }
2270
2271 if (sym->attr.extension
2272 && gfc_find_component (sym->components->ts.u.derived,
2273 name, true, true, NULL__null))
2274 {
2275 gfc_error ("Component %qs at %C already in the parent type "
2276 "at %L", name, &sym->components->ts.u.derived->declared_at);
2277 return false;
2278 }
2279
2280 /* Allocate a new component. */
2281 p = gfc_get_component ()((gfc_component *) xcalloc (1, sizeof (gfc_component)));
2282
2283 if (tail == NULL__null)
2284 sym->components = p;
2285 else
2286 tail->next = p;
2287
2288 p->name = gfc_get_string ("%s", name);
2289 p->loc = gfc_current_locus;
2290 p->ts.type = BT_UNKNOWN;
2291
2292 *component = p;
2293 return true;
2294}
2295
2296
2297/* Recursive function to switch derived types of all symbol in a
2298 namespace. */
2299
2300static void
2301switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
2302{
2303 gfc_symbol *sym;
2304
2305 if (st == NULL__null)
2306 return;
2307
2308 sym = st->n.sym;
2309 if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
2310 sym->ts.u.derived = to;
2311
2312 switch_types (st->left, from, to);
2313 switch_types (st->right, from, to);
2314}
2315
2316
2317/* This subroutine is called when a derived type is used in order to
2318 make the final determination about which version to use. The
2319 standard requires that a type be defined before it is 'used', but
2320 such types can appear in IMPLICIT statements before the actual
2321 definition. 'Using' in this context means declaring a variable to
2322 be that type or using the type constructor.
2323
2324 If a type is used and the components haven't been defined, then we
2325 have to have a derived type in a parent unit. We find the node in
2326 the other namespace and point the symtree node in this namespace to
2327 that node. Further reference to this name point to the correct
2328 node. If we can't find the node in a parent namespace, then we have
2329 an error.
2330
2331 This subroutine takes a pointer to a symbol node and returns a
2332 pointer to the translated node or NULL for an error. Usually there
2333 is no translation and we return the node we were passed. */
2334
2335gfc_symbol *
2336gfc_use_derived (gfc_symbol *sym)
2337{
2338 gfc_symbol *s;
2339 gfc_typespec *t;
2340 gfc_symtree *st;
2341 int i;
2342
2343 if (!sym)
2344 return NULL__null;
2345
2346 if (sym->attr.unlimited_polymorphic)
2347 return sym;
2348
2349 if (sym->attr.generic)
2350 sym = gfc_find_dt_in_generic (sym);
2351
2352 if (sym->components != NULL__null || sym->attr.zero_comp)
2353 return sym; /* Already defined. */
2354
2355 if (sym->ns->parent == NULL__null)
2356 goto bad;
2357
2358 if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
2359 {
2360 gfc_error ("Symbol %qs at %C is ambiguous", sym->name);
2361 return NULL__null;
2362 }
2363
2364 if (s == NULL__null || !gfc_fl_struct (s->attr.flavor)((s->attr.flavor) == FL_DERIVED || (s->attr.flavor) == FL_UNION
|| (s->attr.flavor) == FL_STRUCT)
)
2365 goto bad;
2366
2367 /* Get rid of symbol sym, translating all references to s. */
2368 for (i = 0; i < GFC_LETTERS26; i++)
2369 {
2370 t = &sym->ns->default_type[i];
2371 if (t->u.derived == sym)
2372 t->u.derived = s;
2373 }
2374
2375 st = gfc_find_symtree (sym->ns->sym_root, sym->name);
2376 st->n.sym = s;
2377
2378 s->refs++;
2379
2380 /* Unlink from list of modified symbols. */
2381 gfc_commit_symbol (sym);
2382
2383 switch_types (sym->ns->sym_root, sym, s);
2384
2385 /* TODO: Also have to replace sym -> s in other lists like
2386 namelists, common lists and interface lists. */
2387 gfc_free_symbol (sym);
2388
2389 return s;
2390
2391bad:
2392 gfc_error ("Derived type %qs at %C is being used before it is defined",
2393 sym->name);
2394 return NULL__null;
2395}
2396
2397
2398/* Find the component with the given name in the union type symbol.
2399 If ref is not NULL it will be set to the chain of components through which
2400 the component can actually be accessed. This is necessary for unions because
2401 intermediate structures may be maps, nested structures, or other unions,
2402 all of which may (or must) be 'anonymous' to user code. */
2403
2404static gfc_component *
2405find_union_component (gfc_symbol *un, const char *name,
2406 bool noaccess, gfc_ref **ref)
2407{
2408 gfc_component *m, *check;
2409 gfc_ref *sref, *tmp;
2410
2411 for (m = un->components; m; m = m->next)
2412 {
2413 check = gfc_find_component (m->ts.u.derived, name, noaccess, true, &tmp);
2414 if (check == NULL__null)
2415 continue;
2416
2417 /* Found component somewhere in m; chain the refs together. */
2418 if (ref)
2419 {
2420 /* Map ref. */
2421 sref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
2422 sref->type = REF_COMPONENT;
2423 sref->u.c.component = m;
2424 sref->u.c.sym = m->ts.u.derived;
2425 sref->next = tmp;
2426
2427 *ref = sref;
2428 }
2429 /* Other checks (such as access) were done in the recursive calls. */
2430 return check;
2431 }
2432 return NULL__null;
2433}
2434
2435
2436/* Recursively append candidate COMPONENT structures to CANDIDATES. Store
2437 the number of total candidates in CANDIDATES_LEN. */
2438
2439static void
2440lookup_component_fuzzy_find_candidates (gfc_component *component,
2441 char **&candidates,
2442 size_t &candidates_len)
2443{
2444 for (gfc_component *p = component; p; p = p->next)
2445 vec_push (candidates, candidates_len, p->name);
2446}
2447
2448
2449/* Lookup component MEMBER fuzzily, taking names in COMPONENT into account. */
2450
2451static const char*
2452lookup_component_fuzzy (const char *member, gfc_component *component)
2453{
2454 char **candidates = NULL__null;
2455 size_t candidates_len = 0;
2456 lookup_component_fuzzy_find_candidates (component, candidates,
2457 candidates_len);
2458 return gfc_closest_fuzzy_match (member, candidates);
2459}
2460
2461
2462/* Given a derived type node and a component name, try to locate the
2463 component structure. Returns the NULL pointer if the component is
2464 not found or the components are private. If noaccess is set, no access
2465 checks are done. If silent is set, an error will not be generated if
2466 the component cannot be found or accessed.
2467
2468 If ref is not NULL, *ref is set to represent the chain of components
2469 required to get to the ultimate component.
2470
2471 If the component is simply a direct subcomponent, or is inherited from a
2472 parent derived type in the given derived type, this is a single ref with its
2473 component set to the returned component.
2474
2475 Otherwise, *ref is constructed as a chain of subcomponents. This occurs
2476 when the component is found through an implicit chain of nested union and
2477 map components. Unions and maps are "anonymous" substructures in FORTRAN
2478 which cannot be explicitly referenced, but the reference chain must be
2479 considered as in C for backend translation to correctly compute layouts.
2480 (For example, x.a may refer to x->(UNION)->(MAP)->(UNION)->(MAP)->a). */
2481
2482gfc_component *
2483gfc_find_component (gfc_symbol *sym, const char *name,
2484 bool noaccess, bool silent, gfc_ref **ref)
2485{
2486 gfc_component *p, *check;
2487 gfc_ref *sref = NULL__null, *tmp = NULL__null;
2488
2489 if (name == NULL__null || sym == NULL__null)
2490 return NULL__null;
2491
2492 if (sym->attr.flavor == FL_DERIVED)
2493 sym = gfc_use_derived (sym);
2494 else
2495 gcc_assert (gfc_fl_struct (sym->attr.flavor))((void)(!(((sym->attr.flavor) == FL_DERIVED || (sym->attr
.flavor) == FL_UNION || (sym->attr.flavor) == FL_STRUCT)) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 2495, __FUNCTION__), 0 : 0))
;
2496
2497 if (sym == NULL__null)
2498 return NULL__null;
2499
2500 /* Handle UNIONs specially - mutually recursive with gfc_find_component. */
2501 if (sym->attr.flavor == FL_UNION)
2502 return find_union_component (sym, name, noaccess, ref);
2503
2504 if (ref) *ref = NULL__null;
2505 for (p = sym->components; p; p = p->next)
2506 {
2507 /* Nest search into union's maps. */
2508 if (p->ts.type == BT_UNION)
2509 {
2510 check = find_union_component (p->ts.u.derived, name, noaccess, &tmp);
2511 if (check != NULL__null)
2512 {
2513 /* Union ref. */
2514 if (ref)
2515 {
2516 sref = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
2517 sref->type = REF_COMPONENT;
2518 sref->u.c.component = p;
2519 sref->u.c.sym = p->ts.u.derived;
2520 sref->next = tmp;
2521 *ref = sref;
2522 }
2523 return check;
2524 }
2525 }
2526 else if (strcmp (p->name, name) == 0)
2527 break;
2528
2529 continue;
2530 }
2531
2532 if (p && sym->attr.use_assoc && !noaccess)
2533 {
2534 bool is_parent_comp = sym->attr.extension && (p == sym->components);
2535 if (p->attr.access == ACCESS_PRIVATE ||
2536 (p->attr.access != ACCESS_PUBLIC
2537 && sym->component_access == ACCESS_PRIVATE
2538 && !is_parent_comp))
2539 {
2540 if (!silent)
2541 gfc_error ("Component %qs at %C is a PRIVATE component of %qs",
2542 name, sym->name);
2543 return NULL__null;
2544 }
2545 }
2546
2547 if (p == NULL__null
2548 && sym->attr.extension
2549 && sym->components->ts.type == BT_DERIVED)
2550 {
2551 p = gfc_find_component (sym->components->ts.u.derived, name,
2552 noaccess, silent, ref);
2553 /* Do not overwrite the error. */
2554 if (p == NULL__null)
2555 return p;
2556 }
2557
2558 if (p == NULL__null && !silent)
2559 {
2560 const char *guessed = lookup_component_fuzzy (name, sym->components);
2561 if (guessed)
2562 gfc_error ("%qs at %C is not a member of the %qs structure"
2563 "; did you mean %qs?",
2564 name, sym->name, guessed);
2565 else
2566 gfc_error ("%qs at %C is not a member of the %qs structure",
2567 name, sym->name);
2568 }
2569
2570 /* Component was found; build the ultimate component reference. */
2571 if (p != NULL__null && ref)
2572 {
2573 tmp = gfc_get_ref ()((gfc_ref *) xcalloc (1, sizeof (gfc_ref)));
2574 tmp->type = REF_COMPONENT;
2575 tmp->u.c.component = p;
2576 tmp->u.c.sym = sym;
2577 /* Link the final component ref to the end of the chain of subrefs. */
2578 if (sref)
2579 {
2580 *ref = sref;
2581 for (; sref->next; sref = sref->next)
2582 ;
2583 sref->next = tmp;
2584 }
2585 else
2586 *ref = tmp;
2587 }
2588
2589 return p;
2590}
2591
2592
2593/* Given a symbol, free all of the component structures and everything
2594 they point to. */
2595
2596static void
2597free_components (gfc_component *p)
2598{
2599 gfc_component *q;
2600
2601 for (; p; p = q)
2602 {
2603 q = p->next;
2604
2605 gfc_free_array_spec (p->as);
2606 gfc_free_expr (p->initializer);
2607 if (p->kind_expr)
2608 gfc_free_expr (p->kind_expr);
2609 if (p->param_list)
2610 gfc_free_actual_arglist (p->param_list);
2611 free (p->tb);
2612
2613 free (p);
2614 }
2615}
2616
2617
2618/******************** Statement label management ********************/
2619
2620/* Comparison function for statement labels, used for managing the
2621 binary tree. */
2622
2623static int
2624compare_st_labels (void *a1, void *b1)
2625{
2626 int a = ((gfc_st_label *) a1)->value;
2627 int b = ((gfc_st_label *) b1)->value;
2628
2629 return (b - a);
2630}
2631
2632
2633/* Free a single gfc_st_label structure, making sure the tree is not
2634 messed up. This function is called only when some parse error
2635 occurs. */
2636
2637void
2638gfc_free_st_label (gfc_st_label *label)
2639{
2640
2641 if (label == NULL__null)
2642 return;
2643
2644 gfc_delete_bbt (&label->ns->st_labels, label, compare_st_labels);
2645
2646 if (label->format != NULL__null)
2647 gfc_free_expr (label->format);
2648
2649 free (label);
2650}
2651
2652
2653/* Free a whole tree of gfc_st_label structures. */
2654
2655static void
2656free_st_labels (gfc_st_label *label)
2657{
2658
2659 if (label == NULL__null)
2660 return;
2661
2662 free_st_labels (label->left);
2663 free_st_labels (label->right);
2664
2665 if (label->format != NULL__null)
2666 gfc_free_expr (label->format);
2667 free (label);
2668}
2669
2670
2671/* Given a label number, search for and return a pointer to the label
2672 structure, creating it if it does not exist. */
2673
2674gfc_st_label *
2675gfc_get_st_label (int labelno)
2676{
2677 gfc_st_label *lp;
2678 gfc_namespace *ns;
2679
2680 if (gfc_current_state ()(gfc_state_stack->state) == COMP_DERIVED)
2681 ns = gfc_current_block ()(gfc_state_stack->sym)->f2k_derived;
2682 else
2683 {
2684 /* Find the namespace of the scoping unit:
2685 If we're in a BLOCK construct, jump to the parent namespace. */
2686 ns = gfc_current_ns;
2687 while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2688 ns = ns->parent;
2689 }
2690
2691 /* First see if the label is already in this namespace. */
2692 lp = ns->st_labels;
2693 while (lp)
2694 {
2695 if (lp->value == labelno)
2696 return lp;
2697
2698 if (lp->value < labelno)
2699 lp = lp->left;
2700 else
2701 lp = lp->right;
2702 }
2703
2704 lp = XCNEW (gfc_st_label)((gfc_st_label *) xcalloc (1, sizeof (gfc_st_label)));
2705
2706 lp->value = labelno;
2707 lp->defined = ST_LABEL_UNKNOWN;
2708 lp->referenced = ST_LABEL_UNKNOWN;
2709 lp->ns = ns;
2710
2711 gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2712
2713 return lp;
2714}
2715
2716
2717/* Called when a statement with a statement label is about to be
2718 accepted. We add the label to the list of the current namespace,
2719 making sure it hasn't been defined previously and referenced
2720 correctly. */
2721
2722void
2723gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2724{
2725 int labelno;
2726
2727 labelno = lp->value;
2728
2729 if (lp->defined != ST_LABEL_UNKNOWN)
2730 gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2731 &lp->where, label_locus);
2732 else
2733 {
2734 lp->where = *label_locus;
2735
2736 switch (type)
2737 {
2738 case ST_LABEL_FORMAT:
2739 if (lp->referenced == ST_LABEL_TARGET
2740 || lp->referenced == ST_LABEL_DO_TARGET)
2741 gfc_error ("Label %d at %C already referenced as branch target",
2742 labelno);
2743 else
2744 lp->defined = ST_LABEL_FORMAT;
2745
2746 break;
2747
2748 case ST_LABEL_TARGET:
2749 case ST_LABEL_DO_TARGET:
2750 if (lp->referenced == ST_LABEL_FORMAT)
2751 gfc_error ("Label %d at %C already referenced as a format label",
2752 labelno);
2753 else
2754 lp->defined = type;
2755
2756 if (lp->referenced == ST_LABEL_DO_TARGET && type != ST_LABEL_DO_TARGET
2757 && !gfc_notify_std (GFC_STD_F95_OBS(1<<1) | GFC_STD_F2018_DEL(1<<11),
2758 "DO termination statement which is not END DO"
2759 " or CONTINUE with label %d at %C", labelno))
2760 return;
2761 break;
2762
2763 default:
2764 lp->defined = ST_LABEL_BAD_TARGET;
2765 lp->referenced = ST_LABEL_BAD_TARGET;
2766 }
2767 }
2768}
2769
2770
2771/* Reference a label. Given a label and its type, see if that
2772 reference is consistent with what is known about that label,
2773 updating the unknown state. Returns false if something goes
2774 wrong. */
2775
2776bool
2777gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2778{
2779 gfc_sl_type label_type;
2780 int labelno;
2781 bool rc;
2782
2783 if (lp == NULL__null)
2784 return true;
2785
2786 labelno = lp->value;
2787
2788 if (lp->defined != ST_LABEL_UNKNOWN)
2789 label_type = lp->defined;
2790 else
2791 {
2792 label_type = lp->referenced;
2793 lp->where = gfc_current_locus;
2794 }
2795
2796 if (label_type == ST_LABEL_FORMAT
2797 && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
2798 {
2799 gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2800 rc = false;
2801 goto done;
2802 }
2803
2804 if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
2805 || label_type == ST_LABEL_BAD_TARGET)
2806 && type == ST_LABEL_FORMAT)
2807 {
2808 gfc_error ("Label %d at %C previously used as branch target", labelno);
2809 rc = false;
2810 goto done;
2811 }
2812
2813 if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
2814 && !gfc_notify_std (GFC_STD_F95_OBS(1<<1) | GFC_STD_F2018_DEL(1<<11),
2815 "Shared DO termination label %d at %C", labelno))
2816 return false;
2817
2818 if (type == ST_LABEL_DO_TARGET
2819 && !gfc_notify_std (GFC_STD_F2018_OBS(1<<10), "Labeled DO statement "
2820 "at %L", &gfc_current_locus))
2821 return false;
2822
2823 if (lp->referenced != ST_LABEL_DO_TARGET)
2824 lp->referenced = type;
2825 rc = true;
2826
2827done:
2828 return rc;
2829}
2830
2831
2832/************** Symbol table management subroutines ****************/
2833
2834/* Basic details: Fortran 95 requires a potentially unlimited number
2835 of distinct namespaces when compiling a program unit. This case
2836 occurs during a compilation of internal subprograms because all of
2837 the internal subprograms must be read before we can start
2838 generating code for the host.
2839
2840 Given the tricky nature of the Fortran grammar, we must be able to
2841 undo changes made to a symbol table if the current interpretation
2842 of a statement is found to be incorrect. Whenever a symbol is
2843 looked up, we make a copy of it and link to it. All of these
2844 symbols are kept in a vector so that we can commit or
2845 undo the changes at a later time.
2846
2847 A symtree may point to a symbol node outside of its namespace. In
2848 this case, that symbol has been used as a host associated variable
2849 at some previous time. */
2850
2851/* Allocate a new namespace structure. Copies the implicit types from
2852 PARENT if PARENT_TYPES is set. */
2853
2854gfc_namespace *
2855gfc_get_namespace (gfc_namespace *parent, int parent_types)
2856{
2857 gfc_namespace *ns;
2858 gfc_typespec *ts;
2859 int in;
2860 int i;
2861
2862 ns = XCNEW (gfc_namespace)((gfc_namespace *) xcalloc (1, sizeof (gfc_namespace)));
2863 ns->sym_root = NULL__null;
2864 ns->uop_root = NULL__null;
2865 ns->tb_sym_root = NULL__null;
2866 ns->finalizers = NULL__null;
2867 ns->default_access = ACCESS_UNKNOWN;
2868 ns->parent = parent;
2869
2870 for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2871 {
2872 ns->operator_access[in] = ACCESS_UNKNOWN;
2873 ns->tb_op[in] = NULL__null;
2874 }
2875
2876 /* Initialize default implicit types. */
2877 for (i = 'a'; i <= 'z'; i++)
2878 {
2879 ns->set_flag[i - 'a'] = 0;
2880 ts = &ns->default_type[i - 'a'];
2881
2882 if (parent_types && ns->parent != NULL__null)
2883 {
2884 /* Copy parent settings. */
2885 *ts = ns->parent->default_type[i - 'a'];
2886 continue;
2887 }
2888
2889 if (flag_implicit_noneglobal_options.x_flag_implicit_none != 0)
2890 {
2891 gfc_clear_ts (ts);
2892 continue;
2893 }
2894
2895 if ('i' <= i && i <= 'n')
2896 {
2897 ts->type = BT_INTEGER;
2898 ts->kind = gfc_default_integer_kind;
2899 }
2900 else
2901 {
2902 ts->type = BT_REAL;
2903 ts->kind = gfc_default_real_kind;
2904 }
2905 }
2906
2907 ns->refs = 1;
2908
2909 return ns;
2910}
2911
2912
2913/* Comparison function for symtree nodes. */
2914
2915static int
2916compare_symtree (void *_st1, void *_st2)
2917{
2918 gfc_symtree *st1, *st2;
2919
2920 st1 = (gfc_symtree *) _st1;
2921 st2 = (gfc_symtree *) _st2;
2922
2923 return strcmp (st1->name, st2->name);
2924}
2925
2926
2927/* Allocate a new symtree node and associate it with the new symbol. */
2928
2929gfc_symtree *
2930gfc_new_symtree (gfc_symtree **root, const char *name)
2931{
2932 gfc_symtree *st;
2933
2934 st = XCNEW (gfc_symtree)((gfc_symtree *) xcalloc (1, sizeof (gfc_symtree)));
2935 st->name = gfc_get_string ("%s", name);
2936
2937 gfc_insert_bbt (root, st, compare_symtree);
2938 return st;
2939}
2940
2941
2942/* Delete a symbol from the tree. Does not free the symbol itself! */
2943
2944void
2945gfc_delete_symtree (gfc_symtree **root, const char *name)
2946{
2947 gfc_symtree st, *st0;
2948 const char *p;
2949
2950 /* Submodules are marked as mod.submod. When freeing a submodule
2951 symbol, the symtree only has "submod", so adjust that here. */
2952
2953 p = strrchr(name, '.');
2954 if (p)
2955 p++;
2956 else
2957 p = name;
2958
2959 st0 = gfc_find_symtree (*root, p);
2960
2961 st.name = gfc_get_string ("%s", p);
2962 gfc_delete_bbt (root, &st, compare_symtree);
2963
2964 free (st0);
2965}
2966
2967
2968/* Given a root symtree node and a name, try to find the symbol within
2969 the namespace. Returns NULL if the symbol is not found. */
2970
2971gfc_symtree *
2972gfc_find_symtree (gfc_symtree *st, const char *name)
2973{
2974 int c;
2975
2976 while (st != NULL__null)
2977 {
2978 c = strcmp (name, st->name);
2979 if (c == 0)
2980 return st;
2981
2982 st = (c < 0) ? st->left : st->right;
2983 }
2984
2985 return NULL__null;
2986}
2987
2988
2989/* Return a symtree node with a name that is guaranteed to be unique
2990 within the namespace and corresponds to an illegal fortran name. */
2991
2992gfc_symtree *
2993gfc_get_unique_symtree (gfc_namespace *ns)
2994{
2995 char name[GFC_MAX_SYMBOL_LEN63 + 1];
2996 static int serial = 0;
2997
2998 sprintf (name, "@%d", serial++);
2999 return gfc_new_symtree (&ns->sym_root, name);
3000}
3001
3002
3003/* Given a name find a user operator node, creating it if it doesn't
3004 exist. These are much simpler than symbols because they can't be
3005 ambiguous with one another. */
3006
3007gfc_user_op *
3008gfc_get_uop (const char *name)
3009{
3010 gfc_user_op *uop;
3011 gfc_symtree *st;
3012 gfc_namespace *ns = gfc_current_ns;
3013
3014 if (ns->omp_udr_ns)
3015 ns = ns->parent;
3016 st = gfc_find_symtree (ns->uop_root, name);
3017 if (st != NULL__null)
3018 return st->n.uop;
3019
3020 st = gfc_new_symtree (&ns->uop_root, name);
3021
3022 uop = st->n.uop = XCNEW (gfc_user_op)((gfc_user_op *) xcalloc (1, sizeof (gfc_user_op)));
3023 uop->name = gfc_get_string ("%s", name);
3024 uop->access = ACCESS_UNKNOWN;
3025 uop->ns = ns;
3026
3027 return uop;
3028}
3029
3030
3031/* Given a name find the user operator node. Returns NULL if it does
3032 not exist. */
3033
3034gfc_user_op *
3035gfc_find_uop (const char *name, gfc_namespace *ns)
3036{
3037 gfc_symtree *st;
3038
3039 if (ns == NULL__null)
3040 ns = gfc_current_ns;
3041
3042 st = gfc_find_symtree (ns->uop_root, name);
3043 return (st == NULL__null) ? NULL__null : st->n.uop;
3044}
3045
3046
3047/* Update a symbol's common_block field, and take care of the associated
3048 memory management. */
3049
3050static void
3051set_symbol_common_block (gfc_symbol *sym, gfc_common_head *common_block)
3052{
3053 if (sym->common_block == common_block)
3054 return;
3055
3056 if (sym->common_block && sym->common_block->name[0] != '\0')
3057 {
3058 sym->common_block->refs--;
3059 if (sym->common_block->refs == 0)
3060 free (sym->common_block);
3061 }
3062 sym->common_block = common_block;
3063}
3064
3065
3066/* Remove a gfc_symbol structure and everything it points to. */
3067
3068void
3069gfc_free_symbol (gfc_symbol *sym)
3070{
3071
3072 if (sym == NULL__null)
3073 return;
3074
3075 gfc_free_array_spec (sym->as);
3076
3077 free_components (sym->components);
3078
3079 gfc_free_expr (sym->value);
3080
3081 gfc_free_namelist (sym->namelist);
3082
3083 if (sym->ns != sym->formal_ns)
3084 gfc_free_namespace (sym->formal_ns);
3085
3086 if (!sym->attr.generic_copy)
3087 gfc_free_interface (sym->generic);
3088
3089 gfc_free_formal_arglist (sym->formal);
3090
3091 gfc_free_namespace (sym->f2k_derived);
3092
3093 set_symbol_common_block (sym, NULL__null);
3094
3095 if (sym->param_list)
3096 gfc_free_actual_arglist (sym->param_list);
3097
3098 free (sym);
3099}
3100
3101
3102/* Decrease the reference counter and free memory when we reach zero. */
3103
3104void
3105gfc_release_symbol (gfc_symbol *sym)
3106{
3107 if (sym == NULL__null)
3108 return;
3109
3110 if (sym->formal_ns != NULL__null && sym->refs == 2 && sym->formal_ns != sym->ns
3111 && (!sym->attr.entry || !sym->module))
3112 {
3113 /* As formal_ns contains a reference to sym, delete formal_ns just
3114 before the deletion of sym. */
3115 gfc_namespace *ns = sym->formal_ns;
3116 sym->formal_ns = NULL__null;
3117 gfc_free_namespace (ns);
3118 }
3119
3120 sym->refs--;
3121 if (sym->refs > 0)
3122 return;
3123
3124 gcc_assert (sym->refs == 0)((void)(!(sym->refs == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3124, __FUNCTION__), 0 : 0))
;
3125 gfc_free_symbol (sym);
3126}
3127
3128
3129/* Allocate and initialize a new symbol node. */
3130
3131gfc_symbol *
3132gfc_new_symbol (const char *name, gfc_namespace *ns)
3133{
3134 gfc_symbol *p;
3135
3136 p = XCNEW (gfc_symbol)((gfc_symbol *) xcalloc (1, sizeof (gfc_symbol)));
3137
3138 gfc_clear_ts (&p->ts);
3139 gfc_clear_attr (&p->attr);
3140 p->ns = ns;
3141 p->declared_at = gfc_current_locus;
3142 p->name = gfc_get_string ("%s", name);
3143
3144 return p;
3145}
3146
3147
3148/* Generate an error if a symbol is ambiguous, and set the error flag
3149 on it. */
3150
3151static void
3152ambiguous_symbol (const char *name, gfc_symtree *st)
3153{
3154
3155 if (st->n.sym->error)
3156 return;
3157
3158 if (st->n.sym->module)
3159 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3160 "from module %qs", name, st->n.sym->name, st->n.sym->module);
3161 else
3162 gfc_error ("Name %qs at %C is an ambiguous reference to %qs "
3163 "from current program unit", name, st->n.sym->name);
3164
3165 st->n.sym->error = 1;
3166}
3167
3168
3169/* If we're in a SELECT TYPE block, check if the variable 'st' matches any
3170 selector on the stack. If yes, replace it by the corresponding temporary. */
3171
3172static void
3173select_type_insert_tmp (gfc_symtree **st)
3174{
3175 gfc_select_type_stack *stack = select_type_stack;
3176 for (; stack; stack = stack->prev)
3177 if ((*st)->n.sym == stack->selector && stack->tmp)
3178 {
3179 *st = stack->tmp;
3180 select_type_insert_tmp (st);
3181 return;
3182 }
3183}
3184
3185
3186/* Look for a symtree in the current procedure -- that is, go up to
3187 parent namespaces but only if inside a BLOCK. Returns NULL if not found. */
3188
3189gfc_symtree*
3190gfc_find_symtree_in_proc (const char* name, gfc_namespace* ns)
3191{
3192 while (ns)
3193 {
3194 gfc_symtree* st = gfc_find_symtree (ns->sym_root, name);
3195 if (st)
3196 return st;
3197
3198 if (!ns->construct_entities)
3199 break;
3200 ns = ns->parent;
3201 }
3202
3203 return NULL__null;
3204}
3205
3206
3207/* Search for a symtree starting in the current namespace, resorting to
3208 any parent namespaces if requested by a nonzero parent_flag.
3209 Returns nonzero if the name is ambiguous. */
3210
3211int
3212gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
3213 gfc_symtree **result)
3214{
3215 gfc_symtree *st;
3216
3217 if (ns == NULL__null)
3218 ns = gfc_current_ns;
3219
3220 do
3221 {
3222 st = gfc_find_symtree (ns->sym_root, name);
3223 if (st != NULL__null)
3224 {
3225 select_type_insert_tmp (&st);
3226
3227 *result = st;
3228 /* Ambiguous generic interfaces are permitted, as long
3229 as the specific interfaces are different. */
3230 if (st->ambiguous && !st->n.sym->attr.generic)
3231 {
3232 ambiguous_symbol (name, st);
3233 return 1;
3234 }
3235
3236 return 0;
3237 }
3238
3239 if (!parent_flag)
3240 break;
3241
3242 /* Don't escape an interface block. */
3243 if (ns && !ns->has_import_set
3244 && ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY)
3245 break;
3246
3247 ns = ns->parent;
3248 }
3249 while (ns != NULL__null);
3250
3251 if (gfc_current_state()(gfc_state_stack->state) == COMP_DERIVED
3252 && gfc_current_block ()(gfc_state_stack->sym)->attr.pdt_template)
3253 {
3254 gfc_symbol *der = gfc_current_block ()(gfc_state_stack->sym);
3255 for (; der; der = gfc_get_derived_super_type (der))
3256 {
3257 if (der->f2k_derived && der->f2k_derived->sym_root)
3258 {
3259 st = gfc_find_symtree (der->f2k_derived->sym_root, name);
3260 if (st)
3261 break;
3262 }
3263 }
3264 *result = st;
3265 return 0;
3266 }
3267
3268 *result = NULL__null;
3269
3270 return 0;
3271}
3272
3273
3274/* Same, but returns the symbol instead. */
3275
3276int
3277gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
3278 gfc_symbol **result)
3279{
3280 gfc_symtree *st;
3281 int i;
3282
3283 i = gfc_find_sym_tree (name, ns, parent_flag, &st);
3284
3285 if (st == NULL__null)
3286 *result = NULL__null;
3287 else
3288 *result = st->n.sym;
3289
3290 return i;
3291}
3292
3293
3294/* Tells whether there is only one set of changes in the stack. */
3295
3296static bool
3297single_undo_checkpoint_p (void)
3298{
3299 if (latest_undo_chgset == &default_undo_chgset_var)
3300 {
3301 gcc_assert (latest_undo_chgset->previous == NULL)((void)(!(latest_undo_chgset->previous == __null) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3301, __FUNCTION__), 0 : 0))
;
3302 return true;
3303 }
3304 else
3305 {
3306 gcc_assert (latest_undo_chgset->previous != NULL)((void)(!(latest_undo_chgset->previous != __null) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3306, __FUNCTION__), 0 : 0))
;
3307 return false;
3308 }
3309}
3310
3311/* Save symbol with the information necessary to back it out. */
3312
3313void
3314gfc_save_symbol_data (gfc_symbol *sym)
3315{
3316 gfc_symbol *s;
3317 unsigned i;
3318
3319 if (!single_undo_checkpoint_p ())
3320 {
3321 /* If there is more than one change set, look for the symbol in the
3322 current one. If it is found there, we can reuse it. */
3323 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(s)); ++(i))
3324 if (s == sym)
3325 {
3326 gcc_assert (sym->gfc_new || sym->old_symbol != NULL)((void)(!(sym->gfc_new || sym->old_symbol != __null) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3326, __FUNCTION__), 0 : 0))
;
3327 return;
3328 }
3329 }
3330 else if (sym->gfc_new || sym->old_symbol != NULL__null)
3331 return;
3332
3333 s = XCNEW (gfc_symbol)((gfc_symbol *) xcalloc (1, sizeof (gfc_symbol)));
3334 *s = *sym;
3335 sym->old_symbol = s;
3336 sym->gfc_new = 0;
3337
3338 latest_undo_chgset->syms.safe_push (sym);
3339}
3340
3341
3342/* Given a name, find a symbol, or create it if it does not exist yet
3343 in the current namespace. If the symbol is found we make sure that
3344 it's OK.
3345
3346 The integer return code indicates
3347 0 All OK
3348 1 The symbol name was ambiguous
3349 2 The name meant to be established was already host associated.
3350
3351 So if the return value is nonzero, then an error was issued. */
3352
3353int
3354gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
3355 bool allow_subroutine)
3356{
3357 gfc_symtree *st;
3358 gfc_symbol *p;
3359
3360 /* This doesn't usually happen during resolution. */
3361 if (ns == NULL__null)
3362 ns = gfc_current_ns;
3363
3364 /* Try to find the symbol in ns. */
3365 st = gfc_find_symtree (ns->sym_root, name);
3366
3367 if (st == NULL__null && ns->omp_udr_ns)
3368 {
3369 ns = ns->parent;
3370 st = gfc_find_symtree (ns->sym_root, name);
3371 }
3372
3373 if (st == NULL__null)
3374 {
3375 /* If not there, create a new symbol. */
3376 p = gfc_new_symbol (name, ns);
3377
3378 /* Add to the list of tentative symbols. */
3379 p->old_symbol = NULL__null;
3380 p->mark = 1;
3381 p->gfc_new = 1;
3382 latest_undo_chgset->syms.safe_push (p);
3383
3384 st = gfc_new_symtree (&ns->sym_root, name);
3385 st->n.sym = p;
3386 p->refs++;
3387
3388 }
3389 else
3390 {
3391 /* Make sure the existing symbol is OK. Ambiguous
3392 generic interfaces are permitted, as long as the
3393 specific interfaces are different. */
3394 if (st->ambiguous && !st->n.sym->attr.generic)
3395 {
3396 ambiguous_symbol (name, st);
3397 return 1;
3398 }
3399
3400 p = st->n.sym;
3401 if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
3402 && !(allow_subroutine && p->attr.subroutine)
3403 && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
3404 && (ns->has_import_set || p->attr.imported)))
3405 {
3406 /* Symbol is from another namespace. */
3407 gfc_error ("Symbol %qs at %C has already been host associated",
3408 name);
3409 return 2;
3410 }
3411
3412 p->mark = 1;
3413
3414 /* Copy in case this symbol is changed. */
3415 gfc_save_symbol_data (p);
3416 }
3417
3418 *result = st;
3419 return 0;
3420}
3421
3422
3423int
3424gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
3425{
3426 gfc_symtree *st;
3427 int i;
3428
3429 i = gfc_get_sym_tree (name, ns, &st, false);
3430 if (i != 0)
5
Assuming 'i' is equal to 0
6
Taking false branch
3431 return i;
3432
3433 if (st)
7
Assuming 'st' is null
8
Taking false branch
3434 *result = st->n.sym;
3435 else
3436 *result = NULL__null;
9
Null pointer value stored to field 'sym'
3437 return i;
3438}
3439
3440
3441/* Subroutine that searches for a symbol, creating it if it doesn't
3442 exist, but tries to host-associate the symbol if possible. */
3443
3444int
3445gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
3446{
3447 gfc_symtree *st;
3448 int i;
3449
3450 i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
3451
3452 if (st != NULL__null)
3453 {
3454 gfc_save_symbol_data (st->n.sym);
3455 *result = st;
3456 return i;
3457 }
3458
3459 i = gfc_find_sym_tree (name, gfc_current_ns, 1, &st);
3460 if (i)
3461 return i;
3462
3463 if (st != NULL__null)
3464 {
3465 *result = st;
3466 return 0;
3467 }
3468
3469 return gfc_get_sym_tree (name, gfc_current_ns, result, false);
3470}
3471
3472
3473int
3474gfc_get_ha_symbol (const char *name, gfc_symbol **result)
3475{
3476 int i;
3477 gfc_symtree *st;
3478
3479 i = gfc_get_ha_sym_tree (name, &st);
3480
3481 if (st)
3482 *result = st->n.sym;
3483 else
3484 *result = NULL__null;
3485
3486 return i;
3487}
3488
3489
3490/* Search for the symtree belonging to a gfc_common_head; we cannot use
3491 head->name as the common_root symtree's name might be mangled. */
3492
3493static gfc_symtree *
3494find_common_symtree (gfc_symtree *st, gfc_common_head *head)
3495{
3496
3497 gfc_symtree *result;
3498
3499 if (st == NULL__null)
3500 return NULL__null;
3501
3502 if (st->n.common == head)
3503 return st;
3504
3505 result = find_common_symtree (st->left, head);
3506 if (!result)
3507 result = find_common_symtree (st->right, head);
3508
3509 return result;
3510}
3511
3512
3513/* Restore previous state of symbol. Just copy simple stuff. */
3514
3515static void
3516restore_old_symbol (gfc_symbol *p)
3517{
3518 gfc_symbol *old;
3519
3520 p->mark = 0;
3521 old = p->old_symbol;
3522
3523 p->ts.type = old->ts.type;
3524 p->ts.kind = old->ts.kind;
3525
3526 p->attr = old->attr;
3527
3528 if (p->value != old->value)
3529 {
3530 gcc_checking_assert (old->value == NULL)((void)(!(old->value == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3530, __FUNCTION__), 0 : 0))
;
3531 gfc_free_expr (p->value);
3532 p->value = NULL__null;
3533 }
3534
3535 if (p->as != old->as)
3536 {
3537 if (p->as)
3538 gfc_free_array_spec (p->as);
3539 p->as = old->as;
3540 }
3541
3542 p->generic = old->generic;
3543 p->component_access = old->component_access;
3544
3545 if (p->namelist != NULL__null && old->namelist == NULL__null)
3546 {
3547 gfc_free_namelist (p->namelist);
3548 p->namelist = NULL__null;
3549 }
3550 else
3551 {
3552 if (p->namelist_tail != old->namelist_tail)
3553 {
3554 gfc_free_namelist (old->namelist_tail->next);
3555 old->namelist_tail->next = NULL__null;
3556 }
3557 }
3558
3559 p->namelist_tail = old->namelist_tail;
3560
3561 if (p->formal != old->formal)
3562 {
3563 gfc_free_formal_arglist (p->formal);
3564 p->formal = old->formal;
3565 }
3566
3567 set_symbol_common_block (p, old->common_block);
3568 p->common_head = old->common_head;
3569
3570 p->old_symbol = old->old_symbol;
3571 free (old);
3572}
3573
3574
3575/* Frees the internal data of a gfc_undo_change_set structure. Doesn't free
3576 the structure itself. */
3577
3578static void
3579free_undo_change_set_data (gfc_undo_change_set &cs)
3580{
3581 cs.syms.release ();
3582 cs.tbps.release ();
3583}
3584
3585
3586/* Given a change set pointer, free its target's contents and update it with
3587 the address of the previous change set. Note that only the contents are
3588 freed, not the target itself (the contents' container). It is not a problem
3589 as the latter will be a local variable usually. */
3590
3591static void
3592pop_undo_change_set (gfc_undo_change_set *&cs)
3593{
3594 free_undo_change_set_data (*cs);
3595 cs = cs->previous;
3596}
3597
3598
3599static void free_old_symbol (gfc_symbol *sym);
3600
3601
3602/* Merges the current change set into the previous one. The changes themselves
3603 are left untouched; only one checkpoint is forgotten. */
3604
3605void
3606gfc_drop_last_undo_checkpoint (void)
3607{
3608 gfc_symbol *s, *t;
3609 unsigned i, j;
3610
3611 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, s)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(s)); ++(i))
3612 {
3613 /* No need to loop in this case. */
3614 if (s->old_symbol == NULL__null)
3615 continue;
3616
3617 /* Remove the duplicate symbols. */
3618 FOR_EACH_VEC_ELT (latest_undo_chgset->previous->syms, j, t)for (j = 0; (latest_undo_chgset->previous->syms).iterate
((j), &(t)); ++(j))
3619 if (t == s)
3620 {
3621 latest_undo_chgset->previous->syms.unordered_remove (j);
3622
3623 /* S->OLD_SYMBOL is the backup symbol for S as it was at the
3624 last checkpoint. We drop that checkpoint, so S->OLD_SYMBOL
3625 shall contain from now on the backup symbol for S as it was
3626 at the checkpoint before. */
3627 if (s->old_symbol->gfc_new)
3628 {
3629 gcc_assert (s->old_symbol->old_symbol == NULL)((void)(!(s->old_symbol->old_symbol == __null) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3629, __FUNCTION__), 0 : 0))
;
3630 s->gfc_new = s->old_symbol->gfc_new;
3631 free_old_symbol (s);
3632 }
3633 else
3634 restore_old_symbol (s->old_symbol);
3635 break;
3636 }
3637 }
3638
3639 latest_undo_chgset->previous->syms.safe_splice (latest_undo_chgset->syms);
3640 latest_undo_chgset->previous->tbps.safe_splice (latest_undo_chgset->tbps);
3641
3642 pop_undo_change_set (latest_undo_chgset);
3643}
3644
3645
3646/* Undoes all the changes made to symbols since the previous checkpoint.
3647 This subroutine is made simpler due to the fact that attributes are
3648 never removed once added. */
3649
3650void
3651gfc_restore_last_undo_checkpoint (void)
3652{
3653 gfc_symbol *p;
3654 unsigned i;
3655
3656 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
3657 {
3658 /* Symbol in a common block was new. Or was old and just put in common */
3659 if (p->common_block
3660 && (p->gfc_new || !p->old_symbol->common_block))
3661 {
3662 /* If the symbol was added to any common block, it
3663 needs to be removed to stop the resolver looking
3664 for a (possibly) dead symbol. */
3665 if (p->common_block->head == p && !p->common_next)
3666 {
3667 gfc_symtree st, *st0;
3668 st0 = find_common_symtree (p->ns->common_root,
3669 p->common_block);
3670 if (st0)
3671 {
3672 st.name = st0->name;
3673 gfc_delete_bbt (&p->ns->common_root, &st, compare_symtree);
3674 free (st0);
3675 }
3676 }
3677
3678 if (p->common_block->head == p)
3679 p->common_block->head = p->common_next;
3680 else
3681 {
3682 gfc_symbol *cparent, *csym;
3683
3684 cparent = p->common_block->head;
3685 csym = cparent->common_next;
3686
3687 while (csym != p)
3688 {
3689 cparent = csym;
3690 csym = csym->common_next;
3691 }
3692
3693 gcc_assert(cparent->common_next == p)((void)(!(cparent->common_next == p) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3693, __FUNCTION__), 0 : 0))
;
3694 cparent->common_next = csym->common_next;
3695 }
3696 p->common_next = NULL__null;
3697 }
3698 if (p->gfc_new)
3699 {
3700 /* The derived type is saved in the symtree with the first
3701 letter capitalized; the all lower-case version to the
3702 derived type contains its associated generic function. */
3703 if (gfc_fl_struct (p->attr.flavor)((p->attr.flavor) == FL_DERIVED || (p->attr.flavor) == FL_UNION
|| (p->attr.flavor) == FL_STRUCT)
)
3704 gfc_delete_symtree (&p->ns->sym_root,gfc_dt_upper_string (p->name));
3705 else
3706 gfc_delete_symtree (&p->ns->sym_root, p->name);
3707
3708 gfc_release_symbol (p);
3709 }
3710 else
3711 restore_old_symbol (p);
3712 }
3713
3714 latest_undo_chgset->syms.truncate (0);
3715 latest_undo_chgset->tbps.truncate (0);
3716
3717 if (!single_undo_checkpoint_p ())
3718 pop_undo_change_set (latest_undo_chgset);
3719}
3720
3721
3722/* Makes sure that there is only one set of changes; in other words we haven't
3723 forgotten to pair a call to gfc_new_checkpoint with a call to either
3724 gfc_drop_last_undo_checkpoint or gfc_restore_last_undo_checkpoint. */
3725
3726static void
3727enforce_single_undo_checkpoint (void)
3728{
3729 gcc_checking_assert (single_undo_checkpoint_p ())((void)(!(single_undo_checkpoint_p ()) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3729, __FUNCTION__), 0 : 0))
;
3730}
3731
3732
3733/* Undoes all the changes made to symbols in the current statement. */
3734
3735void
3736gfc_undo_symbols (void)
3737{
3738 enforce_single_undo_checkpoint ();
3739 gfc_restore_last_undo_checkpoint ();
3740}
3741
3742
3743/* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
3744 components of old_symbol that might need deallocation are the "allocatables"
3745 that are restored in gfc_undo_symbols(), with two exceptions: namelist and
3746 namelist_tail. In case these differ between old_symbol and sym, it's just
3747 because sym->namelist has gotten a few more items. */
3748
3749static void
3750free_old_symbol (gfc_symbol *sym)
3751{
3752
3753 if (sym->old_symbol == NULL__null)
3754 return;
3755
3756 if (sym->old_symbol->as != sym->as)
3757 gfc_free_array_spec (sym->old_symbol->as);
3758
3759 if (sym->old_symbol->value != sym->value)
3760 gfc_free_expr (sym->old_symbol->value);
3761
3762 if (sym->old_symbol->formal != sym->formal)
3763 gfc_free_formal_arglist (sym->old_symbol->formal);
3764
3765 free (sym->old_symbol);
3766 sym->old_symbol = NULL__null;
3767}
3768
3769
3770/* Makes the changes made in the current statement permanent-- gets
3771 rid of undo information. */
3772
3773void
3774gfc_commit_symbols (void)
3775{
3776 gfc_symbol *p;
3777 gfc_typebound_proc *tbp;
3778 unsigned i;
3779
3780 enforce_single_undo_checkpoint ();
3781
3782 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
3783 {
3784 p->mark = 0;
3785 p->gfc_new = 0;
3786 free_old_symbol (p);
3787 }
3788 latest_undo_chgset->syms.truncate (0);
3789
3790 FOR_EACH_VEC_ELT (latest_undo_chgset->tbps, i, tbp)for (i = 0; (latest_undo_chgset->tbps).iterate ((i), &
(tbp)); ++(i))
3791 tbp->error = 0;
3792 latest_undo_chgset->tbps.truncate (0);
3793}
3794
3795
3796/* Makes the changes made in one symbol permanent -- gets rid of undo
3797 information. */
3798
3799void
3800gfc_commit_symbol (gfc_symbol *sym)
3801{
3802 gfc_symbol *p;
3803 unsigned i;
3804
3805 enforce_single_undo_checkpoint ();
3806
3807 FOR_EACH_VEC_ELT (latest_undo_chgset->syms, i, p)for (i = 0; (latest_undo_chgset->syms).iterate ((i), &
(p)); ++(i))
3808 if (p == sym)
3809 {
3810 latest_undo_chgset->syms.unordered_remove (i);
3811 break;
3812 }
3813
3814 sym->mark = 0;
3815 sym->gfc_new = 0;
3816
3817 free_old_symbol (sym);
3818}
3819
3820
3821/* Recursively free trees containing type-bound procedures. */
3822
3823static void
3824free_tb_tree (gfc_symtree *t)
3825{
3826 if (t == NULL__null)
3827 return;
3828
3829 free_tb_tree (t->left);
3830 free_tb_tree (t->right);
3831
3832 /* TODO: Free type-bound procedure structs themselves; probably needs some
3833 sort of ref-counting mechanism. */
3834
3835 free (t);
3836}
3837
3838
3839/* Recursive function that deletes an entire tree and all the common
3840 head structures it points to. */
3841
3842static void
3843free_common_tree (gfc_symtree * common_tree)
3844{
3845 if (common_tree == NULL__null)
3846 return;
3847
3848 free_common_tree (common_tree->left);
3849 free_common_tree (common_tree->right);
3850
3851 free (common_tree);
3852}
3853
3854
3855/* Recursive function that deletes an entire tree and all the common
3856 head structures it points to. */
3857
3858static void
3859free_omp_udr_tree (gfc_symtree * omp_udr_tree)
3860{
3861 if (omp_udr_tree == NULL__null)
3862 return;
3863
3864 free_omp_udr_tree (omp_udr_tree->left);
3865 free_omp_udr_tree (omp_udr_tree->right);
3866
3867 gfc_free_omp_udr (omp_udr_tree->n.omp_udr);
3868 free (omp_udr_tree);
3869}
3870
3871
3872/* Recursive function that deletes an entire tree and all the user
3873 operator nodes that it contains. */
3874
3875static void
3876free_uop_tree (gfc_symtree *uop_tree)
3877{
3878 if (uop_tree == NULL__null)
3879 return;
3880
3881 free_uop_tree (uop_tree->left);
3882 free_uop_tree (uop_tree->right);
3883
3884 gfc_free_interface (uop_tree->n.uop->op);
3885 free (uop_tree->n.uop);
3886 free (uop_tree);
3887}
3888
3889
3890/* Recursive function that deletes an entire tree and all the symbols
3891 that it contains. */
3892
3893static void
3894free_sym_tree (gfc_symtree *sym_tree)
3895{
3896 if (sym_tree == NULL__null)
3897 return;
3898
3899 free_sym_tree (sym_tree->left);
3900 free_sym_tree (sym_tree->right);
3901
3902 gfc_release_symbol (sym_tree->n.sym);
3903 free (sym_tree);
3904}
3905
3906
3907/* Free the gfc_equiv_info's. */
3908
3909static void
3910gfc_free_equiv_infos (gfc_equiv_info *s)
3911{
3912 if (s == NULL__null)
3913 return;
3914 gfc_free_equiv_infos (s->next);
3915 free (s);
3916}
3917
3918
3919/* Free the gfc_equiv_lists. */
3920
3921static void
3922gfc_free_equiv_lists (gfc_equiv_list *l)
3923{
3924 if (l == NULL__null)
3925 return;
3926 gfc_free_equiv_lists (l->next);
3927 gfc_free_equiv_infos (l->equiv);
3928 free (l);
3929}
3930
3931
3932/* Free a finalizer procedure list. */
3933
3934void
3935gfc_free_finalizer (gfc_finalizer* el)
3936{
3937 if (el)
3938 {
3939 gfc_release_symbol (el->proc_sym);
3940 free (el);
3941 }
3942}
3943
3944static void
3945gfc_free_finalizer_list (gfc_finalizer* list)
3946{
3947 while (list)
3948 {
3949 gfc_finalizer* current = list;
3950 list = list->next;
3951 gfc_free_finalizer (current);
3952 }
3953}
3954
3955
3956/* Create a new gfc_charlen structure and add it to a namespace.
3957 If 'old_cl' is given, the newly created charlen will be a copy of it. */
3958
3959gfc_charlen*
3960gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3961{
3962 gfc_charlen *cl;
3963
3964 cl = gfc_get_charlen ()((gfc_charlen *) xcalloc (1, sizeof (gfc_charlen)));
3965
3966 /* Copy old_cl. */
3967 if (old_cl)
3968 {
3969 cl->length = gfc_copy_expr (old_cl->length);
3970 cl->length_from_typespec = old_cl->length_from_typespec;
3971 cl->backend_decl = old_cl->backend_decl;
3972 cl->passed_length = old_cl->passed_length;
3973 cl->resolved = old_cl->resolved;
3974 }
3975
3976 /* Put into namespace. */
3977 cl->next = ns->cl_list;
3978 ns->cl_list = cl;
3979
3980 return cl;
3981}
3982
3983
3984/* Free the charlen list from cl to end (end is not freed).
3985 Free the whole list if end is NULL. */
3986
3987void
3988gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3989{
3990 gfc_charlen *cl2;
3991
3992 for (; cl != end; cl = cl2)
3993 {
3994 gcc_assert (cl)((void)(!(cl) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 3994, __FUNCTION__), 0 : 0))
;
3995
3996 cl2 = cl->next;
3997 gfc_free_expr (cl->length);
3998 free (cl);
3999 }
4000}
4001
4002
4003/* Free entry list structs. */
4004
4005static void
4006free_entry_list (gfc_entry_list *el)
4007{
4008 gfc_entry_list *next;
4009
4010 if (el == NULL__null)
4011 return;
4012
4013 next = el->next;
4014 free (el);
4015 free_entry_list (next);
4016}
4017
4018
4019/* Free a namespace structure and everything below it. Interface
4020 lists associated with intrinsic operators are not freed. These are
4021 taken care of when a specific name is freed. */
4022
4023void
4024gfc_free_namespace (gfc_namespace *ns)
4025{
4026 gfc_namespace *p, *q;
4027 int i;
4028 gfc_was_finalized *f;
4029
4030 if (ns == NULL__null)
4031 return;
4032
4033 ns->refs--;
4034 if (ns->refs > 0)
4035 return;
4036
4037 gcc_assert (ns->refs == 0)((void)(!(ns->refs == 0) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4037, __FUNCTION__), 0 : 0))
;
4038
4039 gfc_free_statements (ns->code);
4040
4041 free_sym_tree (ns->sym_root);
4042 free_uop_tree (ns->uop_root);
4043 free_common_tree (ns->common_root);
4044 free_omp_udr_tree (ns->omp_udr_root);
4045 free_tb_tree (ns->tb_sym_root);
4046 free_tb_tree (ns->tb_uop_root);
4047 gfc_free_finalizer_list (ns->finalizers);
4048 gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
4049 gfc_free_charlen (ns->cl_list, NULL__null);
4050 free_st_labels (ns->st_labels);
4051
4052 free_entry_list (ns->entries);
4053 gfc_free_equiv (ns->equiv);
4054 gfc_free_equiv_lists (ns->equiv_lists);
4055 gfc_free_use_stmts (ns->use_stmts);
4056
4057 for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
4058 gfc_free_interface (ns->op[i]);
4059
4060 gfc_free_data (ns->data);
4061
4062 /* Free all the expr + component combinations that have been
4063 finalized. */
4064 f = ns->was_finalized;
4065 while (f)
4066 {
4067 gfc_was_finalized* current = f;
4068 f = f->next;
4069 free (current);
4070 }
4071
4072 p = ns->contained;
4073 free (ns);
4074
4075 /* Recursively free any contained namespaces. */
4076 while (p != NULL__null)
4077 {
4078 q = p;
4079 p = p->sibling;
4080 gfc_free_namespace (q);
4081 }
4082}
4083
4084
4085void
4086gfc_symbol_init_2 (void)
4087{
4088
4089 gfc_current_ns = gfc_get_namespace (NULL__null, 0);
4090}
4091
4092
4093void
4094gfc_symbol_done_2 (void)
4095{
4096 if (gfc_current_ns != NULL__null)
4097 {
4098 /* free everything from the root. */
4099 while (gfc_current_ns->parent != NULL__null)
4100 gfc_current_ns = gfc_current_ns->parent;
4101 gfc_free_namespace (gfc_current_ns);
4102 gfc_current_ns = NULL__null;
4103 }
4104 gfc_derived_types = NULL__null;
4105
4106 enforce_single_undo_checkpoint ();
4107 free_undo_change_set_data (*latest_undo_chgset);
4108}
4109
4110
4111/* Count how many nodes a symtree has. */
4112
4113static unsigned
4114count_st_nodes (const gfc_symtree *st)
4115{
4116 unsigned nodes;
4117 if (!st)
4118 return 0;
4119
4120 nodes = count_st_nodes (st->left);
4121 nodes++;
4122 nodes += count_st_nodes (st->right);
4123
4124 return nodes;
4125}
4126
4127
4128/* Convert symtree tree into symtree vector. */
4129
4130static unsigned
4131fill_st_vector (gfc_symtree *st, gfc_symtree **st_vec, unsigned node_cntr)
4132{
4133 if (!st)
4134 return node_cntr;
4135
4136 node_cntr = fill_st_vector (st->left, st_vec, node_cntr);
4137 st_vec[node_cntr++] = st;
4138 node_cntr = fill_st_vector (st->right, st_vec, node_cntr);
4139
4140 return node_cntr;
4141}
4142
4143
4144/* Traverse namespace. As the functions might modify the symtree, we store the
4145 symtree as a vector and operate on this vector. Note: We assume that
4146 sym_func or st_func never deletes nodes from the symtree - only adding is
4147 allowed. Additionally, newly added nodes are not traversed. */
4148
4149static void
4150do_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *),
4151 void (*sym_func) (gfc_symbol *))
4152{
4153 gfc_symtree **st_vec;
4154 unsigned nodes, i, node_cntr;
4155
4156 gcc_assert ((st_func && !sym_func) || (!st_func && sym_func))((void)(!((st_func && !sym_func) || (!st_func &&
sym_func)) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4156, __FUNCTION__), 0 : 0))
;
4157 nodes = count_st_nodes (st);
4158 st_vec = XALLOCAVEC (gfc_symtree *, nodes)((gfc_symtree * *) __builtin_alloca(sizeof (gfc_symtree *) * (
nodes)))
;
4159 node_cntr = 0;
4160 fill_st_vector (st, st_vec, node_cntr);
4161
4162 if (sym_func)
4163 {
4164 /* Clear marks. */
4165 for (i = 0; i < nodes; i++)
4166 st_vec[i]->n.sym->mark = 0;
4167 for (i = 0; i < nodes; i++)
4168 if (!st_vec[i]->n.sym->mark)
4169 {
4170 (*sym_func) (st_vec[i]->n.sym);
4171 st_vec[i]->n.sym->mark = 1;
4172 }
4173 }
4174 else
4175 for (i = 0; i < nodes; i++)
4176 (*st_func) (st_vec[i]);
4177}
4178
4179
4180/* Recursively traverse the symtree nodes. */
4181
4182void
4183gfc_traverse_symtree (gfc_symtree *st, void (*st_func) (gfc_symtree *))
4184{
4185 do_traverse_symtree (st, st_func, NULL__null);
4186}
4187
4188
4189/* Call a given function for all symbols in the namespace. We take
4190 care that each gfc_symbol node is called exactly once. */
4191
4192void
4193gfc_traverse_ns (gfc_namespace *ns, void (*sym_func) (gfc_symbol *))
4194{
4195 do_traverse_symtree (ns->sym_root, NULL__null, sym_func);
4196}
4197
4198
4199/* Return TRUE when name is the name of an intrinsic type. */
4200
4201bool
4202gfc_is_intrinsic_typename (const char *name)
4203{
4204 if (strcmp (name, "integer") == 0
4205 || strcmp (name, "real") == 0
4206 || strcmp (name, "character") == 0
4207 || strcmp (name, "logical") == 0
4208 || strcmp (name, "complex") == 0
4209 || strcmp (name, "doubleprecision") == 0
4210 || strcmp (name, "doublecomplex") == 0)
4211 return true;
4212 else
4213 return false;
4214}
4215
4216
4217/* Return TRUE if the symbol is an automatic variable. */
4218
4219static bool
4220gfc_is_var_automatic (gfc_symbol *sym)
4221{
4222 /* Pointer and allocatable variables are never automatic. */
4223 if (sym->attr.pointer || sym->attr.allocatable)
4224 return false;
4225 /* Check for arrays with non-constant size. */
4226 if (sym->attr.dimension && sym->as
4227 && !gfc_is_compile_time_shape (sym->as))
4228 return true;
4229 /* Check for non-constant length character variables. */
4230 if (sym->ts.type == BT_CHARACTER
4231 && sym->ts.u.cl
4232 && !gfc_is_constant_expr (sym->ts.u.cl->length))
4233 return true;
4234 /* Variables with explicit AUTOMATIC attribute. */
4235 if (sym->attr.automatic)
4236 return true;
4237
4238 return false;
4239}
4240
4241/* Given a symbol, mark it as SAVEd if it is allowed. */
4242
4243static void
4244save_symbol (gfc_symbol *sym)
4245{
4246
4247 if (sym->attr.use_assoc)
4248 return;
4249
4250 if (sym->attr.in_common
4251 || sym->attr.in_equivalence
4252 || sym->attr.dummy
4253 || sym->attr.result
4254 || sym->attr.flavor != FL_VARIABLE)
4255 return;
4256 /* Automatic objects are not saved. */
4257 if (gfc_is_var_automatic (sym))
4258 return;
4259 gfc_add_save (&sym->attr, SAVE_EXPLICIT, sym->name, &sym->declared_at);
4260}
4261
4262
4263/* Mark those symbols which can be SAVEd as such. */
4264
4265void
4266gfc_save_all (gfc_namespace *ns)
4267{
4268 gfc_traverse_ns (ns, save_symbol);
4269}
4270
4271
4272/* Make sure that no changes to symbols are pending. */
4273
4274void
4275gfc_enforce_clean_symbol_state(void)
4276{
4277 enforce_single_undo_checkpoint ();
4278 gcc_assert (latest_undo_chgset->syms.is_empty ())((void)(!(latest_undo_chgset->syms.is_empty ()) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4278, __FUNCTION__), 0 : 0))
;
4279}
4280
4281
4282/************** Global symbol handling ************/
4283
4284
4285/* Search a tree for the global symbol. */
4286
4287gfc_gsymbol *
4288gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
4289{
4290 int c;
4291
4292 if (symbol == NULL__null)
4293 return NULL__null;
4294
4295 while (symbol)
4296 {
4297 c = strcmp (name, symbol->name);
4298 if (!c)
4299 return symbol;
4300
4301 symbol = (c < 0) ? symbol->left : symbol->right;
4302 }
4303
4304 return NULL__null;
4305}
4306
4307
4308/* Case insensitive search a tree for the global symbol. */
4309
4310gfc_gsymbol *
4311gfc_find_case_gsymbol (gfc_gsymbol *symbol, const char *name)
4312{
4313 int c;
4314
4315 if (symbol == NULL__null)
4316 return NULL__null;
4317
4318 while (symbol)
4319 {
4320 c = strcasecmp (name, symbol->name);
4321 if (!c)
4322 return symbol;
4323
4324 symbol = (c < 0) ? symbol->left : symbol->right;
4325 }
4326
4327 return NULL__null;
4328}
4329
4330
4331/* Compare two global symbols. Used for managing the BB tree. */
4332
4333static int
4334gsym_compare (void *_s1, void *_s2)
4335{
4336 gfc_gsymbol *s1, *s2;
4337
4338 s1 = (gfc_gsymbol *) _s1;
4339 s2 = (gfc_gsymbol *) _s2;
4340 return strcmp (s1->name, s2->name);
4341}
4342
4343
4344/* Get a global symbol, creating it if it doesn't exist. */
4345
4346gfc_gsymbol *
4347gfc_get_gsymbol (const char *name, bool bind_c)
4348{
4349 gfc_gsymbol *s;
4350
4351 s = gfc_find_gsymbol (gfc_gsym_root, name);
4352 if (s != NULL__null)
4353 return s;
4354
4355 s = XCNEW (gfc_gsymbol)((gfc_gsymbol *) xcalloc (1, sizeof (gfc_gsymbol)));
4356 s->type = GSYM_UNKNOWN;
4357 s->name = gfc_get_string ("%s", name);
4358 s->bind_c = bind_c;
4359
4360 gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
4361
4362 return s;
4363}
4364
4365void
4366gfc_traverse_gsymbol (gfc_gsymbol *gsym,
4367 void (*do_something) (gfc_gsymbol *, void *),
4368 void *data)
4369{
4370 if (gsym->left)
4371 gfc_traverse_gsymbol (gsym->left, do_something, data);
4372
4373 (*do_something) (gsym, data);
4374
4375 if (gsym->right)
4376 gfc_traverse_gsymbol (gsym->right, do_something, data);
4377}
4378
4379static gfc_symbol *
4380get_iso_c_binding_dt (int sym_id)
4381{
4382 gfc_symbol *dt_list = gfc_derived_types;
4383
4384 /* Loop through the derived types in the name list, searching for
4385 the desired symbol from iso_c_binding. Search the parent namespaces
4386 if necessary and requested to (parent_flag). */
4387 if (dt_list)
4388 {
4389 while (dt_list->dt_next != gfc_derived_types)
4390 {
4391 if (dt_list->from_intmod != INTMOD_NONE
4392 && dt_list->intmod_sym_id == sym_id)
4393 return dt_list;
4394
4395 dt_list = dt_list->dt_next;
4396 }
4397 }
4398
4399 return NULL__null;
4400}
4401
4402
4403/* Verifies that the given derived type symbol, derived_sym, is interoperable
4404 with C. This is necessary for any derived type that is BIND(C) and for
4405 derived types that are parameters to functions that are BIND(C). All
4406 fields of the derived type are required to be interoperable, and are tested
4407 for such. If an error occurs, the errors are reported here, allowing for
4408 multiple errors to be handled for a single derived type. */
4409
4410bool
4411verify_bind_c_derived_type (gfc_symbol *derived_sym)
4412{
4413 gfc_component *curr_comp = NULL__null;
4414 bool is_c_interop = false;
4415 bool retval = true;
4416
4417 if (derived_sym == NULL__null)
4418 gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
4419 "unexpectedly NULL");
4420
4421 /* If we've already looked at this derived symbol, do not look at it again
4422 so we don't repeat warnings/errors. */
4423 if (derived_sym->ts.is_c_interop)
4424 return true;
4425
4426 /* The derived type must have the BIND attribute to be interoperable
4427 J3/04-007, Section 15.2.3. */
4428 if (derived_sym->attr.is_bind_c != 1)
4429 {
4430 derived_sym->ts.is_c_interop = 0;
4431 gfc_error_now ("Derived type %qs declared at %L must have the BIND "
4432 "attribute to be C interoperable", derived_sym->name,
4433 &(derived_sym->declared_at));
4434 retval = false;
4435 }
4436
4437 curr_comp = derived_sym->components;
4438
4439 /* Fortran 2003 allows an empty derived type. C99 appears to disallow an
4440 empty struct. Section 15.2 in Fortran 2003 states: "The following
4441 subclauses define the conditions under which a Fortran entity is
4442 interoperable. If a Fortran entity is interoperable, an equivalent
4443 entity may be defined by means of C and the Fortran entity is said
4444 to be interoperable with the C entity. There does not have to be such
4445 an interoperating C entity."
4446 */
4447 if (curr_comp == NULL__null)
4448 {
4449 gfc_warning (0, "Derived type %qs with BIND(C) attribute at %L is empty, "
4450 "and may be inaccessible by the C companion processor",
4451 derived_sym->name, &(derived_sym->declared_at));
4452 derived_sym->ts.is_c_interop = 1;
4453 derived_sym->attr.is_bind_c = 1;
4454 return true;
4455 }
4456
4457
4458 /* Initialize the derived type as being C interoperable.
4459 If we find an error in the components, this will be set false. */
4460 derived_sym->ts.is_c_interop = 1;
4461
4462 /* Loop through the list of components to verify that the kind of
4463 each is a C interoperable type. */
4464 do
4465 {
4466 /* The components cannot be pointers (fortran sense).
4467 J3/04-007, Section 15.2.3, C1505. */
4468 if (curr_comp->attr.pointer != 0)
4469 {
4470 gfc_error ("Component %qs at %L cannot have the "
4471 "POINTER attribute because it is a member "
4472 "of the BIND(C) derived type %qs at %L",
4473 curr_comp->name, &(curr_comp->loc),
4474 derived_sym->name, &(derived_sym->declared_at));
4475 retval = false;
4476 }
4477
4478 if (curr_comp->attr.proc_pointer != 0)
4479 {
4480 gfc_error ("Procedure pointer component %qs at %L cannot be a member"
4481 " of the BIND(C) derived type %qs at %L", curr_comp->name,
4482 &curr_comp->loc, derived_sym->name,
4483 &derived_sym->declared_at);
4484 retval = false;
4485 }
4486
4487 /* The components cannot be allocatable.
4488 J3/04-007, Section 15.2.3, C1505. */
4489 if (curr_comp->attr.allocatable != 0)
4490 {
4491 gfc_error ("Component %qs at %L cannot have the "
4492 "ALLOCATABLE attribute because it is a member "
4493 "of the BIND(C) derived type %qs at %L",
4494 curr_comp->name, &(curr_comp->loc),
4495 derived_sym->name, &(derived_sym->declared_at));
4496 retval = false;
4497 }
4498
4499 /* BIND(C) derived types must have interoperable components. */
4500 if (curr_comp->ts.type == BT_DERIVED
4501 && curr_comp->ts.u.derived->ts.is_iso_c != 1
4502 && curr_comp->ts.u.derived != derived_sym)
4503 {
4504 /* This should be allowed; the draft says a derived-type cannot
4505 have type parameters if it is has the BIND attribute. Type
4506 parameters seem to be for making parameterized derived types.
4507 There's no need to verify the type if it is c_ptr/c_funptr. */
4508 retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
4509 }
4510 else
4511 {
4512 /* Grab the typespec for the given component and test the kind. */
4513 is_c_interop = gfc_verify_c_interop (&(curr_comp->ts));
4514
4515 if (!is_c_interop)
4516 {
4517 /* Report warning and continue since not fatal. The
4518 draft does specify a constraint that requires all fields
4519 to interoperate, but if the user says real(4), etc., it
4520 may interoperate with *something* in C, but the compiler
4521 most likely won't know exactly what. Further, it may not
4522 interoperate with the same data type(s) in C if the user
4523 recompiles with different flags (e.g., -m32 and -m64 on
4524 x86_64 and using integer(4) to claim interop with a
4525 C_LONG). */
4526 if (derived_sym->attr.is_bind_c == 1 && warn_c_binding_typeglobal_options.x_warn_c_binding_type)
4527 /* If the derived type is bind(c), all fields must be
4528 interop. */
4529 gfc_warning (OPT_Wc_binding_type,
4530 "Component %qs in derived type %qs at %L "
4531 "may not be C interoperable, even though "
4532 "derived type %qs is BIND(C)",
4533 curr_comp->name, derived_sym->name,
4534 &(curr_comp->loc), derived_sym->name);
4535 else if (warn_c_binding_typeglobal_options.x_warn_c_binding_type)
4536 /* If derived type is param to bind(c) routine, or to one
4537 of the iso_c_binding procs, it must be interoperable, so
4538 all fields must interop too. */
4539 gfc_warning (OPT_Wc_binding_type,
4540 "Component %qs in derived type %qs at %L "
4541 "may not be C interoperable",
4542 curr_comp->name, derived_sym->name,
4543 &(curr_comp->loc));
4544 }
4545 }
4546
4547 curr_comp = curr_comp->next;
4548 } while (curr_comp != NULL__null);
4549
4550 if (derived_sym->attr.sequence != 0)
4551 {
4552 gfc_error ("Derived type %qs at %L cannot have the SEQUENCE "
4553 "attribute because it is BIND(C)", derived_sym->name,
4554 &(derived_sym->declared_at));
4555 retval = false;
4556 }
4557
4558 /* Mark the derived type as not being C interoperable if we found an
4559 error. If there were only warnings, proceed with the assumption
4560 it's interoperable. */
4561 if (!retval)
4562 derived_sym->ts.is_c_interop = 0;
4563
4564 return retval;
4565}
4566
4567
4568/* Generate symbols for the named constants c_null_ptr and c_null_funptr. */
4569
4570static bool
4571gen_special_c_interop_ptr (gfc_symbol *tmp_sym, gfc_symtree *dt_symtree)
4572{
4573 gfc_constructor *c;
4574
4575 gcc_assert (tmp_sym && dt_symtree && dt_symtree->n.sym)((void)(!(tmp_sym && dt_symtree && dt_symtree
->n.sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4575, __FUNCTION__), 0 : 0))
;
4576 dt_symtree->n.sym->attr.referenced = 1;
4577
4578 tmp_sym->attr.is_c_interop = 1;
4579 tmp_sym->attr.is_bind_c = 1;
4580 tmp_sym->ts.is_c_interop = 1;
4581 tmp_sym->ts.is_iso_c = 1;
4582 tmp_sym->ts.type = BT_DERIVED;
4583 tmp_sym->ts.f90_type = BT_VOID;
4584 tmp_sym->attr.flavor = FL_PARAMETER;
4585 tmp_sym->ts.u.derived = dt_symtree->n.sym;
4586
4587 /* Set the c_address field of c_null_ptr and c_null_funptr to
4588 the value of NULL. */
4589 tmp_sym->value = gfc_get_expr ();
4590 tmp_sym->value->expr_type = EXPR_STRUCTURE;
4591 tmp_sym->value->ts.type = BT_DERIVED;
4592 tmp_sym->value->ts.f90_type = BT_VOID;
4593 tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
4594 gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL__null, NULL__null);
4595 c = gfc_constructor_first (tmp_sym->value->value.constructor);
4596 c->expr = gfc_get_int_expr (gfc_index_integer_kind, NULL__null, 0);
4597 c->expr->ts.is_iso_c = 1;
4598
4599 return true;
4600}
4601
4602
4603/* Add a formal argument, gfc_formal_arglist, to the
4604 end of the given list of arguments. Set the reference to the
4605 provided symbol, param_sym, in the argument. */
4606
4607static void
4608add_formal_arg (gfc_formal_arglist **head,
4609 gfc_formal_arglist **tail,
4610 gfc_formal_arglist *formal_arg,
4611 gfc_symbol *param_sym)
4612{
4613 /* Put in list, either as first arg or at the tail (curr arg). */
4614 if (*head == NULL__null)
4615 *head = *tail = formal_arg;
4616 else
4617 {
4618 (*tail)->next = formal_arg;
4619 (*tail) = formal_arg;
4620 }
4621
4622 (*tail)->sym = param_sym;
4623 (*tail)->next = NULL__null;
4624
4625 return;
4626}
4627
4628
4629/* Add a procedure interface to the given symbol (i.e., store a
4630 reference to the list of formal arguments). */
4631
4632static void
4633add_proc_interface (gfc_symbol *sym, ifsrc source, gfc_formal_arglist *formal)
4634{
4635
4636 sym->formal = formal;
4637 sym->attr.if_source = source;
4638}
4639
4640
4641/* Copy the formal args from an existing symbol, src, into a new
4642 symbol, dest. New formal args are created, and the description of
4643 each arg is set according to the existing ones. This function is
4644 used when creating procedure declaration variables from a procedure
4645 declaration statement (see match_proc_decl()) to create the formal
4646 args based on the args of a given named interface.
4647
4648 When an actual argument list is provided, skip the absent arguments
4649 unless copy_type is true.
4650 To be used together with gfc_se->ignore_optional. */
4651
4652void
4653gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src,
4654 gfc_actual_arglist *actual, bool copy_type)
4655{
4656 gfc_formal_arglist *head = NULL__null;
4657 gfc_formal_arglist *tail = NULL__null;
4658 gfc_formal_arglist *formal_arg = NULL__null;
4659 gfc_intrinsic_arg *curr_arg = NULL__null;
4660 gfc_formal_arglist *formal_prev = NULL__null;
4661 gfc_actual_arglist *act_arg = actual;
4662 /* Save current namespace so we can change it for formal args. */
4663 gfc_namespace *parent_ns = gfc_current_ns;
4664
4665 /* Create a new namespace, which will be the formal ns (namespace
4666 of the formal args). */
4667 gfc_current_ns = gfc_get_namespace (parent_ns, 0);
4668 gfc_current_ns->proc_name = dest;
4669
4670 for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next)
1
Loop condition is true. Entering loop body
4671 {
4672 /* Skip absent arguments. */
4673 if (actual)
2
Assuming 'actual' is null
3
Taking false branch
4674 {
4675 gcc_assert (act_arg != NULL)((void)(!(act_arg != __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4675, __FUNCTION__), 0 : 0))
;
4676 if (act_arg->expr == NULL__null)
4677 {
4678 act_arg = act_arg->next;
4679 continue;
4680 }
4681 }
4682 formal_arg = gfc_get_formal_arglist ()((gfc_formal_arglist *) xcalloc (1, sizeof (gfc_formal_arglist
)))
;
4683 gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym));
4
Calling 'gfc_get_symbol'
10
Returning from 'gfc_get_symbol'
4684
4685 /* May need to copy more info for the symbol. */
4686 if (copy_type && act_arg->expr != NULL__null)
11
Assuming 'copy_type' is false
4687 {
4688 formal_arg->sym->ts = act_arg->expr->ts;
4689 if (act_arg->expr->rank > 0)
4690 {
4691 formal_arg->sym->attr.dimension = 1;
4692 formal_arg->sym->as = gfc_get_array_spec()((gfc_array_spec *) xcalloc (1, sizeof (gfc_array_spec)));
4693 formal_arg->sym->as->rank = -1;
4694 formal_arg->sym->as->type = AS_ASSUMED_RANK;
4695 }
4696 if (act_arg->name && strcmp (act_arg->name, "%VAL") == 0)
4697 formal_arg->sym->pass_as_value = 1;
4698 }
4699 else
4700 formal_arg->sym->ts = curr_arg->ts;
12
Called C++ object pointer is null
4701
4702 formal_arg->sym->attr.optional = curr_arg->optional;
4703 formal_arg->sym->attr.value = curr_arg->value;
4704 formal_arg->sym->attr.intent = curr_arg->intent;
4705 formal_arg->sym->attr.flavor = FL_VARIABLE;
4706 formal_arg->sym->attr.dummy = 1;
4707
4708 if (formal_arg->sym->ts.type == BT_CHARACTER)
4709 formal_arg->sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
4710
4711 /* If this isn't the first arg, set up the next ptr. For the
4712 last arg built, the formal_arg->next will never get set to
4713 anything other than NULL. */
4714 if (formal_prev != NULL__null)
4715 formal_prev->next = formal_arg;
4716 else
4717 formal_arg->next = NULL__null;
4718
4719 formal_prev = formal_arg;
4720
4721 /* Add arg to list of formal args. */
4722 add_formal_arg (&head, &tail, formal_arg, formal_arg->sym);
4723
4724 /* Validate changes. */
4725 gfc_commit_symbol (formal_arg->sym);
4726 if (actual)
4727 act_arg = act_arg->next;
4728 }
4729
4730 /* Add the interface to the symbol. */
4731 add_proc_interface (dest, IFSRC_DECL, head);
4732
4733 /* Store the formal namespace information. */
4734 if (dest->formal != NULL__null)
4735 /* The current ns should be that for the dest proc. */
4736 dest->formal_ns = gfc_current_ns;
4737 /* Restore the current namespace to what it was on entry. */
4738 gfc_current_ns = parent_ns;
4739}
4740
4741
4742static int
4743std_for_isocbinding_symbol (int id)
4744{
4745 switch (id)
4746 {
4747#define NAMED_INTCST(a,b,c,d) \
4748 case a:\
4749 return d;
4750#include "iso-c-binding.def"
4751#undef NAMED_INTCST
4752
4753#define NAMED_FUNCTION(a,b,c,d) \
4754 case a:\
4755 return d;
4756#define NAMED_SUBROUTINE(a,b,c,d) \
4757 case a:\
4758 return d;
4759#include "iso-c-binding.def"
4760#undef NAMED_FUNCTION
4761#undef NAMED_SUBROUTINE
4762
4763 default:
4764 return GFC_STD_F2003(1<<4);
4765 }
4766}
4767
4768/* Generate the given set of C interoperable kind objects, or all
4769 interoperable kinds. This function will only be given kind objects
4770 for valid iso_c_binding defined types because this is verified when
4771 the 'use' statement is parsed. If the user gives an 'only' clause,
4772 the specific kinds are looked up; if they don't exist, an error is
4773 reported. If the user does not give an 'only' clause, all
4774 iso_c_binding symbols are generated. If a list of specific kinds
4775 is given, it must have a NULL in the first empty spot to mark the
4776 end of the list. For C_null_(fun)ptr, dt_symtree has to be set and
4777 point to the symtree for c_(fun)ptr. */
4778
4779gfc_symtree *
4780generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
4781 const char *local_name, gfc_symtree *dt_symtree,
4782 bool hidden)
4783{
4784 const char *const name = (local_name && local_name[0])
4785 ? local_name : c_interop_kinds_table[s].name;
4786 gfc_symtree *tmp_symtree;
4787 gfc_symbol *tmp_sym = NULL__null;
4788 int index;
4789
4790 if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
4791 return NULL__null;
4792
4793 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
4794 if (hidden
4795 && (!tmp_symtree || !tmp_symtree->n.sym
4796 || tmp_symtree->n.sym->from_intmod != INTMOD_ISO_C_BINDING
4797 || tmp_symtree->n.sym->intmod_sym_id != s))
4798 tmp_symtree = NULL__null;
4799
4800 /* Already exists in this scope so don't re-add it. */
4801 if (tmp_symtree != NULL__null && (tmp_sym = tmp_symtree->n.sym) != NULL__null
4802 && (!tmp_sym->attr.generic
4803 || (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL__null)
4804 && tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
4805 {
4806 if (tmp_sym->attr.flavor == FL_DERIVED
4807 && !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
4808 {
4809 if (gfc_derived_types)
4810 {
4811 tmp_sym->dt_next = gfc_derived_types->dt_next;
4812 gfc_derived_types->dt_next = tmp_sym;
4813 }
4814 else
4815 {
4816 tmp_sym->dt_next = tmp_sym;
4817 }
4818 gfc_derived_types = tmp_sym;
4819 }
4820
4821 return tmp_symtree;
4822 }
4823
4824 /* Create the sym tree in the current ns. */
4825 if (hidden)
4826 {
4827 tmp_symtree = gfc_get_unique_symtree (gfc_current_ns);
4828 tmp_sym = gfc_new_symbol (name, gfc_current_ns);
4829
4830 /* Add to the list of tentative symbols. */
4831 latest_undo_chgset->syms.safe_push (tmp_sym);
4832 tmp_sym->old_symbol = NULL__null;
4833 tmp_sym->mark = 1;
4834 tmp_sym->gfc_new = 1;
4835
4836 tmp_symtree->n.sym = tmp_sym;
4837 tmp_sym->refs++;
4838 }
4839 else
4840 {
4841 gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
4842 gcc_assert (tmp_symtree)((void)(!(tmp_symtree) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4842, __FUNCTION__), 0 : 0))
;
4843 tmp_sym = tmp_symtree->n.sym;
4844 }
4845
4846 /* Say what module this symbol belongs to. */
4847 tmp_sym->module = gfc_get_string ("%s", mod_name);
4848 tmp_sym->from_intmod = INTMOD_ISO_C_BINDING;
4849 tmp_sym->intmod_sym_id = s;
4850 tmp_sym->attr.is_iso_c = 1;
4851 tmp_sym->attr.use_assoc = 1;
4852
4853 gcc_assert (dt_symtree == NULL || s == ISOCBINDING_NULL_FUNPTR((void)(!(dt_symtree == __null || s == ISOCBINDING_NULL_FUNPTR
|| s == ISOCBINDING_NULL_PTR) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4854, __FUNCTION__), 0 : 0))
4854 || s == ISOCBINDING_NULL_PTR)((void)(!(dt_symtree == __null || s == ISOCBINDING_NULL_FUNPTR
|| s == ISOCBINDING_NULL_PTR) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4854, __FUNCTION__), 0 : 0))
;
4855
4856 switch (s)
4857 {
4858
4859#define NAMED_INTCST(a,b,c,d) case a :
4860#define NAMED_REALCST(a,b,c,d) case a :
4861#define NAMED_CMPXCST(a,b,c,d) case a :
4862#define NAMED_LOGCST(a,b,c) case a :
4863#define NAMED_CHARKNDCST(a,b,c) case a :
4864#include "iso-c-binding.def"
4865
4866 tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL__null,
4867 c_interop_kinds_table[s].value);
4868
4869 /* Initialize an integer constant expression node. */
4870 tmp_sym->attr.flavor = FL_PARAMETER;
4871 tmp_sym->ts.type = BT_INTEGER;
4872 tmp_sym->ts.kind = gfc_default_integer_kind;
4873
4874 /* Mark this type as a C interoperable one. */
4875 tmp_sym->ts.is_c_interop = 1;
4876 tmp_sym->ts.is_iso_c = 1;
4877 tmp_sym->value->ts.is_c_interop = 1;
4878 tmp_sym->value->ts.is_iso_c = 1;
4879 tmp_sym->attr.is_c_interop = 1;
4880
4881 /* Tell what f90 type this c interop kind is valid. */
4882 tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type;
4883
4884 break;
4885
4886
4887#define NAMED_CHARCST(a,b,c) case a :
4888#include "iso-c-binding.def"
4889
4890 /* Initialize an integer constant expression node for the
4891 length of the character. */
4892 tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
4893 &gfc_current_locus, NULL__null, 1);
4894 tmp_sym->value->ts.is_c_interop = 1;
4895 tmp_sym->value->ts.is_iso_c = 1;
4896 tmp_sym->value->value.character.length = 1;
4897 tmp_sym->value->value.character.string[0]
4898 = (gfc_char_t) c_interop_kinds_table[s].value;
4899 tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL__null);
4900 tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
4901 NULL__null, 1);
4902
4903 /* May not need this in both attr and ts, but do need in
4904 attr for writing module file. */
4905 tmp_sym->attr.is_c_interop = 1;
4906
4907 tmp_sym->attr.flavor = FL_PARAMETER;
4908 tmp_sym->ts.type = BT_CHARACTER;
4909
4910 /* Need to set it to the C_CHAR kind. */
4911 tmp_sym->ts.kind = gfc_default_character_kind;
4912
4913 /* Mark this type as a C interoperable one. */
4914 tmp_sym->ts.is_c_interop = 1;
4915 tmp_sym->ts.is_iso_c = 1;
4916
4917 /* Tell what f90 type this c interop kind is valid. */
4918 tmp_sym->ts.f90_type = BT_CHARACTER;
4919
4920 break;
4921
4922 case ISOCBINDING_PTR:
4923 case ISOCBINDING_FUNPTR:
4924 {
4925 gfc_symbol *dt_sym;
4926 gfc_component *tmp_comp = NULL__null;
4927
4928 /* Generate real derived type. */
4929 if (hidden)
4930 dt_sym = tmp_sym;
4931 else
4932 {
4933 const char *hidden_name;
4934 gfc_interface *intr, *head;
4935
4936 hidden_name = gfc_dt_upper_string (tmp_sym->name);
4937 tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
4938 hidden_name);
4939 gcc_assert (tmp_symtree == NULL)((void)(!(tmp_symtree == __null) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 4939, __FUNCTION__), 0 : 0))
;
4940 gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
4941 dt_sym = tmp_symtree->n.sym;
4942 dt_sym->name = gfc_get_string (s == ISOCBINDING_PTR
4943 ? "c_ptr" : "c_funptr");
4944
4945 /* Generate an artificial generic function. */
4946 head = tmp_sym->generic;
4947 intr = gfc_get_interface ()((gfc_interface *) xcalloc (1, sizeof (gfc_interface)));
4948 intr->sym = dt_sym;
4949 intr->where = gfc_current_locus;
4950 intr->next = head;
4951 tmp_sym->generic = intr;
4952
4953 if (!tmp_sym->attr.generic
4954 && !gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL__null))
4955 return NULL__null;
4956
4957 if (!tmp_sym->attr.function
4958 && !gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL__null))
4959 return NULL__null;
4960 }
4961
4962 /* Say what module this symbol belongs to. */
4963 dt_sym->module = gfc_get_string ("%s", mod_name);
4964 dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
4965 dt_sym->intmod_sym_id = s;
4966 dt_sym->attr.use_assoc = 1;
4967
4968 /* Initialize an integer constant expression node. */
4969 dt_sym->attr.flavor = FL_DERIVED;
4970 dt_sym->ts.is_c_interop = 1;
4971 dt_sym->attr.is_c_interop = 1;
4972 dt_sym->attr.private_comp = 1;
4973 dt_sym->component_access = ACCESS_PRIVATE;
4974 dt_sym->ts.is_iso_c = 1;
4975 dt_sym->ts.type = BT_DERIVED;
4976 dt_sym->ts.f90_type = BT_VOID;
4977
4978 /* A derived type must have the bind attribute to be
4979 interoperable (J3/04-007, Section 15.2.3), even though
4980 the binding label is not used. */
4981 dt_sym->attr.is_bind_c = 1;
4982
4983 dt_sym->attr.referenced = 1;
4984 dt_sym->ts.u.derived = dt_sym;
4985
4986 /* Add the symbol created for the derived type to the current ns. */
4987 if (gfc_derived_types)
4988 {
4989 dt_sym->dt_next = gfc_derived_types->dt_next;
4990 gfc_derived_types->dt_next = dt_sym;
4991 }
4992 else
4993 {
4994 dt_sym->dt_next = dt_sym;
4995 }
4996 gfc_derived_types = dt_sym;
4997
4998 gfc_add_component (dt_sym, "c_address", &tmp_comp);
4999 if (tmp_comp == NULL__null)
5000 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5000, __FUNCTION__))
;
5001
5002 tmp_comp->ts.type = BT_INTEGER;
5003
5004 /* Set this because the module will need to read/write this field. */
5005 tmp_comp->ts.f90_type = BT_INTEGER;
5006
5007 /* The kinds for c_ptr and c_funptr are the same. */
5008 index = get_c_kind ("c_ptr", c_interop_kinds_table);
5009 tmp_comp->ts.kind = c_interop_kinds_table[index].value;
5010 tmp_comp->attr.access = ACCESS_PRIVATE;
5011
5012 /* Mark the component as C interoperable. */
5013 tmp_comp->ts.is_c_interop = 1;
5014 }
5015
5016 break;
5017
5018 case ISOCBINDING_NULL_PTR:
5019 case ISOCBINDING_NULL_FUNPTR:
5020 gen_special_c_interop_ptr (tmp_sym, dt_symtree);
5021 break;
5022
5023 default:
5024 gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5024, __FUNCTION__))
;
5025 }
5026 gfc_commit_symbol (tmp_sym);
5027 return tmp_symtree;
5028}
5029
5030
5031/* Check that a symbol is already typed. If strict is not set, an untyped
5032 symbol is acceptable for non-standard-conforming mode. */
5033
5034bool
5035gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns,
5036 bool strict, locus where)
5037{
5038 gcc_assert (sym)((void)(!(sym) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5038, __FUNCTION__), 0 : 0))
;
5039
5040 if (gfc_matching_prefix)
5041 return true;
5042
5043 /* Check for the type and try to give it an implicit one. */
5044 if (sym->ts.type == BT_UNKNOWN
5045 && !gfc_set_default_type (sym, 0, ns))
5046 {
5047 if (strict)
5048 {
5049 gfc_error ("Symbol %qs is used before it is typed at %L",
5050 sym->name, &where);
5051 return false;
5052 }
5053
5054 if (!gfc_notify_std (GFC_STD_GNU(1<<5), "Symbol %qs is used before"
5055 " it is typed at %L", sym->name, &where))
5056 return false;
5057 }
5058
5059 /* Everything is ok. */
5060 return true;
5061}
5062
5063
5064/* Construct a typebound-procedure structure. Those are stored in a tentative
5065 list and marked `error' until symbols are committed. */
5066
5067gfc_typebound_proc*
5068gfc_get_typebound_proc (gfc_typebound_proc *tb0)
5069{
5070 gfc_typebound_proc *result;
5071
5072 result = XCNEW (gfc_typebound_proc)((gfc_typebound_proc *) xcalloc (1, sizeof (gfc_typebound_proc
)))
;
5073 if (tb0)
5074 *result = *tb0;
5075 result->error = 1;
5076
5077 latest_undo_chgset->tbps.safe_push (result);
5078
5079 return result;
5080}
5081
5082
5083/* Get the super-type of a given derived type. */
5084
5085gfc_symbol*
5086gfc_get_derived_super_type (gfc_symbol* derived)
5087{
5088 gcc_assert (derived)((void)(!(derived) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5088, __FUNCTION__), 0 : 0))
;
5089
5090 if (derived->attr.generic)
5091 derived = gfc_find_dt_in_generic (derived);
5092
5093 if (!derived->attr.extension)
5094 return NULL__null;
5095
5096 gcc_assert (derived->components)((void)(!(derived->components) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5096, __FUNCTION__), 0 : 0))
;
5097 gcc_assert (derived->components->ts.type == BT_DERIVED)((void)(!(derived->components->ts.type == BT_DERIVED) ?
fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5097, __FUNCTION__), 0 : 0))
;
5098 gcc_assert (derived->components->ts.u.derived)((void)(!(derived->components->ts.u.derived) ? fancy_abort
("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5098, __FUNCTION__), 0 : 0))
;
5099
5100 if (derived->components->ts.u.derived->attr.generic)
5101 return gfc_find_dt_in_generic (derived->components->ts.u.derived);
5102
5103 return derived->components->ts.u.derived;
5104}
5105
5106
5107/* Get the ultimate super-type of a given derived type. */
5108
5109gfc_symbol*
5110gfc_get_ultimate_derived_super_type (gfc_symbol* derived)
5111{
5112 if (!derived->attr.extension)
5113 return NULL__null;
5114
5115 derived = gfc_get_derived_super_type (derived);
5116
5117 if (derived->attr.extension)
5118 return gfc_get_ultimate_derived_super_type (derived);
5119 else
5120 return derived;
5121}
5122
5123
5124/* Check if a derived type t2 is an extension of (or equal to) a type t1. */
5125
5126bool
5127gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2)
5128{
5129 while (!gfc_compare_derived_types (t1, t2) && t2->attr.extension)
5130 t2 = gfc_get_derived_super_type (t2);
5131 return gfc_compare_derived_types (t1, t2);
5132}
5133
5134
5135/* Check if two typespecs are type compatible (F03:5.1.1.2):
5136 If ts1 is nonpolymorphic, ts2 must be the same type.
5137 If ts1 is polymorphic (CLASS), ts2 must be an extension of ts1. */
5138
5139bool
5140gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
5141{
5142 bool is_class1 = (ts1->type == BT_CLASS);
5143 bool is_class2 = (ts2->type == BT_CLASS);
5144 bool is_derived1 = (ts1->type == BT_DERIVED);
5145 bool is_derived2 = (ts2->type == BT_DERIVED);
5146 bool is_union1 = (ts1->type == BT_UNION);
5147 bool is_union2 = (ts2->type == BT_UNION);
5148
5149 if (is_class1
5150 && ts1->u.derived->components
5151 && ((ts1->u.derived->attr.is_class
5152 && ts1->u.derived->components->ts.u.derived->attr
5153 .unlimited_polymorphic)
5154 || ts1->u.derived->attr.unlimited_polymorphic))
5155 return 1;
5156
5157 if (!is_derived1 && !is_derived2 && !is_class1 && !is_class2
5158 && !is_union1 && !is_union2)
5159 return (ts1->type == ts2->type);
5160
5161 if ((is_derived1 && is_derived2) || (is_union1 && is_union2))
5162 return gfc_compare_derived_types (ts1->u.derived, ts2->u.derived);
5163
5164 if (is_derived1 && is_class2)
5165 return gfc_compare_derived_types (ts1->u.derived,
5166 ts2->u.derived->attr.is_class ?
5167 ts2->u.derived->components->ts.u.derived
5168 : ts2->u.derived);
5169 if (is_class1 && is_derived2)
5170 return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
5171 ts1->u.derived->components->ts.u.derived
5172 : ts1->u.derived,
5173 ts2->u.derived);
5174 else if (is_class1 && is_class2)
5175 return gfc_type_is_extension_of (ts1->u.derived->attr.is_class ?
5176 ts1->u.derived->components->ts.u.derived
5177 : ts1->u.derived,
5178 ts2->u.derived->attr.is_class ?
5179 ts2->u.derived->components->ts.u.derived
5180 : ts2->u.derived);
5181 else
5182 return 0;
5183}
5184
5185
5186/* Find the parent-namespace of the current function. If we're inside
5187 BLOCK constructs, it may not be the current one. */
5188
5189gfc_namespace*
5190gfc_find_proc_namespace (gfc_namespace* ns)
5191{
5192 while (ns->construct_entities)
5193 {
5194 ns = ns->parent;
5195 gcc_assert (ns)((void)(!(ns) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/symbol.c"
, 5195, __FUNCTION__), 0 : 0))
;
5196 }
5197
5198 return ns;
5199}
5200
5201
5202/* Check if an associate-variable should be translated as an `implicit' pointer
5203 internally (if it is associated to a variable and not an array with
5204 descriptor). */
5205
5206bool
5207gfc_is_associate_pointer (gfc_symbol* sym)
5208{
5209 if (!sym->assoc)
5210 return false;
5211
5212 if (sym->ts.type == BT_CLASS)
5213 return true;
5214
5215 if (sym->ts.type == BT_CHARACTER
5216 && sym->ts.deferred
5217 && sym->assoc->target
5218 && sym->assoc->target->expr_type == EXPR_FUNCTION)
5219 return true;
5220
5221 if (!sym->assoc->variable)
5222 return false;
5223
5224 if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
5225 return false;
5226
5227 return true;
5228}
5229
5230
5231gfc_symbol *
5232gfc_find_dt_in_generic (gfc_symbol *sym)
5233{
5234 gfc_interface *intr = NULL__null;
5235
5236 if (!sym || gfc_fl_struct (sym->attr.flavor)((sym->attr.flavor) == FL_DERIVED || (sym->attr.flavor)
== FL_UNION || (sym->attr.flavor) == FL_STRUCT)
)
5237 return sym;
5238
5239 if (sym->attr.generic)
5240 for (intr = sym->generic; intr; intr = intr->next)
5241 if (gfc_fl_struct (intr->sym->attr.flavor)((intr->sym->attr.flavor) == FL_DERIVED || (intr->sym
->attr.flavor) == FL_UNION || (intr->sym->attr.flavor
) == FL_STRUCT)
)
5242 break;
5243 return intr ? intr->sym : NULL__null;
5244}
5245
5246
5247/* Get the dummy arguments from a procedure symbol. If it has been declared
5248 via a PROCEDURE statement with a named interface, ts.interface will be set
5249 and the arguments need to be taken from there. */
5250
5251gfc_formal_arglist *
5252gfc_sym_get_dummy_args (gfc_symbol *sym)
5253{
5254 gfc_formal_arglist *dummies;
5255
5256 dummies = sym->formal;
5257 if (dummies == NULL__null && sym->ts.interface != NULL__null)
5258 dummies = sym->ts.interface->formal;
5259
5260 return dummies;
5261}