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