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