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