OSDN Git Service

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