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