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