OSDN Git Service

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