OSDN Git Service

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