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