]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Maintain binary trees of symbols. |
8b791297 | 2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 |
710a179f | 3 | Free Software Foundation, Inc. |
6de9cd9a DN |
4 | Contributed by Andy Vaught |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 10 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 11 | version. |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
19 | along with GCC; see the file COPYING3. If not see |
20 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
21 | |
22 | ||
23 | #include "config.h" | |
d22e4895 | 24 | #include "system.h" |
6690a9e0 | 25 | #include "flags.h" |
6de9cd9a DN |
26 | #include "gfortran.h" |
27 | #include "parse.h" | |
3df684e2 | 28 | #include "match.h" |
6de9cd9a | 29 | |
a8b3b0b6 | 30 | |
6de9cd9a DN |
31 | /* Strings for all symbol attributes. We use these for dumping the |
32 | parse tree, in error messages, and also when reading and writing | |
33 | modules. */ | |
34 | ||
35 | const mstring flavors[] = | |
36 | { | |
37 | minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), | |
38 | minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), | |
39 | minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), | |
40 | minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), | |
41 | minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), | |
42 | minit (NULL, -1) | |
43 | }; | |
44 | ||
45 | const mstring procedures[] = | |
46 | { | |
47 | minit ("UNKNOWN-PROC", PROC_UNKNOWN), | |
48 | minit ("MODULE-PROC", PROC_MODULE), | |
49 | minit ("INTERNAL-PROC", PROC_INTERNAL), | |
50 | minit ("DUMMY-PROC", PROC_DUMMY), | |
51 | minit ("INTRINSIC-PROC", PROC_INTRINSIC), | |
52 | minit ("EXTERNAL-PROC", PROC_EXTERNAL), | |
53 | minit ("STATEMENT-PROC", PROC_ST_FUNCTION), | |
54 | minit (NULL, -1) | |
55 | }; | |
56 | ||
57 | const mstring intents[] = | |
58 | { | |
59 | minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), | |
60 | minit ("IN", INTENT_IN), | |
61 | minit ("OUT", INTENT_OUT), | |
62 | minit ("INOUT", INTENT_INOUT), | |
63 | minit (NULL, -1) | |
64 | }; | |
65 | ||
66 | const mstring access_types[] = | |
67 | { | |
68 | minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), | |
69 | minit ("PUBLIC", ACCESS_PUBLIC), | |
70 | minit ("PRIVATE", ACCESS_PRIVATE), | |
71 | minit (NULL, -1) | |
72 | }; | |
73 | ||
74 | const mstring ifsrc_types[] = | |
75 | { | |
76 | minit ("UNKNOWN", IFSRC_UNKNOWN), | |
77 | minit ("DECL", IFSRC_DECL), | |
c73b6478 | 78 | minit ("BODY", IFSRC_IFBODY) |
6de9cd9a DN |
79 | }; |
80 | ||
ef7236d2 DF |
81 | const mstring save_status[] = |
82 | { | |
83 | minit ("UNKNOWN", SAVE_NONE), | |
84 | minit ("EXPLICIT-SAVE", SAVE_EXPLICIT), | |
85 | minit ("IMPLICIT-SAVE", SAVE_IMPLICIT), | |
86 | }; | |
6de9cd9a DN |
87 | |
88 | /* This is to make sure the backend generates setup code in the correct | |
89 | order. */ | |
90 | ||
91 | static int next_dummy_order = 1; | |
92 | ||
93 | ||
94 | gfc_namespace *gfc_current_ns; | |
71a7778c | 95 | gfc_namespace *gfc_global_ns_list; |
6de9cd9a | 96 | |
c9543002 TS |
97 | gfc_gsymbol *gfc_gsym_root = NULL; |
98 | ||
6de9cd9a DN |
99 | static gfc_symbol *changed_syms = NULL; |
100 | ||
7453378e PT |
101 | gfc_dt_list *gfc_derived_types; |
102 | ||
6de9cd9a | 103 | |
e34ccb4c DK |
104 | /* List of tentative typebound-procedures. */ |
105 | ||
106 | typedef struct tentative_tbp | |
107 | { | |
108 | gfc_typebound_proc *proc; | |
109 | struct tentative_tbp *next; | |
110 | } | |
111 | tentative_tbp; | |
112 | ||
113 | static tentative_tbp *tentative_tbp_list = NULL; | |
114 | ||
115 | ||
6de9cd9a DN |
116 | /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ |
117 | ||
1107b970 PB |
118 | /* The following static variable indicates whether a particular element has |
119 | been explicitly set or not. */ | |
6de9cd9a | 120 | |
6de9cd9a DN |
121 | static int new_flag[GFC_LETTERS]; |
122 | ||
123 | ||
124 | /* Handle a correctly parsed IMPLICIT NONE. */ | |
125 | ||
126 | void | |
127 | gfc_set_implicit_none (void) | |
128 | { | |
129 | int i; | |
130 | ||
438e1428 TS |
131 | if (gfc_current_ns->seen_implicit_none) |
132 | { | |
133 | gfc_error ("Duplicate IMPLICIT NONE statement at %C"); | |
134 | return; | |
135 | } | |
136 | ||
137 | gfc_current_ns->seen_implicit_none = 1; | |
138 | ||
1107b970 | 139 | for (i = 0; i < GFC_LETTERS; i++) |
6de9cd9a | 140 | { |
1107b970 PB |
141 | gfc_clear_ts (&gfc_current_ns->default_type[i]); |
142 | gfc_current_ns->set_flag[i] = 1; | |
6de9cd9a DN |
143 | } |
144 | } | |
145 | ||
146 | ||
1107b970 | 147 | /* Reset the implicit range flags. */ |
6de9cd9a DN |
148 | |
149 | void | |
1107b970 | 150 | gfc_clear_new_implicit (void) |
6de9cd9a DN |
151 | { |
152 | int i; | |
153 | ||
154 | for (i = 0; i < GFC_LETTERS; i++) | |
1107b970 | 155 | new_flag[i] = 0; |
6de9cd9a DN |
156 | } |
157 | ||
158 | ||
1107b970 | 159 | /* Prepare for a new implicit range. Sets flags in new_flag[]. */ |
6de9cd9a | 160 | |
17b1d2a0 | 161 | gfc_try |
1107b970 | 162 | gfc_add_new_implicit_range (int c1, int c2) |
6de9cd9a DN |
163 | { |
164 | int i; | |
165 | ||
166 | c1 -= 'a'; | |
167 | c2 -= 'a'; | |
168 | ||
169 | for (i = c1; i <= c2; i++) | |
170 | { | |
171 | if (new_flag[i]) | |
172 | { | |
173 | gfc_error ("Letter '%c' already set in IMPLICIT statement at %C", | |
174 | i + 'A'); | |
175 | return FAILURE; | |
176 | } | |
177 | ||
6de9cd9a DN |
178 | new_flag[i] = 1; |
179 | } | |
180 | ||
181 | return SUCCESS; | |
182 | } | |
183 | ||
184 | ||
1107b970 PB |
185 | /* Add a matched implicit range for gfc_set_implicit(). Check if merging |
186 | the new implicit types back into the existing types will work. */ | |
6de9cd9a | 187 | |
17b1d2a0 | 188 | gfc_try |
66e4ab31 | 189 | gfc_merge_new_implicit (gfc_typespec *ts) |
6de9cd9a DN |
190 | { |
191 | int i; | |
192 | ||
438e1428 TS |
193 | if (gfc_current_ns->seen_implicit_none) |
194 | { | |
195 | gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); | |
196 | return FAILURE; | |
197 | } | |
198 | ||
6de9cd9a | 199 | for (i = 0; i < GFC_LETTERS; i++) |
1107b970 PB |
200 | { |
201 | if (new_flag[i]) | |
202 | { | |
1107b970 PB |
203 | if (gfc_current_ns->set_flag[i]) |
204 | { | |
205 | gfc_error ("Letter %c already has an IMPLICIT type at %C", | |
206 | i + 'A'); | |
207 | return FAILURE; | |
208 | } | |
52f49934 | 209 | |
1107b970 | 210 | gfc_current_ns->default_type[i] = *ts; |
52f49934 | 211 | gfc_current_ns->implicit_loc[i] = gfc_current_locus; |
1107b970 PB |
212 | gfc_current_ns->set_flag[i] = 1; |
213 | } | |
214 | } | |
6de9cd9a DN |
215 | return SUCCESS; |
216 | } | |
217 | ||
218 | ||
eebc3ee0 | 219 | /* Given a symbol, return a pointer to the typespec for its default type. */ |
6de9cd9a DN |
220 | |
221 | gfc_typespec * | |
66e4ab31 | 222 | gfc_get_default_type (gfc_symbol *sym, gfc_namespace *ns) |
6de9cd9a DN |
223 | { |
224 | char letter; | |
225 | ||
226 | letter = sym->name[0]; | |
e6472bce FXC |
227 | |
228 | if (gfc_option.flag_allow_leading_underscore && letter == '_') | |
b0be8e5c | 229 | gfc_internal_error ("Option -fallow-leading-underscore is for use only by " |
e6472bce FXC |
230 | "gfortran developers, and should not be used for " |
231 | "implicitly typed variables"); | |
232 | ||
6de9cd9a | 233 | if (letter < 'a' || letter > 'z') |
c6acea9d | 234 | gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'",sym->name); |
6de9cd9a DN |
235 | |
236 | if (ns == NULL) | |
237 | ns = gfc_current_ns; | |
238 | ||
239 | return &ns->default_type[letter - 'a']; | |
240 | } | |
241 | ||
242 | ||
243 | /* Given a pointer to a symbol, set its type according to the first | |
244 | letter of its name. Fails if the letter in question has no default | |
245 | type. */ | |
246 | ||
17b1d2a0 | 247 | gfc_try |
66e4ab31 | 248 | gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) |
6de9cd9a DN |
249 | { |
250 | gfc_typespec *ts; | |
251 | ||
252 | if (sym->ts.type != BT_UNKNOWN) | |
253 | gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); | |
254 | ||
255 | ts = gfc_get_default_type (sym, ns); | |
256 | ||
257 | if (ts->type == BT_UNKNOWN) | |
258 | { | |
d1303acd TS |
259 | if (error_flag && !sym->attr.untyped) |
260 | { | |
261 | gfc_error ("Symbol '%s' at %L has no IMPLICIT type", | |
262 | sym->name, &sym->declared_at); | |
263 | sym->attr.untyped = 1; /* Ensure we only give an error once. */ | |
264 | } | |
6de9cd9a DN |
265 | |
266 | return FAILURE; | |
267 | } | |
268 | ||
269 | sym->ts = *ts; | |
270 | sym->attr.implicit_type = 1; | |
271 | ||
10c17e8f TB |
272 | if (ts->cl) |
273 | { | |
274 | sym->ts.cl = gfc_get_charlen (); | |
275 | *sym->ts.cl = *ts->cl; | |
276 | } | |
277 | ||
a8b3b0b6 CR |
278 | if (sym->attr.is_bind_c == 1) |
279 | { | |
280 | /* BIND(C) variables should not be implicitly declared. */ | |
281 | gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may " | |
282 | "not be C interoperable", sym->name, &sym->declared_at); | |
283 | sym->ts.f90_type = sym->ts.type; | |
284 | } | |
285 | ||
286 | if (sym->attr.dummy != 0) | |
287 | { | |
288 | if (sym->ns->proc_name != NULL | |
289 | && (sym->ns->proc_name->attr.subroutine != 0 | |
290 | || sym->ns->proc_name->attr.function != 0) | |
291 | && sym->ns->proc_name->attr.is_bind_c != 0) | |
292 | { | |
293 | /* Dummy args to a BIND(C) routine may not be interoperable if | |
294 | they are implicitly typed. */ | |
df2fba9e | 295 | gfc_warning_now ("Implicitly declared variable '%s' at %L may not " |
a8b3b0b6 CR |
296 | "be C interoperable but it is a dummy argument to " |
297 | "the BIND(C) procedure '%s' at %L", sym->name, | |
298 | &(sym->declared_at), sym->ns->proc_name->name, | |
299 | &(sym->ns->proc_name->declared_at)); | |
300 | sym->ts.f90_type = sym->ts.type; | |
301 | } | |
302 | } | |
303 | ||
6de9cd9a DN |
304 | return SUCCESS; |
305 | } | |
306 | ||
307 | ||
e9bd9f7d PT |
308 | /* This function is called from parse.c(parse_progunit) to check the |
309 | type of the function is not implicitly typed in the host namespace | |
310 | and to implicitly type the function result, if necessary. */ | |
311 | ||
312 | void | |
313 | gfc_check_function_type (gfc_namespace *ns) | |
314 | { | |
315 | gfc_symbol *proc = ns->proc_name; | |
316 | ||
317 | if (!proc->attr.contained || proc->result->attr.implicit_type) | |
318 | return; | |
319 | ||
320 | if (proc->result->ts.type == BT_UNKNOWN) | |
321 | { | |
322 | if (gfc_set_default_type (proc->result, 0, gfc_current_ns) | |
323 | == SUCCESS) | |
324 | { | |
325 | if (proc->result != proc) | |
c2de0c19 TB |
326 | { |
327 | proc->ts = proc->result->ts; | |
328 | proc->as = gfc_copy_array_spec (proc->result->as); | |
329 | proc->attr.dimension = proc->result->attr.dimension; | |
330 | proc->attr.pointer = proc->result->attr.pointer; | |
331 | proc->attr.allocatable = proc->result->attr.allocatable; | |
332 | } | |
e9bd9f7d | 333 | } |
3070bab4 | 334 | else if (!proc->result->attr.proc_pointer) |
e9bd9f7d | 335 | { |
c2de0c19 TB |
336 | gfc_error ("Function result '%s' at %L has no IMPLICIT type", |
337 | proc->result->name, &proc->result->declared_at); | |
e9bd9f7d PT |
338 | proc->result->attr.untyped = 1; |
339 | } | |
340 | } | |
341 | } | |
342 | ||
343 | ||
6de9cd9a DN |
344 | /******************** Symbol attribute stuff *********************/ |
345 | ||
346 | /* This is a generic conflict-checker. We do this to avoid having a | |
347 | single conflict in two places. */ | |
348 | ||
349 | #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } | |
350 | #define conf2(a) if (attr->a) { a2 = a; goto conflict; } | |
aa08038d EE |
351 | #define conf_std(a, b, std) if (attr->a && attr->b)\ |
352 | {\ | |
353 | a1 = a;\ | |
354 | a2 = b;\ | |
355 | standard = std;\ | |
356 | goto conflict_std;\ | |
357 | } | |
6de9cd9a | 358 | |
17b1d2a0 | 359 | static gfc_try |
66e4ab31 | 360 | check_conflict (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
361 | { |
362 | static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", | |
363 | *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", | |
775e6c3a | 364 | *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC", |
06469efd | 365 | *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)", |
775e6c3a | 366 | *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL", |
9aa433c2 | 367 | *privat = "PRIVATE", *recursive = "RECURSIVE", |
6de9cd9a | 368 | *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", |
9aa433c2 | 369 | *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", |
6de9cd9a | 370 | *function = "FUNCTION", *subroutine = "SUBROUTINE", |
e8ec07e1 | 371 | *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE", |
83d890b9 | 372 | *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER", |
06469efd | 373 | *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", |
9aa433c2 | 374 | *volatile_ = "VOLATILE", *is_protected = "PROTECTED", |
69773742 | 375 | *is_bind_c = "BIND(C)", *procedure = "PROCEDURE"; |
6c7a4dfd | 376 | static const char *threadprivate = "THREADPRIVATE"; |
6de9cd9a DN |
377 | |
378 | const char *a1, *a2; | |
aa08038d | 379 | int standard; |
6de9cd9a DN |
380 | |
381 | if (where == NULL) | |
63645982 | 382 | where = &gfc_current_locus; |
6de9cd9a DN |
383 | |
384 | if (attr->pointer && attr->intent != INTENT_UNKNOWN) | |
385 | { | |
386 | a1 = pointer; | |
387 | a2 = intent; | |
f17facac TB |
388 | standard = GFC_STD_F2003; |
389 | goto conflict_std; | |
6de9cd9a DN |
390 | } |
391 | ||
392 | /* Check for attributes not allowed in a BLOCK DATA. */ | |
393 | if (gfc_current_state () == COMP_BLOCK_DATA) | |
394 | { | |
395 | a1 = NULL; | |
396 | ||
53096259 PT |
397 | if (attr->in_namelist) |
398 | a1 = in_namelist; | |
6de9cd9a DN |
399 | if (attr->allocatable) |
400 | a1 = allocatable; | |
401 | if (attr->external) | |
402 | a1 = external; | |
403 | if (attr->optional) | |
404 | a1 = optional; | |
405 | if (attr->access == ACCESS_PRIVATE) | |
9aa433c2 | 406 | a1 = privat; |
6de9cd9a | 407 | if (attr->access == ACCESS_PUBLIC) |
9aa433c2 | 408 | a1 = publik; |
6de9cd9a DN |
409 | if (attr->intent != INTENT_UNKNOWN) |
410 | a1 = intent; | |
411 | ||
412 | if (a1 != NULL) | |
413 | { | |
414 | gfc_error | |
66e4ab31 SK |
415 | ("%s attribute not allowed in BLOCK DATA program unit at %L", |
416 | a1, where); | |
6de9cd9a DN |
417 | return FAILURE; |
418 | } | |
419 | } | |
420 | ||
ef7236d2 DF |
421 | if (attr->save == SAVE_EXPLICIT) |
422 | { | |
423 | conf (dummy, save); | |
424 | conf (in_common, save); | |
425 | conf (result, save); | |
426 | ||
427 | switch (attr->flavor) | |
428 | { | |
429 | case FL_PROGRAM: | |
430 | case FL_BLOCK_DATA: | |
431 | case FL_MODULE: | |
432 | case FL_LABEL: | |
ef7236d2 DF |
433 | case FL_DERIVED: |
434 | case FL_PARAMETER: | |
435 | a1 = gfc_code2string (flavors, attr->flavor); | |
436 | a2 = save; | |
437 | goto conflict; | |
438 | ||
8fb74da4 | 439 | case FL_PROCEDURE: |
beb4bd6c JW |
440 | /* Conflicts between SAVE and PROCEDURE will be checked at |
441 | resolution stage, see "resolve_fl_procedure". */ | |
ef7236d2 DF |
442 | case FL_VARIABLE: |
443 | case FL_NAMELIST: | |
444 | default: | |
445 | break; | |
446 | } | |
447 | } | |
448 | ||
9c213349 TB |
449 | conf (dummy, entry); |
450 | conf (dummy, intrinsic); | |
6c7a4dfd | 451 | conf (dummy, threadprivate); |
6de9cd9a | 452 | conf (pointer, target); |
6de9cd9a | 453 | conf (pointer, intrinsic); |
1902704e | 454 | conf (pointer, elemental); |
8e119f1b | 455 | conf (allocatable, elemental); |
1902704e | 456 | |
6de9cd9a DN |
457 | conf (target, external); |
458 | conf (target, intrinsic); | |
e6895430 JW |
459 | |
460 | if (!attr->if_source) | |
461 | conf (external, dimension); /* See Fortran 95's R504. */ | |
6de9cd9a DN |
462 | |
463 | conf (external, intrinsic); | |
a1dde7d4 | 464 | conf (entry, intrinsic); |
ef7236d2 | 465 | |
e6895430 | 466 | if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained) |
3070bab4 | 467 | conf (external, subroutine); |
1902704e | 468 | |
d1e49db4 JW |
469 | if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003, |
470 | "Fortran 2003: Procedure pointer at %C") == FAILURE) | |
471 | return FAILURE; | |
472 | ||
6de9cd9a | 473 | conf (allocatable, pointer); |
aa08038d | 474 | conf_std (allocatable, dummy, GFC_STD_F2003); |
8e119f1b EE |
475 | conf_std (allocatable, function, GFC_STD_F2003); |
476 | conf_std (allocatable, result, GFC_STD_F2003); | |
6de9cd9a DN |
477 | conf (elemental, recursive); |
478 | ||
479 | conf (in_common, dummy); | |
480 | conf (in_common, allocatable); | |
481 | conf (in_common, result); | |
96b95725 | 482 | |
6de9cd9a DN |
483 | conf (dummy, result); |
484 | ||
e8ec07e1 PT |
485 | conf (in_equivalence, use_assoc); |
486 | conf (in_equivalence, dummy); | |
487 | conf (in_equivalence, target); | |
488 | conf (in_equivalence, pointer); | |
489 | conf (in_equivalence, function); | |
490 | conf (in_equivalence, result); | |
491 | conf (in_equivalence, entry); | |
492 | conf (in_equivalence, allocatable); | |
6c7a4dfd | 493 | conf (in_equivalence, threadprivate); |
e8ec07e1 | 494 | |
6de9cd9a DN |
495 | conf (in_namelist, pointer); |
496 | conf (in_namelist, allocatable); | |
497 | ||
498 | conf (entry, result); | |
499 | ||
500 | conf (function, subroutine); | |
501 | ||
a8b3b0b6 CR |
502 | if (!function && !subroutine) |
503 | conf (is_bind_c, dummy); | |
504 | ||
505 | conf (is_bind_c, cray_pointer); | |
506 | conf (is_bind_c, cray_pointee); | |
507 | conf (is_bind_c, allocatable); | |
e3bfd8f4 | 508 | conf (is_bind_c, elemental); |
a8b3b0b6 CR |
509 | |
510 | /* Need to also get volatile attr, according to 5.1 of F2003 draft. | |
511 | Parameter conflict caught below. Also, value cannot be specified | |
512 | for a dummy procedure. */ | |
513 | ||
83d890b9 AL |
514 | /* Cray pointer/pointee conflicts. */ |
515 | conf (cray_pointer, cray_pointee); | |
516 | conf (cray_pointer, dimension); | |
517 | conf (cray_pointer, pointer); | |
518 | conf (cray_pointer, target); | |
519 | conf (cray_pointer, allocatable); | |
520 | conf (cray_pointer, external); | |
521 | conf (cray_pointer, intrinsic); | |
522 | conf (cray_pointer, in_namelist); | |
523 | conf (cray_pointer, function); | |
524 | conf (cray_pointer, subroutine); | |
525 | conf (cray_pointer, entry); | |
526 | ||
527 | conf (cray_pointee, allocatable); | |
528 | conf (cray_pointee, intent); | |
529 | conf (cray_pointee, optional); | |
530 | conf (cray_pointee, dummy); | |
531 | conf (cray_pointee, target); | |
83d890b9 AL |
532 | conf (cray_pointee, intrinsic); |
533 | conf (cray_pointee, pointer); | |
83d890b9 | 534 | conf (cray_pointee, entry); |
b122dc6a JJ |
535 | conf (cray_pointee, in_common); |
536 | conf (cray_pointee, in_equivalence); | |
6c7a4dfd | 537 | conf (cray_pointee, threadprivate); |
83d890b9 | 538 | |
4075a94e PT |
539 | conf (data, dummy); |
540 | conf (data, function); | |
541 | conf (data, result); | |
542 | conf (data, allocatable); | |
543 | conf (data, use_assoc); | |
544 | ||
06469efd PT |
545 | conf (value, pointer) |
546 | conf (value, allocatable) | |
547 | conf (value, subroutine) | |
548 | conf (value, function) | |
549 | conf (value, volatile_) | |
550 | conf (value, dimension) | |
551 | conf (value, external) | |
552 | ||
66e4ab31 SK |
553 | if (attr->value |
554 | && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) | |
06469efd PT |
555 | { |
556 | a1 = value; | |
557 | a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout; | |
558 | goto conflict; | |
559 | } | |
560 | ||
9aa433c2 KG |
561 | conf (is_protected, intrinsic) |
562 | conf (is_protected, external) | |
563 | conf (is_protected, in_common) | |
a8b3b0b6 | 564 | |
775e6c3a TB |
565 | conf (volatile_, intrinsic) |
566 | conf (volatile_, external) | |
567 | ||
568 | if (attr->volatile_ && attr->intent == INTENT_IN) | |
569 | { | |
570 | a1 = volatile_; | |
571 | a2 = intent_in; | |
572 | goto conflict; | |
573 | } | |
574 | ||
69773742 JW |
575 | conf (procedure, allocatable) |
576 | conf (procedure, dimension) | |
577 | conf (procedure, intrinsic) | |
9aa433c2 | 578 | conf (procedure, is_protected) |
69773742 JW |
579 | conf (procedure, target) |
580 | conf (procedure, value) | |
581 | conf (procedure, volatile_) | |
582 | conf (procedure, entry) | |
69773742 | 583 | |
6de9cd9a DN |
584 | a1 = gfc_code2string (flavors, attr->flavor); |
585 | ||
586 | if (attr->in_namelist | |
587 | && attr->flavor != FL_VARIABLE | |
847b053d | 588 | && attr->flavor != FL_PROCEDURE |
6de9cd9a DN |
589 | && attr->flavor != FL_UNKNOWN) |
590 | { | |
6de9cd9a DN |
591 | a2 = in_namelist; |
592 | goto conflict; | |
593 | } | |
594 | ||
595 | switch (attr->flavor) | |
596 | { | |
597 | case FL_PROGRAM: | |
598 | case FL_BLOCK_DATA: | |
599 | case FL_MODULE: | |
600 | case FL_LABEL: | |
9c213349 | 601 | conf2 (dimension); |
6de9cd9a | 602 | conf2 (dummy); |
d7043acd | 603 | conf2 (volatile_); |
6de9cd9a | 604 | conf2 (pointer); |
9aa433c2 | 605 | conf2 (is_protected); |
6de9cd9a DN |
606 | conf2 (target); |
607 | conf2 (external); | |
608 | conf2 (intrinsic); | |
609 | conf2 (allocatable); | |
610 | conf2 (result); | |
611 | conf2 (in_namelist); | |
612 | conf2 (optional); | |
613 | conf2 (function); | |
614 | conf2 (subroutine); | |
6c7a4dfd | 615 | conf2 (threadprivate); |
e7bff0d1 TB |
616 | |
617 | if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE) | |
618 | { | |
9aa433c2 | 619 | a2 = attr->access == ACCESS_PUBLIC ? publik : privat; |
e7bff0d1 TB |
620 | gfc_error ("%s attribute applied to %s %s at %L", a2, a1, |
621 | name, where); | |
622 | return FAILURE; | |
623 | } | |
624 | ||
625 | if (attr->is_bind_c) | |
626 | { | |
627 | gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where); | |
628 | return FAILURE; | |
629 | } | |
630 | ||
6de9cd9a DN |
631 | break; |
632 | ||
633 | case FL_VARIABLE: | |
726d8566 JW |
634 | break; |
635 | ||
6de9cd9a | 636 | case FL_NAMELIST: |
726d8566 | 637 | conf2 (result); |
6de9cd9a DN |
638 | break; |
639 | ||
640 | case FL_PROCEDURE: | |
3070bab4 JW |
641 | /* Conflicts with INTENT, SAVE and RESULT will be checked |
642 | at resolution stage, see "resolve_fl_procedure". */ | |
6de9cd9a DN |
643 | |
644 | if (attr->subroutine) | |
645 | { | |
66e4ab31 SK |
646 | conf2 (target); |
647 | conf2 (allocatable); | |
66e4ab31 SK |
648 | conf2 (in_namelist); |
649 | conf2 (dimension); | |
650 | conf2 (function); | |
651 | conf2 (threadprivate); | |
6de9cd9a DN |
652 | } |
653 | ||
00625fae JW |
654 | if (!attr->proc_pointer) |
655 | conf2 (in_common); | |
656 | ||
6de9cd9a DN |
657 | switch (attr->proc) |
658 | { | |
659 | case PROC_ST_FUNCTION: | |
2bb02bf0 | 660 | conf2 (dummy); |
6de9cd9a DN |
661 | break; |
662 | ||
663 | case PROC_MODULE: | |
664 | conf2 (dummy); | |
665 | break; | |
666 | ||
667 | case PROC_DUMMY: | |
668 | conf2 (result); | |
6c7a4dfd | 669 | conf2 (threadprivate); |
6de9cd9a DN |
670 | break; |
671 | ||
672 | default: | |
673 | break; | |
674 | } | |
675 | ||
676 | break; | |
677 | ||
678 | case FL_DERIVED: | |
679 | conf2 (dummy); | |
6de9cd9a DN |
680 | conf2 (pointer); |
681 | conf2 (target); | |
682 | conf2 (external); | |
683 | conf2 (intrinsic); | |
684 | conf2 (allocatable); | |
685 | conf2 (optional); | |
686 | conf2 (entry); | |
687 | conf2 (function); | |
688 | conf2 (subroutine); | |
6c7a4dfd | 689 | conf2 (threadprivate); |
726d8566 | 690 | conf2 (result); |
6de9cd9a DN |
691 | |
692 | if (attr->intent != INTENT_UNKNOWN) | |
693 | { | |
694 | a2 = intent; | |
695 | goto conflict; | |
696 | } | |
697 | break; | |
698 | ||
699 | case FL_PARAMETER: | |
700 | conf2 (external); | |
701 | conf2 (intrinsic); | |
702 | conf2 (optional); | |
703 | conf2 (allocatable); | |
704 | conf2 (function); | |
705 | conf2 (subroutine); | |
706 | conf2 (entry); | |
707 | conf2 (pointer); | |
9aa433c2 | 708 | conf2 (is_protected); |
6de9cd9a DN |
709 | conf2 (target); |
710 | conf2 (dummy); | |
711 | conf2 (in_common); | |
06469efd | 712 | conf2 (value); |
775e6c3a | 713 | conf2 (volatile_); |
6c7a4dfd | 714 | conf2 (threadprivate); |
a8b3b0b6 | 715 | conf2 (value); |
a1dde7d4 | 716 | conf2 (is_bind_c); |
726d8566 | 717 | conf2 (result); |
6de9cd9a DN |
718 | break; |
719 | ||
720 | default: | |
721 | break; | |
722 | } | |
723 | ||
724 | return SUCCESS; | |
725 | ||
726 | conflict: | |
231b2fcc TS |
727 | if (name == NULL) |
728 | gfc_error ("%s attribute conflicts with %s attribute at %L", | |
729 | a1, a2, where); | |
730 | else | |
731 | gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L", | |
732 | a1, a2, name, where); | |
733 | ||
6de9cd9a | 734 | return FAILURE; |
aa08038d EE |
735 | |
736 | conflict_std: | |
737 | if (name == NULL) | |
738 | { | |
f17facac | 739 | return gfc_notify_std (standard, "Fortran 2003: %s attribute " |
ee167bcb | 740 | "with %s attribute at %L", a1, a2, |
aa08038d EE |
741 | where); |
742 | } | |
743 | else | |
744 | { | |
f17facac TB |
745 | return gfc_notify_std (standard, "Fortran 2003: %s attribute " |
746 | "with %s attribute in '%s' at %L", | |
aa08038d EE |
747 | a1, a2, name, where); |
748 | } | |
6de9cd9a DN |
749 | } |
750 | ||
751 | #undef conf | |
752 | #undef conf2 | |
aa08038d | 753 | #undef conf_std |
6de9cd9a DN |
754 | |
755 | ||
756 | /* Mark a symbol as referenced. */ | |
757 | ||
758 | void | |
66e4ab31 | 759 | gfc_set_sym_referenced (gfc_symbol *sym) |
6de9cd9a | 760 | { |
66e4ab31 | 761 | |
6de9cd9a DN |
762 | if (sym->attr.referenced) |
763 | return; | |
764 | ||
765 | sym->attr.referenced = 1; | |
766 | ||
767 | /* Remember which order dummy variables are accessed in. */ | |
768 | if (sym->attr.dummy) | |
769 | sym->dummy_order = next_dummy_order++; | |
770 | } | |
771 | ||
772 | ||
773 | /* Common subroutine called by attribute changing subroutines in order | |
774 | to prevent them from changing a symbol that has been | |
775 | use-associated. Returns zero if it is OK to change the symbol, | |
776 | nonzero if not. */ | |
777 | ||
778 | static int | |
66e4ab31 | 779 | check_used (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
780 | { |
781 | ||
782 | if (attr->use_assoc == 0) | |
783 | return 0; | |
784 | ||
785 | if (where == NULL) | |
63645982 | 786 | where = &gfc_current_locus; |
6de9cd9a | 787 | |
231b2fcc TS |
788 | if (name == NULL) |
789 | gfc_error ("Cannot change attributes of USE-associated symbol at %L", | |
790 | where); | |
791 | else | |
792 | gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", | |
793 | name, where); | |
6de9cd9a DN |
794 | |
795 | return 1; | |
796 | } | |
797 | ||
798 | ||
6de9cd9a DN |
799 | /* Generate an error because of a duplicate attribute. */ |
800 | ||
801 | static void | |
66e4ab31 | 802 | duplicate_attr (const char *attr, locus *where) |
6de9cd9a DN |
803 | { |
804 | ||
805 | if (where == NULL) | |
63645982 | 806 | where = &gfc_current_locus; |
6de9cd9a DN |
807 | |
808 | gfc_error ("Duplicate %s attribute specified at %L", attr, where); | |
809 | } | |
810 | ||
66e4ab31 SK |
811 | |
812 | /* Called from decl.c (attr_decl1) to check attributes, when declared | |
813 | separately. */ | |
6de9cd9a | 814 | |
17b1d2a0 | 815 | gfc_try |
66e4ab31 | 816 | gfc_add_attribute (symbol_attribute *attr, locus *where) |
1902704e | 817 | { |
66e4ab31 | 818 | |
7114edca | 819 | if (check_used (attr, NULL, where)) |
1902704e PT |
820 | return FAILURE; |
821 | ||
822 | return check_conflict (attr, NULL, where); | |
823 | } | |
824 | ||
17b1d2a0 | 825 | gfc_try |
66e4ab31 | 826 | gfc_add_allocatable (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
827 | { |
828 | ||
7114edca | 829 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
830 | return FAILURE; |
831 | ||
832 | if (attr->allocatable) | |
833 | { | |
834 | duplicate_attr ("ALLOCATABLE", where); | |
835 | return FAILURE; | |
836 | } | |
837 | ||
e62532af JW |
838 | if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY |
839 | && gfc_find_state (COMP_INTERFACE) == FAILURE) | |
840 | { | |
841 | gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L", | |
842 | where); | |
843 | return FAILURE; | |
844 | } | |
845 | ||
6de9cd9a | 846 | attr->allocatable = 1; |
231b2fcc | 847 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
848 | } |
849 | ||
850 | ||
17b1d2a0 | 851 | gfc_try |
66e4ab31 | 852 | gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
853 | { |
854 | ||
7114edca | 855 | if (check_used (attr, name, where)) |
6de9cd9a DN |
856 | return FAILURE; |
857 | ||
858 | if (attr->dimension) | |
859 | { | |
860 | duplicate_attr ("DIMENSION", where); | |
861 | return FAILURE; | |
862 | } | |
863 | ||
e62532af JW |
864 | if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY |
865 | && gfc_find_state (COMP_INTERFACE) == FAILURE) | |
866 | { | |
867 | gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body " | |
868 | "at %L", name, where); | |
869 | return FAILURE; | |
870 | } | |
871 | ||
6de9cd9a | 872 | attr->dimension = 1; |
231b2fcc | 873 | return check_conflict (attr, name, where); |
6de9cd9a DN |
874 | } |
875 | ||
876 | ||
17b1d2a0 | 877 | gfc_try |
66e4ab31 | 878 | gfc_add_external (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
879 | { |
880 | ||
7114edca | 881 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
882 | return FAILURE; |
883 | ||
884 | if (attr->external) | |
885 | { | |
886 | duplicate_attr ("EXTERNAL", where); | |
887 | return FAILURE; | |
888 | } | |
889 | ||
8fb74da4 JW |
890 | if (attr->pointer && attr->if_source != IFSRC_IFBODY) |
891 | { | |
892 | attr->pointer = 0; | |
893 | attr->proc_pointer = 1; | |
894 | } | |
895 | ||
6de9cd9a DN |
896 | attr->external = 1; |
897 | ||
231b2fcc | 898 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
899 | } |
900 | ||
901 | ||
17b1d2a0 | 902 | gfc_try |
66e4ab31 | 903 | gfc_add_intrinsic (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
904 | { |
905 | ||
7114edca | 906 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
907 | return FAILURE; |
908 | ||
909 | if (attr->intrinsic) | |
910 | { | |
911 | duplicate_attr ("INTRINSIC", where); | |
912 | return FAILURE; | |
913 | } | |
914 | ||
915 | attr->intrinsic = 1; | |
916 | ||
231b2fcc | 917 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
918 | } |
919 | ||
920 | ||
17b1d2a0 | 921 | gfc_try |
66e4ab31 | 922 | gfc_add_optional (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
923 | { |
924 | ||
7114edca | 925 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
926 | return FAILURE; |
927 | ||
928 | if (attr->optional) | |
929 | { | |
930 | duplicate_attr ("OPTIONAL", where); | |
931 | return FAILURE; | |
932 | } | |
933 | ||
934 | attr->optional = 1; | |
231b2fcc | 935 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
936 | } |
937 | ||
938 | ||
17b1d2a0 | 939 | gfc_try |
66e4ab31 | 940 | gfc_add_pointer (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
941 | { |
942 | ||
7114edca | 943 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
944 | return FAILURE; |
945 | ||
8fb74da4 JW |
946 | if (attr->pointer && !(attr->if_source == IFSRC_IFBODY |
947 | && gfc_find_state (COMP_INTERFACE) == FAILURE)) | |
948 | { | |
949 | duplicate_attr ("POINTER", where); | |
950 | return FAILURE; | |
951 | } | |
952 | ||
953 | if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY) | |
954 | || (attr->if_source == IFSRC_IFBODY | |
955 | && gfc_find_state (COMP_INTERFACE) == FAILURE)) | |
956 | attr->proc_pointer = 1; | |
957 | else | |
958 | attr->pointer = 1; | |
959 | ||
231b2fcc | 960 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
961 | } |
962 | ||
963 | ||
17b1d2a0 | 964 | gfc_try |
66e4ab31 | 965 | gfc_add_cray_pointer (symbol_attribute *attr, locus *where) |
83d890b9 AL |
966 | { |
967 | ||
7114edca | 968 | if (check_used (attr, NULL, where)) |
83d890b9 AL |
969 | return FAILURE; |
970 | ||
971 | attr->cray_pointer = 1; | |
972 | return check_conflict (attr, NULL, where); | |
973 | } | |
974 | ||
975 | ||
17b1d2a0 | 976 | gfc_try |
66e4ab31 | 977 | gfc_add_cray_pointee (symbol_attribute *attr, locus *where) |
83d890b9 AL |
978 | { |
979 | ||
7114edca | 980 | if (check_used (attr, NULL, where)) |
83d890b9 AL |
981 | return FAILURE; |
982 | ||
983 | if (attr->cray_pointee) | |
984 | { | |
985 | gfc_error ("Cray Pointee at %L appears in multiple pointer()" | |
e25a0da3 | 986 | " statements", where); |
83d890b9 AL |
987 | return FAILURE; |
988 | } | |
989 | ||
990 | attr->cray_pointee = 1; | |
991 | return check_conflict (attr, NULL, where); | |
992 | } | |
993 | ||
66e4ab31 | 994 | |
17b1d2a0 | 995 | gfc_try |
66e4ab31 | 996 | gfc_add_protected (symbol_attribute *attr, const char *name, locus *where) |
ee7e677f TB |
997 | { |
998 | if (check_used (attr, name, where)) | |
999 | return FAILURE; | |
1000 | ||
9aa433c2 | 1001 | if (attr->is_protected) |
ee7e677f TB |
1002 | { |
1003 | if (gfc_notify_std (GFC_STD_LEGACY, | |
1004 | "Duplicate PROTECTED attribute specified at %L", | |
1005 | where) | |
1006 | == FAILURE) | |
1007 | return FAILURE; | |
1008 | } | |
1009 | ||
9aa433c2 | 1010 | attr->is_protected = 1; |
ee7e677f TB |
1011 | return check_conflict (attr, name, where); |
1012 | } | |
83d890b9 | 1013 | |
66e4ab31 | 1014 | |
17b1d2a0 | 1015 | gfc_try |
66e4ab31 | 1016 | gfc_add_result (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1017 | { |
1018 | ||
7114edca | 1019 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1020 | return FAILURE; |
1021 | ||
1022 | attr->result = 1; | |
231b2fcc | 1023 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1024 | } |
1025 | ||
1026 | ||
17b1d2a0 | 1027 | gfc_try |
66e4ab31 | 1028 | gfc_add_save (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1029 | { |
1030 | ||
231b2fcc | 1031 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1032 | return FAILURE; |
1033 | ||
1034 | if (gfc_pure (NULL)) | |
1035 | { | |
1036 | gfc_error | |
1037 | ("SAVE attribute at %L cannot be specified in a PURE procedure", | |
1038 | where); | |
1039 | return FAILURE; | |
1040 | } | |
1041 | ||
5349080d | 1042 | if (attr->save == SAVE_EXPLICIT) |
6de9cd9a | 1043 | { |
09e87839 AL |
1044 | if (gfc_notify_std (GFC_STD_LEGACY, |
1045 | "Duplicate SAVE attribute specified at %L", | |
1046 | where) | |
1047 | == FAILURE) | |
1048 | return FAILURE; | |
6de9cd9a DN |
1049 | } |
1050 | ||
5349080d | 1051 | attr->save = SAVE_EXPLICIT; |
231b2fcc | 1052 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1053 | } |
1054 | ||
66e4ab31 | 1055 | |
17b1d2a0 | 1056 | gfc_try |
66e4ab31 | 1057 | gfc_add_value (symbol_attribute *attr, const char *name, locus *where) |
06469efd PT |
1058 | { |
1059 | ||
1060 | if (check_used (attr, name, where)) | |
1061 | return FAILURE; | |
1062 | ||
1063 | if (attr->value) | |
1064 | { | |
1065 | if (gfc_notify_std (GFC_STD_LEGACY, | |
1066 | "Duplicate VALUE attribute specified at %L", | |
1067 | where) | |
1068 | == FAILURE) | |
1069 | return FAILURE; | |
1070 | } | |
1071 | ||
1072 | attr->value = 1; | |
1073 | return check_conflict (attr, name, where); | |
1074 | } | |
1075 | ||
66e4ab31 | 1076 | |
17b1d2a0 | 1077 | gfc_try |
66e4ab31 | 1078 | gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) |
775e6c3a | 1079 | { |
9bce3c1c TB |
1080 | /* No check_used needed as 11.2.1 of the F2003 standard allows |
1081 | that the local identifier made accessible by a use statement can be | |
1082 | given a VOLATILE attribute. */ | |
1083 | ||
77bb16aa TB |
1084 | if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) |
1085 | if (gfc_notify_std (GFC_STD_LEGACY, | |
1086 | "Duplicate VOLATILE attribute specified at %L", where) | |
1087 | == FAILURE) | |
1088 | return FAILURE; | |
775e6c3a TB |
1089 | |
1090 | attr->volatile_ = 1; | |
77bb16aa | 1091 | attr->volatile_ns = gfc_current_ns; |
775e6c3a TB |
1092 | return check_conflict (attr, name, where); |
1093 | } | |
1094 | ||
6de9cd9a | 1095 | |
17b1d2a0 | 1096 | gfc_try |
66e4ab31 | 1097 | gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where) |
6c7a4dfd | 1098 | { |
66e4ab31 | 1099 | |
6c7a4dfd JJ |
1100 | if (check_used (attr, name, where)) |
1101 | return FAILURE; | |
1102 | ||
1103 | if (attr->threadprivate) | |
1104 | { | |
1105 | duplicate_attr ("THREADPRIVATE", where); | |
1106 | return FAILURE; | |
1107 | } | |
1108 | ||
1109 | attr->threadprivate = 1; | |
1110 | return check_conflict (attr, name, where); | |
1111 | } | |
1112 | ||
1113 | ||
17b1d2a0 | 1114 | gfc_try |
66e4ab31 | 1115 | gfc_add_target (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
1116 | { |
1117 | ||
7114edca | 1118 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
1119 | return FAILURE; |
1120 | ||
1121 | if (attr->target) | |
1122 | { | |
1123 | duplicate_attr ("TARGET", where); | |
1124 | return FAILURE; | |
1125 | } | |
1126 | ||
1127 | attr->target = 1; | |
231b2fcc | 1128 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
1129 | } |
1130 | ||
1131 | ||
17b1d2a0 | 1132 | gfc_try |
66e4ab31 | 1133 | gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1134 | { |
1135 | ||
231b2fcc | 1136 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1137 | return FAILURE; |
1138 | ||
eebc3ee0 | 1139 | /* Duplicate dummy arguments are allowed due to ENTRY statements. */ |
6de9cd9a | 1140 | attr->dummy = 1; |
231b2fcc | 1141 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1142 | } |
1143 | ||
1144 | ||
17b1d2a0 | 1145 | gfc_try |
66e4ab31 | 1146 | gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1147 | { |
1148 | ||
7114edca | 1149 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1150 | return FAILURE; |
1151 | ||
1152 | /* Duplicate attribute already checked for. */ | |
1153 | attr->in_common = 1; | |
00625fae | 1154 | return check_conflict (attr, name, where); |
e8ec07e1 PT |
1155 | } |
1156 | ||
66e4ab31 | 1157 | |
17b1d2a0 | 1158 | gfc_try |
66e4ab31 | 1159 | gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where) |
e8ec07e1 PT |
1160 | { |
1161 | ||
1162 | /* Duplicate attribute already checked for. */ | |
1163 | attr->in_equivalence = 1; | |
1164 | if (check_conflict (attr, name, where) == FAILURE) | |
1165 | return FAILURE; | |
1166 | ||
1167 | if (attr->flavor == FL_VARIABLE) | |
1168 | return SUCCESS; | |
6de9cd9a | 1169 | |
231b2fcc | 1170 | return gfc_add_flavor (attr, FL_VARIABLE, name, where); |
6de9cd9a DN |
1171 | } |
1172 | ||
1173 | ||
17b1d2a0 | 1174 | gfc_try |
231b2fcc | 1175 | gfc_add_data (symbol_attribute *attr, const char *name, locus *where) |
9056bd70 TS |
1176 | { |
1177 | ||
231b2fcc | 1178 | if (check_used (attr, name, where)) |
9056bd70 TS |
1179 | return FAILURE; |
1180 | ||
1181 | attr->data = 1; | |
231b2fcc | 1182 | return check_conflict (attr, name, where); |
9056bd70 TS |
1183 | } |
1184 | ||
1185 | ||
17b1d2a0 | 1186 | gfc_try |
66e4ab31 | 1187 | gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1188 | { |
1189 | ||
1190 | attr->in_namelist = 1; | |
231b2fcc | 1191 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1192 | } |
1193 | ||
1194 | ||
17b1d2a0 | 1195 | gfc_try |
66e4ab31 | 1196 | gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1197 | { |
1198 | ||
231b2fcc | 1199 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1200 | return FAILURE; |
1201 | ||
1202 | attr->sequence = 1; | |
231b2fcc | 1203 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1204 | } |
1205 | ||
1206 | ||
17b1d2a0 | 1207 | gfc_try |
66e4ab31 | 1208 | gfc_add_elemental (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
1209 | { |
1210 | ||
7114edca | 1211 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
1212 | return FAILURE; |
1213 | ||
10a6db6e TB |
1214 | if (attr->elemental) |
1215 | { | |
1216 | duplicate_attr ("ELEMENTAL", where); | |
1217 | return FAILURE; | |
1218 | } | |
1219 | ||
6de9cd9a | 1220 | attr->elemental = 1; |
231b2fcc | 1221 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
1222 | } |
1223 | ||
1224 | ||
17b1d2a0 | 1225 | gfc_try |
66e4ab31 | 1226 | gfc_add_pure (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
1227 | { |
1228 | ||
7114edca | 1229 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
1230 | return FAILURE; |
1231 | ||
10a6db6e TB |
1232 | if (attr->pure) |
1233 | { | |
1234 | duplicate_attr ("PURE", where); | |
1235 | return FAILURE; | |
1236 | } | |
1237 | ||
6de9cd9a | 1238 | attr->pure = 1; |
231b2fcc | 1239 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
1240 | } |
1241 | ||
1242 | ||
17b1d2a0 | 1243 | gfc_try |
66e4ab31 | 1244 | gfc_add_recursive (symbol_attribute *attr, locus *where) |
6de9cd9a DN |
1245 | { |
1246 | ||
7114edca | 1247 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
1248 | return FAILURE; |
1249 | ||
10a6db6e TB |
1250 | if (attr->recursive) |
1251 | { | |
1252 | duplicate_attr ("RECURSIVE", where); | |
1253 | return FAILURE; | |
1254 | } | |
1255 | ||
6de9cd9a | 1256 | attr->recursive = 1; |
231b2fcc | 1257 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
1258 | } |
1259 | ||
1260 | ||
17b1d2a0 | 1261 | gfc_try |
66e4ab31 | 1262 | gfc_add_entry (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1263 | { |
1264 | ||
231b2fcc | 1265 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1266 | return FAILURE; |
1267 | ||
1268 | if (attr->entry) | |
1269 | { | |
1270 | duplicate_attr ("ENTRY", where); | |
1271 | return FAILURE; | |
1272 | } | |
1273 | ||
1274 | attr->entry = 1; | |
231b2fcc | 1275 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1276 | } |
1277 | ||
1278 | ||
17b1d2a0 | 1279 | gfc_try |
66e4ab31 | 1280 | gfc_add_function (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1281 | { |
1282 | ||
1283 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 1284 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
1285 | return FAILURE; |
1286 | ||
1287 | attr->function = 1; | |
231b2fcc | 1288 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1289 | } |
1290 | ||
1291 | ||
17b1d2a0 | 1292 | gfc_try |
66e4ab31 | 1293 | gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1294 | { |
1295 | ||
1296 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 1297 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
1298 | return FAILURE; |
1299 | ||
1300 | attr->subroutine = 1; | |
231b2fcc | 1301 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1302 | } |
1303 | ||
1304 | ||
17b1d2a0 | 1305 | gfc_try |
66e4ab31 | 1306 | gfc_add_generic (symbol_attribute *attr, const char *name, locus *where) |
6de9cd9a DN |
1307 | { |
1308 | ||
1309 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 1310 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
1311 | return FAILURE; |
1312 | ||
1313 | attr->generic = 1; | |
231b2fcc | 1314 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1315 | } |
1316 | ||
1317 | ||
17b1d2a0 | 1318 | gfc_try |
69773742 JW |
1319 | gfc_add_proc (symbol_attribute *attr, const char *name, locus *where) |
1320 | { | |
1321 | ||
1322 | if (check_used (attr, NULL, where)) | |
1323 | return FAILURE; | |
1324 | ||
1325 | if (attr->flavor != FL_PROCEDURE | |
1326 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) | |
1327 | return FAILURE; | |
1328 | ||
1329 | if (attr->procedure) | |
1330 | { | |
1331 | duplicate_attr ("PROCEDURE", where); | |
1332 | return FAILURE; | |
1333 | } | |
1334 | ||
1335 | attr->procedure = 1; | |
1336 | ||
1337 | return check_conflict (attr, NULL, where); | |
1338 | } | |
1339 | ||
1340 | ||
52f49934 DK |
1341 | gfc_try |
1342 | gfc_add_abstract (symbol_attribute* attr, locus* where) | |
1343 | { | |
1344 | if (attr->abstract) | |
1345 | { | |
1346 | duplicate_attr ("ABSTRACT", where); | |
1347 | return FAILURE; | |
1348 | } | |
1349 | ||
1350 | attr->abstract = 1; | |
1351 | return SUCCESS; | |
1352 | } | |
1353 | ||
1354 | ||
eebc3ee0 | 1355 | /* Flavors are special because some flavors are not what Fortran |
6de9cd9a DN |
1356 | considers attributes and can be reaffirmed multiple times. */ |
1357 | ||
17b1d2a0 | 1358 | gfc_try |
66e4ab31 SK |
1359 | gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, |
1360 | locus *where) | |
6de9cd9a DN |
1361 | { |
1362 | ||
1363 | if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE | |
1364 | || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED | |
231b2fcc | 1365 | || f == FL_NAMELIST) && check_used (attr, name, where)) |
6de9cd9a DN |
1366 | return FAILURE; |
1367 | ||
1368 | if (attr->flavor == f && f == FL_VARIABLE) | |
1369 | return SUCCESS; | |
1370 | ||
1371 | if (attr->flavor != FL_UNKNOWN) | |
1372 | { | |
1373 | if (where == NULL) | |
63645982 | 1374 | where = &gfc_current_locus; |
6de9cd9a | 1375 | |
661051aa DF |
1376 | if (name) |
1377 | gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L", | |
1378 | gfc_code2string (flavors, attr->flavor), name, | |
1379 | gfc_code2string (flavors, f), where); | |
1380 | else | |
1381 | gfc_error ("%s attribute conflicts with %s attribute at %L", | |
1382 | gfc_code2string (flavors, attr->flavor), | |
1383 | gfc_code2string (flavors, f), where); | |
6de9cd9a DN |
1384 | |
1385 | return FAILURE; | |
1386 | } | |
1387 | ||
1388 | attr->flavor = f; | |
1389 | ||
231b2fcc | 1390 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1391 | } |
1392 | ||
1393 | ||
17b1d2a0 | 1394 | gfc_try |
66e4ab31 SK |
1395 | gfc_add_procedure (symbol_attribute *attr, procedure_type t, |
1396 | const char *name, locus *where) | |
6de9cd9a DN |
1397 | { |
1398 | ||
7114edca | 1399 | if (check_used (attr, name, where)) |
6de9cd9a DN |
1400 | return FAILURE; |
1401 | ||
1402 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 1403 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
1404 | return FAILURE; |
1405 | ||
1406 | if (where == NULL) | |
63645982 | 1407 | where = &gfc_current_locus; |
6de9cd9a DN |
1408 | |
1409 | if (attr->proc != PROC_UNKNOWN) | |
1410 | { | |
31043f6c | 1411 | gfc_error ("%s procedure at %L is already declared as %s procedure", |
6de9cd9a | 1412 | gfc_code2string (procedures, t), where, |
6de9cd9a DN |
1413 | gfc_code2string (procedures, attr->proc)); |
1414 | ||
1415 | return FAILURE; | |
1416 | } | |
1417 | ||
1418 | attr->proc = t; | |
1419 | ||
1420 | /* Statement functions are always scalar and functions. */ | |
1421 | if (t == PROC_ST_FUNCTION | |
231b2fcc | 1422 | && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE) |
6de9cd9a DN |
1423 | || attr->dimension)) |
1424 | return FAILURE; | |
1425 | ||
231b2fcc | 1426 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1427 | } |
1428 | ||
1429 | ||
17b1d2a0 | 1430 | gfc_try |
66e4ab31 | 1431 | gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where) |
6de9cd9a DN |
1432 | { |
1433 | ||
231b2fcc | 1434 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
1435 | return FAILURE; |
1436 | ||
1437 | if (attr->intent == INTENT_UNKNOWN) | |
1438 | { | |
1439 | attr->intent = intent; | |
231b2fcc | 1440 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
1441 | } |
1442 | ||
1443 | if (where == NULL) | |
63645982 | 1444 | where = &gfc_current_locus; |
6de9cd9a DN |
1445 | |
1446 | gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", | |
1447 | gfc_intent_string (attr->intent), | |
1448 | gfc_intent_string (intent), where); | |
1449 | ||
1450 | return FAILURE; | |
1451 | } | |
1452 | ||
1453 | ||
1454 | /* No checks for use-association in public and private statements. */ | |
1455 | ||
17b1d2a0 | 1456 | gfc_try |
66e4ab31 SK |
1457 | gfc_add_access (symbol_attribute *attr, gfc_access access, |
1458 | const char *name, locus *where) | |
6de9cd9a DN |
1459 | { |
1460 | ||
0b4e2af7 PT |
1461 | if (attr->access == ACCESS_UNKNOWN |
1462 | || (attr->use_assoc && attr->access != ACCESS_PRIVATE)) | |
6de9cd9a DN |
1463 | { |
1464 | attr->access = access; | |
231b2fcc | 1465 | return check_conflict (attr, name, where); |
6de9cd9a DN |
1466 | } |
1467 | ||
1468 | if (where == NULL) | |
63645982 | 1469 | where = &gfc_current_locus; |
6de9cd9a DN |
1470 | gfc_error ("ACCESS specification at %L was already specified", where); |
1471 | ||
1472 | return FAILURE; | |
1473 | } | |
1474 | ||
1475 | ||
a8b3b0b6 CR |
1476 | /* Set the is_bind_c field for the given symbol_attribute. */ |
1477 | ||
17b1d2a0 | 1478 | gfc_try |
a8b3b0b6 CR |
1479 | gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where, |
1480 | int is_proc_lang_bind_spec) | |
1481 | { | |
1482 | ||
1483 | if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE) | |
1484 | gfc_error_now ("BIND(C) attribute at %L can only be used for " | |
1485 | "variables or common blocks", where); | |
1486 | else if (attr->is_bind_c) | |
1487 | gfc_error_now ("Duplicate BIND attribute specified at %L", where); | |
1488 | else | |
1489 | attr->is_bind_c = 1; | |
1490 | ||
1491 | if (where == NULL) | |
1492 | where = &gfc_current_locus; | |
1493 | ||
1494 | if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where) | |
1495 | == FAILURE) | |
1496 | return FAILURE; | |
1497 | ||
1498 | return check_conflict (attr, name, where); | |
1499 | } | |
1500 | ||
1501 | ||
63a3341a PT |
1502 | /* Set the extension field for the given symbol_attribute. */ |
1503 | ||
1504 | gfc_try | |
1505 | gfc_add_extension (symbol_attribute *attr, locus *where) | |
1506 | { | |
1507 | if (where == NULL) | |
1508 | where = &gfc_current_locus; | |
1509 | ||
1510 | if (attr->extension) | |
1511 | gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where); | |
1512 | else | |
1513 | attr->extension = 1; | |
1514 | ||
1515 | if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where) | |
1516 | == FAILURE) | |
1517 | return FAILURE; | |
1518 | ||
1519 | return SUCCESS; | |
1520 | } | |
1521 | ||
1522 | ||
17b1d2a0 | 1523 | gfc_try |
a8b3b0b6 CR |
1524 | gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source, |
1525 | gfc_formal_arglist * formal, locus *where) | |
6de9cd9a DN |
1526 | { |
1527 | ||
231b2fcc | 1528 | if (check_used (&sym->attr, sym->name, where)) |
6de9cd9a DN |
1529 | return FAILURE; |
1530 | ||
1531 | if (where == NULL) | |
63645982 | 1532 | where = &gfc_current_locus; |
6de9cd9a DN |
1533 | |
1534 | if (sym->attr.if_source != IFSRC_UNKNOWN | |
1535 | && sym->attr.if_source != IFSRC_DECL) | |
1536 | { | |
1537 | gfc_error ("Symbol '%s' at %L already has an explicit interface", | |
1538 | sym->name, where); | |
1539 | return FAILURE; | |
1540 | } | |
1541 | ||
e62532af JW |
1542 | if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable)) |
1543 | { | |
1544 | gfc_error ("'%s' at %L has attributes specified outside its INTERFACE " | |
1545 | "body", sym->name, where); | |
1546 | return FAILURE; | |
1547 | } | |
1548 | ||
6de9cd9a DN |
1549 | sym->formal = formal; |
1550 | sym->attr.if_source = source; | |
1551 | ||
1552 | return SUCCESS; | |
1553 | } | |
1554 | ||
1555 | ||
1556 | /* Add a type to a symbol. */ | |
1557 | ||
17b1d2a0 | 1558 | gfc_try |
66e4ab31 | 1559 | gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where) |
6de9cd9a DN |
1560 | { |
1561 | sym_flavor flavor; | |
1562 | ||
6de9cd9a | 1563 | if (where == NULL) |
63645982 | 1564 | where = &gfc_current_locus; |
6de9cd9a DN |
1565 | |
1566 | if (sym->ts.type != BT_UNKNOWN) | |
1567 | { | |
6690a9e0 | 1568 | const char *msg = "Symbol '%s' at %L already has basic type of %s"; |
1d146030 | 1569 | if (!(sym->ts.type == ts->type && sym->attr.result) |
66e4ab31 SK |
1570 | || gfc_notification_std (GFC_STD_GNU) == ERROR |
1571 | || pedantic) | |
6690a9e0 PT |
1572 | { |
1573 | gfc_error (msg, sym->name, where, gfc_basic_typename (sym->ts.type)); | |
1574 | return FAILURE; | |
1575 | } | |
fee3292b DK |
1576 | if (gfc_notify_std (GFC_STD_GNU, msg, sym->name, where, |
1577 | gfc_basic_typename (sym->ts.type)) == FAILURE) | |
66e4ab31 | 1578 | return FAILURE; |
fee3292b DK |
1579 | if (gfc_option.warn_surprising) |
1580 | gfc_warning (msg, sym->name, where, gfc_basic_typename (sym->ts.type)); | |
6de9cd9a DN |
1581 | } |
1582 | ||
1d146030 JW |
1583 | if (sym->attr.procedure && sym->ts.interface) |
1584 | { | |
1585 | gfc_error ("Procedure '%s' at %L may not have basic type of %s", sym->name, where, | |
1586 | gfc_basic_typename (ts->type)); | |
1587 | return FAILURE; | |
1588 | } | |
1589 | ||
6de9cd9a DN |
1590 | flavor = sym->attr.flavor; |
1591 | ||
1592 | if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE | |
66e4ab31 SK |
1593 | || flavor == FL_LABEL |
1594 | || (flavor == FL_PROCEDURE && sym->attr.subroutine) | |
6de9cd9a DN |
1595 | || flavor == FL_DERIVED || flavor == FL_NAMELIST) |
1596 | { | |
1597 | gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where); | |
1598 | return FAILURE; | |
1599 | } | |
1600 | ||
1601 | sym->ts = *ts; | |
1602 | return SUCCESS; | |
1603 | } | |
1604 | ||
1605 | ||
1606 | /* Clears all attributes. */ | |
1607 | ||
1608 | void | |
66e4ab31 | 1609 | gfc_clear_attr (symbol_attribute *attr) |
6de9cd9a | 1610 | { |
66e4ab31 | 1611 | memset (attr, 0, sizeof (symbol_attribute)); |
6de9cd9a DN |
1612 | } |
1613 | ||
1614 | ||
1615 | /* Check for missing attributes in the new symbol. Currently does | |
1616 | nothing, but it's not clear that it is unnecessary yet. */ | |
1617 | ||
17b1d2a0 | 1618 | gfc_try |
66e4ab31 SK |
1619 | gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED, |
1620 | locus *where ATTRIBUTE_UNUSED) | |
6de9cd9a DN |
1621 | { |
1622 | ||
1623 | return SUCCESS; | |
1624 | } | |
1625 | ||
1626 | ||
1627 | /* Copy an attribute to a symbol attribute, bit by bit. Some | |
1628 | attributes have a lot of side-effects but cannot be present given | |
1629 | where we are called from, so we ignore some bits. */ | |
1630 | ||
17b1d2a0 | 1631 | gfc_try |
a8b3b0b6 | 1632 | gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) |
6de9cd9a | 1633 | { |
a8b3b0b6 CR |
1634 | int is_proc_lang_bind_spec; |
1635 | ||
6de9cd9a DN |
1636 | if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) |
1637 | goto fail; | |
1638 | ||
231b2fcc | 1639 | if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1640 | goto fail; |
1641 | if (src->optional && gfc_add_optional (dest, where) == FAILURE) | |
1642 | goto fail; | |
1643 | if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) | |
1644 | goto fail; | |
9aa433c2 | 1645 | if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE) |
ee7e677f | 1646 | goto fail; |
231b2fcc | 1647 | if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) |
6de9cd9a | 1648 | goto fail; |
06469efd PT |
1649 | if (src->value && gfc_add_value (dest, NULL, where) == FAILURE) |
1650 | goto fail; | |
775e6c3a TB |
1651 | if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE) |
1652 | goto fail; | |
66e4ab31 SK |
1653 | if (src->threadprivate |
1654 | && gfc_add_threadprivate (dest, NULL, where) == FAILURE) | |
6c7a4dfd | 1655 | goto fail; |
6de9cd9a DN |
1656 | if (src->target && gfc_add_target (dest, where) == FAILURE) |
1657 | goto fail; | |
231b2fcc | 1658 | if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE) |
6de9cd9a | 1659 | goto fail; |
231b2fcc | 1660 | if (src->result && gfc_add_result (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1661 | goto fail; |
1662 | if (src->entry) | |
1663 | dest->entry = 1; | |
1664 | ||
231b2fcc | 1665 | if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1666 | goto fail; |
1667 | ||
231b2fcc | 1668 | if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE) |
6de9cd9a | 1669 | goto fail; |
6de9cd9a | 1670 | |
231b2fcc | 1671 | if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE) |
6de9cd9a | 1672 | goto fail; |
231b2fcc | 1673 | if (src->function && gfc_add_function (dest, NULL, where) == FAILURE) |
6de9cd9a | 1674 | goto fail; |
231b2fcc | 1675 | if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1676 | goto fail; |
1677 | ||
231b2fcc | 1678 | if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1679 | goto fail; |
1680 | if (src->elemental && gfc_add_elemental (dest, where) == FAILURE) | |
1681 | goto fail; | |
1682 | if (src->pure && gfc_add_pure (dest, where) == FAILURE) | |
1683 | goto fail; | |
1684 | if (src->recursive && gfc_add_recursive (dest, where) == FAILURE) | |
1685 | goto fail; | |
1686 | ||
1687 | if (src->flavor != FL_UNKNOWN | |
231b2fcc | 1688 | && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE) |
6de9cd9a DN |
1689 | goto fail; |
1690 | ||
1691 | if (src->intent != INTENT_UNKNOWN | |
1692 | && gfc_add_intent (dest, src->intent, where) == FAILURE) | |
1693 | goto fail; | |
1694 | ||
1695 | if (src->access != ACCESS_UNKNOWN | |
231b2fcc | 1696 | && gfc_add_access (dest, src->access, NULL, where) == FAILURE) |
6de9cd9a DN |
1697 | goto fail; |
1698 | ||
1699 | if (gfc_missing_attr (dest, where) == FAILURE) | |
1700 | goto fail; | |
1701 | ||
83d890b9 AL |
1702 | if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE) |
1703 | goto fail; | |
1704 | if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE) | |
1705 | goto fail; | |
23bc73b5 | 1706 | |
a8b3b0b6 CR |
1707 | is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0); |
1708 | if (src->is_bind_c | |
1709 | && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec) | |
1710 | != SUCCESS) | |
1711 | return FAILURE; | |
1712 | ||
1713 | if (src->is_c_interop) | |
1714 | dest->is_c_interop = 1; | |
1715 | if (src->is_iso_c) | |
1716 | dest->is_iso_c = 1; | |
1717 | ||
23bc73b5 DF |
1718 | if (src->external && gfc_add_external (dest, where) == FAILURE) |
1719 | goto fail; | |
1720 | if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE) | |
1721 | goto fail; | |
8fb74da4 JW |
1722 | if (src->proc_pointer) |
1723 | dest->proc_pointer = 1; | |
6de9cd9a DN |
1724 | |
1725 | return SUCCESS; | |
1726 | ||
1727 | fail: | |
1728 | return FAILURE; | |
1729 | } | |
1730 | ||
1731 | ||
1732 | /************** Component name management ************/ | |
1733 | ||
1734 | /* Component names of a derived type form their own little namespaces | |
1735 | that are separate from all other spaces. The space is composed of | |
1736 | a singly linked list of gfc_component structures whose head is | |
1737 | located in the parent symbol. */ | |
1738 | ||
1739 | ||
1740 | /* Add a component name to a symbol. The call fails if the name is | |
1741 | already present. On success, the component pointer is modified to | |
1742 | point to the additional component structure. */ | |
1743 | ||
17b1d2a0 | 1744 | gfc_try |
66e4ab31 SK |
1745 | gfc_add_component (gfc_symbol *sym, const char *name, |
1746 | gfc_component **component) | |
6de9cd9a DN |
1747 | { |
1748 | gfc_component *p, *tail; | |
1749 | ||
1750 | tail = NULL; | |
1751 | ||
1752 | for (p = sym->components; p; p = p->next) | |
1753 | { | |
1754 | if (strcmp (p->name, name) == 0) | |
1755 | { | |
1756 | gfc_error ("Component '%s' at %C already declared at %L", | |
1757 | name, &p->loc); | |
1758 | return FAILURE; | |
1759 | } | |
1760 | ||
1761 | tail = p; | |
1762 | } | |
1763 | ||
7d1f1e61 | 1764 | if (sym->attr.extension |
9d1210f4 | 1765 | && gfc_find_component (sym->components->ts.derived, name, true, true)) |
7d1f1e61 PT |
1766 | { |
1767 | gfc_error ("Component '%s' at %C already in the parent type " | |
1768 | "at %L", name, &sym->components->ts.derived->declared_at); | |
1769 | return FAILURE; | |
1770 | } | |
1771 | ||
eebc3ee0 | 1772 | /* Allocate a new component. */ |
6de9cd9a DN |
1773 | p = gfc_get_component (); |
1774 | ||
1775 | if (tail == NULL) | |
1776 | sym->components = p; | |
1777 | else | |
1778 | tail->next = p; | |
1779 | ||
cb9e4f55 | 1780 | p->name = gfc_get_string (name); |
63645982 | 1781 | p->loc = gfc_current_locus; |
6de9cd9a DN |
1782 | |
1783 | *component = p; | |
1784 | return SUCCESS; | |
1785 | } | |
1786 | ||
1787 | ||
6b887797 PT |
1788 | /* Recursive function to switch derived types of all symbol in a |
1789 | namespace. */ | |
6de9cd9a DN |
1790 | |
1791 | static void | |
66e4ab31 | 1792 | switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to) |
6de9cd9a DN |
1793 | { |
1794 | gfc_symbol *sym; | |
1795 | ||
1796 | if (st == NULL) | |
1797 | return; | |
1798 | ||
1799 | sym = st->n.sym; | |
1800 | if (sym->ts.type == BT_DERIVED && sym->ts.derived == from) | |
1801 | sym->ts.derived = to; | |
1802 | ||
1803 | switch_types (st->left, from, to); | |
1804 | switch_types (st->right, from, to); | |
1805 | } | |
1806 | ||
1807 | ||
1808 | /* This subroutine is called when a derived type is used in order to | |
1809 | make the final determination about which version to use. The | |
1810 | standard requires that a type be defined before it is 'used', but | |
1811 | such types can appear in IMPLICIT statements before the actual | |
1812 | definition. 'Using' in this context means declaring a variable to | |
1813 | be that type or using the type constructor. | |
1814 | ||
1815 | If a type is used and the components haven't been defined, then we | |
1816 | have to have a derived type in a parent unit. We find the node in | |
1817 | the other namespace and point the symtree node in this namespace to | |
1818 | that node. Further reference to this name point to the correct | |
eebc3ee0 | 1819 | node. If we can't find the node in a parent namespace, then we have |
6de9cd9a DN |
1820 | an error. |
1821 | ||
1822 | This subroutine takes a pointer to a symbol node and returns a | |
1823 | pointer to the translated node or NULL for an error. Usually there | |
1824 | is no translation and we return the node we were passed. */ | |
1825 | ||
1e6283cb | 1826 | gfc_symbol * |
66e4ab31 | 1827 | gfc_use_derived (gfc_symbol *sym) |
6de9cd9a | 1828 | { |
810306f2 | 1829 | gfc_symbol *s; |
6de9cd9a DN |
1830 | gfc_typespec *t; |
1831 | gfc_symtree *st; | |
1832 | int i; | |
1833 | ||
9fa6b0af | 1834 | if (sym->components != NULL || sym->attr.zero_comp) |
6b887797 | 1835 | return sym; /* Already defined. */ |
3e978d30 | 1836 | |
6b887797 PT |
1837 | if (sym->ns->parent == NULL) |
1838 | goto bad; | |
6de9cd9a DN |
1839 | |
1840 | if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) | |
1841 | { | |
1842 | gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); | |
1843 | return NULL; | |
1844 | } | |
1845 | ||
1846 | if (s == NULL || s->attr.flavor != FL_DERIVED) | |
1847 | goto bad; | |
1848 | ||
1849 | /* Get rid of symbol sym, translating all references to s. */ | |
1850 | for (i = 0; i < GFC_LETTERS; i++) | |
1851 | { | |
1852 | t = &sym->ns->default_type[i]; | |
1853 | if (t->derived == sym) | |
1854 | t->derived = s; | |
1855 | } | |
1856 | ||
1857 | st = gfc_find_symtree (sym->ns->sym_root, sym->name); | |
1858 | st->n.sym = s; | |
1859 | ||
1860 | s->refs++; | |
1861 | ||
1862 | /* Unlink from list of modified symbols. */ | |
810306f2 | 1863 | gfc_commit_symbol (sym); |
6de9cd9a DN |
1864 | |
1865 | switch_types (sym->ns->sym_root, sym, s); | |
1866 | ||
1867 | /* TODO: Also have to replace sym -> s in other lists like | |
1868 | namelists, common lists and interface lists. */ | |
1869 | gfc_free_symbol (sym); | |
1870 | ||
1e6283cb | 1871 | return s; |
6de9cd9a DN |
1872 | |
1873 | bad: | |
1874 | gfc_error ("Derived type '%s' at %C is being used before it is defined", | |
1875 | sym->name); | |
1876 | return NULL; | |
1877 | } | |
1878 | ||
1879 | ||
6de9cd9a DN |
1880 | /* Given a derived type node and a component name, try to locate the |
1881 | component structure. Returns the NULL pointer if the component is | |
9d1210f4 DK |
1882 | not found or the components are private. If noaccess is set, no access |
1883 | checks are done. */ | |
6de9cd9a DN |
1884 | |
1885 | gfc_component * | |
9d1210f4 DK |
1886 | gfc_find_component (gfc_symbol *sym, const char *name, |
1887 | bool noaccess, bool silent) | |
6de9cd9a DN |
1888 | { |
1889 | gfc_component *p; | |
1890 | ||
1891 | if (name == NULL) | |
1892 | return NULL; | |
1893 | ||
1894 | sym = gfc_use_derived (sym); | |
1895 | ||
1896 | if (sym == NULL) | |
1897 | return NULL; | |
1898 | ||
1899 | for (p = sym->components; p; p = p->next) | |
1900 | if (strcmp (p->name, name) == 0) | |
1901 | break; | |
1902 | ||
7d1f1e61 PT |
1903 | if (p == NULL |
1904 | && sym->attr.extension | |
1905 | && sym->components->ts.type == BT_DERIVED) | |
1906 | { | |
9d1210f4 DK |
1907 | p = gfc_find_component (sym->components->ts.derived, name, |
1908 | noaccess, silent); | |
7d1f1e61 PT |
1909 | /* Do not overwrite the error. */ |
1910 | if (p == NULL) | |
1911 | return p; | |
1912 | } | |
1913 | ||
9d1210f4 | 1914 | if (p == NULL && !silent) |
6de9cd9a DN |
1915 | gfc_error ("'%s' at %C is not a member of the '%s' structure", |
1916 | name, sym->name); | |
7d1f1e61 | 1917 | |
9d1210f4 | 1918 | else if (sym->attr.use_assoc && !noaccess) |
6de9cd9a | 1919 | { |
d4b7d0f0 | 1920 | if (p->attr.access == ACCESS_PRIVATE) |
6de9cd9a | 1921 | { |
9d1210f4 DK |
1922 | if (!silent) |
1923 | gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", | |
1924 | name, sym->name); | |
7d1f1e61 PT |
1925 | return NULL; |
1926 | } | |
1927 | ||
1928 | /* If there were components given and all components are private, error | |
1929 | out at this place. */ | |
d4b7d0f0 | 1930 | if (p->attr.access != ACCESS_PUBLIC && sym->component_access == ACCESS_PRIVATE) |
7d1f1e61 | 1931 | { |
9d1210f4 DK |
1932 | if (!silent) |
1933 | gfc_error ("All components of '%s' are PRIVATE in structure" | |
1934 | " constructor at %C", sym->name); | |
7d1f1e61 | 1935 | return NULL; |
6de9cd9a DN |
1936 | } |
1937 | } | |
1938 | ||
1939 | return p; | |
1940 | } | |
1941 | ||
1942 | ||
1943 | /* Given a symbol, free all of the component structures and everything | |
1944 | they point to. */ | |
1945 | ||
1946 | static void | |
66e4ab31 | 1947 | free_components (gfc_component *p) |
6de9cd9a DN |
1948 | { |
1949 | gfc_component *q; | |
1950 | ||
1951 | for (; p; p = q) | |
1952 | { | |
1953 | q = p->next; | |
1954 | ||
1955 | gfc_free_array_spec (p->as); | |
1956 | gfc_free_expr (p->initializer); | |
1957 | ||
1958 | gfc_free (p); | |
1959 | } | |
1960 | } | |
1961 | ||
1962 | ||
6de9cd9a DN |
1963 | /******************** Statement label management ********************/ |
1964 | ||
5cf54585 TS |
1965 | /* Comparison function for statement labels, used for managing the |
1966 | binary tree. */ | |
1967 | ||
1968 | static int | |
66e4ab31 | 1969 | compare_st_labels (void *a1, void *b1) |
5cf54585 | 1970 | { |
66e4ab31 SK |
1971 | int a = ((gfc_st_label *) a1)->value; |
1972 | int b = ((gfc_st_label *) b1)->value; | |
5cf54585 TS |
1973 | |
1974 | return (b - a); | |
1975 | } | |
1976 | ||
1977 | ||
1978 | /* Free a single gfc_st_label structure, making sure the tree is not | |
6de9cd9a DN |
1979 | messed up. This function is called only when some parse error |
1980 | occurs. */ | |
1981 | ||
1982 | void | |
66e4ab31 | 1983 | gfc_free_st_label (gfc_st_label *label) |
6de9cd9a | 1984 | { |
66e4ab31 | 1985 | |
b5cbe7ee | 1986 | if (label == NULL) |
6de9cd9a DN |
1987 | return; |
1988 | ||
5cf54585 | 1989 | gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels); |
b5cbe7ee SK |
1990 | |
1991 | if (label->format != NULL) | |
1992 | gfc_free_expr (label->format); | |
1993 | ||
1994 | gfc_free (label); | |
6de9cd9a DN |
1995 | } |
1996 | ||
66e4ab31 | 1997 | |
5cf54585 | 1998 | /* Free a whole tree of gfc_st_label structures. */ |
6de9cd9a DN |
1999 | |
2000 | static void | |
66e4ab31 | 2001 | free_st_labels (gfc_st_label *label) |
6de9cd9a | 2002 | { |
66e4ab31 | 2003 | |
5cf54585 TS |
2004 | if (label == NULL) |
2005 | return; | |
6de9cd9a | 2006 | |
5cf54585 TS |
2007 | free_st_labels (label->left); |
2008 | free_st_labels (label->right); | |
2009 | ||
2010 | if (label->format != NULL) | |
2011 | gfc_free_expr (label->format); | |
2012 | gfc_free (label); | |
6de9cd9a DN |
2013 | } |
2014 | ||
2015 | ||
2016 | /* Given a label number, search for and return a pointer to the label | |
2017 | structure, creating it if it does not exist. */ | |
2018 | ||
2019 | gfc_st_label * | |
2020 | gfc_get_st_label (int labelno) | |
2021 | { | |
2022 | gfc_st_label *lp; | |
2023 | ||
2024 | /* First see if the label is already in this namespace. */ | |
5cf54585 TS |
2025 | lp = gfc_current_ns->st_labels; |
2026 | while (lp) | |
2027 | { | |
2028 | if (lp->value == labelno) | |
2029 | return lp; | |
2030 | ||
2031 | if (lp->value < labelno) | |
2032 | lp = lp->left; | |
2033 | else | |
2034 | lp = lp->right; | |
2035 | } | |
6de9cd9a | 2036 | |
ece3f663 | 2037 | lp = XCNEW (gfc_st_label); |
6de9cd9a DN |
2038 | |
2039 | lp->value = labelno; | |
2040 | lp->defined = ST_LABEL_UNKNOWN; | |
2041 | lp->referenced = ST_LABEL_UNKNOWN; | |
2042 | ||
5cf54585 | 2043 | gfc_insert_bbt (&gfc_current_ns->st_labels, lp, compare_st_labels); |
6de9cd9a DN |
2044 | |
2045 | return lp; | |
2046 | } | |
2047 | ||
2048 | ||
2049 | /* Called when a statement with a statement label is about to be | |
2050 | accepted. We add the label to the list of the current namespace, | |
2051 | making sure it hasn't been defined previously and referenced | |
2052 | correctly. */ | |
2053 | ||
2054 | void | |
66e4ab31 | 2055 | gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus) |
6de9cd9a DN |
2056 | { |
2057 | int labelno; | |
2058 | ||
2059 | labelno = lp->value; | |
2060 | ||
2061 | if (lp->defined != ST_LABEL_UNKNOWN) | |
2062 | gfc_error ("Duplicate statement label %d at %L and %L", labelno, | |
2063 | &lp->where, label_locus); | |
2064 | else | |
2065 | { | |
2066 | lp->where = *label_locus; | |
2067 | ||
2068 | switch (type) | |
2069 | { | |
2070 | case ST_LABEL_FORMAT: | |
2071 | if (lp->referenced == ST_LABEL_TARGET) | |
2072 | gfc_error ("Label %d at %C already referenced as branch target", | |
2073 | labelno); | |
2074 | else | |
2075 | lp->defined = ST_LABEL_FORMAT; | |
2076 | ||
2077 | break; | |
2078 | ||
2079 | case ST_LABEL_TARGET: | |
2080 | if (lp->referenced == ST_LABEL_FORMAT) | |
2081 | gfc_error ("Label %d at %C already referenced as a format label", | |
2082 | labelno); | |
2083 | else | |
2084 | lp->defined = ST_LABEL_TARGET; | |
2085 | ||
2086 | break; | |
2087 | ||
2088 | default: | |
2089 | lp->defined = ST_LABEL_BAD_TARGET; | |
2090 | lp->referenced = ST_LABEL_BAD_TARGET; | |
2091 | } | |
2092 | } | |
2093 | } | |
2094 | ||
2095 | ||
2096 | /* Reference a label. Given a label and its type, see if that | |
2097 | reference is consistent with what is known about that label, | |
2098 | updating the unknown state. Returns FAILURE if something goes | |
2099 | wrong. */ | |
2100 | ||
17b1d2a0 | 2101 | gfc_try |
66e4ab31 | 2102 | gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type) |
6de9cd9a DN |
2103 | { |
2104 | gfc_sl_type label_type; | |
2105 | int labelno; | |
17b1d2a0 | 2106 | gfc_try rc; |
6de9cd9a DN |
2107 | |
2108 | if (lp == NULL) | |
2109 | return SUCCESS; | |
2110 | ||
2111 | labelno = lp->value; | |
2112 | ||
2113 | if (lp->defined != ST_LABEL_UNKNOWN) | |
2114 | label_type = lp->defined; | |
2115 | else | |
2116 | { | |
2117 | label_type = lp->referenced; | |
63645982 | 2118 | lp->where = gfc_current_locus; |
6de9cd9a DN |
2119 | } |
2120 | ||
2121 | if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET) | |
2122 | { | |
2123 | gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); | |
2124 | rc = FAILURE; | |
2125 | goto done; | |
2126 | } | |
2127 | ||
2128 | if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET) | |
2129 | && type == ST_LABEL_FORMAT) | |
2130 | { | |
2131 | gfc_error ("Label %d at %C previously used as branch target", labelno); | |
2132 | rc = FAILURE; | |
2133 | goto done; | |
2134 | } | |
2135 | ||
2136 | lp->referenced = type; | |
2137 | rc = SUCCESS; | |
2138 | ||
2139 | done: | |
2140 | return rc; | |
2141 | } | |
2142 | ||
2143 | ||
08113c73 PT |
2144 | /*******A helper function for creating new expressions*************/ |
2145 | ||
2146 | ||
2147 | gfc_expr * | |
2148 | gfc_lval_expr_from_sym (gfc_symbol *sym) | |
2149 | { | |
2150 | gfc_expr *lval; | |
2151 | lval = gfc_get_expr (); | |
2152 | lval->expr_type = EXPR_VARIABLE; | |
2153 | lval->where = sym->declared_at; | |
2154 | lval->ts = sym->ts; | |
2155 | lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name); | |
2156 | ||
2157 | /* It will always be a full array. */ | |
2158 | lval->rank = sym->as ? sym->as->rank : 0; | |
2159 | if (lval->rank) | |
2160 | { | |
2161 | lval->ref = gfc_get_ref (); | |
2162 | lval->ref->type = REF_ARRAY; | |
2163 | lval->ref->u.ar.type = AR_FULL; | |
2164 | lval->ref->u.ar.dimen = lval->rank; | |
2165 | lval->ref->u.ar.where = sym->declared_at; | |
2166 | lval->ref->u.ar.as = sym->as; | |
2167 | } | |
2168 | ||
2169 | return lval; | |
2170 | } | |
2171 | ||
2172 | ||
6de9cd9a DN |
2173 | /************** Symbol table management subroutines ****************/ |
2174 | ||
2175 | /* Basic details: Fortran 95 requires a potentially unlimited number | |
2176 | of distinct namespaces when compiling a program unit. This case | |
2177 | occurs during a compilation of internal subprograms because all of | |
2178 | the internal subprograms must be read before we can start | |
2179 | generating code for the host. | |
2180 | ||
eebc3ee0 | 2181 | Given the tricky nature of the Fortran grammar, we must be able to |
6de9cd9a DN |
2182 | undo changes made to a symbol table if the current interpretation |
2183 | of a statement is found to be incorrect. Whenever a symbol is | |
2184 | looked up, we make a copy of it and link to it. All of these | |
2185 | symbols are kept in a singly linked list so that we can commit or | |
2186 | undo the changes at a later time. | |
2187 | ||
4f613946 | 2188 | A symtree may point to a symbol node outside of its namespace. In |
6de9cd9a DN |
2189 | this case, that symbol has been used as a host associated variable |
2190 | at some previous time. */ | |
2191 | ||
0366dfe9 TS |
2192 | /* Allocate a new namespace structure. Copies the implicit types from |
2193 | PARENT if PARENT_TYPES is set. */ | |
6de9cd9a DN |
2194 | |
2195 | gfc_namespace * | |
66e4ab31 | 2196 | gfc_get_namespace (gfc_namespace *parent, int parent_types) |
6de9cd9a DN |
2197 | { |
2198 | gfc_namespace *ns; | |
2199 | gfc_typespec *ts; | |
2200 | gfc_intrinsic_op in; | |
2201 | int i; | |
2202 | ||
ece3f663 | 2203 | ns = XCNEW (gfc_namespace); |
6de9cd9a DN |
2204 | ns->sym_root = NULL; |
2205 | ns->uop_root = NULL; | |
e34ccb4c | 2206 | ns->tb_sym_root = NULL; |
34523524 | 2207 | ns->finalizers = NULL; |
6de9cd9a DN |
2208 | ns->default_access = ACCESS_UNKNOWN; |
2209 | ns->parent = parent; | |
2210 | ||
2211 | for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) | |
2212 | ns->operator_access[in] = ACCESS_UNKNOWN; | |
2213 | ||
2214 | /* Initialize default implicit types. */ | |
2215 | for (i = 'a'; i <= 'z'; i++) | |
2216 | { | |
2217 | ns->set_flag[i - 'a'] = 0; | |
2218 | ts = &ns->default_type[i - 'a']; | |
2219 | ||
0366dfe9 | 2220 | if (parent_types && ns->parent != NULL) |
6de9cd9a | 2221 | { |
66e4ab31 | 2222 | /* Copy parent settings. */ |
6de9cd9a DN |
2223 | *ts = ns->parent->default_type[i - 'a']; |
2224 | continue; | |
2225 | } | |
2226 | ||
2227 | if (gfc_option.flag_implicit_none != 0) | |
2228 | { | |
2229 | gfc_clear_ts (ts); | |
2230 | continue; | |
2231 | } | |
2232 | ||
2233 | if ('i' <= i && i <= 'n') | |
2234 | { | |
2235 | ts->type = BT_INTEGER; | |
9d64df18 | 2236 | ts->kind = gfc_default_integer_kind; |
6de9cd9a DN |
2237 | } |
2238 | else | |
2239 | { | |
2240 | ts->type = BT_REAL; | |
9d64df18 | 2241 | ts->kind = gfc_default_real_kind; |
6de9cd9a DN |
2242 | } |
2243 | } | |
2244 | ||
3d79abbd PB |
2245 | ns->refs = 1; |
2246 | ||
6de9cd9a DN |
2247 | return ns; |
2248 | } | |
2249 | ||
2250 | ||
2251 | /* Comparison function for symtree nodes. */ | |
2252 | ||
2253 | static int | |
66e4ab31 | 2254 | compare_symtree (void *_st1, void *_st2) |
6de9cd9a DN |
2255 | { |
2256 | gfc_symtree *st1, *st2; | |
2257 | ||
2258 | st1 = (gfc_symtree *) _st1; | |
2259 | st2 = (gfc_symtree *) _st2; | |
2260 | ||
2261 | return strcmp (st1->name, st2->name); | |
2262 | } | |
2263 | ||
2264 | ||
2265 | /* Allocate a new symtree node and associate it with the new symbol. */ | |
2266 | ||
2267 | gfc_symtree * | |
66e4ab31 | 2268 | gfc_new_symtree (gfc_symtree **root, const char *name) |
6de9cd9a DN |
2269 | { |
2270 | gfc_symtree *st; | |
2271 | ||
ece3f663 | 2272 | st = XCNEW (gfc_symtree); |
cb9e4f55 | 2273 | st->name = gfc_get_string (name); |
6de9cd9a DN |
2274 | |
2275 | gfc_insert_bbt (root, st, compare_symtree); | |
2276 | return st; | |
2277 | } | |
2278 | ||
2279 | ||
2280 | /* Delete a symbol from the tree. Does not free the symbol itself! */ | |
2281 | ||
a99d95a2 PT |
2282 | void |
2283 | gfc_delete_symtree (gfc_symtree **root, const char *name) | |
6de9cd9a DN |
2284 | { |
2285 | gfc_symtree st, *st0; | |
2286 | ||
2287 | st0 = gfc_find_symtree (*root, name); | |
2288 | ||
cb9e4f55 | 2289 | st.name = gfc_get_string (name); |
6de9cd9a DN |
2290 | gfc_delete_bbt (root, &st, compare_symtree); |
2291 | ||
2292 | gfc_free (st0); | |
2293 | } | |
2294 | ||
2295 | ||
2296 | /* Given a root symtree node and a name, try to find the symbol within | |
2297 | the namespace. Returns NULL if the symbol is not found. */ | |
2298 | ||
2299 | gfc_symtree * | |
66e4ab31 | 2300 | gfc_find_symtree (gfc_symtree *st, const char *name) |
6de9cd9a DN |
2301 | { |
2302 | int c; | |
2303 | ||
2304 | while (st != NULL) | |
2305 | { | |
2306 | c = strcmp (name, st->name); | |
2307 | if (c == 0) | |
2308 | return st; | |
2309 | ||
2310 | st = (c < 0) ? st->left : st->right; | |
2311 | } | |
2312 | ||
2313 | return NULL; | |
2314 | } | |
2315 | ||
2316 | ||
aa84a9a5 PT |
2317 | /* Return a symtree node with a name that is guaranteed to be unique |
2318 | within the namespace and corresponds to an illegal fortran name. */ | |
2319 | ||
2320 | gfc_symtree * | |
2321 | gfc_get_unique_symtree (gfc_namespace *ns) | |
2322 | { | |
2323 | char name[GFC_MAX_SYMBOL_LEN + 1]; | |
2324 | static int serial = 0; | |
2325 | ||
2326 | sprintf (name, "@%d", serial++); | |
2327 | return gfc_new_symtree (&ns->sym_root, name); | |
2328 | } | |
2329 | ||
2330 | ||
6de9cd9a DN |
2331 | /* Given a name find a user operator node, creating it if it doesn't |
2332 | exist. These are much simpler than symbols because they can't be | |
2333 | ambiguous with one another. */ | |
2334 | ||
2335 | gfc_user_op * | |
2336 | gfc_get_uop (const char *name) | |
2337 | { | |
2338 | gfc_user_op *uop; | |
2339 | gfc_symtree *st; | |
2340 | ||
2341 | st = gfc_find_symtree (gfc_current_ns->uop_root, name); | |
2342 | if (st != NULL) | |
2343 | return st->n.uop; | |
2344 | ||
2345 | st = gfc_new_symtree (&gfc_current_ns->uop_root, name); | |
2346 | ||
ece3f663 | 2347 | uop = st->n.uop = XCNEW (gfc_user_op); |
cb9e4f55 | 2348 | uop->name = gfc_get_string (name); |
6de9cd9a DN |
2349 | uop->access = ACCESS_UNKNOWN; |
2350 | uop->ns = gfc_current_ns; | |
2351 | ||
2352 | return uop; | |
2353 | } | |
2354 | ||
2355 | ||
2356 | /* Given a name find the user operator node. Returns NULL if it does | |
2357 | not exist. */ | |
2358 | ||
2359 | gfc_user_op * | |
66e4ab31 | 2360 | gfc_find_uop (const char *name, gfc_namespace *ns) |
6de9cd9a DN |
2361 | { |
2362 | gfc_symtree *st; | |
2363 | ||
2364 | if (ns == NULL) | |
2365 | ns = gfc_current_ns; | |
2366 | ||
2367 | st = gfc_find_symtree (ns->uop_root, name); | |
2368 | return (st == NULL) ? NULL : st->n.uop; | |
2369 | } | |
2370 | ||
2371 | ||
2372 | /* Remove a gfc_symbol structure and everything it points to. */ | |
2373 | ||
2374 | void | |
66e4ab31 | 2375 | gfc_free_symbol (gfc_symbol *sym) |
6de9cd9a DN |
2376 | { |
2377 | ||
2378 | if (sym == NULL) | |
2379 | return; | |
2380 | ||
2381 | gfc_free_array_spec (sym->as); | |
2382 | ||
2383 | free_components (sym->components); | |
2384 | ||
2385 | gfc_free_expr (sym->value); | |
2386 | ||
2387 | gfc_free_namelist (sym->namelist); | |
2388 | ||
2389 | gfc_free_namespace (sym->formal_ns); | |
2390 | ||
1027275d PT |
2391 | if (!sym->attr.generic_copy) |
2392 | gfc_free_interface (sym->generic); | |
6de9cd9a DN |
2393 | |
2394 | gfc_free_formal_arglist (sym->formal); | |
2395 | ||
34523524 DK |
2396 | gfc_free_namespace (sym->f2k_derived); |
2397 | ||
6de9cd9a DN |
2398 | gfc_free (sym); |
2399 | } | |
2400 | ||
2401 | ||
2402 | /* Allocate and initialize a new symbol node. */ | |
2403 | ||
2404 | gfc_symbol * | |
66e4ab31 | 2405 | gfc_new_symbol (const char *name, gfc_namespace *ns) |
6de9cd9a DN |
2406 | { |
2407 | gfc_symbol *p; | |
2408 | ||
ece3f663 | 2409 | p = XCNEW (gfc_symbol); |
6de9cd9a DN |
2410 | |
2411 | gfc_clear_ts (&p->ts); | |
2412 | gfc_clear_attr (&p->attr); | |
2413 | p->ns = ns; | |
2414 | ||
63645982 | 2415 | p->declared_at = gfc_current_locus; |
6de9cd9a DN |
2416 | |
2417 | if (strlen (name) > GFC_MAX_SYMBOL_LEN) | |
2418 | gfc_internal_error ("new_symbol(): Symbol name too long"); | |
2419 | ||
cb9e4f55 | 2420 | p->name = gfc_get_string (name); |
a8b3b0b6 CR |
2421 | |
2422 | /* Make sure flags for symbol being C bound are clear initially. */ | |
2423 | p->attr.is_bind_c = 0; | |
2424 | p->attr.is_iso_c = 0; | |
2425 | /* Make sure the binding label field has a Nul char to start. */ | |
2426 | p->binding_label[0] = '\0'; | |
2427 | ||
2428 | /* Clear the ptrs we may need. */ | |
2429 | p->common_block = NULL; | |
34523524 | 2430 | p->f2k_derived = NULL; |
a8b3b0b6 | 2431 | |
6de9cd9a DN |
2432 | return p; |
2433 | } | |
2434 | ||
2435 | ||
2436 | /* Generate an error if a symbol is ambiguous. */ | |
2437 | ||
2438 | static void | |
66e4ab31 | 2439 | ambiguous_symbol (const char *name, gfc_symtree *st) |
6de9cd9a DN |
2440 | { |
2441 | ||
cb9e4f55 | 2442 | if (st->n.sym->module) |
6de9cd9a DN |
2443 | gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " |
2444 | "from module '%s'", name, st->n.sym->name, st->n.sym->module); | |
2445 | else | |
2446 | gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " | |
2447 | "from current program unit", name, st->n.sym->name); | |
2448 | } | |
2449 | ||
2450 | ||
294fbfc8 | 2451 | /* Search for a symtree starting in the current namespace, resorting to |
6de9cd9a | 2452 | any parent namespaces if requested by a nonzero parent_flag. |
294fbfc8 | 2453 | Returns nonzero if the name is ambiguous. */ |
6de9cd9a DN |
2454 | |
2455 | int | |
66e4ab31 SK |
2456 | gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag, |
2457 | gfc_symtree **result) | |
6de9cd9a DN |
2458 | { |
2459 | gfc_symtree *st; | |
2460 | ||
2461 | if (ns == NULL) | |
2462 | ns = gfc_current_ns; | |
2463 | ||
2464 | do | |
2465 | { | |
2466 | st = gfc_find_symtree (ns->sym_root, name); | |
2467 | if (st != NULL) | |
2468 | { | |
2469 | *result = st; | |
993ef28f PT |
2470 | /* Ambiguous generic interfaces are permitted, as long |
2471 | as the specific interfaces are different. */ | |
2472 | if (st->ambiguous && !st->n.sym->attr.generic) | |
6de9cd9a DN |
2473 | { |
2474 | ambiguous_symbol (name, st); | |
2475 | return 1; | |
2476 | } | |
2477 | ||
2478 | return 0; | |
2479 | } | |
2480 | ||
2481 | if (!parent_flag) | |
2482 | break; | |
2483 | ||
2484 | ns = ns->parent; | |
2485 | } | |
2486 | while (ns != NULL); | |
2487 | ||
2488 | *result = NULL; | |
2489 | return 0; | |
2490 | } | |
2491 | ||
2492 | ||
294fbfc8 TS |
2493 | /* Same, but returns the symbol instead. */ |
2494 | ||
6de9cd9a | 2495 | int |
66e4ab31 SK |
2496 | gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag, |
2497 | gfc_symbol **result) | |
6de9cd9a DN |
2498 | { |
2499 | gfc_symtree *st; | |
2500 | int i; | |
2501 | ||
2502 | i = gfc_find_sym_tree (name, ns, parent_flag, &st); | |
2503 | ||
2504 | if (st == NULL) | |
2505 | *result = NULL; | |
2506 | else | |
2507 | *result = st->n.sym; | |
2508 | ||
2509 | return i; | |
2510 | } | |
2511 | ||
2512 | ||
2513 | /* Save symbol with the information necessary to back it out. */ | |
2514 | ||
2515 | static void | |
66e4ab31 | 2516 | save_symbol_data (gfc_symbol *sym) |
6de9cd9a DN |
2517 | { |
2518 | ||
7b901ac4 | 2519 | if (sym->gfc_new || sym->old_symbol != NULL) |
6de9cd9a DN |
2520 | return; |
2521 | ||
ece3f663 | 2522 | sym->old_symbol = XCNEW (gfc_symbol); |
6de9cd9a DN |
2523 | *(sym->old_symbol) = *sym; |
2524 | ||
2525 | sym->tlink = changed_syms; | |
2526 | changed_syms = sym; | |
2527 | } | |
2528 | ||
2529 | ||
2530 | /* Given a name, find a symbol, or create it if it does not exist yet | |
2531 | in the current namespace. If the symbol is found we make sure that | |
2532 | it's OK. | |
2533 | ||
2534 | The integer return code indicates | |
2535 | 0 All OK | |
2536 | 1 The symbol name was ambiguous | |
2537 | 2 The name meant to be established was already host associated. | |
2538 | ||
2539 | So if the return value is nonzero, then an error was issued. */ | |
2540 | ||
2541 | int | |
66e4ab31 | 2542 | gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result) |
6de9cd9a DN |
2543 | { |
2544 | gfc_symtree *st; | |
2545 | gfc_symbol *p; | |
2546 | ||
2547 | /* This doesn't usually happen during resolution. */ | |
2548 | if (ns == NULL) | |
2549 | ns = gfc_current_ns; | |
2550 | ||
2551 | /* Try to find the symbol in ns. */ | |
2552 | st = gfc_find_symtree (ns->sym_root, name); | |
2553 | ||
2554 | if (st == NULL) | |
2555 | { | |
2556 | /* If not there, create a new symbol. */ | |
2557 | p = gfc_new_symbol (name, ns); | |
2558 | ||
2559 | /* Add to the list of tentative symbols. */ | |
2560 | p->old_symbol = NULL; | |
2561 | p->tlink = changed_syms; | |
2562 | p->mark = 1; | |
7b901ac4 | 2563 | p->gfc_new = 1; |
6de9cd9a DN |
2564 | changed_syms = p; |
2565 | ||
2566 | st = gfc_new_symtree (&ns->sym_root, name); | |
2567 | st->n.sym = p; | |
2568 | p->refs++; | |
2569 | ||
2570 | } | |
2571 | else | |
2572 | { | |
993ef28f PT |
2573 | /* Make sure the existing symbol is OK. Ambiguous |
2574 | generic interfaces are permitted, as long as the | |
2575 | specific interfaces are different. */ | |
2576 | if (st->ambiguous && !st->n.sym->attr.generic) | |
6de9cd9a DN |
2577 | { |
2578 | ambiguous_symbol (name, st); | |
2579 | return 1; | |
2580 | } | |
2581 | ||
2582 | p = st->n.sym; | |
2583 | ||
5a8af0b4 PT |
2584 | if (p->ns != ns && (!p->attr.function || ns->proc_name != p) |
2585 | && !(ns->proc_name | |
2586 | && ns->proc_name->attr.if_source == IFSRC_IFBODY | |
2587 | && (ns->has_import_set || p->attr.imported))) | |
6de9cd9a DN |
2588 | { |
2589 | /* Symbol is from another namespace. */ | |
2590 | gfc_error ("Symbol '%s' at %C has already been host associated", | |
2591 | name); | |
2592 | return 2; | |
2593 | } | |
2594 | ||
2595 | p->mark = 1; | |
2596 | ||
2597 | /* Copy in case this symbol is changed. */ | |
2598 | save_symbol_data (p); | |
2599 | } | |
2600 | ||
2601 | *result = st; | |
2602 | return 0; | |
2603 | } | |
2604 | ||
2605 | ||
2606 | int | |
66e4ab31 | 2607 | gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result) |
6de9cd9a DN |
2608 | { |
2609 | gfc_symtree *st; | |
2610 | int i; | |
2611 | ||
6de9cd9a DN |
2612 | i = gfc_get_sym_tree (name, ns, &st); |
2613 | if (i != 0) | |
2614 | return i; | |
2615 | ||
2616 | if (st) | |
2617 | *result = st->n.sym; | |
2618 | else | |
2619 | *result = NULL; | |
2620 | return i; | |
2621 | } | |
2622 | ||
2623 | ||
2624 | /* Subroutine that searches for a symbol, creating it if it doesn't | |
2625 | exist, but tries to host-associate the symbol if possible. */ | |
2626 | ||
2627 | int | |
66e4ab31 | 2628 | gfc_get_ha_sym_tree (const char *name, gfc_symtree **result) |
6de9cd9a DN |
2629 | { |
2630 | gfc_symtree *st; | |
2631 | int i; | |
2632 | ||
2633 | i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); | |
2634 | if (st != NULL) | |
2635 | { | |
2636 | save_symbol_data (st->n.sym); | |
6de9cd9a DN |
2637 | *result = st; |
2638 | return i; | |
2639 | } | |
2640 | ||
2641 | if (gfc_current_ns->parent != NULL) | |
2642 | { | |
2643 | i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st); | |
2644 | if (i) | |
2645 | return i; | |
2646 | ||
2647 | if (st != NULL) | |
2648 | { | |
2649 | *result = st; | |
2650 | return 0; | |
2651 | } | |
2652 | } | |
2653 | ||
2654 | return gfc_get_sym_tree (name, gfc_current_ns, result); | |
2655 | } | |
2656 | ||
2657 | ||
2658 | int | |
66e4ab31 | 2659 | gfc_get_ha_symbol (const char *name, gfc_symbol **result) |
6de9cd9a DN |
2660 | { |
2661 | int i; | |
2662 | gfc_symtree *st; | |
2663 | ||
2664 | i = gfc_get_ha_sym_tree (name, &st); | |
2665 | ||
2666 | if (st) | |
2667 | *result = st->n.sym; | |
2668 | else | |
2669 | *result = NULL; | |
2670 | ||
2671 | return i; | |
2672 | } | |
2673 | ||
2674 | /* Return true if both symbols could refer to the same data object. Does | |
2675 | not take account of aliasing due to equivalence statements. */ | |
2676 | ||
2677 | int | |
66e4ab31 | 2678 | gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym) |
6de9cd9a DN |
2679 | { |
2680 | /* Aliasing isn't possible if the symbols have different base types. */ | |
2681 | if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) | |
2682 | return 0; | |
2683 | ||
2684 | /* Pointers can point to other pointers, target objects and allocatable | |
2685 | objects. Two allocatable objects cannot share the same storage. */ | |
2686 | if (lsym->attr.pointer | |
2687 | && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target)) | |
2688 | return 1; | |
2689 | if (lsym->attr.target && rsym->attr.pointer) | |
2690 | return 1; | |
2691 | if (lsym->attr.allocatable && rsym->attr.pointer) | |
2692 | return 1; | |
2693 | ||
2694 | return 0; | |
2695 | } | |
2696 | ||
2697 | ||
2698 | /* Undoes all the changes made to symbols in the current statement. | |
2699 | This subroutine is made simpler due to the fact that attributes are | |
2700 | never removed once added. */ | |
2701 | ||
2702 | void | |
2703 | gfc_undo_symbols (void) | |
2704 | { | |
2705 | gfc_symbol *p, *q, *old; | |
e34ccb4c | 2706 | tentative_tbp *tbp, *tbq; |
6de9cd9a DN |
2707 | |
2708 | for (p = changed_syms; p; p = q) | |
2709 | { | |
2710 | q = p->tlink; | |
2711 | ||
7b901ac4 | 2712 | if (p->gfc_new) |
6de9cd9a DN |
2713 | { |
2714 | /* Symbol was new. */ | |
79f40de6 DF |
2715 | if (p->attr.in_common && p->common_block->head) |
2716 | { | |
2717 | /* If the symbol was added to any common block, it | |
2718 | needs to be removed to stop the resolver looking | |
2719 | for a (possibly) dead symbol. */ | |
2720 | ||
2721 | if (p->common_block->head == p) | |
2722 | p->common_block->head = p->common_next; | |
2723 | else | |
2724 | { | |
2725 | gfc_symbol *cparent, *csym; | |
2726 | ||
2727 | cparent = p->common_block->head; | |
2728 | csym = cparent->common_next; | |
2729 | ||
2730 | while (csym != p) | |
2731 | { | |
2732 | cparent = csym; | |
2733 | csym = csym->common_next; | |
2734 | } | |
2735 | ||
2736 | gcc_assert(cparent->common_next == p); | |
2737 | ||
2738 | cparent->common_next = csym->common_next; | |
2739 | } | |
2740 | } | |
2741 | ||
a99d95a2 | 2742 | gfc_delete_symtree (&p->ns->sym_root, p->name); |
6de9cd9a DN |
2743 | |
2744 | p->refs--; | |
2745 | if (p->refs < 0) | |
2746 | gfc_internal_error ("gfc_undo_symbols(): Negative refs"); | |
2747 | if (p->refs == 0) | |
2748 | gfc_free_symbol (p); | |
2749 | continue; | |
2750 | } | |
2751 | ||
2752 | /* Restore previous state of symbol. Just copy simple stuff. */ | |
2753 | p->mark = 0; | |
2754 | old = p->old_symbol; | |
2755 | ||
2756 | p->ts.type = old->ts.type; | |
2757 | p->ts.kind = old->ts.kind; | |
2758 | ||
2759 | p->attr = old->attr; | |
2760 | ||
2761 | if (p->value != old->value) | |
2762 | { | |
2763 | gfc_free_expr (old->value); | |
2764 | p->value = NULL; | |
2765 | } | |
2766 | ||
2767 | if (p->as != old->as) | |
2768 | { | |
2769 | if (p->as) | |
2770 | gfc_free_array_spec (p->as); | |
2771 | p->as = old->as; | |
2772 | } | |
2773 | ||
2774 | p->generic = old->generic; | |
2775 | p->component_access = old->component_access; | |
2776 | ||
2777 | if (p->namelist != NULL && old->namelist == NULL) | |
2778 | { | |
2779 | gfc_free_namelist (p->namelist); | |
2780 | p->namelist = NULL; | |
2781 | } | |
2782 | else | |
2783 | { | |
6de9cd9a DN |
2784 | if (p->namelist_tail != old->namelist_tail) |
2785 | { | |
2786 | gfc_free_namelist (old->namelist_tail); | |
2787 | old->namelist_tail->next = NULL; | |
2788 | } | |
2789 | } | |
2790 | ||
2791 | p->namelist_tail = old->namelist_tail; | |
2792 | ||
2793 | if (p->formal != old->formal) | |
2794 | { | |
2795 | gfc_free_formal_arglist (p->formal); | |
2796 | p->formal = old->formal; | |
2797 | } | |
2798 | ||
2799 | gfc_free (p->old_symbol); | |
2800 | p->old_symbol = NULL; | |
2801 | p->tlink = NULL; | |
2802 | } | |
2803 | ||
2804 | changed_syms = NULL; | |
e34ccb4c DK |
2805 | |
2806 | for (tbp = tentative_tbp_list; tbp; tbp = tbq) | |
2807 | { | |
2808 | tbq = tbp->next; | |
2809 | /* Procedure is already marked `error' by default. */ | |
2810 | gfc_free (tbp); | |
2811 | } | |
2812 | tentative_tbp_list = NULL; | |
6de9cd9a DN |
2813 | } |
2814 | ||
2815 | ||
091c9413 EE |
2816 | /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the |
2817 | components of old_symbol that might need deallocation are the "allocatables" | |
2818 | that are restored in gfc_undo_symbols(), with two exceptions: namelist and | |
2819 | namelist_tail. In case these differ between old_symbol and sym, it's just | |
2820 | because sym->namelist has gotten a few more items. */ | |
810306f2 EE |
2821 | |
2822 | static void | |
66e4ab31 | 2823 | free_old_symbol (gfc_symbol *sym) |
810306f2 | 2824 | { |
66e4ab31 | 2825 | |
810306f2 EE |
2826 | if (sym->old_symbol == NULL) |
2827 | return; | |
2828 | ||
2829 | if (sym->old_symbol->as != sym->as) | |
2830 | gfc_free_array_spec (sym->old_symbol->as); | |
2831 | ||
2832 | if (sym->old_symbol->value != sym->value) | |
2833 | gfc_free_expr (sym->old_symbol->value); | |
2834 | ||
091c9413 EE |
2835 | if (sym->old_symbol->formal != sym->formal) |
2836 | gfc_free_formal_arglist (sym->old_symbol->formal); | |
2837 | ||
810306f2 EE |
2838 | gfc_free (sym->old_symbol); |
2839 | sym->old_symbol = NULL; | |
2840 | } | |
2841 | ||
2842 | ||
6de9cd9a DN |
2843 | /* Makes the changes made in the current statement permanent-- gets |
2844 | rid of undo information. */ | |
2845 | ||
2846 | void | |
2847 | gfc_commit_symbols (void) | |
2848 | { | |
2849 | gfc_symbol *p, *q; | |
e34ccb4c | 2850 | tentative_tbp *tbp, *tbq; |
6de9cd9a DN |
2851 | |
2852 | for (p = changed_syms; p; p = q) | |
2853 | { | |
2854 | q = p->tlink; | |
2855 | p->tlink = NULL; | |
2856 | p->mark = 0; | |
7b901ac4 | 2857 | p->gfc_new = 0; |
810306f2 | 2858 | free_old_symbol (p); |
6de9cd9a | 2859 | } |
6de9cd9a | 2860 | changed_syms = NULL; |
e34ccb4c DK |
2861 | |
2862 | for (tbp = tentative_tbp_list; tbp; tbp = tbq) | |
2863 | { | |
2864 | tbq = tbp->next; | |
2865 | tbp->proc->error = 0; | |
2866 | gfc_free (tbp); | |
2867 | } | |
2868 | tentative_tbp_list = NULL; | |
6de9cd9a DN |
2869 | } |
2870 | ||
2871 | ||
810306f2 EE |
2872 | /* Makes the changes made in one symbol permanent -- gets rid of undo |
2873 | information. */ | |
2874 | ||
2875 | void | |
66e4ab31 | 2876 | gfc_commit_symbol (gfc_symbol *sym) |
810306f2 EE |
2877 | { |
2878 | gfc_symbol *p; | |
2879 | ||
2880 | if (changed_syms == sym) | |
2881 | changed_syms = sym->tlink; | |
2882 | else | |
2883 | { | |
2884 | for (p = changed_syms; p; p = p->tlink) | |
2885 | if (p->tlink == sym) | |
2886 | { | |
2887 | p->tlink = sym->tlink; | |
2888 | break; | |
2889 | } | |
2890 | } | |
2891 | ||
2892 | sym->tlink = NULL; | |
2893 | sym->mark = 0; | |
7b901ac4 | 2894 | sym->gfc_new = 0; |
810306f2 EE |
2895 | |
2896 | free_old_symbol (sym); | |
2897 | } | |
2898 | ||
2899 | ||
e34ccb4c DK |
2900 | /* Recursively free trees containing type-bound procedures. */ |
2901 | ||
2902 | static void | |
2903 | free_tb_tree (gfc_symtree *t) | |
2904 | { | |
2905 | if (t == NULL) | |
2906 | return; | |
2907 | ||
2908 | free_tb_tree (t->left); | |
2909 | free_tb_tree (t->right); | |
2910 | ||
2911 | /* TODO: Free type-bound procedure structs themselves; probably needs some | |
2912 | sort of ref-counting mechanism. */ | |
2913 | ||
2914 | gfc_free (t); | |
2915 | } | |
2916 | ||
2917 | ||
53814b8f TS |
2918 | /* Recursive function that deletes an entire tree and all the common |
2919 | head structures it points to. */ | |
2920 | ||
79f40de6 DF |
2921 | static void |
2922 | free_common_tree (gfc_symtree * common_tree) | |
53814b8f TS |
2923 | { |
2924 | if (common_tree == NULL) | |
2925 | return; | |
2926 | ||
79f40de6 DF |
2927 | free_common_tree (common_tree->left); |
2928 | free_common_tree (common_tree->right); | |
53814b8f TS |
2929 | |
2930 | gfc_free (common_tree); | |
2931 | } | |
2932 | ||
2933 | ||
6de9cd9a DN |
2934 | /* Recursive function that deletes an entire tree and all the user |
2935 | operator nodes that it contains. */ | |
2936 | ||
2937 | static void | |
66e4ab31 | 2938 | free_uop_tree (gfc_symtree *uop_tree) |
6de9cd9a DN |
2939 | { |
2940 | ||
2941 | if (uop_tree == NULL) | |
2942 | return; | |
2943 | ||
2944 | free_uop_tree (uop_tree->left); | |
2945 | free_uop_tree (uop_tree->right); | |
2946 | ||
a1ee985f | 2947 | gfc_free_interface (uop_tree->n.uop->op); |
6de9cd9a DN |
2948 | |
2949 | gfc_free (uop_tree->n.uop); | |
2950 | gfc_free (uop_tree); | |
2951 | } | |
2952 | ||
2953 | ||
2954 | /* Recursive function that deletes an entire tree and all the symbols | |
2955 | that it contains. */ | |
2956 | ||
2957 | static void | |
66e4ab31 | 2958 | free_sym_tree (gfc_symtree *sym_tree) |
6de9cd9a DN |
2959 | { |
2960 | gfc_namespace *ns; | |
2961 | gfc_symbol *sym; | |
2962 | ||
2963 | if (sym_tree == NULL) | |
2964 | return; | |
2965 | ||
2966 | free_sym_tree (sym_tree->left); | |
2967 | free_sym_tree (sym_tree->right); | |
2968 | ||
2969 | sym = sym_tree->n.sym; | |
2970 | ||
2971 | sym->refs--; | |
2972 | if (sym->refs < 0) | |
2973 | gfc_internal_error ("free_sym_tree(): Negative refs"); | |
2974 | ||
2975 | if (sym->formal_ns != NULL && sym->refs == 1) | |
2976 | { | |
2977 | /* As formal_ns contains a reference to sym, delete formal_ns just | |
2978 | before the deletion of sym. */ | |
2979 | ns = sym->formal_ns; | |
2980 | sym->formal_ns = NULL; | |
2981 | gfc_free_namespace (ns); | |
2982 | } | |
2983 | else if (sym->refs == 0) | |
2984 | { | |
2985 | /* Go ahead and delete the symbol. */ | |
2986 | gfc_free_symbol (sym); | |
2987 | } | |
2988 | ||
2989 | gfc_free (sym_tree); | |
2990 | } | |
2991 | ||
2992 | ||
7453378e | 2993 | /* Free the derived type list. */ |
6b887797 | 2994 | |
71a7778c | 2995 | void |
7453378e | 2996 | gfc_free_dt_list (void) |
6b887797 | 2997 | { |
7453378e | 2998 | gfc_dt_list *dt, *n; |
6b887797 | 2999 | |
7453378e | 3000 | for (dt = gfc_derived_types; dt; dt = n) |
6b887797 PT |
3001 | { |
3002 | n = dt->next; | |
3003 | gfc_free (dt); | |
3004 | } | |
7453378e PT |
3005 | |
3006 | gfc_derived_types = NULL; | |
6b887797 PT |
3007 | } |
3008 | ||
3009 | ||
61321991 PT |
3010 | /* Free the gfc_equiv_info's. */ |
3011 | ||
3012 | static void | |
66e4ab31 | 3013 | gfc_free_equiv_infos (gfc_equiv_info *s) |
61321991 PT |
3014 | { |
3015 | if (s == NULL) | |
3016 | return; | |
3017 | gfc_free_equiv_infos (s->next); | |
3018 | gfc_free (s); | |
3019 | } | |
3020 | ||
3021 | ||
3022 | /* Free the gfc_equiv_lists. */ | |
3023 | ||
3024 | static void | |
66e4ab31 | 3025 | gfc_free_equiv_lists (gfc_equiv_list *l) |
61321991 PT |
3026 | { |
3027 | if (l == NULL) | |
3028 | return; | |
3029 | gfc_free_equiv_lists (l->next); | |
3030 | gfc_free_equiv_infos (l->equiv); | |
3031 | gfc_free (l); | |
3032 | } | |
3033 | ||
3034 | ||
34523524 DK |
3035 | /* Free a finalizer procedure list. */ |
3036 | ||
3037 | void | |
3038 | gfc_free_finalizer (gfc_finalizer* el) | |
3039 | { | |
3040 | if (el) | |
3041 | { | |
f6fad28e DK |
3042 | if (el->proc_sym) |
3043 | { | |
3044 | --el->proc_sym->refs; | |
3045 | if (!el->proc_sym->refs) | |
3046 | gfc_free_symbol (el->proc_sym); | |
3047 | } | |
34523524 DK |
3048 | |
3049 | gfc_free (el); | |
3050 | } | |
3051 | } | |
3052 | ||
3053 | static void | |
3054 | gfc_free_finalizer_list (gfc_finalizer* list) | |
3055 | { | |
3056 | while (list) | |
3057 | { | |
3058 | gfc_finalizer* current = list; | |
3059 | list = list->next; | |
3060 | gfc_free_finalizer (current); | |
3061 | } | |
3062 | } | |
3063 | ||
3064 | ||
27f31e39 MM |
3065 | /* Free the charlen list from cl to end (end is not freed). |
3066 | Free the whole list if end is NULL. */ | |
3067 | ||
3068 | void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end) | |
3069 | { | |
3070 | gfc_charlen *cl2; | |
3071 | ||
3072 | for (; cl != end; cl = cl2) | |
3073 | { | |
3074 | gcc_assert (cl); | |
3075 | ||
3076 | cl2 = cl->next; | |
3077 | gfc_free_expr (cl->length); | |
3078 | gfc_free (cl); | |
3079 | } | |
3080 | } | |
3081 | ||
3082 | ||
6de9cd9a DN |
3083 | /* Free a namespace structure and everything below it. Interface |
3084 | lists associated with intrinsic operators are not freed. These are | |
3085 | taken care of when a specific name is freed. */ | |
3086 | ||
3087 | void | |
66e4ab31 | 3088 | gfc_free_namespace (gfc_namespace *ns) |
6de9cd9a | 3089 | { |
6de9cd9a DN |
3090 | gfc_namespace *p, *q; |
3091 | gfc_intrinsic_op i; | |
3092 | ||
3093 | if (ns == NULL) | |
3094 | return; | |
3095 | ||
3d79abbd PB |
3096 | ns->refs--; |
3097 | if (ns->refs > 0) | |
3098 | return; | |
6e45f57b | 3099 | gcc_assert (ns->refs == 0); |
3d79abbd | 3100 | |
6de9cd9a DN |
3101 | gfc_free_statements (ns->code); |
3102 | ||
3103 | free_sym_tree (ns->sym_root); | |
3104 | free_uop_tree (ns->uop_root); | |
79f40de6 | 3105 | free_common_tree (ns->common_root); |
e34ccb4c | 3106 | free_tb_tree (ns->tb_sym_root); |
34523524 | 3107 | gfc_free_finalizer_list (ns->finalizers); |
27f31e39 | 3108 | gfc_free_charlen (ns->cl_list, NULL); |
6de9cd9a DN |
3109 | free_st_labels (ns->st_labels); |
3110 | ||
3111 | gfc_free_equiv (ns->equiv); | |
61321991 | 3112 | gfc_free_equiv_lists (ns->equiv_lists); |
a64f5186 | 3113 | gfc_free_use_stmts (ns->use_stmts); |
6de9cd9a DN |
3114 | |
3115 | for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) | |
a1ee985f | 3116 | gfc_free_interface (ns->op[i]); |
6de9cd9a DN |
3117 | |
3118 | gfc_free_data (ns->data); | |
3119 | p = ns->contained; | |
3120 | gfc_free (ns); | |
3121 | ||
3122 | /* Recursively free any contained namespaces. */ | |
3123 | while (p != NULL) | |
3124 | { | |
3125 | q = p; | |
3126 | p = p->sibling; | |
6de9cd9a DN |
3127 | gfc_free_namespace (q); |
3128 | } | |
3129 | } | |
3130 | ||
3131 | ||
3132 | void | |
3133 | gfc_symbol_init_2 (void) | |
3134 | { | |
3135 | ||
0366dfe9 | 3136 | gfc_current_ns = gfc_get_namespace (NULL, 0); |
6de9cd9a DN |
3137 | } |
3138 | ||
3139 | ||
3140 | void | |
3141 | gfc_symbol_done_2 (void) | |
3142 | { | |
3143 | ||
3144 | gfc_free_namespace (gfc_current_ns); | |
3145 | gfc_current_ns = NULL; | |
7453378e | 3146 | gfc_free_dt_list (); |
6de9cd9a DN |
3147 | } |
3148 | ||
3149 | ||
3150 | /* Clear mark bits from symbol nodes associated with a symtree node. */ | |
3151 | ||
3152 | static void | |
66e4ab31 | 3153 | clear_sym_mark (gfc_symtree *st) |
6de9cd9a DN |
3154 | { |
3155 | ||
3156 | st->n.sym->mark = 0; | |
3157 | } | |
3158 | ||
3159 | ||
3160 | /* Recursively traverse the symtree nodes. */ | |
3161 | ||
9056bd70 | 3162 | void |
66e4ab31 | 3163 | gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *)) |
6de9cd9a | 3164 | { |
5cb41805 TS |
3165 | if (!st) |
3166 | return; | |
6de9cd9a | 3167 | |
5cb41805 TS |
3168 | gfc_traverse_symtree (st->left, func); |
3169 | (*func) (st); | |
3170 | gfc_traverse_symtree (st->right, func); | |
6de9cd9a DN |
3171 | } |
3172 | ||
3173 | ||
6de9cd9a DN |
3174 | /* Recursive namespace traversal function. */ |
3175 | ||
3176 | static void | |
66e4ab31 | 3177 | traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *)) |
6de9cd9a DN |
3178 | { |
3179 | ||
3180 | if (st == NULL) | |
3181 | return; | |
3182 | ||
5cb41805 TS |
3183 | traverse_ns (st->left, func); |
3184 | ||
6de9cd9a DN |
3185 | if (st->n.sym->mark == 0) |
3186 | (*func) (st->n.sym); | |
3187 | st->n.sym->mark = 1; | |
3188 | ||
6de9cd9a DN |
3189 | traverse_ns (st->right, func); |
3190 | } | |
3191 | ||
3192 | ||
3193 | /* Call a given function for all symbols in the namespace. We take | |
3194 | care that each gfc_symbol node is called exactly once. */ | |
3195 | ||
3196 | void | |
66e4ab31 | 3197 | gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *)) |
6de9cd9a DN |
3198 | { |
3199 | ||
9056bd70 | 3200 | gfc_traverse_symtree (ns->sym_root, clear_sym_mark); |
6de9cd9a DN |
3201 | |
3202 | traverse_ns (ns->sym_root, func); | |
3203 | } | |
3204 | ||
3205 | ||
e9c06563 TB |
3206 | /* Return TRUE when name is the name of an intrinsic type. */ |
3207 | ||
3208 | bool | |
3209 | gfc_is_intrinsic_typename (const char *name) | |
3210 | { | |
3211 | if (strcmp (name, "integer") == 0 | |
3212 | || strcmp (name, "real") == 0 | |
3213 | || strcmp (name, "character") == 0 | |
3214 | || strcmp (name, "logical") == 0 | |
3215 | || strcmp (name, "complex") == 0 | |
3216 | || strcmp (name, "doubleprecision") == 0 | |
3217 | || strcmp (name, "doublecomplex") == 0) | |
3218 | return true; | |
3219 | else | |
3220 | return false; | |
3221 | } | |
3222 | ||
3223 | ||
bd83e614 | 3224 | /* Return TRUE if the symbol is an automatic variable. */ |
66e4ab31 | 3225 | |
bd83e614 | 3226 | static bool |
66e4ab31 | 3227 | gfc_is_var_automatic (gfc_symbol *sym) |
bd83e614 PB |
3228 | { |
3229 | /* Pointer and allocatable variables are never automatic. */ | |
3230 | if (sym->attr.pointer || sym->attr.allocatable) | |
3231 | return false; | |
3232 | /* Check for arrays with non-constant size. */ | |
3233 | if (sym->attr.dimension && sym->as | |
3234 | && !gfc_is_compile_time_shape (sym->as)) | |
3235 | return true; | |
5189dd41 | 3236 | /* Check for non-constant length character variables. */ |
bd83e614 PB |
3237 | if (sym->ts.type == BT_CHARACTER |
3238 | && sym->ts.cl | |
d05d9ac7 | 3239 | && !gfc_is_constant_expr (sym->ts.cl->length)) |
bd83e614 PB |
3240 | return true; |
3241 | return false; | |
3242 | } | |
3243 | ||
6de9cd9a DN |
3244 | /* Given a symbol, mark it as SAVEd if it is allowed. */ |
3245 | ||
3246 | static void | |
66e4ab31 | 3247 | save_symbol (gfc_symbol *sym) |
6de9cd9a DN |
3248 | { |
3249 | ||
3250 | if (sym->attr.use_assoc) | |
3251 | return; | |
3252 | ||
6de9cd9a DN |
3253 | if (sym->attr.in_common |
3254 | || sym->attr.dummy | |
5a47fc2f | 3255 | || sym->attr.result |
6de9cd9a DN |
3256 | || sym->attr.flavor != FL_VARIABLE) |
3257 | return; | |
bd83e614 PB |
3258 | /* Automatic objects are not saved. */ |
3259 | if (gfc_is_var_automatic (sym)) | |
3260 | return; | |
231b2fcc | 3261 | gfc_add_save (&sym->attr, sym->name, &sym->declared_at); |
6de9cd9a DN |
3262 | } |
3263 | ||
3264 | ||
3265 | /* Mark those symbols which can be SAVEd as such. */ | |
3266 | ||
3267 | void | |
66e4ab31 | 3268 | gfc_save_all (gfc_namespace *ns) |
6de9cd9a | 3269 | { |
6de9cd9a DN |
3270 | gfc_traverse_ns (ns, save_symbol); |
3271 | } | |
3272 | ||
3273 | ||
3274 | #ifdef GFC_DEBUG | |
3275 | /* Make sure that no changes to symbols are pending. */ | |
3276 | ||
3277 | void | |
3278 | gfc_symbol_state(void) { | |
3279 | ||
3280 | if (changed_syms != NULL) | |
3281 | gfc_internal_error("Symbol changes still pending!"); | |
3282 | } | |
3283 | #endif | |
3284 | ||
c9543002 TS |
3285 | |
3286 | /************** Global symbol handling ************/ | |
3287 | ||
3288 | ||
3289 | /* Search a tree for the global symbol. */ | |
3290 | ||
3291 | gfc_gsymbol * | |
cb9e4f55 | 3292 | gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) |
c9543002 | 3293 | { |
1a549788 | 3294 | int c; |
c9543002 TS |
3295 | |
3296 | if (symbol == NULL) | |
3297 | return NULL; | |
c9543002 | 3298 | |
1a549788 TS |
3299 | while (symbol) |
3300 | { | |
3301 | c = strcmp (name, symbol->name); | |
3302 | if (!c) | |
3303 | return symbol; | |
c9543002 | 3304 | |
1a549788 TS |
3305 | symbol = (c < 0) ? symbol->left : symbol->right; |
3306 | } | |
c9543002 TS |
3307 | |
3308 | return NULL; | |
3309 | } | |
3310 | ||
3311 | ||
3312 | /* Compare two global symbols. Used for managing the BB tree. */ | |
3313 | ||
3314 | static int | |
66e4ab31 | 3315 | gsym_compare (void *_s1, void *_s2) |
c9543002 TS |
3316 | { |
3317 | gfc_gsymbol *s1, *s2; | |
3318 | ||
66e4ab31 SK |
3319 | s1 = (gfc_gsymbol *) _s1; |
3320 | s2 = (gfc_gsymbol *) _s2; | |
3321 | return strcmp (s1->name, s2->name); | |
c9543002 TS |
3322 | } |
3323 | ||
3324 | ||
3325 | /* Get a global symbol, creating it if it doesn't exist. */ | |
3326 | ||
3327 | gfc_gsymbol * | |
cb9e4f55 | 3328 | gfc_get_gsymbol (const char *name) |
c9543002 TS |
3329 | { |
3330 | gfc_gsymbol *s; | |
3331 | ||
3332 | s = gfc_find_gsymbol (gfc_gsym_root, name); | |
3333 | if (s != NULL) | |
3334 | return s; | |
3335 | ||
ece3f663 | 3336 | s = XCNEW (gfc_gsymbol); |
c9543002 | 3337 | s->type = GSYM_UNKNOWN; |
973a384d | 3338 | s->name = gfc_get_string (name); |
c9543002 TS |
3339 | |
3340 | gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); | |
3341 | ||
3342 | return s; | |
3343 | } | |
a8b3b0b6 CR |
3344 | |
3345 | ||
3346 | static gfc_symbol * | |
3347 | get_iso_c_binding_dt (int sym_id) | |
3348 | { | |
3349 | gfc_dt_list *dt_list; | |
3350 | ||
3351 | dt_list = gfc_derived_types; | |
3352 | ||
3353 | /* Loop through the derived types in the name list, searching for | |
3354 | the desired symbol from iso_c_binding. Search the parent namespaces | |
3355 | if necessary and requested to (parent_flag). */ | |
3356 | while (dt_list != NULL) | |
3357 | { | |
3358 | if (dt_list->derived->from_intmod != INTMOD_NONE | |
3359 | && dt_list->derived->intmod_sym_id == sym_id) | |
3360 | return dt_list->derived; | |
3361 | ||
3362 | dt_list = dt_list->next; | |
3363 | } | |
3364 | ||
3365 | return NULL; | |
3366 | } | |
3367 | ||
3368 | ||
3369 | /* Verifies that the given derived type symbol, derived_sym, is interoperable | |
3370 | with C. This is necessary for any derived type that is BIND(C) and for | |
3371 | derived types that are parameters to functions that are BIND(C). All | |
3372 | fields of the derived type are required to be interoperable, and are tested | |
3373 | for such. If an error occurs, the errors are reported here, allowing for | |
3374 | multiple errors to be handled for a single derived type. */ | |
3375 | ||
17b1d2a0 | 3376 | gfc_try |
a8b3b0b6 CR |
3377 | verify_bind_c_derived_type (gfc_symbol *derived_sym) |
3378 | { | |
3379 | gfc_component *curr_comp = NULL; | |
17b1d2a0 KG |
3380 | gfc_try is_c_interop = FAILURE; |
3381 | gfc_try retval = SUCCESS; | |
a8b3b0b6 CR |
3382 | |
3383 | if (derived_sym == NULL) | |
3384 | gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is " | |
3385 | "unexpectedly NULL"); | |
3386 | ||
3387 | /* If we've already looked at this derived symbol, do not look at it again | |
3388 | so we don't repeat warnings/errors. */ | |
3389 | if (derived_sym->ts.is_c_interop) | |
3390 | return SUCCESS; | |
3391 | ||
3392 | /* The derived type must have the BIND attribute to be interoperable | |
3393 | J3/04-007, Section 15.2.3. */ | |
3394 | if (derived_sym->attr.is_bind_c != 1) | |
3395 | { | |
3396 | derived_sym->ts.is_c_interop = 0; | |
3397 | gfc_error_now ("Derived type '%s' declared at %L must have the BIND " | |
3398 | "attribute to be C interoperable", derived_sym->name, | |
3399 | &(derived_sym->declared_at)); | |
3400 | retval = FAILURE; | |
3401 | } | |
3402 | ||
3403 | curr_comp = derived_sym->components; | |
3404 | ||
3405 | /* TODO: is this really an error? */ | |
3406 | if (curr_comp == NULL) | |
3407 | { | |
3408 | gfc_error ("Derived type '%s' at %L is empty", | |
3409 | derived_sym->name, &(derived_sym->declared_at)); | |
3410 | return FAILURE; | |
3411 | } | |
3412 | ||
3413 | /* Initialize the derived type as being C interoperable. | |
3414 | If we find an error in the components, this will be set false. */ | |
3415 | derived_sym->ts.is_c_interop = 1; | |
3416 | ||
3417 | /* Loop through the list of components to verify that the kind of | |
3418 | each is a C interoperable type. */ | |
3419 | do | |
3420 | { | |
3421 | /* The components cannot be pointers (fortran sense). | |
3422 | J3/04-007, Section 15.2.3, C1505. */ | |
d4b7d0f0 | 3423 | if (curr_comp->attr.pointer != 0) |
a8b3b0b6 CR |
3424 | { |
3425 | gfc_error ("Component '%s' at %L cannot have the " | |
3426 | "POINTER attribute because it is a member " | |
3427 | "of the BIND(C) derived type '%s' at %L", | |
3428 | curr_comp->name, &(curr_comp->loc), | |
3429 | derived_sym->name, &(derived_sym->declared_at)); | |
3430 | retval = FAILURE; | |
3431 | } | |
3432 | ||
3433 | /* The components cannot be allocatable. | |
3434 | J3/04-007, Section 15.2.3, C1505. */ | |
d4b7d0f0 | 3435 | if (curr_comp->attr.allocatable != 0) |
a8b3b0b6 CR |
3436 | { |
3437 | gfc_error ("Component '%s' at %L cannot have the " | |
3438 | "ALLOCATABLE attribute because it is a member " | |
3439 | "of the BIND(C) derived type '%s' at %L", | |
3440 | curr_comp->name, &(curr_comp->loc), | |
3441 | derived_sym->name, &(derived_sym->declared_at)); | |
3442 | retval = FAILURE; | |
3443 | } | |
3444 | ||
3445 | /* BIND(C) derived types must have interoperable components. */ | |
3446 | if (curr_comp->ts.type == BT_DERIVED | |
3447 | && curr_comp->ts.derived->ts.is_iso_c != 1 | |
3448 | && curr_comp->ts.derived != derived_sym) | |
3449 | { | |
3450 | /* This should be allowed; the draft says a derived-type can not | |
3451 | have type parameters if it is has the BIND attribute. Type | |
3452 | parameters seem to be for making parameterized derived types. | |
3453 | There's no need to verify the type if it is c_ptr/c_funptr. */ | |
3454 | retval = verify_bind_c_derived_type (curr_comp->ts.derived); | |
3455 | } | |
3456 | else | |
3457 | { | |
3458 | /* Grab the typespec for the given component and test the kind. */ | |
2ec855f1 | 3459 | is_c_interop = verify_c_interop (&(curr_comp->ts)); |
a8b3b0b6 CR |
3460 | |
3461 | if (is_c_interop != SUCCESS) | |
3462 | { | |
3463 | /* Report warning and continue since not fatal. The | |
3464 | draft does specify a constraint that requires all fields | |
3465 | to interoperate, but if the user says real(4), etc., it | |
3466 | may interoperate with *something* in C, but the compiler | |
3467 | most likely won't know exactly what. Further, it may not | |
3468 | interoperate with the same data type(s) in C if the user | |
3469 | recompiles with different flags (e.g., -m32 and -m64 on | |
3470 | x86_64 and using integer(4) to claim interop with a | |
3471 | C_LONG). */ | |
3472 | if (derived_sym->attr.is_bind_c == 1) | |
3473 | /* If the derived type is bind(c), all fields must be | |
3474 | interop. */ | |
3475 | gfc_warning ("Component '%s' in derived type '%s' at %L " | |
3476 | "may not be C interoperable, even though " | |
3477 | "derived type '%s' is BIND(C)", | |
3478 | curr_comp->name, derived_sym->name, | |
3479 | &(curr_comp->loc), derived_sym->name); | |
3480 | else | |
3481 | /* If derived type is param to bind(c) routine, or to one | |
3482 | of the iso_c_binding procs, it must be interoperable, so | |
3483 | all fields must interop too. */ | |
3484 | gfc_warning ("Component '%s' in derived type '%s' at %L " | |
3485 | "may not be C interoperable", | |
3486 | curr_comp->name, derived_sym->name, | |
3487 | &(curr_comp->loc)); | |
3488 | } | |
3489 | } | |
3490 | ||
3491 | curr_comp = curr_comp->next; | |
3492 | } while (curr_comp != NULL); | |
3493 | ||
3494 | ||
3495 | /* Make sure we don't have conflicts with the attributes. */ | |
3496 | if (derived_sym->attr.access == ACCESS_PRIVATE) | |
3497 | { | |
3498 | gfc_error ("Derived type '%s' at %L cannot be declared with both " | |
3499 | "PRIVATE and BIND(C) attributes", derived_sym->name, | |
3500 | &(derived_sym->declared_at)); | |
3501 | retval = FAILURE; | |
3502 | } | |
3503 | ||
3504 | if (derived_sym->attr.sequence != 0) | |
3505 | { | |
3506 | gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE " | |
3507 | "attribute because it is BIND(C)", derived_sym->name, | |
3508 | &(derived_sym->declared_at)); | |
3509 | retval = FAILURE; | |
3510 | } | |
3511 | ||
3512 | /* Mark the derived type as not being C interoperable if we found an | |
3513 | error. If there were only warnings, proceed with the assumption | |
3514 | it's interoperable. */ | |
3515 | if (retval == FAILURE) | |
3516 | derived_sym->ts.is_c_interop = 0; | |
3517 | ||
3518 | return retval; | |
3519 | } | |
3520 | ||
3521 | ||
3522 | /* Generate symbols for the named constants c_null_ptr and c_null_funptr. */ | |
3523 | ||
17b1d2a0 | 3524 | static gfc_try |
a8b3b0b6 CR |
3525 | gen_special_c_interop_ptr (int ptr_id, const char *ptr_name, |
3526 | const char *module_name) | |
3527 | { | |
3528 | gfc_symtree *tmp_symtree; | |
3529 | gfc_symbol *tmp_sym; | |
3530 | ||
3531 | tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name); | |
3532 | ||
3533 | if (tmp_symtree != NULL) | |
3534 | tmp_sym = tmp_symtree->n.sym; | |
3535 | else | |
3536 | { | |
3537 | tmp_sym = NULL; | |
3538 | gfc_internal_error ("gen_special_c_interop_ptr(): Unable to " | |
3539 | "create symbol for %s", ptr_name); | |
3540 | } | |
3541 | ||
3542 | /* Set up the symbol's important fields. Save attr required so we can | |
3543 | initialize the ptr to NULL. */ | |
ef7236d2 | 3544 | tmp_sym->attr.save = SAVE_EXPLICIT; |
a8b3b0b6 CR |
3545 | tmp_sym->ts.is_c_interop = 1; |
3546 | tmp_sym->attr.is_c_interop = 1; | |
3547 | tmp_sym->ts.is_iso_c = 1; | |
3548 | tmp_sym->ts.type = BT_DERIVED; | |
3549 | ||
3550 | /* The c_ptr and c_funptr derived types will provide the | |
3551 | definition for c_null_ptr and c_null_funptr, respectively. */ | |
3552 | if (ptr_id == ISOCBINDING_NULL_PTR) | |
3553 | tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_PTR); | |
3554 | else | |
3555 | tmp_sym->ts.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); | |
3556 | if (tmp_sym->ts.derived == NULL) | |
3557 | { | |
3558 | /* This can occur if the user forgot to declare c_ptr or | |
3559 | c_funptr and they're trying to use one of the procedures | |
3560 | that has arg(s) of the missing type. In this case, a | |
3561 | regular version of the thing should have been put in the | |
3562 | current ns. */ | |
3563 | generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR | |
3564 | ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR, | |
741ac903 | 3565 | (const char *) (ptr_id == ISOCBINDING_NULL_PTR |
a8b3b0b6 CR |
3566 | ? "_gfortran_iso_c_binding_c_ptr" |
3567 | : "_gfortran_iso_c_binding_c_funptr")); | |
3568 | ||
3569 | tmp_sym->ts.derived = | |
3570 | get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR | |
3571 | ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR); | |
3572 | } | |
3573 | ||
3574 | /* Module name is some mangled version of iso_c_binding. */ | |
3575 | tmp_sym->module = gfc_get_string (module_name); | |
3576 | ||
3577 | /* Say it's from the iso_c_binding module. */ | |
3578 | tmp_sym->attr.is_iso_c = 1; | |
3579 | ||
3580 | tmp_sym->attr.use_assoc = 1; | |
3581 | tmp_sym->attr.is_bind_c = 1; | |
3582 | /* Set the binding_label. */ | |
3583 | sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name); | |
3584 | ||
3585 | /* Set the c_address field of c_null_ptr and c_null_funptr to | |
3586 | the value of NULL. */ | |
3587 | tmp_sym->value = gfc_get_expr (); | |
3588 | tmp_sym->value->expr_type = EXPR_STRUCTURE; | |
3589 | tmp_sym->value->ts.type = BT_DERIVED; | |
3590 | tmp_sym->value->ts.derived = tmp_sym->ts.derived; | |
36dcec91 CR |
3591 | /* Create a constructor with no expr, that way we can recognize if the user |
3592 | tries to call the structure constructor for one of the iso_c_binding | |
3593 | derived types during resolution (resolve_structure_cons). */ | |
a8b3b0b6 | 3594 | tmp_sym->value->value.constructor = gfc_get_constructor (); |
a8b3b0b6 CR |
3595 | /* Must declare c_null_ptr and c_null_funptr as having the |
3596 | PARAMETER attribute so they can be used in init expressions. */ | |
3597 | tmp_sym->attr.flavor = FL_PARAMETER; | |
3598 | ||
3599 | return SUCCESS; | |
3600 | } | |
3601 | ||
3602 | ||
3603 | /* Add a formal argument, gfc_formal_arglist, to the | |
3604 | end of the given list of arguments. Set the reference to the | |
3605 | provided symbol, param_sym, in the argument. */ | |
3606 | ||
3607 | static void | |
3608 | add_formal_arg (gfc_formal_arglist **head, | |
3609 | gfc_formal_arglist **tail, | |
3610 | gfc_formal_arglist *formal_arg, | |
3611 | gfc_symbol *param_sym) | |
3612 | { | |
3613 | /* Put in list, either as first arg or at the tail (curr arg). */ | |
3614 | if (*head == NULL) | |
3615 | *head = *tail = formal_arg; | |
3616 | else | |
3617 | { | |
3618 | (*tail)->next = formal_arg; | |
3619 | (*tail) = formal_arg; | |
3620 | } | |
3621 | ||
3622 | (*tail)->sym = param_sym; | |
3623 | (*tail)->next = NULL; | |
3624 | ||
3625 | return; | |
3626 | } | |
3627 | ||
3628 | ||
3629 | /* Generates a symbol representing the CPTR argument to an | |
3630 | iso_c_binding procedure. Also, create a gfc_formal_arglist for the | |
3631 | CPTR and add it to the provided argument list. */ | |
3632 | ||
3633 | static void | |
3634 | gen_cptr_param (gfc_formal_arglist **head, | |
3635 | gfc_formal_arglist **tail, | |
3636 | const char *module_name, | |
9eb0d3d7 CR |
3637 | gfc_namespace *ns, const char *c_ptr_name, |
3638 | int iso_c_sym_id) | |
a8b3b0b6 CR |
3639 | { |
3640 | gfc_symbol *param_sym = NULL; | |
3641 | gfc_symbol *c_ptr_sym = NULL; | |
3642 | gfc_symtree *param_symtree = NULL; | |
3643 | gfc_formal_arglist *formal_arg = NULL; | |
3644 | const char *c_ptr_in; | |
9eb0d3d7 CR |
3645 | const char *c_ptr_type = NULL; |
3646 | ||
3647 | if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) | |
3648 | c_ptr_type = "_gfortran_iso_c_binding_c_funptr"; | |
9eb0d3d7 CR |
3649 | else |
3650 | c_ptr_type = "_gfortran_iso_c_binding_c_ptr"; | |
a8b3b0b6 CR |
3651 | |
3652 | if(c_ptr_name == NULL) | |
3653 | c_ptr_in = "gfc_cptr__"; | |
3654 | else | |
3655 | c_ptr_in = c_ptr_name; | |
3656 | gfc_get_sym_tree (c_ptr_in, ns, ¶m_symtree); | |
3657 | if (param_symtree != NULL) | |
3658 | param_sym = param_symtree->n.sym; | |
3659 | else | |
3660 | gfc_internal_error ("gen_cptr_param(): Unable to " | |
3661 | "create symbol for %s", c_ptr_in); | |
3662 | ||
3663 | /* Set up the appropriate fields for the new c_ptr param sym. */ | |
3664 | param_sym->refs++; | |
3665 | param_sym->attr.flavor = FL_DERIVED; | |
3666 | param_sym->ts.type = BT_DERIVED; | |
3667 | param_sym->attr.intent = INTENT_IN; | |
3668 | param_sym->attr.dummy = 1; | |
3669 | ||
3670 | /* This will pass the ptr to the iso_c routines as a (void *). */ | |
3671 | param_sym->attr.value = 1; | |
3672 | param_sym->attr.use_assoc = 1; | |
3673 | ||
9eb0d3d7 CR |
3674 | /* Get the symbol for c_ptr or c_funptr, no matter what it's name is |
3675 | (user renamed). */ | |
3676 | if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) | |
3677 | c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR); | |
3678 | else | |
aa5e22f0 | 3679 | c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR); |
a8b3b0b6 CR |
3680 | if (c_ptr_sym == NULL) |
3681 | { | |
3682 | /* This can happen if the user did not define c_ptr but they are | |
3683 | trying to use one of the iso_c_binding functions that need it. */ | |
9eb0d3d7 CR |
3684 | if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER) |
3685 | generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR, | |
741ac903 | 3686 | (const char *)c_ptr_type); |
9eb0d3d7 | 3687 | else |
aa5e22f0 | 3688 | generate_isocbinding_symbol (module_name, ISOCBINDING_PTR, |
741ac903 | 3689 | (const char *)c_ptr_type); |
a8b3b0b6 CR |
3690 | |
3691 | gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym)); | |
3692 | } | |
3693 | ||
3694 | param_sym->ts.derived = c_ptr_sym; | |
3695 | param_sym->module = gfc_get_string (module_name); | |
3696 | ||
3697 | /* Make new formal arg. */ | |
3698 | formal_arg = gfc_get_formal_arglist (); | |
3699 | /* Add arg to list of formal args (the CPTR arg). */ | |
3700 | add_formal_arg (head, tail, formal_arg, param_sym); | |
3701 | } | |
3702 | ||
3703 | ||
3704 | /* Generates a symbol representing the FPTR argument to an | |
3705 | iso_c_binding procedure. Also, create a gfc_formal_arglist for the | |
3706 | FPTR and add it to the provided argument list. */ | |
3707 | ||
3708 | static void | |
3709 | gen_fptr_param (gfc_formal_arglist **head, | |
3710 | gfc_formal_arglist **tail, | |
3711 | const char *module_name, | |
8fb74da4 | 3712 | gfc_namespace *ns, const char *f_ptr_name, int proc) |
a8b3b0b6 CR |
3713 | { |
3714 | gfc_symbol *param_sym = NULL; | |
3715 | gfc_symtree *param_symtree = NULL; | |
3716 | gfc_formal_arglist *formal_arg = NULL; | |
3717 | const char *f_ptr_out = "gfc_fptr__"; | |
3718 | ||
3719 | if (f_ptr_name != NULL) | |
3720 | f_ptr_out = f_ptr_name; | |
3721 | ||
3722 | gfc_get_sym_tree (f_ptr_out, ns, ¶m_symtree); | |
3723 | if (param_symtree != NULL) | |
3724 | param_sym = param_symtree->n.sym; | |
3725 | else | |
3726 | gfc_internal_error ("generateFPtrParam(): Unable to " | |
3727 | "create symbol for %s", f_ptr_out); | |
3728 | ||
3729 | /* Set up the necessary fields for the fptr output param sym. */ | |
3730 | param_sym->refs++; | |
8fb74da4 JW |
3731 | if (proc) |
3732 | param_sym->attr.proc_pointer = 1; | |
3733 | else | |
3734 | param_sym->attr.pointer = 1; | |
a8b3b0b6 CR |
3735 | param_sym->attr.dummy = 1; |
3736 | param_sym->attr.use_assoc = 1; | |
3737 | ||
3738 | /* ISO C Binding type to allow any pointer type as actual param. */ | |
3739 | param_sym->ts.type = BT_VOID; | |
3740 | param_sym->module = gfc_get_string (module_name); | |
3741 | ||
3742 | /* Make the arg. */ | |
3743 | formal_arg = gfc_get_formal_arglist (); | |
3744 | /* Add arg to list of formal args. */ | |
3745 | add_formal_arg (head, tail, formal_arg, param_sym); | |
3746 | } | |
3747 | ||
3748 | ||
3749 | /* Generates a symbol representing the optional SHAPE argument for the | |
3750 | iso_c_binding c_f_pointer() procedure. Also, create a | |
3751 | gfc_formal_arglist for the SHAPE and add it to the provided | |
3752 | argument list. */ | |
3753 | ||
3754 | static void | |
3755 | gen_shape_param (gfc_formal_arglist **head, | |
3756 | gfc_formal_arglist **tail, | |
3757 | const char *module_name, | |
3758 | gfc_namespace *ns, const char *shape_param_name) | |
3759 | { | |
3760 | gfc_symbol *param_sym = NULL; | |
3761 | gfc_symtree *param_symtree = NULL; | |
3762 | gfc_formal_arglist *formal_arg = NULL; | |
3763 | const char *shape_param = "gfc_shape_array__"; | |
3764 | int i; | |
3765 | ||
3766 | if (shape_param_name != NULL) | |
3767 | shape_param = shape_param_name; | |
3768 | ||
3769 | gfc_get_sym_tree (shape_param, ns, ¶m_symtree); | |
3770 | if (param_symtree != NULL) | |
3771 | param_sym = param_symtree->n.sym; | |
3772 | else | |
3773 | gfc_internal_error ("generateShapeParam(): Unable to " | |
3774 | "create symbol for %s", shape_param); | |
3775 | ||
3776 | /* Set up the necessary fields for the shape input param sym. */ | |
3777 | param_sym->refs++; | |
3778 | param_sym->attr.dummy = 1; | |
3779 | param_sym->attr.use_assoc = 1; | |
3780 | ||
d8fa96e0 CR |
3781 | /* Integer array, rank 1, describing the shape of the object. Make it's |
3782 | type BT_VOID initially so we can accept any type/kind combination of | |
3783 | integer. During gfc_iso_c_sub_interface (resolve.c), we'll make it | |
3784 | of BT_INTEGER type. */ | |
3785 | param_sym->ts.type = BT_VOID; | |
3786 | ||
1207ac67 | 3787 | /* Initialize the kind to default integer. However, it will be overridden |
6ad5cf72 CR |
3788 | during resolution to match the kind of the SHAPE parameter given as |
3789 | the actual argument (to allow for any valid integer kind). */ | |
a8b3b0b6 CR |
3790 | param_sym->ts.kind = gfc_default_integer_kind; |
3791 | param_sym->as = gfc_get_array_spec (); | |
3792 | ||
3793 | /* Clear out the dimension info for the array. */ | |
3794 | for (i = 0; i < GFC_MAX_DIMENSIONS; i++) | |
3795 | { | |
3796 | param_sym->as->lower[i] = NULL; | |
3797 | param_sym->as->upper[i] = NULL; | |
3798 | } | |
3799 | param_sym->as->rank = 1; | |
3800 | param_sym->as->lower[0] = gfc_int_expr (1); | |
3801 | ||
3802 | /* The extent is unknown until we get it. The length give us | |
3803 | the rank the incoming pointer. */ | |
3804 | param_sym->as->type = AS_ASSUMED_SHAPE; | |
3805 | ||
3806 | /* The arg is also optional; it is required iff the second arg | |
3807 | (fptr) is to an array, otherwise, it's ignored. */ | |
3808 | param_sym->attr.optional = 1; | |
3809 | param_sym->attr.intent = INTENT_IN; | |
3810 | param_sym->attr.dimension = 1; | |
3811 | param_sym->module = gfc_get_string (module_name); | |
3812 | ||
3813 | /* Make the arg. */ | |
3814 | formal_arg = gfc_get_formal_arglist (); | |
3815 | /* Add arg to list of formal args. */ | |
3816 | add_formal_arg (head, tail, formal_arg, param_sym); | |
3817 | } | |
3818 | ||
c73b6478 | 3819 | |
a8b3b0b6 CR |
3820 | /* Add a procedure interface to the given symbol (i.e., store a |
3821 | reference to the list of formal arguments). */ | |
3822 | ||
3823 | static void | |
3824 | add_proc_interface (gfc_symbol *sym, ifsrc source, | |
3825 | gfc_formal_arglist *formal) | |
3826 | { | |
3827 | ||
3828 | sym->formal = formal; | |
3829 | sym->attr.if_source = source; | |
3830 | } | |
3831 | ||
c73b6478 | 3832 | |
69773742 JW |
3833 | /* Copy the formal args from an existing symbol, src, into a new |
3834 | symbol, dest. New formal args are created, and the description of | |
3835 | each arg is set according to the existing ones. This function is | |
3836 | used when creating procedure declaration variables from a procedure | |
3837 | declaration statement (see match_proc_decl()) to create the formal | |
3838 | args based on the args of a given named interface. */ | |
3839 | ||
e7bff0d1 | 3840 | void |
c73b6478 | 3841 | gfc_copy_formal_args (gfc_symbol *dest, gfc_symbol *src) |
69773742 JW |
3842 | { |
3843 | gfc_formal_arglist *head = NULL; | |
3844 | gfc_formal_arglist *tail = NULL; | |
3845 | gfc_formal_arglist *formal_arg = NULL; | |
3846 | gfc_formal_arglist *curr_arg = NULL; | |
3847 | gfc_formal_arglist *formal_prev = NULL; | |
3848 | /* Save current namespace so we can change it for formal args. */ | |
3849 | gfc_namespace *parent_ns = gfc_current_ns; | |
3850 | ||
3851 | /* Create a new namespace, which will be the formal ns (namespace | |
3852 | of the formal args). */ | |
3853 | gfc_current_ns = gfc_get_namespace (parent_ns, 0); | |
3854 | gfc_current_ns->proc_name = dest; | |
3855 | ||
3856 | for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) | |
3857 | { | |
3858 | formal_arg = gfc_get_formal_arglist (); | |
3859 | gfc_get_symbol (curr_arg->sym->name, gfc_current_ns, &(formal_arg->sym)); | |
3860 | ||
3861 | /* May need to copy more info for the symbol. */ | |
3862 | formal_arg->sym->attr = curr_arg->sym->attr; | |
3863 | formal_arg->sym->ts = curr_arg->sym->ts; | |
e6895430 | 3864 | formal_arg->sym->as = gfc_copy_array_spec (curr_arg->sym->as); |
c73b6478 | 3865 | gfc_copy_formal_args (formal_arg->sym, curr_arg->sym); |
69773742 JW |
3866 | |
3867 | /* If this isn't the first arg, set up the next ptr. For the | |
3868 | last arg built, the formal_arg->next will never get set to | |
3869 | anything other than NULL. */ | |
3870 | if (formal_prev != NULL) | |
3871 | formal_prev->next = formal_arg; | |
3872 | else | |
3873 | formal_arg->next = NULL; | |
3874 | ||
3875 | formal_prev = formal_arg; | |
3876 | ||
3877 | /* Add arg to list of formal args. */ | |
3878 | add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); | |
3879 | } | |
3880 | ||
3881 | /* Add the interface to the symbol. */ | |
3882 | add_proc_interface (dest, IFSRC_DECL, head); | |
3883 | ||
3884 | /* Store the formal namespace information. */ | |
3afadac3 JW |
3885 | if (dest->formal != NULL) |
3886 | /* The current ns should be that for the dest proc. */ | |
3887 | dest->formal_ns = gfc_current_ns; | |
3888 | /* Restore the current namespace to what it was on entry. */ | |
3889 | gfc_current_ns = parent_ns; | |
3890 | } | |
3891 | ||
c73b6478 | 3892 | |
3afadac3 | 3893 | void |
c73b6478 | 3894 | gfc_copy_formal_args_intr (gfc_symbol *dest, gfc_intrinsic_sym *src) |
3afadac3 JW |
3895 | { |
3896 | gfc_formal_arglist *head = NULL; | |
3897 | gfc_formal_arglist *tail = NULL; | |
3898 | gfc_formal_arglist *formal_arg = NULL; | |
3899 | gfc_intrinsic_arg *curr_arg = NULL; | |
3900 | gfc_formal_arglist *formal_prev = NULL; | |
3901 | /* Save current namespace so we can change it for formal args. */ | |
3902 | gfc_namespace *parent_ns = gfc_current_ns; | |
3903 | ||
3904 | /* Create a new namespace, which will be the formal ns (namespace | |
3905 | of the formal args). */ | |
3906 | gfc_current_ns = gfc_get_namespace (parent_ns, 0); | |
3907 | gfc_current_ns->proc_name = dest; | |
3908 | ||
3909 | for (curr_arg = src->formal; curr_arg; curr_arg = curr_arg->next) | |
3910 | { | |
3911 | formal_arg = gfc_get_formal_arglist (); | |
3912 | gfc_get_symbol (curr_arg->name, gfc_current_ns, &(formal_arg->sym)); | |
3913 | ||
3914 | /* May need to copy more info for the symbol. */ | |
3915 | formal_arg->sym->ts = curr_arg->ts; | |
3916 | formal_arg->sym->attr.optional = curr_arg->optional; | |
87526ff1 JW |
3917 | formal_arg->sym->attr.flavor = FL_VARIABLE; |
3918 | formal_arg->sym->attr.dummy = 1; | |
3afadac3 JW |
3919 | |
3920 | /* If this isn't the first arg, set up the next ptr. For the | |
3921 | last arg built, the formal_arg->next will never get set to | |
3922 | anything other than NULL. */ | |
3923 | if (formal_prev != NULL) | |
3924 | formal_prev->next = formal_arg; | |
3925 | else | |
3926 | formal_arg->next = NULL; | |
3927 | ||
3928 | formal_prev = formal_arg; | |
3929 | ||
3930 | /* Add arg to list of formal args. */ | |
3931 | add_formal_arg (&head, &tail, formal_arg, formal_arg->sym); | |
3932 | } | |
3933 | ||
3934 | /* Add the interface to the symbol. */ | |
3935 | add_proc_interface (dest, IFSRC_DECL, head); | |
3936 | ||
3937 | /* Store the formal namespace information. */ | |
69773742 JW |
3938 | if (dest->formal != NULL) |
3939 | /* The current ns should be that for the dest proc. */ | |
3940 | dest->formal_ns = gfc_current_ns; | |
3941 | /* Restore the current namespace to what it was on entry. */ | |
3942 | gfc_current_ns = parent_ns; | |
3943 | } | |
a8b3b0b6 | 3944 | |
c73b6478 | 3945 | |
a8b3b0b6 CR |
3946 | /* Builds the parameter list for the iso_c_binding procedure |
3947 | c_f_pointer or c_f_procpointer. The old_sym typically refers to a | |
3948 | generic version of either the c_f_pointer or c_f_procpointer | |
3949 | functions. The new_proc_sym represents a "resolved" version of the | |
3950 | symbol. The functions are resolved to match the types of their | |
3951 | parameters; for example, c_f_pointer(cptr, fptr) would resolve to | |
3952 | something similar to c_f_pointer_i4 if the type of data object fptr | |
3953 | pointed to was a default integer. The actual name of the resolved | |
3954 | procedure symbol is further mangled with the module name, etc., but | |
3955 | the idea holds true. */ | |
3956 | ||
3957 | static void | |
3958 | build_formal_args (gfc_symbol *new_proc_sym, | |
3959 | gfc_symbol *old_sym, int add_optional_arg) | |
3960 | { | |
3961 | gfc_formal_arglist *head = NULL, *tail = NULL; | |
3962 | gfc_namespace *parent_ns = NULL; | |
3963 | ||
3964 | parent_ns = gfc_current_ns; | |
3965 | /* Create a new namespace, which will be the formal ns (namespace | |
3966 | of the formal args). */ | |
3967 | gfc_current_ns = gfc_get_namespace(parent_ns, 0); | |
3968 | gfc_current_ns->proc_name = new_proc_sym; | |
3969 | ||
3970 | /* Generate the params. */ | |
8fb74da4 | 3971 | if (old_sym->intmod_sym_id == ISOCBINDING_F_PROCPOINTER) |
a8b3b0b6 CR |
3972 | { |
3973 | gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, | |
9eb0d3d7 | 3974 | gfc_current_ns, "cptr", old_sym->intmod_sym_id); |
a8b3b0b6 | 3975 | gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module, |
8fb74da4 JW |
3976 | gfc_current_ns, "fptr", 1); |
3977 | } | |
3978 | else if (old_sym->intmod_sym_id == ISOCBINDING_F_POINTER) | |
3979 | { | |
3980 | gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, | |
3981 | gfc_current_ns, "cptr", old_sym->intmod_sym_id); | |
3982 | gen_fptr_param (&head, &tail, (const char *) new_proc_sym->module, | |
3983 | gfc_current_ns, "fptr", 0); | |
a8b3b0b6 | 3984 | /* If we're dealing with c_f_pointer, it has an optional third arg. */ |
8fb74da4 JW |
3985 | gen_shape_param (&head, &tail,(const char *) new_proc_sym->module, |
3986 | gfc_current_ns, "shape"); | |
3987 | ||
a8b3b0b6 CR |
3988 | } |
3989 | else if (old_sym->intmod_sym_id == ISOCBINDING_ASSOCIATED) | |
3990 | { | |
3991 | /* c_associated has one required arg and one optional; both | |
3992 | are c_ptrs. */ | |
3993 | gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, | |
9eb0d3d7 | 3994 | gfc_current_ns, "c_ptr_1", ISOCBINDING_ASSOCIATED); |
a8b3b0b6 CR |
3995 | if (add_optional_arg) |
3996 | { | |
3997 | gen_cptr_param (&head, &tail, (const char *) new_proc_sym->module, | |
9eb0d3d7 | 3998 | gfc_current_ns, "c_ptr_2", ISOCBINDING_ASSOCIATED); |
a8b3b0b6 CR |
3999 | /* The last param is optional so mark it as such. */ |
4000 | tail->sym->attr.optional = 1; | |
4001 | } | |
4002 | } | |
4003 | ||
4004 | /* Add the interface (store formal args to new_proc_sym). */ | |
4005 | add_proc_interface (new_proc_sym, IFSRC_DECL, head); | |
4006 | ||
4007 | /* Set up the formal_ns pointer to the one created for the | |
4008 | new procedure so it'll get cleaned up during gfc_free_symbol(). */ | |
4009 | new_proc_sym->formal_ns = gfc_current_ns; | |
4010 | ||
4011 | gfc_current_ns = parent_ns; | |
4012 | } | |
4013 | ||
05e73743 SL |
4014 | static int |
4015 | std_for_isocbinding_symbol (int id) | |
4016 | { | |
4017 | switch (id) | |
4018 | { | |
4019 | #define NAMED_INTCST(a,b,c,d) \ | |
4020 | case a:\ | |
4021 | return d; | |
4022 | #include "iso-c-binding.def" | |
4023 | #undef NAMED_INTCST | |
4024 | default: | |
4025 | return GFC_STD_F2003; | |
4026 | } | |
4027 | } | |
a8b3b0b6 CR |
4028 | |
4029 | /* Generate the given set of C interoperable kind objects, or all | |
4030 | interoperable kinds. This function will only be given kind objects | |
4031 | for valid iso_c_binding defined types because this is verified when | |
4032 | the 'use' statement is parsed. If the user gives an 'only' clause, | |
4033 | the specific kinds are looked up; if they don't exist, an error is | |
4034 | reported. If the user does not give an 'only' clause, all | |
4035 | iso_c_binding symbols are generated. If a list of specific kinds | |
4036 | is given, it must have a NULL in the first empty spot to mark the | |
4037 | end of the list. */ | |
4038 | ||
4039 | ||
4040 | void | |
4041 | generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, | |
741ac903 | 4042 | const char *local_name) |
a8b3b0b6 | 4043 | { |
741ac903 | 4044 | const char *const name = (local_name && local_name[0]) ? local_name |
a8b3b0b6 CR |
4045 | : c_interop_kinds_table[s].name; |
4046 | gfc_symtree *tmp_symtree = NULL; | |
4047 | gfc_symbol *tmp_sym = NULL; | |
4048 | gfc_dt_list **dt_list_ptr = NULL; | |
4049 | gfc_component *tmp_comp = NULL; | |
4050 | char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1]; | |
4051 | int index; | |
4052 | ||
e0c68ce9 | 4053 | if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR) |
05e73743 | 4054 | return; |
a8b3b0b6 CR |
4055 | tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name); |
4056 | ||
4057 | /* Already exists in this scope so don't re-add it. | |
4058 | TODO: we should probably check that it's really the same symbol. */ | |
4059 | if (tmp_symtree != NULL) | |
4060 | return; | |
4061 | ||
4062 | /* Create the sym tree in the current ns. */ | |
4063 | gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree); | |
4064 | if (tmp_symtree) | |
4065 | tmp_sym = tmp_symtree->n.sym; | |
4066 | else | |
4067 | gfc_internal_error ("generate_isocbinding_symbol(): Unable to " | |
4068 | "create symbol"); | |
4069 | ||
4070 | /* Say what module this symbol belongs to. */ | |
4071 | tmp_sym->module = gfc_get_string (mod_name); | |
4072 | tmp_sym->from_intmod = INTMOD_ISO_C_BINDING; | |
4073 | tmp_sym->intmod_sym_id = s; | |
4074 | ||
4075 | switch (s) | |
4076 | { | |
4077 | ||
05e73743 | 4078 | #define NAMED_INTCST(a,b,c,d) case a : |
a8b3b0b6 CR |
4079 | #define NAMED_REALCST(a,b,c) case a : |
4080 | #define NAMED_CMPXCST(a,b,c) case a : | |
4081 | #define NAMED_LOGCST(a,b,c) case a : | |
4082 | #define NAMED_CHARKNDCST(a,b,c) case a : | |
4083 | #include "iso-c-binding.def" | |
4084 | ||
4085 | tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value); | |
4086 | ||
4087 | /* Initialize an integer constant expression node. */ | |
4088 | tmp_sym->attr.flavor = FL_PARAMETER; | |
4089 | tmp_sym->ts.type = BT_INTEGER; | |
4090 | tmp_sym->ts.kind = gfc_default_integer_kind; | |
4091 | ||
4092 | /* Mark this type as a C interoperable one. */ | |
4093 | tmp_sym->ts.is_c_interop = 1; | |
4094 | tmp_sym->ts.is_iso_c = 1; | |
4095 | tmp_sym->value->ts.is_c_interop = 1; | |
4096 | tmp_sym->value->ts.is_iso_c = 1; | |
4097 | tmp_sym->attr.is_c_interop = 1; | |
4098 | ||
4099 | /* Tell what f90 type this c interop kind is valid. */ | |
4100 | tmp_sym->ts.f90_type = c_interop_kinds_table[s].f90_type; | |
4101 | ||
4102 | /* Say it's from the iso_c_binding module. */ | |
4103 | tmp_sym->attr.is_iso_c = 1; | |
4104 | ||
4105 | /* Make it use associated. */ | |
4106 | tmp_sym->attr.use_assoc = 1; | |
4107 | break; | |
4108 | ||
4109 | ||
4110 | #define NAMED_CHARCST(a,b,c) case a : | |
4111 | #include "iso-c-binding.def" | |
4112 | ||
4113 | /* Initialize an integer constant expression node for the | |
4114 | length of the character. */ | |
4115 | tmp_sym->value = gfc_get_expr (); | |
4116 | tmp_sym->value->expr_type = EXPR_CONSTANT; | |
4117 | tmp_sym->value->ts.type = BT_CHARACTER; | |
4118 | tmp_sym->value->ts.kind = gfc_default_character_kind; | |
4119 | tmp_sym->value->where = gfc_current_locus; | |
4120 | tmp_sym->value->ts.is_c_interop = 1; | |
4121 | tmp_sym->value->ts.is_iso_c = 1; | |
4122 | tmp_sym->value->value.character.length = 1; | |
00660189 | 4123 | tmp_sym->value->value.character.string = gfc_get_wide_string (2); |
a8b3b0b6 | 4124 | tmp_sym->value->value.character.string[0] |
00660189 | 4125 | = (gfc_char_t) c_interop_kinds_table[s].value; |
a8b3b0b6 | 4126 | tmp_sym->value->value.character.string[1] = '\0'; |
19cfe6c0 TB |
4127 | tmp_sym->ts.cl = gfc_get_charlen (); |
4128 | tmp_sym->ts.cl->length = gfc_int_expr (1); | |
a8b3b0b6 CR |
4129 | |
4130 | /* May not need this in both attr and ts, but do need in | |
4131 | attr for writing module file. */ | |
4132 | tmp_sym->attr.is_c_interop = 1; | |
4133 | ||
4134 | tmp_sym->attr.flavor = FL_PARAMETER; | |
4135 | tmp_sym->ts.type = BT_CHARACTER; | |
4136 | ||
4137 | /* Need to set it to the C_CHAR kind. */ | |
4138 | tmp_sym->ts.kind = gfc_default_character_kind; | |
4139 | ||
4140 | /* Mark this type as a C interoperable one. */ | |
4141 | tmp_sym->ts.is_c_interop = 1; | |
4142 | tmp_sym->ts.is_iso_c = 1; | |
4143 | ||
4144 | /* Tell what f90 type this c interop kind is valid. */ | |
4145 | tmp_sym->ts.f90_type = BT_CHARACTER; | |
4146 | ||
4147 | /* Say it's from the iso_c_binding module. */ | |
4148 | tmp_sym->attr.is_iso_c = 1; | |
4149 | ||
4150 | /* Make it use associated. */ | |
4151 | tmp_sym->attr.use_assoc = 1; | |
4152 | break; | |
4153 | ||
4154 | case ISOCBINDING_PTR: | |
4155 | case ISOCBINDING_FUNPTR: | |
4156 | ||
4157 | /* Initialize an integer constant expression node. */ | |
4158 | tmp_sym->attr.flavor = FL_DERIVED; | |
4159 | tmp_sym->ts.is_c_interop = 1; | |
4160 | tmp_sym->attr.is_c_interop = 1; | |
4161 | tmp_sym->attr.is_iso_c = 1; | |
4162 | tmp_sym->ts.is_iso_c = 1; | |
4163 | tmp_sym->ts.type = BT_DERIVED; | |
4164 | ||
4165 | /* A derived type must have the bind attribute to be | |
4166 | interoperable (J3/04-007, Section 15.2.3), even though | |
4167 | the binding label is not used. */ | |
4168 | tmp_sym->attr.is_bind_c = 1; | |
4169 | ||
4170 | tmp_sym->attr.referenced = 1; | |
4171 | ||
4172 | tmp_sym->ts.derived = tmp_sym; | |
4173 | ||
4174 | /* Add the symbol created for the derived type to the current ns. */ | |
4175 | dt_list_ptr = &(gfc_derived_types); | |
4176 | while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL) | |
4177 | dt_list_ptr = &((*dt_list_ptr)->next); | |
4178 | ||
4179 | /* There is already at least one derived type in the list, so append | |
4180 | the one we're currently building for c_ptr or c_funptr. */ | |
4181 | if (*dt_list_ptr != NULL) | |
4182 | dt_list_ptr = &((*dt_list_ptr)->next); | |
4183 | (*dt_list_ptr) = gfc_get_dt_list (); | |
4184 | (*dt_list_ptr)->derived = tmp_sym; | |
4185 | (*dt_list_ptr)->next = NULL; | |
4186 | ||
4187 | /* Set up the component of the derived type, which will be | |
4188 | an integer with kind equal to c_ptr_size. Mangle the name of | |
4189 | the field for the c_address to prevent the curious user from | |
4190 | trying to access it from Fortran. */ | |
4191 | sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address"); | |
4192 | gfc_add_component (tmp_sym, comp_name, &tmp_comp); | |
4193 | if (tmp_comp == NULL) | |
4194 | gfc_internal_error ("generate_isocbinding_symbol(): Unable to " | |
4195 | "create component for c_address"); | |
4196 | ||
4197 | tmp_comp->ts.type = BT_INTEGER; | |
4198 | ||
4199 | /* Set this because the module will need to read/write this field. */ | |
4200 | tmp_comp->ts.f90_type = BT_INTEGER; | |
4201 | ||
4202 | /* The kinds for c_ptr and c_funptr are the same. */ | |
4203 | index = get_c_kind ("c_ptr", c_interop_kinds_table); | |
4204 | tmp_comp->ts.kind = c_interop_kinds_table[index].value; | |
4205 | ||
d4b7d0f0 JW |
4206 | tmp_comp->attr.pointer = 0; |
4207 | tmp_comp->attr.dimension = 0; | |
a8b3b0b6 CR |
4208 | |
4209 | /* Mark the component as C interoperable. */ | |
4210 | tmp_comp->ts.is_c_interop = 1; | |
4211 | ||
4212 | /* Make it use associated (iso_c_binding module). */ | |
4213 | tmp_sym->attr.use_assoc = 1; | |
4214 | break; | |
4215 | ||
4216 | case ISOCBINDING_NULL_PTR: | |
4217 | case ISOCBINDING_NULL_FUNPTR: | |
4218 | gen_special_c_interop_ptr (s, name, mod_name); | |
4219 | break; | |
4220 | ||
4221 | case ISOCBINDING_F_POINTER: | |
4222 | case ISOCBINDING_ASSOCIATED: | |
4223 | case ISOCBINDING_LOC: | |
4224 | case ISOCBINDING_FUNLOC: | |
4225 | case ISOCBINDING_F_PROCPOINTER: | |
4226 | ||
4227 | tmp_sym->attr.proc = PROC_MODULE; | |
4228 | ||
4229 | /* Use the procedure's name as it is in the iso_c_binding module for | |
4230 | setting the binding label in case the user renamed the symbol. */ | |
4231 | sprintf (tmp_sym->binding_label, "%s_%s", mod_name, | |
4232 | c_interop_kinds_table[s].name); | |
4233 | tmp_sym->attr.is_iso_c = 1; | |
4234 | if (s == ISOCBINDING_F_POINTER || s == ISOCBINDING_F_PROCPOINTER) | |
4235 | tmp_sym->attr.subroutine = 1; | |
4236 | else | |
4237 | { | |
4238 | /* TODO! This needs to be finished more for the expr of the | |
4239 | function or something! | |
4240 | This may not need to be here, because trying to do c_loc | |
4241 | as an external. */ | |
4242 | if (s == ISOCBINDING_ASSOCIATED) | |
4243 | { | |
4244 | tmp_sym->attr.function = 1; | |
4245 | tmp_sym->ts.type = BT_LOGICAL; | |
4246 | tmp_sym->ts.kind = gfc_default_logical_kind; | |
4247 | tmp_sym->result = tmp_sym; | |
4248 | } | |
4249 | else | |
4250 | { | |
4251 | /* Here, we're taking the simple approach. We're defining | |
4252 | c_loc as an external identifier so the compiler will put | |
4253 | what we expect on the stack for the address we want the | |
4254 | C address of. */ | |
4255 | tmp_sym->ts.type = BT_DERIVED; | |
4256 | if (s == ISOCBINDING_LOC) | |
4257 | tmp_sym->ts.derived = | |
4258 | get_iso_c_binding_dt (ISOCBINDING_PTR); | |
4259 | else | |
4260 | tmp_sym->ts.derived = | |
4261 | get_iso_c_binding_dt (ISOCBINDING_FUNPTR); | |
4262 | ||
4263 | if (tmp_sym->ts.derived == NULL) | |
4264 | { | |
4265 | /* Create the necessary derived type so we can continue | |
4266 | processing the file. */ | |
4267 | generate_isocbinding_symbol | |
21a77227 CR |
4268 | (mod_name, s == ISOCBINDING_FUNLOC |
4269 | ? ISOCBINDING_FUNPTR : ISOCBINDING_PTR, | |
741ac903 | 4270 | (const char *)(s == ISOCBINDING_FUNLOC |
a8b3b0b6 CR |
4271 | ? "_gfortran_iso_c_binding_c_funptr" |
4272 | : "_gfortran_iso_c_binding_c_ptr")); | |
4273 | tmp_sym->ts.derived = | |
4274 | get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC | |
4275 | ? ISOCBINDING_FUNPTR | |
4276 | : ISOCBINDING_PTR); | |
4277 | } | |
4278 | ||
4279 | /* The function result is itself (no result clause). */ | |
4280 | tmp_sym->result = tmp_sym; | |
4281 | tmp_sym->attr.external = 1; | |
4282 | tmp_sym->attr.use_assoc = 0; | |
a9c5fe7e | 4283 | tmp_sym->attr.pure = 1; |
a8b3b0b6 CR |
4284 | tmp_sym->attr.if_source = IFSRC_UNKNOWN; |
4285 | tmp_sym->attr.proc = PROC_UNKNOWN; | |
4286 | } | |
4287 | } | |
4288 | ||
4289 | tmp_sym->attr.flavor = FL_PROCEDURE; | |
4290 | tmp_sym->attr.contained = 0; | |
4291 | ||
4292 | /* Try using this builder routine, with the new and old symbols | |
4293 | both being the generic iso_c proc sym being created. This | |
4294 | will create the formal args (and the new namespace for them). | |
4295 | Don't build an arg list for c_loc because we're going to treat | |
4296 | c_loc as an external procedure. */ | |
4297 | if (s != ISOCBINDING_LOC && s != ISOCBINDING_FUNLOC) | |
4298 | /* The 1 says to add any optional args, if applicable. */ | |
4299 | build_formal_args (tmp_sym, tmp_sym, 1); | |
4300 | ||
4301 | /* Set this after setting up the symbol, to prevent error messages. */ | |
4302 | tmp_sym->attr.use_assoc = 1; | |
4303 | ||
4304 | /* This symbol will not be referenced directly. It will be | |
4305 | resolved to the implementation for the given f90 kind. */ | |
4306 | tmp_sym->attr.referenced = 0; | |
4307 | ||
4308 | break; | |
4309 | ||
4310 | default: | |
4311 | gcc_unreachable (); | |
4312 | } | |
4313 | } | |
4314 | ||
4315 | ||
4316 | /* Creates a new symbol based off of an old iso_c symbol, with a new | |
4317 | binding label. This function can be used to create a new, | |
4318 | resolved, version of a procedure symbol for c_f_pointer or | |
4319 | c_f_procpointer that is based on the generic symbols. A new | |
4320 | parameter list is created for the new symbol using | |
4321 | build_formal_args(). The add_optional_flag specifies whether the | |
4322 | to add the optional SHAPE argument. The new symbol is | |
4323 | returned. */ | |
4324 | ||
4325 | gfc_symbol * | |
4326 | get_iso_c_sym (gfc_symbol *old_sym, char *new_name, | |
4327 | char *new_binding_label, int add_optional_arg) | |
4328 | { | |
4329 | gfc_symtree *new_symtree = NULL; | |
4330 | ||
4331 | /* See if we have a symbol by that name already available, looking | |
4332 | through any parent namespaces. */ | |
4333 | gfc_find_sym_tree (new_name, gfc_current_ns, 1, &new_symtree); | |
4334 | if (new_symtree != NULL) | |
4335 | /* Return the existing symbol. */ | |
4336 | return new_symtree->n.sym; | |
4337 | ||
4338 | /* Create the symtree/symbol, with attempted host association. */ | |
4339 | gfc_get_ha_sym_tree (new_name, &new_symtree); | |
4340 | if (new_symtree == NULL) | |
4341 | gfc_internal_error ("get_iso_c_sym(): Unable to create " | |
4342 | "symtree for '%s'", new_name); | |
4343 | ||
4344 | /* Now fill in the fields of the resolved symbol with the old sym. */ | |
4345 | strcpy (new_symtree->n.sym->binding_label, new_binding_label); | |
4346 | new_symtree->n.sym->attr = old_sym->attr; | |
4347 | new_symtree->n.sym->ts = old_sym->ts; | |
4348 | new_symtree->n.sym->module = gfc_get_string (old_sym->module); | |
9fd25b5c CR |
4349 | new_symtree->n.sym->from_intmod = old_sym->from_intmod; |
4350 | new_symtree->n.sym->intmod_sym_id = old_sym->intmod_sym_id; | |
a8b3b0b6 CR |
4351 | /* Build the formal arg list. */ |
4352 | build_formal_args (new_symtree->n.sym, old_sym, add_optional_arg); | |
4353 | ||
4354 | gfc_commit_symbol (new_symtree->n.sym); | |
4355 | ||
4356 | return new_symtree->n.sym; | |
4357 | } | |
4358 | ||
f37e928c DK |
4359 | |
4360 | /* Check that a symbol is already typed. If strict is not set, an untyped | |
4361 | symbol is acceptable for non-standard-conforming mode. */ | |
4362 | ||
4363 | gfc_try | |
4364 | gfc_check_symbol_typed (gfc_symbol* sym, gfc_namespace* ns, | |
4365 | bool strict, locus where) | |
4366 | { | |
4367 | gcc_assert (sym); | |
4368 | ||
3df684e2 | 4369 | if (gfc_matching_prefix) |
f37e928c DK |
4370 | return SUCCESS; |
4371 | ||
4372 | /* Check for the type and try to give it an implicit one. */ | |
4373 | if (sym->ts.type == BT_UNKNOWN | |
4374 | && gfc_set_default_type (sym, 0, ns) == FAILURE) | |
4375 | { | |
4376 | if (strict) | |
4377 | { | |
4378 | gfc_error ("Symbol '%s' is used before it is typed at %L", | |
4379 | sym->name, &where); | |
4380 | return FAILURE; | |
4381 | } | |
4382 | ||
4383 | if (gfc_notify_std (GFC_STD_GNU, | |
4384 | "Extension: Symbol '%s' is used before" | |
4385 | " it is typed at %L", sym->name, &where) == FAILURE) | |
4386 | return FAILURE; | |
4387 | } | |
4388 | ||
4389 | /* Everything is ok. */ | |
4390 | return SUCCESS; | |
4391 | } | |
30b608eb DK |
4392 | |
4393 | ||
e34ccb4c DK |
4394 | /* Construct a typebound-procedure structure. Those are stored in a tentative |
4395 | list and marked `error' until symbols are committed. */ | |
4396 | ||
4397 | gfc_typebound_proc* | |
4398 | gfc_get_typebound_proc (void) | |
4399 | { | |
4400 | gfc_typebound_proc *result; | |
4401 | tentative_tbp *list_node; | |
4402 | ||
4403 | result = XCNEW (gfc_typebound_proc); | |
4404 | result->error = 1; | |
4405 | ||
4406 | list_node = XCNEW (tentative_tbp); | |
4407 | list_node->next = tentative_tbp_list; | |
4408 | list_node->proc = result; | |
4409 | tentative_tbp_list = list_node; | |
4410 | ||
4411 | return result; | |
4412 | } | |
4413 | ||
4414 | ||
30b608eb DK |
4415 | /* Get the super-type of a given derived type. */ |
4416 | ||
4417 | gfc_symbol* | |
4418 | gfc_get_derived_super_type (gfc_symbol* derived) | |
4419 | { | |
4420 | if (!derived->attr.extension) | |
4421 | return NULL; | |
4422 | ||
4423 | gcc_assert (derived->components); | |
4424 | gcc_assert (derived->components->ts.type == BT_DERIVED); | |
4425 | gcc_assert (derived->components->ts.derived); | |
4426 | ||
4427 | return derived->components->ts.derived; | |
4428 | } | |
4429 | ||
4430 | ||
4431 | /* Find a type-bound procedure by name for a derived-type (looking recursively | |
4432 | through the super-types). */ | |
4433 | ||
4434 | gfc_symtree* | |
8e1f752a DK |
4435 | gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t, |
4436 | const char* name, bool noaccess) | |
30b608eb DK |
4437 | { |
4438 | gfc_symtree* res; | |
4439 | ||
8e1f752a DK |
4440 | /* Set default to failure. */ |
4441 | if (t) | |
4442 | *t = FAILURE; | |
4443 | ||
30b608eb DK |
4444 | /* Try to find it in the current type's namespace. */ |
4445 | gcc_assert (derived->f2k_derived); | |
e34ccb4c DK |
4446 | res = gfc_find_symtree (derived->f2k_derived->tb_sym_root, name); |
4447 | if (res && res->n.tb) | |
8e1f752a | 4448 | { |
8e1f752a DK |
4449 | /* We found one. */ |
4450 | if (t) | |
4451 | *t = SUCCESS; | |
4452 | ||
4453 | if (!noaccess && derived->attr.use_assoc | |
e34ccb4c | 4454 | && res->n.tb->access == ACCESS_PRIVATE) |
8e1f752a DK |
4455 | { |
4456 | gfc_error ("'%s' of '%s' is PRIVATE at %C", name, derived->name); | |
4457 | if (t) | |
4458 | *t = FAILURE; | |
4459 | } | |
4460 | ||
4461 | return res; | |
4462 | } | |
30b608eb DK |
4463 | |
4464 | /* Otherwise, recurse on parent type if derived is an extension. */ | |
4465 | if (derived->attr.extension) | |
4466 | { | |
4467 | gfc_symbol* super_type; | |
4468 | super_type = gfc_get_derived_super_type (derived); | |
4469 | gcc_assert (super_type); | |
8e1f752a | 4470 | return gfc_find_typebound_proc (super_type, t, name, noaccess); |
30b608eb DK |
4471 | } |
4472 | ||
4473 | /* Nothing found. */ | |
4474 | return NULL; | |
4475 | } | |
e34ccb4c DK |
4476 | |
4477 | ||
4478 | /* Get a typebound-procedure symtree or create and insert it if not yet | |
4479 | present. This is like a very simplified version of gfc_get_sym_tree for | |
4480 | tbp-symtrees rather than regular ones. */ | |
4481 | ||
4482 | gfc_symtree* | |
4483 | gfc_get_tbp_symtree (gfc_symtree **root, const char *name) | |
4484 | { | |
4485 | gfc_symtree *result; | |
4486 | ||
4487 | result = gfc_find_symtree (*root, name); | |
4488 | if (!result) | |
4489 | { | |
4490 | result = gfc_new_symtree (root, name); | |
4491 | gcc_assert (result); | |
4492 | result->n.tb = NULL; | |
4493 | } | |
4494 | ||
4495 | return result; | |
4496 | } |