OSDN Git Service

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