OSDN Git Service

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