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