]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Maintain binary trees of symbols. |
ec378180 | 2 | Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, |
ef558756 | 3 | 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 | |
10 | Software Foundation; either version 2, or (at your option) any later | |
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 | |
9fc4d79b | 19 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
20 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
21 | 02110-1301, USA. */ | |
6de9cd9a DN |
22 | |
23 | ||
24 | #include "config.h" | |
d22e4895 | 25 | #include "system.h" |
6de9cd9a DN |
26 | #include "gfortran.h" |
27 | #include "parse.h" | |
28 | ||
29 | /* Strings for all symbol attributes. We use these for dumping the | |
30 | parse tree, in error messages, and also when reading and writing | |
31 | modules. */ | |
32 | ||
33 | const mstring flavors[] = | |
34 | { | |
35 | minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM), | |
36 | minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE), | |
37 | minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER), | |
38 | minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE), | |
39 | minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST), | |
40 | minit (NULL, -1) | |
41 | }; | |
42 | ||
43 | const mstring procedures[] = | |
44 | { | |
45 | minit ("UNKNOWN-PROC", PROC_UNKNOWN), | |
46 | minit ("MODULE-PROC", PROC_MODULE), | |
47 | minit ("INTERNAL-PROC", PROC_INTERNAL), | |
48 | minit ("DUMMY-PROC", PROC_DUMMY), | |
49 | minit ("INTRINSIC-PROC", PROC_INTRINSIC), | |
50 | minit ("EXTERNAL-PROC", PROC_EXTERNAL), | |
51 | minit ("STATEMENT-PROC", PROC_ST_FUNCTION), | |
52 | minit (NULL, -1) | |
53 | }; | |
54 | ||
55 | const mstring intents[] = | |
56 | { | |
57 | minit ("UNKNOWN-INTENT", INTENT_UNKNOWN), | |
58 | minit ("IN", INTENT_IN), | |
59 | minit ("OUT", INTENT_OUT), | |
60 | minit ("INOUT", INTENT_INOUT), | |
61 | minit (NULL, -1) | |
62 | }; | |
63 | ||
64 | const mstring access_types[] = | |
65 | { | |
66 | minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN), | |
67 | minit ("PUBLIC", ACCESS_PUBLIC), | |
68 | minit ("PRIVATE", ACCESS_PRIVATE), | |
69 | minit (NULL, -1) | |
70 | }; | |
71 | ||
72 | const mstring ifsrc_types[] = | |
73 | { | |
74 | minit ("UNKNOWN", IFSRC_UNKNOWN), | |
75 | minit ("DECL", IFSRC_DECL), | |
76 | minit ("BODY", IFSRC_IFBODY), | |
77 | minit ("USAGE", IFSRC_USAGE) | |
78 | }; | |
79 | ||
80 | ||
81 | /* This is to make sure the backend generates setup code in the correct | |
82 | order. */ | |
83 | ||
84 | static int next_dummy_order = 1; | |
85 | ||
86 | ||
87 | gfc_namespace *gfc_current_ns; | |
88 | ||
c9543002 TS |
89 | gfc_gsymbol *gfc_gsym_root = NULL; |
90 | ||
6de9cd9a DN |
91 | static gfc_symbol *changed_syms = NULL; |
92 | ||
93 | ||
94 | /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/ | |
95 | ||
1107b970 PB |
96 | /* The following static variable indicates whether a particular element has |
97 | been explicitly set or not. */ | |
6de9cd9a | 98 | |
6de9cd9a DN |
99 | static int new_flag[GFC_LETTERS]; |
100 | ||
101 | ||
102 | /* Handle a correctly parsed IMPLICIT NONE. */ | |
103 | ||
104 | void | |
105 | gfc_set_implicit_none (void) | |
106 | { | |
107 | int i; | |
108 | ||
438e1428 TS |
109 | if (gfc_current_ns->seen_implicit_none) |
110 | { | |
111 | gfc_error ("Duplicate IMPLICIT NONE statement at %C"); | |
112 | return; | |
113 | } | |
114 | ||
115 | gfc_current_ns->seen_implicit_none = 1; | |
116 | ||
1107b970 | 117 | for (i = 0; i < GFC_LETTERS; i++) |
6de9cd9a | 118 | { |
1107b970 PB |
119 | gfc_clear_ts (&gfc_current_ns->default_type[i]); |
120 | gfc_current_ns->set_flag[i] = 1; | |
6de9cd9a DN |
121 | } |
122 | } | |
123 | ||
124 | ||
1107b970 | 125 | /* Reset the implicit range flags. */ |
6de9cd9a DN |
126 | |
127 | void | |
1107b970 | 128 | gfc_clear_new_implicit (void) |
6de9cd9a DN |
129 | { |
130 | int i; | |
131 | ||
132 | for (i = 0; i < GFC_LETTERS; i++) | |
1107b970 | 133 | new_flag[i] = 0; |
6de9cd9a DN |
134 | } |
135 | ||
136 | ||
1107b970 | 137 | /* Prepare for a new implicit range. Sets flags in new_flag[]. */ |
6de9cd9a | 138 | |
1107b970 PB |
139 | try |
140 | gfc_add_new_implicit_range (int c1, int c2) | |
6de9cd9a DN |
141 | { |
142 | int i; | |
143 | ||
144 | c1 -= 'a'; | |
145 | c2 -= 'a'; | |
146 | ||
147 | for (i = c1; i <= c2; i++) | |
148 | { | |
149 | if (new_flag[i]) | |
150 | { | |
151 | gfc_error ("Letter '%c' already set in IMPLICIT statement at %C", | |
152 | i + 'A'); | |
153 | return FAILURE; | |
154 | } | |
155 | ||
6de9cd9a DN |
156 | new_flag[i] = 1; |
157 | } | |
158 | ||
159 | return SUCCESS; | |
160 | } | |
161 | ||
162 | ||
1107b970 PB |
163 | /* Add a matched implicit range for gfc_set_implicit(). Check if merging |
164 | the new implicit types back into the existing types will work. */ | |
6de9cd9a DN |
165 | |
166 | try | |
1107b970 | 167 | gfc_merge_new_implicit (gfc_typespec * ts) |
6de9cd9a DN |
168 | { |
169 | int i; | |
170 | ||
438e1428 TS |
171 | if (gfc_current_ns->seen_implicit_none) |
172 | { | |
173 | gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE"); | |
174 | return FAILURE; | |
175 | } | |
176 | ||
6de9cd9a | 177 | for (i = 0; i < GFC_LETTERS; i++) |
1107b970 PB |
178 | { |
179 | if (new_flag[i]) | |
180 | { | |
6de9cd9a | 181 | |
1107b970 PB |
182 | if (gfc_current_ns->set_flag[i]) |
183 | { | |
184 | gfc_error ("Letter %c already has an IMPLICIT type at %C", | |
185 | i + 'A'); | |
186 | return FAILURE; | |
187 | } | |
188 | gfc_current_ns->default_type[i] = *ts; | |
189 | gfc_current_ns->set_flag[i] = 1; | |
190 | } | |
191 | } | |
6de9cd9a DN |
192 | return SUCCESS; |
193 | } | |
194 | ||
195 | ||
eebc3ee0 | 196 | /* Given a symbol, return a pointer to the typespec for its default type. */ |
6de9cd9a DN |
197 | |
198 | gfc_typespec * | |
199 | gfc_get_default_type (gfc_symbol * sym, gfc_namespace * ns) | |
200 | { | |
201 | char letter; | |
202 | ||
203 | letter = sym->name[0]; | |
204 | if (letter < 'a' || letter > 'z') | |
205 | gfc_internal_error ("gfc_get_default_type(): Bad symbol"); | |
206 | ||
207 | if (ns == NULL) | |
208 | ns = gfc_current_ns; | |
209 | ||
210 | return &ns->default_type[letter - 'a']; | |
211 | } | |
212 | ||
213 | ||
214 | /* Given a pointer to a symbol, set its type according to the first | |
215 | letter of its name. Fails if the letter in question has no default | |
216 | type. */ | |
217 | ||
218 | try | |
219 | gfc_set_default_type (gfc_symbol * sym, int error_flag, gfc_namespace * ns) | |
220 | { | |
221 | gfc_typespec *ts; | |
222 | ||
223 | if (sym->ts.type != BT_UNKNOWN) | |
224 | gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); | |
225 | ||
226 | ts = gfc_get_default_type (sym, ns); | |
227 | ||
228 | if (ts->type == BT_UNKNOWN) | |
229 | { | |
d1303acd TS |
230 | if (error_flag && !sym->attr.untyped) |
231 | { | |
232 | gfc_error ("Symbol '%s' at %L has no IMPLICIT type", | |
233 | sym->name, &sym->declared_at); | |
234 | sym->attr.untyped = 1; /* Ensure we only give an error once. */ | |
235 | } | |
6de9cd9a DN |
236 | |
237 | return FAILURE; | |
238 | } | |
239 | ||
240 | sym->ts = *ts; | |
241 | sym->attr.implicit_type = 1; | |
242 | ||
243 | return SUCCESS; | |
244 | } | |
245 | ||
246 | ||
247 | /******************** Symbol attribute stuff *********************/ | |
248 | ||
249 | /* This is a generic conflict-checker. We do this to avoid having a | |
250 | single conflict in two places. */ | |
251 | ||
252 | #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; } | |
253 | #define conf2(a) if (attr->a) { a2 = a; goto conflict; } | |
254 | ||
255 | static try | |
231b2fcc | 256 | check_conflict (symbol_attribute * attr, const char * name, locus * where) |
6de9cd9a DN |
257 | { |
258 | static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER", | |
259 | *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT", | |
260 | *intrinsic = "INTRINSIC", *allocatable = "ALLOCATABLE", | |
261 | *elemental = "ELEMENTAL", *private = "PRIVATE", *recursive = "RECURSIVE", | |
262 | *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST", | |
263 | *public = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY", | |
264 | *function = "FUNCTION", *subroutine = "SUBROUTINE", | |
265 | *dimension = "DIMENSION"; | |
266 | ||
267 | const char *a1, *a2; | |
268 | ||
269 | if (where == NULL) | |
63645982 | 270 | where = &gfc_current_locus; |
6de9cd9a DN |
271 | |
272 | if (attr->pointer && attr->intent != INTENT_UNKNOWN) | |
273 | { | |
274 | a1 = pointer; | |
275 | a2 = intent; | |
276 | goto conflict; | |
277 | } | |
278 | ||
279 | /* Check for attributes not allowed in a BLOCK DATA. */ | |
280 | if (gfc_current_state () == COMP_BLOCK_DATA) | |
281 | { | |
282 | a1 = NULL; | |
283 | ||
284 | if (attr->allocatable) | |
285 | a1 = allocatable; | |
286 | if (attr->external) | |
287 | a1 = external; | |
288 | if (attr->optional) | |
289 | a1 = optional; | |
290 | if (attr->access == ACCESS_PRIVATE) | |
291 | a1 = private; | |
292 | if (attr->access == ACCESS_PUBLIC) | |
293 | a1 = public; | |
294 | if (attr->intent != INTENT_UNKNOWN) | |
295 | a1 = intent; | |
296 | ||
297 | if (a1 != NULL) | |
298 | { | |
299 | gfc_error | |
300 | ("%s attribute not allowed in BLOCK DATA program unit at %L", a1, | |
301 | where); | |
302 | return FAILURE; | |
303 | } | |
304 | } | |
305 | ||
306 | conf (dummy, save); | |
307 | conf (pointer, target); | |
308 | conf (pointer, external); | |
309 | conf (pointer, intrinsic); | |
310 | conf (target, external); | |
311 | conf (target, intrinsic); | |
312 | conf (external, dimension); /* See Fortran 95's R504. */ | |
313 | ||
314 | conf (external, intrinsic); | |
315 | conf (allocatable, pointer); | |
316 | conf (allocatable, dummy); /* TODO: Allowed in Fortran 200x. */ | |
317 | conf (allocatable, function); /* TODO: Allowed in Fortran 200x. */ | |
318 | conf (allocatable, result); /* TODO: Allowed in Fortran 200x. */ | |
319 | conf (elemental, recursive); | |
320 | ||
321 | conf (in_common, dummy); | |
322 | conf (in_common, allocatable); | |
323 | conf (in_common, result); | |
324 | conf (dummy, result); | |
325 | ||
326 | conf (in_namelist, pointer); | |
327 | conf (in_namelist, allocatable); | |
328 | ||
329 | conf (entry, result); | |
330 | ||
331 | conf (function, subroutine); | |
332 | ||
333 | a1 = gfc_code2string (flavors, attr->flavor); | |
334 | ||
335 | if (attr->in_namelist | |
336 | && attr->flavor != FL_VARIABLE | |
337 | && attr->flavor != FL_UNKNOWN) | |
338 | { | |
339 | ||
340 | a2 = in_namelist; | |
341 | goto conflict; | |
342 | } | |
343 | ||
344 | switch (attr->flavor) | |
345 | { | |
346 | case FL_PROGRAM: | |
347 | case FL_BLOCK_DATA: | |
348 | case FL_MODULE: | |
349 | case FL_LABEL: | |
350 | conf2 (dummy); | |
351 | conf2 (save); | |
352 | conf2 (pointer); | |
353 | conf2 (target); | |
354 | conf2 (external); | |
355 | conf2 (intrinsic); | |
356 | conf2 (allocatable); | |
357 | conf2 (result); | |
358 | conf2 (in_namelist); | |
359 | conf2 (optional); | |
360 | conf2 (function); | |
361 | conf2 (subroutine); | |
362 | break; | |
363 | ||
364 | case FL_VARIABLE: | |
365 | case FL_NAMELIST: | |
366 | break; | |
367 | ||
368 | case FL_PROCEDURE: | |
369 | conf2 (intent); | |
370 | ||
371 | if (attr->subroutine) | |
372 | { | |
373 | conf2(save); | |
374 | conf2(pointer); | |
375 | conf2(target); | |
376 | conf2(allocatable); | |
377 | conf2(result); | |
378 | conf2(in_namelist); | |
379 | conf2(function); | |
380 | } | |
381 | ||
382 | switch (attr->proc) | |
383 | { | |
384 | case PROC_ST_FUNCTION: | |
385 | conf2 (in_common); | |
2bb02bf0 | 386 | conf2 (dummy); |
6de9cd9a DN |
387 | break; |
388 | ||
389 | case PROC_MODULE: | |
390 | conf2 (dummy); | |
391 | break; | |
392 | ||
393 | case PROC_DUMMY: | |
394 | conf2 (result); | |
395 | conf2 (in_common); | |
396 | conf2 (save); | |
397 | break; | |
398 | ||
399 | default: | |
400 | break; | |
401 | } | |
402 | ||
403 | break; | |
404 | ||
405 | case FL_DERIVED: | |
406 | conf2 (dummy); | |
407 | conf2 (save); | |
408 | conf2 (pointer); | |
409 | conf2 (target); | |
410 | conf2 (external); | |
411 | conf2 (intrinsic); | |
412 | conf2 (allocatable); | |
413 | conf2 (optional); | |
414 | conf2 (entry); | |
415 | conf2 (function); | |
416 | conf2 (subroutine); | |
417 | ||
418 | if (attr->intent != INTENT_UNKNOWN) | |
419 | { | |
420 | a2 = intent; | |
421 | goto conflict; | |
422 | } | |
423 | break; | |
424 | ||
425 | case FL_PARAMETER: | |
426 | conf2 (external); | |
427 | conf2 (intrinsic); | |
428 | conf2 (optional); | |
429 | conf2 (allocatable); | |
430 | conf2 (function); | |
431 | conf2 (subroutine); | |
432 | conf2 (entry); | |
433 | conf2 (pointer); | |
434 | conf2 (target); | |
435 | conf2 (dummy); | |
436 | conf2 (in_common); | |
437 | break; | |
438 | ||
439 | default: | |
440 | break; | |
441 | } | |
442 | ||
443 | return SUCCESS; | |
444 | ||
445 | conflict: | |
231b2fcc TS |
446 | if (name == NULL) |
447 | gfc_error ("%s attribute conflicts with %s attribute at %L", | |
448 | a1, a2, where); | |
449 | else | |
450 | gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L", | |
451 | a1, a2, name, where); | |
452 | ||
6de9cd9a DN |
453 | return FAILURE; |
454 | } | |
455 | ||
456 | #undef conf | |
457 | #undef conf2 | |
458 | ||
459 | ||
460 | /* Mark a symbol as referenced. */ | |
461 | ||
462 | void | |
463 | gfc_set_sym_referenced (gfc_symbol * sym) | |
464 | { | |
465 | if (sym->attr.referenced) | |
466 | return; | |
467 | ||
468 | sym->attr.referenced = 1; | |
469 | ||
470 | /* Remember which order dummy variables are accessed in. */ | |
471 | if (sym->attr.dummy) | |
472 | sym->dummy_order = next_dummy_order++; | |
473 | } | |
474 | ||
475 | ||
476 | /* Common subroutine called by attribute changing subroutines in order | |
477 | to prevent them from changing a symbol that has been | |
478 | use-associated. Returns zero if it is OK to change the symbol, | |
479 | nonzero if not. */ | |
480 | ||
481 | static int | |
231b2fcc | 482 | check_used (symbol_attribute * attr, const char * name, locus * where) |
6de9cd9a DN |
483 | { |
484 | ||
485 | if (attr->use_assoc == 0) | |
486 | return 0; | |
487 | ||
488 | if (where == NULL) | |
63645982 | 489 | where = &gfc_current_locus; |
6de9cd9a | 490 | |
231b2fcc TS |
491 | if (name == NULL) |
492 | gfc_error ("Cannot change attributes of USE-associated symbol at %L", | |
493 | where); | |
494 | else | |
495 | gfc_error ("Cannot change attributes of USE-associated symbol %s at %L", | |
496 | name, where); | |
6de9cd9a DN |
497 | |
498 | return 1; | |
499 | } | |
500 | ||
501 | ||
502 | /* Used to prevent changing the attributes of a symbol after it has been | |
eebc3ee0 | 503 | used. This check is only done for dummy variables as only these can be |
6de9cd9a | 504 | used in specification expressions. Applying this to all symbols causes |
eebc3ee0 | 505 | an error when we reach the body of a contained function. */ |
6de9cd9a DN |
506 | |
507 | static int | |
508 | check_done (symbol_attribute * attr, locus * where) | |
509 | { | |
510 | ||
511 | if (!(attr->dummy && attr->referenced)) | |
512 | return 0; | |
513 | ||
514 | if (where == NULL) | |
63645982 | 515 | where = &gfc_current_locus; |
6de9cd9a DN |
516 | |
517 | gfc_error ("Cannot change attributes of symbol at %L" | |
518 | " after it has been used", where); | |
519 | ||
520 | return 1; | |
521 | } | |
522 | ||
523 | ||
524 | /* Generate an error because of a duplicate attribute. */ | |
525 | ||
526 | static void | |
527 | duplicate_attr (const char *attr, locus * where) | |
528 | { | |
529 | ||
530 | if (where == NULL) | |
63645982 | 531 | where = &gfc_current_locus; |
6de9cd9a DN |
532 | |
533 | gfc_error ("Duplicate %s attribute specified at %L", attr, where); | |
534 | } | |
535 | ||
536 | ||
537 | try | |
538 | gfc_add_allocatable (symbol_attribute * attr, locus * where) | |
539 | { | |
540 | ||
231b2fcc | 541 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
542 | return FAILURE; |
543 | ||
544 | if (attr->allocatable) | |
545 | { | |
546 | duplicate_attr ("ALLOCATABLE", where); | |
547 | return FAILURE; | |
548 | } | |
549 | ||
550 | attr->allocatable = 1; | |
231b2fcc | 551 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
552 | } |
553 | ||
554 | ||
555 | try | |
231b2fcc | 556 | gfc_add_dimension (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
557 | { |
558 | ||
231b2fcc | 559 | if (check_used (attr, name, where) || check_done (attr, where)) |
6de9cd9a DN |
560 | return FAILURE; |
561 | ||
562 | if (attr->dimension) | |
563 | { | |
564 | duplicate_attr ("DIMENSION", where); | |
565 | return FAILURE; | |
566 | } | |
567 | ||
568 | attr->dimension = 1; | |
231b2fcc | 569 | return check_conflict (attr, name, where); |
6de9cd9a DN |
570 | } |
571 | ||
572 | ||
573 | try | |
574 | gfc_add_external (symbol_attribute * attr, locus * where) | |
575 | { | |
576 | ||
231b2fcc | 577 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
578 | return FAILURE; |
579 | ||
580 | if (attr->external) | |
581 | { | |
582 | duplicate_attr ("EXTERNAL", where); | |
583 | return FAILURE; | |
584 | } | |
585 | ||
586 | attr->external = 1; | |
587 | ||
231b2fcc | 588 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
589 | } |
590 | ||
591 | ||
592 | try | |
593 | gfc_add_intrinsic (symbol_attribute * attr, locus * where) | |
594 | { | |
595 | ||
231b2fcc | 596 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
597 | return FAILURE; |
598 | ||
599 | if (attr->intrinsic) | |
600 | { | |
601 | duplicate_attr ("INTRINSIC", where); | |
602 | return FAILURE; | |
603 | } | |
604 | ||
605 | attr->intrinsic = 1; | |
606 | ||
231b2fcc | 607 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
608 | } |
609 | ||
610 | ||
611 | try | |
612 | gfc_add_optional (symbol_attribute * attr, locus * where) | |
613 | { | |
614 | ||
231b2fcc | 615 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
616 | return FAILURE; |
617 | ||
618 | if (attr->optional) | |
619 | { | |
620 | duplicate_attr ("OPTIONAL", where); | |
621 | return FAILURE; | |
622 | } | |
623 | ||
624 | attr->optional = 1; | |
231b2fcc | 625 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
626 | } |
627 | ||
628 | ||
629 | try | |
630 | gfc_add_pointer (symbol_attribute * attr, locus * where) | |
631 | { | |
632 | ||
231b2fcc | 633 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
634 | return FAILURE; |
635 | ||
636 | attr->pointer = 1; | |
231b2fcc | 637 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
638 | } |
639 | ||
640 | ||
641 | try | |
231b2fcc | 642 | gfc_add_result (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
643 | { |
644 | ||
231b2fcc | 645 | if (check_used (attr, name, where) || check_done (attr, where)) |
6de9cd9a DN |
646 | return FAILURE; |
647 | ||
648 | attr->result = 1; | |
231b2fcc | 649 | return check_conflict (attr, name, where); |
6de9cd9a DN |
650 | } |
651 | ||
652 | ||
653 | try | |
231b2fcc | 654 | gfc_add_save (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
655 | { |
656 | ||
231b2fcc | 657 | if (check_used (attr, name, where)) |
6de9cd9a DN |
658 | return FAILURE; |
659 | ||
660 | if (gfc_pure (NULL)) | |
661 | { | |
662 | gfc_error | |
663 | ("SAVE attribute at %L cannot be specified in a PURE procedure", | |
664 | where); | |
665 | return FAILURE; | |
666 | } | |
667 | ||
668 | if (attr->save) | |
669 | { | |
670 | duplicate_attr ("SAVE", where); | |
671 | return FAILURE; | |
672 | } | |
673 | ||
674 | attr->save = 1; | |
231b2fcc | 675 | return check_conflict (attr, name, where); |
6de9cd9a DN |
676 | } |
677 | ||
678 | ||
6de9cd9a DN |
679 | try |
680 | gfc_add_target (symbol_attribute * attr, locus * where) | |
681 | { | |
682 | ||
231b2fcc | 683 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
684 | return FAILURE; |
685 | ||
686 | if (attr->target) | |
687 | { | |
688 | duplicate_attr ("TARGET", where); | |
689 | return FAILURE; | |
690 | } | |
691 | ||
692 | attr->target = 1; | |
231b2fcc | 693 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
694 | } |
695 | ||
696 | ||
697 | try | |
231b2fcc | 698 | gfc_add_dummy (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
699 | { |
700 | ||
231b2fcc | 701 | if (check_used (attr, name, where)) |
6de9cd9a DN |
702 | return FAILURE; |
703 | ||
eebc3ee0 | 704 | /* Duplicate dummy arguments are allowed due to ENTRY statements. */ |
6de9cd9a | 705 | attr->dummy = 1; |
231b2fcc | 706 | return check_conflict (attr, name, where); |
6de9cd9a DN |
707 | } |
708 | ||
709 | ||
6de9cd9a | 710 | try |
231b2fcc | 711 | gfc_add_in_common (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
712 | { |
713 | ||
231b2fcc | 714 | if (check_used (attr, name, where) || check_done (attr, where)) |
6de9cd9a DN |
715 | return FAILURE; |
716 | ||
717 | /* Duplicate attribute already checked for. */ | |
718 | attr->in_common = 1; | |
231b2fcc | 719 | if (check_conflict (attr, name, where) == FAILURE) |
6de9cd9a DN |
720 | return FAILURE; |
721 | ||
722 | if (attr->flavor == FL_VARIABLE) | |
723 | return SUCCESS; | |
724 | ||
231b2fcc | 725 | return gfc_add_flavor (attr, FL_VARIABLE, name, where); |
6de9cd9a DN |
726 | } |
727 | ||
728 | ||
9056bd70 | 729 | try |
231b2fcc | 730 | gfc_add_data (symbol_attribute *attr, const char *name, locus *where) |
9056bd70 TS |
731 | { |
732 | ||
231b2fcc | 733 | if (check_used (attr, name, where)) |
9056bd70 TS |
734 | return FAILURE; |
735 | ||
736 | attr->data = 1; | |
231b2fcc | 737 | return check_conflict (attr, name, where); |
9056bd70 TS |
738 | } |
739 | ||
740 | ||
6de9cd9a | 741 | try |
231b2fcc TS |
742 | gfc_add_in_namelist (symbol_attribute * attr, const char *name, |
743 | locus * where) | |
6de9cd9a DN |
744 | { |
745 | ||
746 | attr->in_namelist = 1; | |
231b2fcc | 747 | return check_conflict (attr, name, where); |
6de9cd9a DN |
748 | } |
749 | ||
750 | ||
751 | try | |
231b2fcc | 752 | gfc_add_sequence (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
753 | { |
754 | ||
231b2fcc | 755 | if (check_used (attr, name, where)) |
6de9cd9a DN |
756 | return FAILURE; |
757 | ||
758 | attr->sequence = 1; | |
231b2fcc | 759 | return check_conflict (attr, name, where); |
6de9cd9a DN |
760 | } |
761 | ||
762 | ||
763 | try | |
764 | gfc_add_elemental (symbol_attribute * attr, locus * where) | |
765 | { | |
766 | ||
231b2fcc | 767 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
768 | return FAILURE; |
769 | ||
770 | attr->elemental = 1; | |
231b2fcc | 771 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
772 | } |
773 | ||
774 | ||
775 | try | |
776 | gfc_add_pure (symbol_attribute * attr, locus * where) | |
777 | { | |
778 | ||
231b2fcc | 779 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
780 | return FAILURE; |
781 | ||
782 | attr->pure = 1; | |
231b2fcc | 783 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
784 | } |
785 | ||
786 | ||
787 | try | |
788 | gfc_add_recursive (symbol_attribute * attr, locus * where) | |
789 | { | |
790 | ||
231b2fcc | 791 | if (check_used (attr, NULL, where) || check_done (attr, where)) |
6de9cd9a DN |
792 | return FAILURE; |
793 | ||
794 | attr->recursive = 1; | |
231b2fcc | 795 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
796 | } |
797 | ||
798 | ||
799 | try | |
231b2fcc | 800 | gfc_add_entry (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
801 | { |
802 | ||
231b2fcc | 803 | if (check_used (attr, name, where)) |
6de9cd9a DN |
804 | return FAILURE; |
805 | ||
806 | if (attr->entry) | |
807 | { | |
808 | duplicate_attr ("ENTRY", where); | |
809 | return FAILURE; | |
810 | } | |
811 | ||
812 | attr->entry = 1; | |
231b2fcc | 813 | return check_conflict (attr, name, where); |
6de9cd9a DN |
814 | } |
815 | ||
816 | ||
817 | try | |
231b2fcc | 818 | gfc_add_function (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
819 | { |
820 | ||
821 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 822 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
823 | return FAILURE; |
824 | ||
825 | attr->function = 1; | |
231b2fcc | 826 | return check_conflict (attr, name, where); |
6de9cd9a DN |
827 | } |
828 | ||
829 | ||
830 | try | |
231b2fcc | 831 | gfc_add_subroutine (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
832 | { |
833 | ||
834 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 835 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
836 | return FAILURE; |
837 | ||
838 | attr->subroutine = 1; | |
231b2fcc | 839 | return check_conflict (attr, name, where); |
6de9cd9a DN |
840 | } |
841 | ||
842 | ||
843 | try | |
231b2fcc | 844 | gfc_add_generic (symbol_attribute * attr, const char *name, locus * where) |
6de9cd9a DN |
845 | { |
846 | ||
847 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 848 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
849 | return FAILURE; |
850 | ||
851 | attr->generic = 1; | |
231b2fcc | 852 | return check_conflict (attr, name, where); |
6de9cd9a DN |
853 | } |
854 | ||
855 | ||
eebc3ee0 | 856 | /* Flavors are special because some flavors are not what Fortran |
6de9cd9a DN |
857 | considers attributes and can be reaffirmed multiple times. */ |
858 | ||
859 | try | |
231b2fcc TS |
860 | gfc_add_flavor (symbol_attribute * attr, sym_flavor f, const char *name, |
861 | locus * where) | |
6de9cd9a DN |
862 | { |
863 | ||
864 | if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE | |
865 | || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED | |
231b2fcc | 866 | || f == FL_NAMELIST) && check_used (attr, name, where)) |
6de9cd9a DN |
867 | return FAILURE; |
868 | ||
869 | if (attr->flavor == f && f == FL_VARIABLE) | |
870 | return SUCCESS; | |
871 | ||
872 | if (attr->flavor != FL_UNKNOWN) | |
873 | { | |
874 | if (where == NULL) | |
63645982 | 875 | where = &gfc_current_locus; |
6de9cd9a DN |
876 | |
877 | gfc_error ("%s attribute conflicts with %s attribute at %L", | |
878 | gfc_code2string (flavors, attr->flavor), | |
879 | gfc_code2string (flavors, f), where); | |
880 | ||
881 | return FAILURE; | |
882 | } | |
883 | ||
884 | attr->flavor = f; | |
885 | ||
231b2fcc | 886 | return check_conflict (attr, name, where); |
6de9cd9a DN |
887 | } |
888 | ||
889 | ||
890 | try | |
231b2fcc TS |
891 | gfc_add_procedure (symbol_attribute * attr, procedure_type t, |
892 | const char *name, locus * where) | |
6de9cd9a DN |
893 | { |
894 | ||
231b2fcc | 895 | if (check_used (attr, name, where) || check_done (attr, where)) |
6de9cd9a DN |
896 | return FAILURE; |
897 | ||
898 | if (attr->flavor != FL_PROCEDURE | |
231b2fcc | 899 | && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE) |
6de9cd9a DN |
900 | return FAILURE; |
901 | ||
902 | if (where == NULL) | |
63645982 | 903 | where = &gfc_current_locus; |
6de9cd9a DN |
904 | |
905 | if (attr->proc != PROC_UNKNOWN) | |
906 | { | |
907 | gfc_error ("%s procedure at %L is already %s %s procedure", | |
908 | gfc_code2string (procedures, t), where, | |
909 | gfc_article (gfc_code2string (procedures, attr->proc)), | |
910 | gfc_code2string (procedures, attr->proc)); | |
911 | ||
912 | return FAILURE; | |
913 | } | |
914 | ||
915 | attr->proc = t; | |
916 | ||
917 | /* Statement functions are always scalar and functions. */ | |
918 | if (t == PROC_ST_FUNCTION | |
231b2fcc | 919 | && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE) |
6de9cd9a DN |
920 | || attr->dimension)) |
921 | return FAILURE; | |
922 | ||
231b2fcc | 923 | return check_conflict (attr, name, where); |
6de9cd9a DN |
924 | } |
925 | ||
926 | ||
927 | try | |
928 | gfc_add_intent (symbol_attribute * attr, sym_intent intent, locus * where) | |
929 | { | |
930 | ||
231b2fcc | 931 | if (check_used (attr, NULL, where)) |
6de9cd9a DN |
932 | return FAILURE; |
933 | ||
934 | if (attr->intent == INTENT_UNKNOWN) | |
935 | { | |
936 | attr->intent = intent; | |
231b2fcc | 937 | return check_conflict (attr, NULL, where); |
6de9cd9a DN |
938 | } |
939 | ||
940 | if (where == NULL) | |
63645982 | 941 | where = &gfc_current_locus; |
6de9cd9a DN |
942 | |
943 | gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L", | |
944 | gfc_intent_string (attr->intent), | |
945 | gfc_intent_string (intent), where); | |
946 | ||
947 | return FAILURE; | |
948 | } | |
949 | ||
950 | ||
951 | /* No checks for use-association in public and private statements. */ | |
952 | ||
953 | try | |
231b2fcc TS |
954 | gfc_add_access (symbol_attribute * attr, gfc_access access, |
955 | const char *name, locus * where) | |
6de9cd9a DN |
956 | { |
957 | ||
958 | if (attr->access == ACCESS_UNKNOWN) | |
959 | { | |
960 | attr->access = access; | |
231b2fcc | 961 | return check_conflict (attr, name, where); |
6de9cd9a DN |
962 | } |
963 | ||
964 | if (where == NULL) | |
63645982 | 965 | where = &gfc_current_locus; |
6de9cd9a DN |
966 | gfc_error ("ACCESS specification at %L was already specified", where); |
967 | ||
968 | return FAILURE; | |
969 | } | |
970 | ||
971 | ||
972 | try | |
973 | gfc_add_explicit_interface (gfc_symbol * sym, ifsrc source, | |
974 | gfc_formal_arglist * formal, locus * where) | |
975 | { | |
976 | ||
231b2fcc | 977 | if (check_used (&sym->attr, sym->name, where)) |
6de9cd9a DN |
978 | return FAILURE; |
979 | ||
980 | if (where == NULL) | |
63645982 | 981 | where = &gfc_current_locus; |
6de9cd9a DN |
982 | |
983 | if (sym->attr.if_source != IFSRC_UNKNOWN | |
984 | && sym->attr.if_source != IFSRC_DECL) | |
985 | { | |
986 | gfc_error ("Symbol '%s' at %L already has an explicit interface", | |
987 | sym->name, where); | |
988 | return FAILURE; | |
989 | } | |
990 | ||
991 | sym->formal = formal; | |
992 | sym->attr.if_source = source; | |
993 | ||
994 | return SUCCESS; | |
995 | } | |
996 | ||
997 | ||
998 | /* Add a type to a symbol. */ | |
999 | ||
1000 | try | |
1001 | gfc_add_type (gfc_symbol * sym, gfc_typespec * ts, locus * where) | |
1002 | { | |
1003 | sym_flavor flavor; | |
1004 | ||
1005 | /* TODO: This is legal if it is reaffirming an implicit type. | |
1006 | if (check_done (&sym->attr, where)) | |
1007 | return FAILURE;*/ | |
1008 | ||
1009 | if (where == NULL) | |
63645982 | 1010 | where = &gfc_current_locus; |
6de9cd9a DN |
1011 | |
1012 | if (sym->ts.type != BT_UNKNOWN) | |
1013 | { | |
1014 | gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name, | |
1015 | where, gfc_basic_typename (sym->ts.type)); | |
1016 | return FAILURE; | |
1017 | } | |
1018 | ||
1019 | flavor = sym->attr.flavor; | |
1020 | ||
1021 | if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE | |
1022 | || flavor == FL_LABEL || (flavor == FL_PROCEDURE | |
1023 | && sym->attr.subroutine) | |
1024 | || flavor == FL_DERIVED || flavor == FL_NAMELIST) | |
1025 | { | |
1026 | gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where); | |
1027 | return FAILURE; | |
1028 | } | |
1029 | ||
1030 | sym->ts = *ts; | |
1031 | return SUCCESS; | |
1032 | } | |
1033 | ||
1034 | ||
1035 | /* Clears all attributes. */ | |
1036 | ||
1037 | void | |
1038 | gfc_clear_attr (symbol_attribute * attr) | |
1039 | { | |
bbef13dc | 1040 | memset (attr, 0, sizeof(symbol_attribute)); |
6de9cd9a DN |
1041 | } |
1042 | ||
1043 | ||
1044 | /* Check for missing attributes in the new symbol. Currently does | |
1045 | nothing, but it's not clear that it is unnecessary yet. */ | |
1046 | ||
1047 | try | |
1048 | gfc_missing_attr (symbol_attribute * attr ATTRIBUTE_UNUSED, | |
1049 | locus * where ATTRIBUTE_UNUSED) | |
1050 | { | |
1051 | ||
1052 | return SUCCESS; | |
1053 | } | |
1054 | ||
1055 | ||
1056 | /* Copy an attribute to a symbol attribute, bit by bit. Some | |
1057 | attributes have a lot of side-effects but cannot be present given | |
1058 | where we are called from, so we ignore some bits. */ | |
1059 | ||
1060 | try | |
1061 | gfc_copy_attr (symbol_attribute * dest, symbol_attribute * src, locus * where) | |
1062 | { | |
1063 | ||
1064 | if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE) | |
1065 | goto fail; | |
1066 | ||
231b2fcc | 1067 | if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1068 | goto fail; |
1069 | if (src->optional && gfc_add_optional (dest, where) == FAILURE) | |
1070 | goto fail; | |
1071 | if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) | |
1072 | goto fail; | |
231b2fcc | 1073 | if (src->save && gfc_add_save (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1074 | goto fail; |
1075 | if (src->target && gfc_add_target (dest, where) == FAILURE) | |
1076 | goto fail; | |
231b2fcc | 1077 | if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE) |
6de9cd9a | 1078 | goto fail; |
231b2fcc | 1079 | if (src->result && gfc_add_result (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1080 | goto fail; |
1081 | if (src->entry) | |
1082 | dest->entry = 1; | |
1083 | ||
231b2fcc | 1084 | if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1085 | goto fail; |
1086 | ||
231b2fcc | 1087 | if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE) |
6de9cd9a | 1088 | goto fail; |
6de9cd9a | 1089 | |
231b2fcc | 1090 | if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE) |
6de9cd9a | 1091 | goto fail; |
231b2fcc | 1092 | if (src->function && gfc_add_function (dest, NULL, where) == FAILURE) |
6de9cd9a | 1093 | goto fail; |
231b2fcc | 1094 | if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1095 | goto fail; |
1096 | ||
231b2fcc | 1097 | if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE) |
6de9cd9a DN |
1098 | goto fail; |
1099 | if (src->elemental && gfc_add_elemental (dest, where) == FAILURE) | |
1100 | goto fail; | |
1101 | if (src->pure && gfc_add_pure (dest, where) == FAILURE) | |
1102 | goto fail; | |
1103 | if (src->recursive && gfc_add_recursive (dest, where) == FAILURE) | |
1104 | goto fail; | |
1105 | ||
1106 | if (src->flavor != FL_UNKNOWN | |
231b2fcc | 1107 | && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE) |
6de9cd9a DN |
1108 | goto fail; |
1109 | ||
1110 | if (src->intent != INTENT_UNKNOWN | |
1111 | && gfc_add_intent (dest, src->intent, where) == FAILURE) | |
1112 | goto fail; | |
1113 | ||
1114 | if (src->access != ACCESS_UNKNOWN | |
231b2fcc | 1115 | && gfc_add_access (dest, src->access, NULL, where) == FAILURE) |
6de9cd9a DN |
1116 | goto fail; |
1117 | ||
1118 | if (gfc_missing_attr (dest, where) == FAILURE) | |
1119 | goto fail; | |
1120 | ||
1121 | /* The subroutines that set these bits also cause flavors to be set, | |
eebc3ee0 | 1122 | and that has already happened in the original, so don't let it |
6de9cd9a DN |
1123 | happen again. */ |
1124 | if (src->external) | |
1125 | dest->external = 1; | |
1126 | if (src->intrinsic) | |
1127 | dest->intrinsic = 1; | |
1128 | ||
1129 | return SUCCESS; | |
1130 | ||
1131 | fail: | |
1132 | return FAILURE; | |
1133 | } | |
1134 | ||
1135 | ||
1136 | /************** Component name management ************/ | |
1137 | ||
1138 | /* Component names of a derived type form their own little namespaces | |
1139 | that are separate from all other spaces. The space is composed of | |
1140 | a singly linked list of gfc_component structures whose head is | |
1141 | located in the parent symbol. */ | |
1142 | ||
1143 | ||
1144 | /* Add a component name to a symbol. The call fails if the name is | |
1145 | already present. On success, the component pointer is modified to | |
1146 | point to the additional component structure. */ | |
1147 | ||
1148 | try | |
1149 | gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** component) | |
1150 | { | |
1151 | gfc_component *p, *tail; | |
1152 | ||
1153 | tail = NULL; | |
1154 | ||
1155 | for (p = sym->components; p; p = p->next) | |
1156 | { | |
1157 | if (strcmp (p->name, name) == 0) | |
1158 | { | |
1159 | gfc_error ("Component '%s' at %C already declared at %L", | |
1160 | name, &p->loc); | |
1161 | return FAILURE; | |
1162 | } | |
1163 | ||
1164 | tail = p; | |
1165 | } | |
1166 | ||
eebc3ee0 | 1167 | /* Allocate a new component. */ |
6de9cd9a DN |
1168 | p = gfc_get_component (); |
1169 | ||
1170 | if (tail == NULL) | |
1171 | sym->components = p; | |
1172 | else | |
1173 | tail->next = p; | |
1174 | ||
cb9e4f55 | 1175 | p->name = gfc_get_string (name); |
63645982 | 1176 | p->loc = gfc_current_locus; |
6de9cd9a DN |
1177 | |
1178 | *component = p; | |
1179 | return SUCCESS; | |
1180 | } | |
1181 | ||
1182 | ||
1183 | /* Recursive function to switch derived types of all symbol in a | |
1184 | namespace. */ | |
1185 | ||
1186 | static void | |
1187 | switch_types (gfc_symtree * st, gfc_symbol * from, gfc_symbol * to) | |
1188 | { | |
1189 | gfc_symbol *sym; | |
1190 | ||
1191 | if (st == NULL) | |
1192 | return; | |
1193 | ||
1194 | sym = st->n.sym; | |
1195 | if (sym->ts.type == BT_DERIVED && sym->ts.derived == from) | |
1196 | sym->ts.derived = to; | |
1197 | ||
1198 | switch_types (st->left, from, to); | |
1199 | switch_types (st->right, from, to); | |
1200 | } | |
1201 | ||
1202 | ||
1203 | /* This subroutine is called when a derived type is used in order to | |
1204 | make the final determination about which version to use. The | |
1205 | standard requires that a type be defined before it is 'used', but | |
1206 | such types can appear in IMPLICIT statements before the actual | |
1207 | definition. 'Using' in this context means declaring a variable to | |
1208 | be that type or using the type constructor. | |
1209 | ||
1210 | If a type is used and the components haven't been defined, then we | |
1211 | have to have a derived type in a parent unit. We find the node in | |
1212 | the other namespace and point the symtree node in this namespace to | |
1213 | that node. Further reference to this name point to the correct | |
eebc3ee0 | 1214 | node. If we can't find the node in a parent namespace, then we have |
6de9cd9a DN |
1215 | an error. |
1216 | ||
1217 | This subroutine takes a pointer to a symbol node and returns a | |
1218 | pointer to the translated node or NULL for an error. Usually there | |
1219 | is no translation and we return the node we were passed. */ | |
1220 | ||
1e6283cb TS |
1221 | gfc_symbol * |
1222 | gfc_use_derived (gfc_symbol * sym) | |
6de9cd9a DN |
1223 | { |
1224 | gfc_symbol *s, *p; | |
1225 | gfc_typespec *t; | |
1226 | gfc_symtree *st; | |
1227 | int i; | |
1228 | ||
1e6283cb TS |
1229 | if (sym->components != NULL) |
1230 | return sym; /* Already defined. */ | |
1231 | ||
6de9cd9a DN |
1232 | if (sym->ns->parent == NULL) |
1233 | goto bad; | |
1234 | ||
1235 | if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s)) | |
1236 | { | |
1237 | gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); | |
1238 | return NULL; | |
1239 | } | |
1240 | ||
1241 | if (s == NULL || s->attr.flavor != FL_DERIVED) | |
1242 | goto bad; | |
1243 | ||
1244 | /* Get rid of symbol sym, translating all references to s. */ | |
1245 | for (i = 0; i < GFC_LETTERS; i++) | |
1246 | { | |
1247 | t = &sym->ns->default_type[i]; | |
1248 | if (t->derived == sym) | |
1249 | t->derived = s; | |
1250 | } | |
1251 | ||
1252 | st = gfc_find_symtree (sym->ns->sym_root, sym->name); | |
1253 | st->n.sym = s; | |
1254 | ||
1255 | s->refs++; | |
1256 | ||
1257 | /* Unlink from list of modified symbols. */ | |
1258 | if (changed_syms == sym) | |
1259 | changed_syms = sym->tlink; | |
1260 | else | |
1261 | for (p = changed_syms; p; p = p->tlink) | |
1262 | if (p->tlink == sym) | |
1263 | { | |
1264 | p->tlink = sym->tlink; | |
1265 | break; | |
1266 | } | |
1267 | ||
1268 | switch_types (sym->ns->sym_root, sym, s); | |
1269 | ||
1270 | /* TODO: Also have to replace sym -> s in other lists like | |
1271 | namelists, common lists and interface lists. */ | |
1272 | gfc_free_symbol (sym); | |
1273 | ||
1e6283cb | 1274 | return s; |
6de9cd9a DN |
1275 | |
1276 | bad: | |
1277 | gfc_error ("Derived type '%s' at %C is being used before it is defined", | |
1278 | sym->name); | |
1279 | return NULL; | |
1280 | } | |
1281 | ||
1282 | ||
6de9cd9a DN |
1283 | /* Given a derived type node and a component name, try to locate the |
1284 | component structure. Returns the NULL pointer if the component is | |
1285 | not found or the components are private. */ | |
1286 | ||
1287 | gfc_component * | |
1288 | gfc_find_component (gfc_symbol * sym, const char *name) | |
1289 | { | |
1290 | gfc_component *p; | |
1291 | ||
1292 | if (name == NULL) | |
1293 | return NULL; | |
1294 | ||
1295 | sym = gfc_use_derived (sym); | |
1296 | ||
1297 | if (sym == NULL) | |
1298 | return NULL; | |
1299 | ||
1300 | for (p = sym->components; p; p = p->next) | |
1301 | if (strcmp (p->name, name) == 0) | |
1302 | break; | |
1303 | ||
1304 | if (p == NULL) | |
1305 | gfc_error ("'%s' at %C is not a member of the '%s' structure", | |
1306 | name, sym->name); | |
1307 | else | |
1308 | { | |
1309 | if (sym->attr.use_assoc && sym->component_access == ACCESS_PRIVATE) | |
1310 | { | |
1311 | gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'", | |
1312 | name, sym->name); | |
1313 | p = NULL; | |
1314 | } | |
1315 | } | |
1316 | ||
1317 | return p; | |
1318 | } | |
1319 | ||
1320 | ||
1321 | /* Given a symbol, free all of the component structures and everything | |
1322 | they point to. */ | |
1323 | ||
1324 | static void | |
1325 | free_components (gfc_component * p) | |
1326 | { | |
1327 | gfc_component *q; | |
1328 | ||
1329 | for (; p; p = q) | |
1330 | { | |
1331 | q = p->next; | |
1332 | ||
1333 | gfc_free_array_spec (p->as); | |
1334 | gfc_free_expr (p->initializer); | |
1335 | ||
1336 | gfc_free (p); | |
1337 | } | |
1338 | } | |
1339 | ||
1340 | ||
1341 | /* Set component attributes from a standard symbol attribute | |
1342 | structure. */ | |
1343 | ||
1344 | void | |
1345 | gfc_set_component_attr (gfc_component * c, symbol_attribute * attr) | |
1346 | { | |
1347 | ||
1348 | c->dimension = attr->dimension; | |
1349 | c->pointer = attr->pointer; | |
1350 | } | |
1351 | ||
1352 | ||
1353 | /* Get a standard symbol attribute structure given the component | |
1354 | structure. */ | |
1355 | ||
1356 | void | |
1357 | gfc_get_component_attr (symbol_attribute * attr, gfc_component * c) | |
1358 | { | |
1359 | ||
1360 | gfc_clear_attr (attr); | |
1361 | attr->dimension = c->dimension; | |
1362 | attr->pointer = c->pointer; | |
1363 | } | |
1364 | ||
1365 | ||
1366 | /******************** Statement label management ********************/ | |
1367 | ||
1368 | /* Free a single gfc_st_label structure, making sure the list is not | |
1369 | messed up. This function is called only when some parse error | |
1370 | occurs. */ | |
1371 | ||
1372 | void | |
1373 | gfc_free_st_label (gfc_st_label * l) | |
1374 | { | |
1375 | ||
1376 | if (l == NULL) | |
1377 | return; | |
1378 | ||
1379 | if (l->prev) | |
1380 | (l->prev->next = l->next); | |
1381 | ||
1382 | if (l->next) | |
1383 | (l->next->prev = l->prev); | |
1384 | ||
1385 | if (l->format != NULL) | |
1386 | gfc_free_expr (l->format); | |
1387 | gfc_free (l); | |
1388 | } | |
1389 | ||
1390 | /* Free a whole list of gfc_st_label structures. */ | |
1391 | ||
1392 | static void | |
1393 | free_st_labels (gfc_st_label * l1) | |
1394 | { | |
1395 | gfc_st_label *l2; | |
1396 | ||
1397 | for (; l1; l1 = l2) | |
1398 | { | |
1399 | l2 = l1->next; | |
1400 | if (l1->format != NULL) | |
1401 | gfc_free_expr (l1->format); | |
1402 | gfc_free (l1); | |
1403 | } | |
1404 | } | |
1405 | ||
1406 | ||
1407 | /* Given a label number, search for and return a pointer to the label | |
1408 | structure, creating it if it does not exist. */ | |
1409 | ||
1410 | gfc_st_label * | |
1411 | gfc_get_st_label (int labelno) | |
1412 | { | |
1413 | gfc_st_label *lp; | |
1414 | ||
1415 | /* First see if the label is already in this namespace. */ | |
1416 | for (lp = gfc_current_ns->st_labels; lp; lp = lp->next) | |
1417 | if (lp->value == labelno) | |
1418 | break; | |
1419 | if (lp != NULL) | |
1420 | return lp; | |
1421 | ||
1422 | lp = gfc_getmem (sizeof (gfc_st_label)); | |
1423 | ||
1424 | lp->value = labelno; | |
1425 | lp->defined = ST_LABEL_UNKNOWN; | |
1426 | lp->referenced = ST_LABEL_UNKNOWN; | |
1427 | ||
1428 | lp->prev = NULL; | |
1429 | lp->next = gfc_current_ns->st_labels; | |
1430 | if (gfc_current_ns->st_labels) | |
1431 | gfc_current_ns->st_labels->prev = lp; | |
1432 | gfc_current_ns->st_labels = lp; | |
1433 | ||
1434 | return lp; | |
1435 | } | |
1436 | ||
1437 | ||
1438 | /* Called when a statement with a statement label is about to be | |
1439 | accepted. We add the label to the list of the current namespace, | |
1440 | making sure it hasn't been defined previously and referenced | |
1441 | correctly. */ | |
1442 | ||
1443 | void | |
1444 | gfc_define_st_label (gfc_st_label * lp, gfc_sl_type type, locus * label_locus) | |
1445 | { | |
1446 | int labelno; | |
1447 | ||
1448 | labelno = lp->value; | |
1449 | ||
1450 | if (lp->defined != ST_LABEL_UNKNOWN) | |
1451 | gfc_error ("Duplicate statement label %d at %L and %L", labelno, | |
1452 | &lp->where, label_locus); | |
1453 | else | |
1454 | { | |
1455 | lp->where = *label_locus; | |
1456 | ||
1457 | switch (type) | |
1458 | { | |
1459 | case ST_LABEL_FORMAT: | |
1460 | if (lp->referenced == ST_LABEL_TARGET) | |
1461 | gfc_error ("Label %d at %C already referenced as branch target", | |
1462 | labelno); | |
1463 | else | |
1464 | lp->defined = ST_LABEL_FORMAT; | |
1465 | ||
1466 | break; | |
1467 | ||
1468 | case ST_LABEL_TARGET: | |
1469 | if (lp->referenced == ST_LABEL_FORMAT) | |
1470 | gfc_error ("Label %d at %C already referenced as a format label", | |
1471 | labelno); | |
1472 | else | |
1473 | lp->defined = ST_LABEL_TARGET; | |
1474 | ||
1475 | break; | |
1476 | ||
1477 | default: | |
1478 | lp->defined = ST_LABEL_BAD_TARGET; | |
1479 | lp->referenced = ST_LABEL_BAD_TARGET; | |
1480 | } | |
1481 | } | |
1482 | } | |
1483 | ||
1484 | ||
1485 | /* Reference a label. Given a label and its type, see if that | |
1486 | reference is consistent with what is known about that label, | |
1487 | updating the unknown state. Returns FAILURE if something goes | |
1488 | wrong. */ | |
1489 | ||
1490 | try | |
1491 | gfc_reference_st_label (gfc_st_label * lp, gfc_sl_type type) | |
1492 | { | |
1493 | gfc_sl_type label_type; | |
1494 | int labelno; | |
1495 | try rc; | |
1496 | ||
1497 | if (lp == NULL) | |
1498 | return SUCCESS; | |
1499 | ||
1500 | labelno = lp->value; | |
1501 | ||
1502 | if (lp->defined != ST_LABEL_UNKNOWN) | |
1503 | label_type = lp->defined; | |
1504 | else | |
1505 | { | |
1506 | label_type = lp->referenced; | |
63645982 | 1507 | lp->where = gfc_current_locus; |
6de9cd9a DN |
1508 | } |
1509 | ||
1510 | if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET) | |
1511 | { | |
1512 | gfc_error ("Label %d at %C previously used as a FORMAT label", labelno); | |
1513 | rc = FAILURE; | |
1514 | goto done; | |
1515 | } | |
1516 | ||
1517 | if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET) | |
1518 | && type == ST_LABEL_FORMAT) | |
1519 | { | |
1520 | gfc_error ("Label %d at %C previously used as branch target", labelno); | |
1521 | rc = FAILURE; | |
1522 | goto done; | |
1523 | } | |
1524 | ||
1525 | lp->referenced = type; | |
1526 | rc = SUCCESS; | |
1527 | ||
1528 | done: | |
1529 | return rc; | |
1530 | } | |
1531 | ||
1532 | ||
1533 | /************** Symbol table management subroutines ****************/ | |
1534 | ||
1535 | /* Basic details: Fortran 95 requires a potentially unlimited number | |
1536 | of distinct namespaces when compiling a program unit. This case | |
1537 | occurs during a compilation of internal subprograms because all of | |
1538 | the internal subprograms must be read before we can start | |
1539 | generating code for the host. | |
1540 | ||
eebc3ee0 | 1541 | Given the tricky nature of the Fortran grammar, we must be able to |
6de9cd9a DN |
1542 | undo changes made to a symbol table if the current interpretation |
1543 | of a statement is found to be incorrect. Whenever a symbol is | |
1544 | looked up, we make a copy of it and link to it. All of these | |
1545 | symbols are kept in a singly linked list so that we can commit or | |
1546 | undo the changes at a later time. | |
1547 | ||
4f613946 | 1548 | A symtree may point to a symbol node outside of its namespace. In |
6de9cd9a DN |
1549 | this case, that symbol has been used as a host associated variable |
1550 | at some previous time. */ | |
1551 | ||
0366dfe9 TS |
1552 | /* Allocate a new namespace structure. Copies the implicit types from |
1553 | PARENT if PARENT_TYPES is set. */ | |
6de9cd9a DN |
1554 | |
1555 | gfc_namespace * | |
0366dfe9 | 1556 | gfc_get_namespace (gfc_namespace * parent, int parent_types) |
6de9cd9a DN |
1557 | { |
1558 | gfc_namespace *ns; | |
1559 | gfc_typespec *ts; | |
1560 | gfc_intrinsic_op in; | |
1561 | int i; | |
1562 | ||
1563 | ns = gfc_getmem (sizeof (gfc_namespace)); | |
1564 | ns->sym_root = NULL; | |
1565 | ns->uop_root = NULL; | |
1566 | ns->default_access = ACCESS_UNKNOWN; | |
1567 | ns->parent = parent; | |
1568 | ||
1569 | for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++) | |
1570 | ns->operator_access[in] = ACCESS_UNKNOWN; | |
1571 | ||
1572 | /* Initialize default implicit types. */ | |
1573 | for (i = 'a'; i <= 'z'; i++) | |
1574 | { | |
1575 | ns->set_flag[i - 'a'] = 0; | |
1576 | ts = &ns->default_type[i - 'a']; | |
1577 | ||
0366dfe9 | 1578 | if (parent_types && ns->parent != NULL) |
6de9cd9a DN |
1579 | { |
1580 | /* Copy parent settings */ | |
1581 | *ts = ns->parent->default_type[i - 'a']; | |
1582 | continue; | |
1583 | } | |
1584 | ||
1585 | if (gfc_option.flag_implicit_none != 0) | |
1586 | { | |
1587 | gfc_clear_ts (ts); | |
1588 | continue; | |
1589 | } | |
1590 | ||
1591 | if ('i' <= i && i <= 'n') | |
1592 | { | |
1593 | ts->type = BT_INTEGER; | |
9d64df18 | 1594 | ts->kind = gfc_default_integer_kind; |
6de9cd9a DN |
1595 | } |
1596 | else | |
1597 | { | |
1598 | ts->type = BT_REAL; | |
9d64df18 | 1599 | ts->kind = gfc_default_real_kind; |
6de9cd9a DN |
1600 | } |
1601 | } | |
1602 | ||
3d79abbd PB |
1603 | ns->refs = 1; |
1604 | ||
6de9cd9a DN |
1605 | return ns; |
1606 | } | |
1607 | ||
1608 | ||
1609 | /* Comparison function for symtree nodes. */ | |
1610 | ||
1611 | static int | |
1612 | compare_symtree (void * _st1, void * _st2) | |
1613 | { | |
1614 | gfc_symtree *st1, *st2; | |
1615 | ||
1616 | st1 = (gfc_symtree *) _st1; | |
1617 | st2 = (gfc_symtree *) _st2; | |
1618 | ||
1619 | return strcmp (st1->name, st2->name); | |
1620 | } | |
1621 | ||
1622 | ||
1623 | /* Allocate a new symtree node and associate it with the new symbol. */ | |
1624 | ||
1625 | gfc_symtree * | |
1626 | gfc_new_symtree (gfc_symtree ** root, const char *name) | |
1627 | { | |
1628 | gfc_symtree *st; | |
1629 | ||
1630 | st = gfc_getmem (sizeof (gfc_symtree)); | |
cb9e4f55 | 1631 | st->name = gfc_get_string (name); |
6de9cd9a DN |
1632 | |
1633 | gfc_insert_bbt (root, st, compare_symtree); | |
1634 | return st; | |
1635 | } | |
1636 | ||
1637 | ||
1638 | /* Delete a symbol from the tree. Does not free the symbol itself! */ | |
1639 | ||
1640 | static void | |
1641 | delete_symtree (gfc_symtree ** root, const char *name) | |
1642 | { | |
1643 | gfc_symtree st, *st0; | |
1644 | ||
1645 | st0 = gfc_find_symtree (*root, name); | |
1646 | ||
cb9e4f55 | 1647 | st.name = gfc_get_string (name); |
6de9cd9a DN |
1648 | gfc_delete_bbt (root, &st, compare_symtree); |
1649 | ||
1650 | gfc_free (st0); | |
1651 | } | |
1652 | ||
1653 | ||
1654 | /* Given a root symtree node and a name, try to find the symbol within | |
1655 | the namespace. Returns NULL if the symbol is not found. */ | |
1656 | ||
1657 | gfc_symtree * | |
1658 | gfc_find_symtree (gfc_symtree * st, const char *name) | |
1659 | { | |
1660 | int c; | |
1661 | ||
1662 | while (st != NULL) | |
1663 | { | |
1664 | c = strcmp (name, st->name); | |
1665 | if (c == 0) | |
1666 | return st; | |
1667 | ||
1668 | st = (c < 0) ? st->left : st->right; | |
1669 | } | |
1670 | ||
1671 | return NULL; | |
1672 | } | |
1673 | ||
1674 | ||
1675 | /* Given a name find a user operator node, creating it if it doesn't | |
1676 | exist. These are much simpler than symbols because they can't be | |
1677 | ambiguous with one another. */ | |
1678 | ||
1679 | gfc_user_op * | |
1680 | gfc_get_uop (const char *name) | |
1681 | { | |
1682 | gfc_user_op *uop; | |
1683 | gfc_symtree *st; | |
1684 | ||
1685 | st = gfc_find_symtree (gfc_current_ns->uop_root, name); | |
1686 | if (st != NULL) | |
1687 | return st->n.uop; | |
1688 | ||
1689 | st = gfc_new_symtree (&gfc_current_ns->uop_root, name); | |
1690 | ||
1691 | uop = st->n.uop = gfc_getmem (sizeof (gfc_user_op)); | |
cb9e4f55 | 1692 | uop->name = gfc_get_string (name); |
6de9cd9a DN |
1693 | uop->access = ACCESS_UNKNOWN; |
1694 | uop->ns = gfc_current_ns; | |
1695 | ||
1696 | return uop; | |
1697 | } | |
1698 | ||
1699 | ||
1700 | /* Given a name find the user operator node. Returns NULL if it does | |
1701 | not exist. */ | |
1702 | ||
1703 | gfc_user_op * | |
1704 | gfc_find_uop (const char *name, gfc_namespace * ns) | |
1705 | { | |
1706 | gfc_symtree *st; | |
1707 | ||
1708 | if (ns == NULL) | |
1709 | ns = gfc_current_ns; | |
1710 | ||
1711 | st = gfc_find_symtree (ns->uop_root, name); | |
1712 | return (st == NULL) ? NULL : st->n.uop; | |
1713 | } | |
1714 | ||
1715 | ||
1716 | /* Remove a gfc_symbol structure and everything it points to. */ | |
1717 | ||
1718 | void | |
1719 | gfc_free_symbol (gfc_symbol * sym) | |
1720 | { | |
1721 | ||
1722 | if (sym == NULL) | |
1723 | return; | |
1724 | ||
1725 | gfc_free_array_spec (sym->as); | |
1726 | ||
1727 | free_components (sym->components); | |
1728 | ||
1729 | gfc_free_expr (sym->value); | |
1730 | ||
1731 | gfc_free_namelist (sym->namelist); | |
1732 | ||
1733 | gfc_free_namespace (sym->formal_ns); | |
1734 | ||
1735 | gfc_free_interface (sym->generic); | |
1736 | ||
1737 | gfc_free_formal_arglist (sym->formal); | |
1738 | ||
1739 | gfc_free (sym); | |
1740 | } | |
1741 | ||
1742 | ||
1743 | /* Allocate and initialize a new symbol node. */ | |
1744 | ||
1745 | gfc_symbol * | |
1746 | gfc_new_symbol (const char *name, gfc_namespace * ns) | |
1747 | { | |
1748 | gfc_symbol *p; | |
1749 | ||
1750 | p = gfc_getmem (sizeof (gfc_symbol)); | |
1751 | ||
1752 | gfc_clear_ts (&p->ts); | |
1753 | gfc_clear_attr (&p->attr); | |
1754 | p->ns = ns; | |
1755 | ||
63645982 | 1756 | p->declared_at = gfc_current_locus; |
6de9cd9a DN |
1757 | |
1758 | if (strlen (name) > GFC_MAX_SYMBOL_LEN) | |
1759 | gfc_internal_error ("new_symbol(): Symbol name too long"); | |
1760 | ||
cb9e4f55 | 1761 | p->name = gfc_get_string (name); |
6de9cd9a DN |
1762 | return p; |
1763 | } | |
1764 | ||
1765 | ||
1766 | /* Generate an error if a symbol is ambiguous. */ | |
1767 | ||
1768 | static void | |
1769 | ambiguous_symbol (const char *name, gfc_symtree * st) | |
1770 | { | |
1771 | ||
cb9e4f55 | 1772 | if (st->n.sym->module) |
6de9cd9a DN |
1773 | gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " |
1774 | "from module '%s'", name, st->n.sym->name, st->n.sym->module); | |
1775 | else | |
1776 | gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' " | |
1777 | "from current program unit", name, st->n.sym->name); | |
1778 | } | |
1779 | ||
1780 | ||
294fbfc8 | 1781 | /* Search for a symtree starting in the current namespace, resorting to |
6de9cd9a | 1782 | any parent namespaces if requested by a nonzero parent_flag. |
294fbfc8 | 1783 | Returns nonzero if the name is ambiguous. */ |
6de9cd9a DN |
1784 | |
1785 | int | |
1786 | gfc_find_sym_tree (const char *name, gfc_namespace * ns, int parent_flag, | |
294fbfc8 | 1787 | gfc_symtree ** result) |
6de9cd9a DN |
1788 | { |
1789 | gfc_symtree *st; | |
1790 | ||
1791 | if (ns == NULL) | |
1792 | ns = gfc_current_ns; | |
1793 | ||
1794 | do | |
1795 | { | |
1796 | st = gfc_find_symtree (ns->sym_root, name); | |
1797 | if (st != NULL) | |
1798 | { | |
1799 | *result = st; | |
1800 | if (st->ambiguous) | |
1801 | { | |
1802 | ambiguous_symbol (name, st); | |
1803 | return 1; | |
1804 | } | |
1805 | ||
1806 | return 0; | |
1807 | } | |
1808 | ||
1809 | if (!parent_flag) | |
1810 | break; | |
1811 | ||
1812 | ns = ns->parent; | |
1813 | } | |
1814 | while (ns != NULL); | |
1815 | ||
1816 | *result = NULL; | |
1817 | return 0; | |
1818 | } | |
1819 | ||
1820 | ||
294fbfc8 TS |
1821 | /* Same, but returns the symbol instead. */ |
1822 | ||
6de9cd9a DN |
1823 | int |
1824 | gfc_find_symbol (const char *name, gfc_namespace * ns, int parent_flag, | |
1825 | gfc_symbol ** result) | |
1826 | { | |
1827 | gfc_symtree *st; | |
1828 | int i; | |
1829 | ||
1830 | i = gfc_find_sym_tree (name, ns, parent_flag, &st); | |
1831 | ||
1832 | if (st == NULL) | |
1833 | *result = NULL; | |
1834 | else | |
1835 | *result = st->n.sym; | |
1836 | ||
1837 | return i; | |
1838 | } | |
1839 | ||
1840 | ||
1841 | /* Save symbol with the information necessary to back it out. */ | |
1842 | ||
1843 | static void | |
1844 | save_symbol_data (gfc_symbol * sym) | |
1845 | { | |
1846 | ||
1847 | if (sym->new || sym->old_symbol != NULL) | |
1848 | return; | |
1849 | ||
1850 | sym->old_symbol = gfc_getmem (sizeof (gfc_symbol)); | |
1851 | *(sym->old_symbol) = *sym; | |
1852 | ||
1853 | sym->tlink = changed_syms; | |
1854 | changed_syms = sym; | |
1855 | } | |
1856 | ||
1857 | ||
1858 | /* Given a name, find a symbol, or create it if it does not exist yet | |
1859 | in the current namespace. If the symbol is found we make sure that | |
1860 | it's OK. | |
1861 | ||
1862 | The integer return code indicates | |
1863 | 0 All OK | |
1864 | 1 The symbol name was ambiguous | |
1865 | 2 The name meant to be established was already host associated. | |
1866 | ||
1867 | So if the return value is nonzero, then an error was issued. */ | |
1868 | ||
1869 | int | |
1870 | gfc_get_sym_tree (const char *name, gfc_namespace * ns, gfc_symtree ** result) | |
1871 | { | |
1872 | gfc_symtree *st; | |
1873 | gfc_symbol *p; | |
1874 | ||
1875 | /* This doesn't usually happen during resolution. */ | |
1876 | if (ns == NULL) | |
1877 | ns = gfc_current_ns; | |
1878 | ||
1879 | /* Try to find the symbol in ns. */ | |
1880 | st = gfc_find_symtree (ns->sym_root, name); | |
1881 | ||
1882 | if (st == NULL) | |
1883 | { | |
1884 | /* If not there, create a new symbol. */ | |
1885 | p = gfc_new_symbol (name, ns); | |
1886 | ||
1887 | /* Add to the list of tentative symbols. */ | |
1888 | p->old_symbol = NULL; | |
1889 | p->tlink = changed_syms; | |
1890 | p->mark = 1; | |
1891 | p->new = 1; | |
1892 | changed_syms = p; | |
1893 | ||
1894 | st = gfc_new_symtree (&ns->sym_root, name); | |
1895 | st->n.sym = p; | |
1896 | p->refs++; | |
1897 | ||
1898 | } | |
1899 | else | |
1900 | { | |
1901 | /* Make sure the existing symbol is OK. */ | |
1902 | if (st->ambiguous) | |
1903 | { | |
1904 | ambiguous_symbol (name, st); | |
1905 | return 1; | |
1906 | } | |
1907 | ||
1908 | p = st->n.sym; | |
1909 | ||
1910 | if (p->ns != ns && (!p->attr.function || ns->proc_name != p)) | |
1911 | { | |
1912 | /* Symbol is from another namespace. */ | |
1913 | gfc_error ("Symbol '%s' at %C has already been host associated", | |
1914 | name); | |
1915 | return 2; | |
1916 | } | |
1917 | ||
1918 | p->mark = 1; | |
1919 | ||
1920 | /* Copy in case this symbol is changed. */ | |
1921 | save_symbol_data (p); | |
1922 | } | |
1923 | ||
1924 | *result = st; | |
1925 | return 0; | |
1926 | } | |
1927 | ||
1928 | ||
1929 | int | |
1930 | gfc_get_symbol (const char *name, gfc_namespace * ns, gfc_symbol ** result) | |
1931 | { | |
1932 | gfc_symtree *st; | |
1933 | int i; | |
1934 | ||
1935 | ||
1936 | i = gfc_get_sym_tree (name, ns, &st); | |
1937 | if (i != 0) | |
1938 | return i; | |
1939 | ||
1940 | if (st) | |
1941 | *result = st->n.sym; | |
1942 | else | |
1943 | *result = NULL; | |
1944 | return i; | |
1945 | } | |
1946 | ||
1947 | ||
1948 | /* Subroutine that searches for a symbol, creating it if it doesn't | |
1949 | exist, but tries to host-associate the symbol if possible. */ | |
1950 | ||
1951 | int | |
1952 | gfc_get_ha_sym_tree (const char *name, gfc_symtree ** result) | |
1953 | { | |
1954 | gfc_symtree *st; | |
1955 | int i; | |
1956 | ||
1957 | i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st); | |
1958 | if (st != NULL) | |
1959 | { | |
1960 | save_symbol_data (st->n.sym); | |
1961 | ||
1962 | *result = st; | |
1963 | return i; | |
1964 | } | |
1965 | ||
1966 | if (gfc_current_ns->parent != NULL) | |
1967 | { | |
1968 | i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st); | |
1969 | if (i) | |
1970 | return i; | |
1971 | ||
1972 | if (st != NULL) | |
1973 | { | |
1974 | *result = st; | |
1975 | return 0; | |
1976 | } | |
1977 | } | |
1978 | ||
1979 | return gfc_get_sym_tree (name, gfc_current_ns, result); | |
1980 | } | |
1981 | ||
1982 | ||
1983 | int | |
1984 | gfc_get_ha_symbol (const char *name, gfc_symbol ** result) | |
1985 | { | |
1986 | int i; | |
1987 | gfc_symtree *st; | |
1988 | ||
1989 | i = gfc_get_ha_sym_tree (name, &st); | |
1990 | ||
1991 | if (st) | |
1992 | *result = st->n.sym; | |
1993 | else | |
1994 | *result = NULL; | |
1995 | ||
1996 | return i; | |
1997 | } | |
1998 | ||
1999 | /* Return true if both symbols could refer to the same data object. Does | |
2000 | not take account of aliasing due to equivalence statements. */ | |
2001 | ||
2002 | int | |
2003 | gfc_symbols_could_alias (gfc_symbol * lsym, gfc_symbol * rsym) | |
2004 | { | |
2005 | /* Aliasing isn't possible if the symbols have different base types. */ | |
2006 | if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0) | |
2007 | return 0; | |
2008 | ||
2009 | /* Pointers can point to other pointers, target objects and allocatable | |
2010 | objects. Two allocatable objects cannot share the same storage. */ | |
2011 | if (lsym->attr.pointer | |
2012 | && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target)) | |
2013 | return 1; | |
2014 | if (lsym->attr.target && rsym->attr.pointer) | |
2015 | return 1; | |
2016 | if (lsym->attr.allocatable && rsym->attr.pointer) | |
2017 | return 1; | |
2018 | ||
2019 | return 0; | |
2020 | } | |
2021 | ||
2022 | ||
2023 | /* Undoes all the changes made to symbols in the current statement. | |
2024 | This subroutine is made simpler due to the fact that attributes are | |
2025 | never removed once added. */ | |
2026 | ||
2027 | void | |
2028 | gfc_undo_symbols (void) | |
2029 | { | |
2030 | gfc_symbol *p, *q, *old; | |
2031 | ||
2032 | for (p = changed_syms; p; p = q) | |
2033 | { | |
2034 | q = p->tlink; | |
2035 | ||
2036 | if (p->new) | |
2037 | { | |
2038 | /* Symbol was new. */ | |
2039 | delete_symtree (&p->ns->sym_root, p->name); | |
2040 | ||
2041 | p->refs--; | |
2042 | if (p->refs < 0) | |
2043 | gfc_internal_error ("gfc_undo_symbols(): Negative refs"); | |
2044 | if (p->refs == 0) | |
2045 | gfc_free_symbol (p); | |
2046 | continue; | |
2047 | } | |
2048 | ||
2049 | /* Restore previous state of symbol. Just copy simple stuff. */ | |
2050 | p->mark = 0; | |
2051 | old = p->old_symbol; | |
2052 | ||
2053 | p->ts.type = old->ts.type; | |
2054 | p->ts.kind = old->ts.kind; | |
2055 | ||
2056 | p->attr = old->attr; | |
2057 | ||
2058 | if (p->value != old->value) | |
2059 | { | |
2060 | gfc_free_expr (old->value); | |
2061 | p->value = NULL; | |
2062 | } | |
2063 | ||
2064 | if (p->as != old->as) | |
2065 | { | |
2066 | if (p->as) | |
2067 | gfc_free_array_spec (p->as); | |
2068 | p->as = old->as; | |
2069 | } | |
2070 | ||
2071 | p->generic = old->generic; | |
2072 | p->component_access = old->component_access; | |
2073 | ||
2074 | if (p->namelist != NULL && old->namelist == NULL) | |
2075 | { | |
2076 | gfc_free_namelist (p->namelist); | |
2077 | p->namelist = NULL; | |
2078 | } | |
2079 | else | |
2080 | { | |
2081 | ||
2082 | if (p->namelist_tail != old->namelist_tail) | |
2083 | { | |
2084 | gfc_free_namelist (old->namelist_tail); | |
2085 | old->namelist_tail->next = NULL; | |
2086 | } | |
2087 | } | |
2088 | ||
2089 | p->namelist_tail = old->namelist_tail; | |
2090 | ||
2091 | if (p->formal != old->formal) | |
2092 | { | |
2093 | gfc_free_formal_arglist (p->formal); | |
2094 | p->formal = old->formal; | |
2095 | } | |
2096 | ||
2097 | gfc_free (p->old_symbol); | |
2098 | p->old_symbol = NULL; | |
2099 | p->tlink = NULL; | |
2100 | } | |
2101 | ||
2102 | changed_syms = NULL; | |
2103 | } | |
2104 | ||
2105 | ||
2106 | /* Makes the changes made in the current statement permanent-- gets | |
2107 | rid of undo information. */ | |
2108 | ||
2109 | void | |
2110 | gfc_commit_symbols (void) | |
2111 | { | |
2112 | gfc_symbol *p, *q; | |
2113 | ||
2114 | for (p = changed_syms; p; p = q) | |
2115 | { | |
2116 | q = p->tlink; | |
2117 | p->tlink = NULL; | |
2118 | p->mark = 0; | |
2119 | p->new = 0; | |
2120 | ||
2121 | if (p->old_symbol != NULL) | |
2122 | { | |
2123 | gfc_free (p->old_symbol); | |
2124 | p->old_symbol = NULL; | |
2125 | } | |
2126 | } | |
2127 | ||
2128 | changed_syms = NULL; | |
2129 | } | |
2130 | ||
2131 | ||
53814b8f TS |
2132 | /* Recursive function that deletes an entire tree and all the common |
2133 | head structures it points to. */ | |
2134 | ||
2135 | static void | |
2136 | free_common_tree (gfc_symtree * common_tree) | |
2137 | { | |
2138 | if (common_tree == NULL) | |
2139 | return; | |
2140 | ||
2141 | free_common_tree (common_tree->left); | |
2142 | free_common_tree (common_tree->right); | |
2143 | ||
2144 | gfc_free (common_tree); | |
2145 | } | |
2146 | ||
2147 | ||
6de9cd9a DN |
2148 | /* Recursive function that deletes an entire tree and all the user |
2149 | operator nodes that it contains. */ | |
2150 | ||
2151 | static void | |
2152 | free_uop_tree (gfc_symtree * uop_tree) | |
2153 | { | |
2154 | ||
2155 | if (uop_tree == NULL) | |
2156 | return; | |
2157 | ||
2158 | free_uop_tree (uop_tree->left); | |
2159 | free_uop_tree (uop_tree->right); | |
2160 | ||
2161 | gfc_free_interface (uop_tree->n.uop->operator); | |
2162 | ||
2163 | gfc_free (uop_tree->n.uop); | |
2164 | gfc_free (uop_tree); | |
2165 | } | |
2166 | ||
2167 | ||
2168 | /* Recursive function that deletes an entire tree and all the symbols | |
2169 | that it contains. */ | |
2170 | ||
2171 | static void | |
2172 | free_sym_tree (gfc_symtree * sym_tree) | |
2173 | { | |
2174 | gfc_namespace *ns; | |
2175 | gfc_symbol *sym; | |
2176 | ||
2177 | if (sym_tree == NULL) | |
2178 | return; | |
2179 | ||
2180 | free_sym_tree (sym_tree->left); | |
2181 | free_sym_tree (sym_tree->right); | |
2182 | ||
2183 | sym = sym_tree->n.sym; | |
2184 | ||
2185 | sym->refs--; | |
2186 | if (sym->refs < 0) | |
2187 | gfc_internal_error ("free_sym_tree(): Negative refs"); | |
2188 | ||
2189 | if (sym->formal_ns != NULL && sym->refs == 1) | |
2190 | { | |
2191 | /* As formal_ns contains a reference to sym, delete formal_ns just | |
2192 | before the deletion of sym. */ | |
2193 | ns = sym->formal_ns; | |
2194 | sym->formal_ns = NULL; | |
2195 | gfc_free_namespace (ns); | |
2196 | } | |
2197 | else if (sym->refs == 0) | |
2198 | { | |
2199 | /* Go ahead and delete the symbol. */ | |
2200 | gfc_free_symbol (sym); | |
2201 | } | |
2202 | ||
2203 | gfc_free (sym_tree); | |
2204 | } | |
2205 | ||
2206 | ||
2207 | /* Free a namespace structure and everything below it. Interface | |
2208 | lists associated with intrinsic operators are not freed. These are | |
2209 | taken care of when a specific name is freed. */ | |
2210 | ||
2211 | void | |
2212 | gfc_free_namespace (gfc_namespace * ns) | |
2213 | { | |
2214 | gfc_charlen *cl, *cl2; | |
2215 | gfc_namespace *p, *q; | |
2216 | gfc_intrinsic_op i; | |
2217 | ||
2218 | if (ns == NULL) | |
2219 | return; | |
2220 | ||
3d79abbd PB |
2221 | ns->refs--; |
2222 | if (ns->refs > 0) | |
2223 | return; | |
6e45f57b | 2224 | gcc_assert (ns->refs == 0); |
3d79abbd | 2225 | |
6de9cd9a DN |
2226 | gfc_free_statements (ns->code); |
2227 | ||
2228 | free_sym_tree (ns->sym_root); | |
2229 | free_uop_tree (ns->uop_root); | |
53814b8f | 2230 | free_common_tree (ns->common_root); |
6de9cd9a DN |
2231 | |
2232 | for (cl = ns->cl_list; cl; cl = cl2) | |
2233 | { | |
2234 | cl2 = cl->next; | |
2235 | gfc_free_expr (cl->length); | |
2236 | gfc_free (cl); | |
2237 | } | |
2238 | ||
2239 | free_st_labels (ns->st_labels); | |
2240 | ||
2241 | gfc_free_equiv (ns->equiv); | |
2242 | ||
2243 | for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) | |
2244 | gfc_free_interface (ns->operator[i]); | |
2245 | ||
2246 | gfc_free_data (ns->data); | |
2247 | p = ns->contained; | |
2248 | gfc_free (ns); | |
2249 | ||
2250 | /* Recursively free any contained namespaces. */ | |
2251 | while (p != NULL) | |
2252 | { | |
2253 | q = p; | |
2254 | p = p->sibling; | |
2255 | ||
2256 | gfc_free_namespace (q); | |
2257 | } | |
2258 | } | |
2259 | ||
2260 | ||
2261 | void | |
2262 | gfc_symbol_init_2 (void) | |
2263 | { | |
2264 | ||
0366dfe9 | 2265 | gfc_current_ns = gfc_get_namespace (NULL, 0); |
6de9cd9a DN |
2266 | } |
2267 | ||
2268 | ||
2269 | void | |
2270 | gfc_symbol_done_2 (void) | |
2271 | { | |
2272 | ||
2273 | gfc_free_namespace (gfc_current_ns); | |
2274 | gfc_current_ns = NULL; | |
2275 | } | |
2276 | ||
2277 | ||
2278 | /* Clear mark bits from symbol nodes associated with a symtree node. */ | |
2279 | ||
2280 | static void | |
2281 | clear_sym_mark (gfc_symtree * st) | |
2282 | { | |
2283 | ||
2284 | st->n.sym->mark = 0; | |
2285 | } | |
2286 | ||
2287 | ||
2288 | /* Recursively traverse the symtree nodes. */ | |
2289 | ||
9056bd70 TS |
2290 | void |
2291 | gfc_traverse_symtree (gfc_symtree * st, void (*func) (gfc_symtree *)) | |
6de9cd9a | 2292 | { |
6de9cd9a DN |
2293 | if (st != NULL) |
2294 | { | |
2295 | (*func) (st); | |
2296 | ||
9056bd70 TS |
2297 | gfc_traverse_symtree (st->left, func); |
2298 | gfc_traverse_symtree (st->right, func); | |
6de9cd9a DN |
2299 | } |
2300 | } | |
2301 | ||
2302 | ||
6de9cd9a DN |
2303 | /* Recursive namespace traversal function. */ |
2304 | ||
2305 | static void | |
2306 | traverse_ns (gfc_symtree * st, void (*func) (gfc_symbol *)) | |
2307 | { | |
2308 | ||
2309 | if (st == NULL) | |
2310 | return; | |
2311 | ||
2312 | if (st->n.sym->mark == 0) | |
2313 | (*func) (st->n.sym); | |
2314 | st->n.sym->mark = 1; | |
2315 | ||
2316 | traverse_ns (st->left, func); | |
2317 | traverse_ns (st->right, func); | |
2318 | } | |
2319 | ||
2320 | ||
2321 | /* Call a given function for all symbols in the namespace. We take | |
2322 | care that each gfc_symbol node is called exactly once. */ | |
2323 | ||
2324 | void | |
2325 | gfc_traverse_ns (gfc_namespace * ns, void (*func) (gfc_symbol *)) | |
2326 | { | |
2327 | ||
9056bd70 | 2328 | gfc_traverse_symtree (ns->sym_root, clear_sym_mark); |
6de9cd9a DN |
2329 | |
2330 | traverse_ns (ns->sym_root, func); | |
2331 | } | |
2332 | ||
2333 | ||
bd83e614 PB |
2334 | /* Return TRUE if the symbol is an automatic variable. */ |
2335 | static bool | |
2336 | gfc_is_var_automatic (gfc_symbol * sym) | |
2337 | { | |
2338 | /* Pointer and allocatable variables are never automatic. */ | |
2339 | if (sym->attr.pointer || sym->attr.allocatable) | |
2340 | return false; | |
2341 | /* Check for arrays with non-constant size. */ | |
2342 | if (sym->attr.dimension && sym->as | |
2343 | && !gfc_is_compile_time_shape (sym->as)) | |
2344 | return true; | |
2345 | /* Check for non-constant length character vairables. */ | |
2346 | if (sym->ts.type == BT_CHARACTER | |
2347 | && sym->ts.cl | |
2348 | && gfc_is_constant_expr (sym->ts.cl->length)) | |
2349 | return true; | |
2350 | return false; | |
2351 | } | |
2352 | ||
6de9cd9a DN |
2353 | /* Given a symbol, mark it as SAVEd if it is allowed. */ |
2354 | ||
2355 | static void | |
2356 | save_symbol (gfc_symbol * sym) | |
2357 | { | |
2358 | ||
2359 | if (sym->attr.use_assoc) | |
2360 | return; | |
2361 | ||
6de9cd9a DN |
2362 | if (sym->attr.in_common |
2363 | || sym->attr.dummy | |
2364 | || sym->attr.flavor != FL_VARIABLE) | |
2365 | return; | |
bd83e614 PB |
2366 | /* Automatic objects are not saved. */ |
2367 | if (gfc_is_var_automatic (sym)) | |
2368 | return; | |
231b2fcc | 2369 | gfc_add_save (&sym->attr, sym->name, &sym->declared_at); |
6de9cd9a DN |
2370 | } |
2371 | ||
2372 | ||
2373 | /* Mark those symbols which can be SAVEd as such. */ | |
2374 | ||
2375 | void | |
2376 | gfc_save_all (gfc_namespace * ns) | |
2377 | { | |
2378 | ||
2379 | gfc_traverse_ns (ns, save_symbol); | |
2380 | } | |
2381 | ||
2382 | ||
2383 | #ifdef GFC_DEBUG | |
2384 | /* Make sure that no changes to symbols are pending. */ | |
2385 | ||
2386 | void | |
2387 | gfc_symbol_state(void) { | |
2388 | ||
2389 | if (changed_syms != NULL) | |
2390 | gfc_internal_error("Symbol changes still pending!"); | |
2391 | } | |
2392 | #endif | |
2393 | ||
c9543002 TS |
2394 | |
2395 | /************** Global symbol handling ************/ | |
2396 | ||
2397 | ||
2398 | /* Search a tree for the global symbol. */ | |
2399 | ||
2400 | gfc_gsymbol * | |
cb9e4f55 | 2401 | gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name) |
c9543002 TS |
2402 | { |
2403 | gfc_gsymbol *s; | |
2404 | ||
2405 | if (symbol == NULL) | |
2406 | return NULL; | |
2407 | if (strcmp (symbol->name, name) == 0) | |
2408 | return symbol; | |
2409 | ||
2410 | s = gfc_find_gsymbol (symbol->left, name); | |
2411 | if (s != NULL) | |
2412 | return s; | |
2413 | ||
2414 | s = gfc_find_gsymbol (symbol->right, name); | |
2415 | if (s != NULL) | |
2416 | return s; | |
2417 | ||
2418 | return NULL; | |
2419 | } | |
2420 | ||
2421 | ||
2422 | /* Compare two global symbols. Used for managing the BB tree. */ | |
2423 | ||
2424 | static int | |
2425 | gsym_compare (void * _s1, void * _s2) | |
2426 | { | |
2427 | gfc_gsymbol *s1, *s2; | |
2428 | ||
2429 | s1 = (gfc_gsymbol *)_s1; | |
2430 | s2 = (gfc_gsymbol *)_s2; | |
2431 | return strcmp(s1->name, s2->name); | |
2432 | } | |
2433 | ||
2434 | ||
2435 | /* Get a global symbol, creating it if it doesn't exist. */ | |
2436 | ||
2437 | gfc_gsymbol * | |
cb9e4f55 | 2438 | gfc_get_gsymbol (const char *name) |
c9543002 TS |
2439 | { |
2440 | gfc_gsymbol *s; | |
2441 | ||
2442 | s = gfc_find_gsymbol (gfc_gsym_root, name); | |
2443 | if (s != NULL) | |
2444 | return s; | |
2445 | ||
2446 | s = gfc_getmem (sizeof (gfc_gsymbol)); | |
2447 | s->type = GSYM_UNKNOWN; | |
973a384d | 2448 | s->name = gfc_get_string (name); |
c9543002 TS |
2449 | |
2450 | gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare); | |
2451 | ||
2452 | return s; | |
2453 | } |