OSDN Git Service

2010-06-20 Tobias Burnus <burnus@net-b.de>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / symbol.c
1 /* Maintain binary trees of symbols.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3    2009, 2010
4    Free Software Foundation, Inc.
5    Contributed by Andy Vaught
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23
24 #include "config.h"
25 #include "system.h"
26 #include "flags.h"
27 #include "gfortran.h"
28 #include "parse.h"
29 #include "match.h"
30 #include "constructor.h"
31
32
33 /* Strings for all symbol attributes.  We use these for dumping the
34    parse tree, in error messages, and also when reading and writing
35    modules.  */
36
37 const mstring flavors[] =
38 {
39   minit ("UNKNOWN-FL", FL_UNKNOWN), minit ("PROGRAM", FL_PROGRAM),
40   minit ("BLOCK-DATA", FL_BLOCK_DATA), minit ("MODULE", FL_MODULE),
41   minit ("VARIABLE", FL_VARIABLE), minit ("PARAMETER", FL_PARAMETER),
42   minit ("LABEL", FL_LABEL), minit ("PROCEDURE", FL_PROCEDURE),
43   minit ("DERIVED", FL_DERIVED), minit ("NAMELIST", FL_NAMELIST),
44   minit (NULL, -1)
45 };
46
47 const mstring procedures[] =
48 {
49     minit ("UNKNOWN-PROC", PROC_UNKNOWN),
50     minit ("MODULE-PROC", PROC_MODULE),
51     minit ("INTERNAL-PROC", PROC_INTERNAL),
52     minit ("DUMMY-PROC", PROC_DUMMY),
53     minit ("INTRINSIC-PROC", PROC_INTRINSIC),
54     minit ("EXTERNAL-PROC", PROC_EXTERNAL),
55     minit ("STATEMENT-PROC", PROC_ST_FUNCTION),
56     minit (NULL, -1)
57 };
58
59 const mstring intents[] =
60 {
61     minit ("UNKNOWN-INTENT", INTENT_UNKNOWN),
62     minit ("IN", INTENT_IN),
63     minit ("OUT", INTENT_OUT),
64     minit ("INOUT", INTENT_INOUT),
65     minit (NULL, -1)
66 };
67
68 const mstring access_types[] =
69 {
70     minit ("UNKNOWN-ACCESS", ACCESS_UNKNOWN),
71     minit ("PUBLIC", ACCESS_PUBLIC),
72     minit ("PRIVATE", ACCESS_PRIVATE),
73     minit (NULL, -1)
74 };
75
76 const mstring ifsrc_types[] =
77 {
78     minit ("UNKNOWN", IFSRC_UNKNOWN),
79     minit ("DECL", IFSRC_DECL),
80     minit ("BODY", IFSRC_IFBODY)
81 };
82
83 const mstring save_status[] =
84 {
85     minit ("UNKNOWN", SAVE_NONE),
86     minit ("EXPLICIT-SAVE", SAVE_EXPLICIT),
87     minit ("IMPLICIT-SAVE", SAVE_IMPLICIT),
88 };
89
90 /* This is to make sure the backend generates setup code in the correct
91    order.  */
92
93 static int next_dummy_order = 1;
94
95
96 gfc_namespace *gfc_current_ns;
97 gfc_namespace *gfc_global_ns_list;
98
99 gfc_gsymbol *gfc_gsym_root = NULL;
100
101 static gfc_symbol *changed_syms = NULL;
102
103 gfc_dt_list *gfc_derived_types;
104
105
106 /* List of tentative typebound-procedures.  */
107
108 typedef struct tentative_tbp
109 {
110   gfc_typebound_proc *proc;
111   struct tentative_tbp *next;
112 }
113 tentative_tbp;
114
115 static tentative_tbp *tentative_tbp_list = NULL;
116
117
118 /*********** IMPLICIT NONE and IMPLICIT statement handlers ***********/
119
120 /* The following static variable indicates whether a particular element has
121    been explicitly set or not.  */
122
123 static int new_flag[GFC_LETTERS];
124
125
126 /* Handle a correctly parsed IMPLICIT NONE.  */
127
128 void
129 gfc_set_implicit_none (void)
130 {
131   int i;
132
133   if (gfc_current_ns->seen_implicit_none)
134     {
135       gfc_error ("Duplicate IMPLICIT NONE statement at %C");
136       return;
137     }
138
139   gfc_current_ns->seen_implicit_none = 1;
140
141   for (i = 0; i < GFC_LETTERS; i++)
142     {
143       gfc_clear_ts (&gfc_current_ns->default_type[i]);
144       gfc_current_ns->set_flag[i] = 1;
145     }
146 }
147
148
149 /* Reset the implicit range flags.  */
150
151 void
152 gfc_clear_new_implicit (void)
153 {
154   int i;
155
156   for (i = 0; i < GFC_LETTERS; i++)
157     new_flag[i] = 0;
158 }
159
160
161 /* Prepare for a new implicit range.  Sets flags in new_flag[].  */
162
163 gfc_try
164 gfc_add_new_implicit_range (int c1, int c2)
165 {
166   int i;
167
168   c1 -= 'a';
169   c2 -= 'a';
170
171   for (i = c1; i <= c2; i++)
172     {
173       if (new_flag[i])
174         {
175           gfc_error ("Letter '%c' already set in IMPLICIT statement at %C",
176                      i + 'A');
177           return FAILURE;
178         }
179
180       new_flag[i] = 1;
181     }
182
183   return SUCCESS;
184 }
185
186
187 /* Add a matched implicit range for gfc_set_implicit().  Check if merging
188    the new implicit types back into the existing types will work.  */
189
190 gfc_try
191 gfc_merge_new_implicit (gfc_typespec *ts)
192 {
193   int i;
194
195   if (gfc_current_ns->seen_implicit_none)
196     {
197       gfc_error ("Cannot specify IMPLICIT at %C after IMPLICIT NONE");
198       return FAILURE;
199     }
200
201   for (i = 0; i < GFC_LETTERS; i++)
202     {
203       if (new_flag[i])
204         {
205           if (gfc_current_ns->set_flag[i])
206             {
207               gfc_error ("Letter %c already has an IMPLICIT type at %C",
208                          i + 'A');
209               return FAILURE;
210             }
211
212           gfc_current_ns->default_type[i] = *ts;
213           gfc_current_ns->implicit_loc[i] = gfc_current_locus;
214           gfc_current_ns->set_flag[i] = 1;
215         }
216     }
217   return SUCCESS;
218 }
219
220
221 /* Given a symbol, return a pointer to the typespec for its default type.  */
222
223 gfc_typespec *
224 gfc_get_default_type (const char *name, gfc_namespace *ns)
225 {
226   char letter;
227
228   letter = name[0];
229
230   if (gfc_option.flag_allow_leading_underscore && letter == '_')
231     gfc_internal_error ("Option -fallow-leading-underscore is for use only by "
232                         "gfortran developers, and should not be used for "
233                         "implicitly typed variables");
234
235   if (letter < 'a' || letter > 'z')
236     gfc_internal_error ("gfc_get_default_type(): Bad symbol '%s'", name);
237
238   if (ns == NULL)
239     ns = gfc_current_ns;
240
241   return &ns->default_type[letter - 'a'];
242 }
243
244
245 /* Given a pointer to a symbol, set its type according to the first
246    letter of its name.  Fails if the letter in question has no default
247    type.  */
248
249 gfc_try
250 gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns)
251 {
252   gfc_typespec *ts;
253
254   if (sym->ts.type != BT_UNKNOWN)
255     gfc_internal_error ("gfc_set_default_type(): symbol already has a type");
256
257   ts = gfc_get_default_type (sym->name, ns);
258
259   if (ts->type == BT_UNKNOWN)
260     {
261       if (error_flag && !sym->attr.untyped)
262         {
263           gfc_error ("Symbol '%s' at %L has no IMPLICIT type",
264                      sym->name, &sym->declared_at);
265           sym->attr.untyped = 1; /* Ensure we only give an error once.  */
266         }
267
268       return FAILURE;
269     }
270
271   sym->ts = *ts;
272   sym->attr.implicit_type = 1;
273
274   if (ts->type == BT_CHARACTER && ts->u.cl)
275     sym->ts.u.cl = gfc_new_charlen (sym->ns, ts->u.cl);
276
277   if (sym->attr.is_bind_c == 1)
278     {
279       /* BIND(C) variables should not be implicitly declared.  */
280       gfc_warning_now ("Implicitly declared BIND(C) variable '%s' at %L may "
281                        "not be C interoperable", sym->name, &sym->declared_at);
282       sym->ts.f90_type = sym->ts.type;
283     }
284
285   if (sym->attr.dummy != 0)
286     {
287       if (sym->ns->proc_name != NULL
288           && (sym->ns->proc_name->attr.subroutine != 0
289               || sym->ns->proc_name->attr.function != 0)
290           && sym->ns->proc_name->attr.is_bind_c != 0)
291         {
292           /* Dummy args to a BIND(C) routine may not be interoperable if
293              they are implicitly typed.  */
294           gfc_warning_now ("Implicitly declared variable '%s' at %L may not "
295                            "be C interoperable but it is a dummy argument to "
296                            "the BIND(C) procedure '%s' at %L", sym->name,
297                            &(sym->declared_at), sym->ns->proc_name->name,
298                            &(sym->ns->proc_name->declared_at));
299           sym->ts.f90_type = sym->ts.type;
300         }
301     }
302   
303   return SUCCESS;
304 }
305
306
307 /* This function is called from parse.c(parse_progunit) to check the
308    type of the function is not implicitly typed in the host namespace
309    and to implicitly type the function result, if necessary.  */
310
311 void
312 gfc_check_function_type (gfc_namespace *ns)
313 {
314   gfc_symbol *proc = ns->proc_name;
315
316   if (!proc->attr.contained || proc->result->attr.implicit_type)
317     return;
318
319   if (proc->result->ts.type == BT_UNKNOWN && proc->result->ts.interface == NULL)
320     {
321       if (gfc_set_default_type (proc->result, 0, gfc_current_ns)
322                 == SUCCESS)
323         {
324           if (proc->result != proc)
325             {
326               proc->ts = proc->result->ts;
327               proc->as = gfc_copy_array_spec (proc->result->as);
328               proc->attr.dimension = proc->result->attr.dimension;
329               proc->attr.pointer = proc->result->attr.pointer;
330               proc->attr.allocatable = proc->result->attr.allocatable;
331             }
332         }
333       else if (!proc->result->attr.proc_pointer)
334         {
335           gfc_error ("Function result '%s' at %L has no IMPLICIT type",
336                      proc->result->name, &proc->result->declared_at);
337           proc->result->attr.untyped = 1;
338         }
339     }
340 }
341
342
343 /******************** Symbol attribute stuff *********************/
344
345 /* This is a generic conflict-checker.  We do this to avoid having a
346    single conflict in two places.  */
347
348 #define conf(a, b) if (attr->a && attr->b) { a1 = a; a2 = b; goto conflict; }
349 #define conf2(a) if (attr->a) { a2 = a; goto conflict; }
350 #define conf_std(a, b, std) if (attr->a && attr->b)\
351                               {\
352                                 a1 = a;\
353                                 a2 = b;\
354                                 standard = std;\
355                                 goto conflict_std;\
356                               }
357
358 static gfc_try
359 check_conflict (symbol_attribute *attr, const char *name, locus *where)
360 {
361   static const char *dummy = "DUMMY", *save = "SAVE", *pointer = "POINTER",
362     *target = "TARGET", *external = "EXTERNAL", *intent = "INTENT",
363     *intent_in = "INTENT(IN)", *intrinsic = "INTRINSIC",
364     *intent_out = "INTENT(OUT)", *intent_inout = "INTENT(INOUT)",
365     *allocatable = "ALLOCATABLE", *elemental = "ELEMENTAL",
366     *privat = "PRIVATE", *recursive = "RECURSIVE",
367     *in_common = "COMMON", *result = "RESULT", *in_namelist = "NAMELIST",
368     *publik = "PUBLIC", *optional = "OPTIONAL", *entry = "ENTRY",
369     *function = "FUNCTION", *subroutine = "SUBROUTINE",
370     *dimension = "DIMENSION", *in_equivalence = "EQUIVALENCE",
371     *use_assoc = "USE ASSOCIATED", *cray_pointer = "CRAY POINTER",
372     *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE",
373     *volatile_ = "VOLATILE", *is_protected = "PROTECTED",
374     *is_bind_c = "BIND(C)", *procedure = "PROCEDURE",
375     *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION",
376     *contiguous = "CONTIGUOUS";
377   static const char *threadprivate = "THREADPRIVATE";
378
379   const char *a1, *a2;
380   int standard;
381
382   if (where == NULL)
383     where = &gfc_current_locus;
384
385   if (attr->pointer && attr->intent != INTENT_UNKNOWN)
386     {
387       a1 = pointer;
388       a2 = intent;
389       standard = GFC_STD_F2003;
390       goto conflict_std;
391     }
392
393   /* Check for attributes not allowed in a BLOCK DATA.  */
394   if (gfc_current_state () == COMP_BLOCK_DATA)
395     {
396       a1 = NULL;
397
398       if (attr->in_namelist)
399         a1 = in_namelist;
400       if (attr->allocatable)
401         a1 = allocatable;
402       if (attr->external)
403         a1 = external;
404       if (attr->optional)
405         a1 = optional;
406       if (attr->access == ACCESS_PRIVATE)
407         a1 = privat;
408       if (attr->access == ACCESS_PUBLIC)
409         a1 = publik;
410       if (attr->intent != INTENT_UNKNOWN)
411         a1 = intent;
412
413       if (a1 != NULL)
414         {
415           gfc_error
416             ("%s attribute not allowed in BLOCK DATA program unit at %L",
417              a1, where);
418           return FAILURE;
419         }
420     }
421
422   if (attr->save == SAVE_EXPLICIT)
423     {
424       conf (dummy, save);
425       conf (in_common, save);
426       conf (result, save);
427
428       switch (attr->flavor)
429         {
430           case FL_PROGRAM:
431           case FL_BLOCK_DATA:
432           case FL_MODULE:
433           case FL_LABEL:
434           case FL_DERIVED:
435           case FL_PARAMETER:
436             a1 = gfc_code2string (flavors, attr->flavor);
437             a2 = save;
438             goto conflict;
439
440           case FL_PROCEDURE:
441             /* Conflicts between SAVE and PROCEDURE will be checked at
442                resolution stage, see "resolve_fl_procedure".  */
443           case FL_VARIABLE:
444           case FL_NAMELIST:
445           default:
446             break;
447         }
448     }
449
450   conf (dummy, entry);
451   conf (dummy, intrinsic);
452   conf (dummy, threadprivate);
453   conf (pointer, target);
454   conf (pointer, intrinsic);
455   conf (pointer, elemental);
456   conf (allocatable, elemental);
457
458   conf (target, external);
459   conf (target, intrinsic);
460
461   if (!attr->if_source)
462     conf (external, dimension);   /* See Fortran 95's R504.  */
463
464   conf (external, intrinsic);
465   conf (entry, intrinsic);
466
467   if ((attr->if_source == IFSRC_DECL && !attr->procedure) || attr->contained)
468     conf (external, subroutine);
469
470   if (attr->proc_pointer && gfc_notify_std (GFC_STD_F2003,
471                             "Fortran 2003: Procedure pointer at %C") == FAILURE)
472     return FAILURE;
473
474   conf (allocatable, pointer);
475   conf_std (allocatable, dummy, GFC_STD_F2003);
476   conf_std (allocatable, function, GFC_STD_F2003);
477   conf_std (allocatable, result, GFC_STD_F2003);
478   conf (elemental, recursive);
479
480   conf (in_common, dummy);
481   conf (in_common, allocatable);
482   conf (in_common, codimension);
483   conf (in_common, result);
484
485   conf (dummy, result);
486
487   conf (in_equivalence, use_assoc);
488   conf (in_equivalence, codimension);
489   conf (in_equivalence, dummy);
490   conf (in_equivalence, target);
491   conf (in_equivalence, pointer);
492   conf (in_equivalence, function);
493   conf (in_equivalence, result);
494   conf (in_equivalence, entry);
495   conf (in_equivalence, allocatable);
496   conf (in_equivalence, threadprivate);
497
498   conf (in_namelist, pointer);
499   conf (in_namelist, allocatable);
500
501   conf (entry, result);
502
503   conf (function, subroutine);
504
505   if (!function && !subroutine)
506     conf (is_bind_c, dummy);
507
508   conf (is_bind_c, cray_pointer);
509   conf (is_bind_c, cray_pointee);
510   conf (is_bind_c, codimension);
511   conf (is_bind_c, allocatable);
512   conf (is_bind_c, elemental);
513
514   /* Need to also get volatile attr, according to 5.1 of F2003 draft.
515      Parameter conflict caught below.  Also, value cannot be specified
516      for a dummy procedure.  */
517
518   /* Cray pointer/pointee conflicts.  */
519   conf (cray_pointer, cray_pointee);
520   conf (cray_pointer, dimension);
521   conf (cray_pointer, codimension);
522   conf (cray_pointer, contiguous);
523   conf (cray_pointer, pointer);
524   conf (cray_pointer, target);
525   conf (cray_pointer, allocatable);
526   conf (cray_pointer, external);
527   conf (cray_pointer, intrinsic);
528   conf (cray_pointer, in_namelist);
529   conf (cray_pointer, function);
530   conf (cray_pointer, subroutine);
531   conf (cray_pointer, entry);
532
533   conf (cray_pointee, allocatable);
534   conf (cray_pointer, contiguous);
535   conf (cray_pointer, codimension);
536   conf (cray_pointee, intent);
537   conf (cray_pointee, optional);
538   conf (cray_pointee, dummy);
539   conf (cray_pointee, target);
540   conf (cray_pointee, intrinsic);
541   conf (cray_pointee, pointer);
542   conf (cray_pointee, entry);
543   conf (cray_pointee, in_common);
544   conf (cray_pointee, in_equivalence);
545   conf (cray_pointee, threadprivate);
546
547   conf (data, dummy);
548   conf (data, function);
549   conf (data, result);
550   conf (data, allocatable);
551
552   conf (value, pointer)
553   conf (value, allocatable)
554   conf (value, subroutine)
555   conf (value, function)
556   conf (value, volatile_)
557   conf (value, dimension)
558   conf (value, codimension)
559   conf (value, external)
560
561   conf (codimension, result)
562
563   if (attr->value
564       && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT))
565     {
566       a1 = value;
567       a2 = attr->intent == INTENT_OUT ? intent_out : intent_inout;
568       goto conflict;
569     }
570
571   conf (is_protected, intrinsic)
572   conf (is_protected, in_common)
573
574   conf (asynchronous, intrinsic)
575   conf (asynchronous, external)
576
577   conf (volatile_, intrinsic)
578   conf (volatile_, external)
579
580   if (attr->volatile_ && attr->intent == INTENT_IN)
581     {
582       a1 = volatile_;
583       a2 = intent_in;
584       goto conflict;
585     }
586
587   conf (procedure, allocatable)
588   conf (procedure, dimension)
589   conf (procedure, codimension)
590   conf (procedure, intrinsic)
591   conf (procedure, target)
592   conf (procedure, value)
593   conf (procedure, volatile_)
594   conf (procedure, asynchronous)
595   conf (procedure, entry)
596
597   a1 = gfc_code2string (flavors, attr->flavor);
598
599   if (attr->in_namelist
600       && attr->flavor != FL_VARIABLE
601       && attr->flavor != FL_PROCEDURE
602       && attr->flavor != FL_UNKNOWN)
603     {
604       a2 = in_namelist;
605       goto conflict;
606     }
607
608   switch (attr->flavor)
609     {
610     case FL_PROGRAM:
611     case FL_BLOCK_DATA:
612     case FL_MODULE:
613     case FL_LABEL:
614       conf2 (codimension);
615       conf2 (dimension);
616       conf2 (dummy);
617       conf2 (volatile_);
618       conf2 (asynchronous);
619       conf2 (contiguous);
620       conf2 (pointer);
621       conf2 (is_protected);
622       conf2 (target);
623       conf2 (external);
624       conf2 (intrinsic);
625       conf2 (allocatable);
626       conf2 (result);
627       conf2 (in_namelist);
628       conf2 (optional);
629       conf2 (function);
630       conf2 (subroutine);
631       conf2 (threadprivate);
632
633       if (attr->access == ACCESS_PUBLIC || attr->access == ACCESS_PRIVATE)
634         {
635           a2 = attr->access == ACCESS_PUBLIC ? publik : privat;
636           gfc_error ("%s attribute applied to %s %s at %L", a2, a1,
637             name, where);
638           return FAILURE;
639         }
640
641       if (attr->is_bind_c)
642         {
643           gfc_error_now ("BIND(C) applied to %s %s at %L", a1, name, where);
644           return FAILURE;
645         }
646
647       break;
648
649     case FL_VARIABLE:
650       break;
651
652     case FL_NAMELIST:
653       conf2 (result);
654       break;
655
656     case FL_PROCEDURE:
657       /* Conflicts with INTENT, SAVE and RESULT will be checked
658          at resolution stage, see "resolve_fl_procedure".  */
659
660       if (attr->subroutine)
661         {
662           a1 = subroutine;
663           conf2 (target);
664           conf2 (allocatable);
665           conf2 (volatile_);
666           conf2 (asynchronous);
667           conf2 (in_namelist);
668           conf2 (codimension);
669           conf2 (dimension);
670           conf2 (function);
671           conf2 (threadprivate);
672         }
673
674       if (!attr->proc_pointer)
675         conf2 (in_common);
676
677       switch (attr->proc)
678         {
679         case PROC_ST_FUNCTION:
680           conf2 (dummy);
681           break;
682
683         case PROC_MODULE:
684           conf2 (dummy);
685           break;
686
687         case PROC_DUMMY:
688           conf2 (result);
689           conf2 (threadprivate);
690           break;
691
692         default:
693           break;
694         }
695
696       break;
697
698     case FL_DERIVED:
699       conf2 (dummy);
700       conf2 (pointer);
701       conf2 (target);
702       conf2 (external);
703       conf2 (intrinsic);
704       conf2 (allocatable);
705       conf2 (optional);
706       conf2 (entry);
707       conf2 (function);
708       conf2 (subroutine);
709       conf2 (threadprivate);
710       conf2 (result);
711
712       if (attr->intent != INTENT_UNKNOWN)
713         {
714           a2 = intent;
715           goto conflict;
716         }
717       break;
718
719     case FL_PARAMETER:
720       conf2 (external);
721       conf2 (intrinsic);
722       conf2 (optional);
723       conf2 (allocatable);
724       conf2 (function);
725       conf2 (subroutine);
726       conf2 (entry);
727       conf2 (contiguous);
728       conf2 (pointer);
729       conf2 (is_protected);
730       conf2 (target);
731       conf2 (dummy);
732       conf2 (in_common);
733       conf2 (value);
734       conf2 (volatile_);
735       conf2 (asynchronous);
736       conf2 (threadprivate);
737       conf2 (value);
738       conf2 (is_bind_c);
739       conf2 (codimension);
740       conf2 (result);
741       break;
742
743     default:
744       break;
745     }
746
747   return SUCCESS;
748
749 conflict:
750   if (name == NULL)
751     gfc_error ("%s attribute conflicts with %s attribute at %L",
752                a1, a2, where);
753   else
754     gfc_error ("%s attribute conflicts with %s attribute in '%s' at %L",
755                a1, a2, name, where);
756
757   return FAILURE;
758
759 conflict_std:
760   if (name == NULL)
761     {
762       return gfc_notify_std (standard, "Fortran 2003: %s attribute "
763                              "with %s attribute at %L", a1, a2,
764                              where);
765     }
766   else
767     {
768       return gfc_notify_std (standard, "Fortran 2003: %s attribute "
769                              "with %s attribute in '%s' at %L",
770                              a1, a2, name, where);
771     }
772 }
773
774 #undef conf
775 #undef conf2
776 #undef conf_std
777
778
779 /* Mark a symbol as referenced.  */
780
781 void
782 gfc_set_sym_referenced (gfc_symbol *sym)
783 {
784
785   if (sym->attr.referenced)
786     return;
787
788   sym->attr.referenced = 1;
789
790   /* Remember which order dummy variables are accessed in.  */
791   if (sym->attr.dummy)
792     sym->dummy_order = next_dummy_order++;
793 }
794
795
796 /* Common subroutine called by attribute changing subroutines in order
797    to prevent them from changing a symbol that has been
798    use-associated.  Returns zero if it is OK to change the symbol,
799    nonzero if not.  */
800
801 static int
802 check_used (symbol_attribute *attr, const char *name, locus *where)
803 {
804
805   if (attr->use_assoc == 0)
806     return 0;
807
808   if (where == NULL)
809     where = &gfc_current_locus;
810
811   if (name == NULL)
812     gfc_error ("Cannot change attributes of USE-associated symbol at %L",
813                where);
814   else
815     gfc_error ("Cannot change attributes of USE-associated symbol %s at %L",
816                name, where);
817
818   return 1;
819 }
820
821
822 /* Generate an error because of a duplicate attribute.  */
823
824 static void
825 duplicate_attr (const char *attr, locus *where)
826 {
827
828   if (where == NULL)
829     where = &gfc_current_locus;
830
831   gfc_error ("Duplicate %s attribute specified at %L", attr, where);
832 }
833
834
835 gfc_try
836 gfc_add_ext_attribute (symbol_attribute *attr, ext_attr_id_t ext_attr,
837                        locus *where ATTRIBUTE_UNUSED)
838 {
839   attr->ext_attr |= 1 << ext_attr;
840   return SUCCESS;
841 }
842
843
844 /* Called from decl.c (attr_decl1) to check attributes, when declared
845    separately.  */
846
847 gfc_try
848 gfc_add_attribute (symbol_attribute *attr, locus *where)
849 {
850   if (check_used (attr, NULL, where))
851     return FAILURE;
852
853   return check_conflict (attr, NULL, where);
854 }
855
856
857 gfc_try
858 gfc_add_allocatable (symbol_attribute *attr, locus *where)
859 {
860
861   if (check_used (attr, NULL, where))
862     return FAILURE;
863
864   if (attr->allocatable)
865     {
866       duplicate_attr ("ALLOCATABLE", where);
867       return FAILURE;
868     }
869
870   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
871       && gfc_find_state (COMP_INTERFACE) == FAILURE)
872     {
873       gfc_error ("ALLOCATABLE specified outside of INTERFACE body at %L",
874                  where);
875       return FAILURE;
876     }
877
878   attr->allocatable = 1;
879   return check_conflict (attr, NULL, where);
880 }
881
882
883 gfc_try
884 gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where)
885 {
886
887   if (check_used (attr, name, where))
888     return FAILURE;
889
890   if (attr->codimension)
891     {
892       duplicate_attr ("CODIMENSION", where);
893       return FAILURE;
894     }
895
896   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
897       && gfc_find_state (COMP_INTERFACE) == FAILURE)
898     {
899       gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body "
900                  "at %L", name, where);
901       return FAILURE;
902     }
903
904   attr->codimension = 1;
905   return check_conflict (attr, name, where);
906 }
907
908
909 gfc_try
910 gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where)
911 {
912
913   if (check_used (attr, name, where))
914     return FAILURE;
915
916   if (attr->dimension)
917     {
918       duplicate_attr ("DIMENSION", where);
919       return FAILURE;
920     }
921
922   if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY
923       && gfc_find_state (COMP_INTERFACE) == FAILURE)
924     {
925       gfc_error ("DIMENSION specified for '%s' outside its INTERFACE body "
926                  "at %L", name, where);
927       return FAILURE;
928     }
929
930   attr->dimension = 1;
931   return check_conflict (attr, name, where);
932 }
933
934
935 gfc_try
936 gfc_add_contiguous (symbol_attribute *attr, const char *name, locus *where)
937 {
938
939   if (check_used (attr, name, where))
940     return FAILURE;
941
942   attr->contiguous = 1;
943   return check_conflict (attr, name, where);
944 }
945
946
947 gfc_try
948 gfc_add_external (symbol_attribute *attr, locus *where)
949 {
950
951   if (check_used (attr, NULL, where))
952     return FAILURE;
953
954   if (attr->external)
955     {
956       duplicate_attr ("EXTERNAL", where);
957       return FAILURE;
958     }
959
960   if (attr->pointer && attr->if_source != IFSRC_IFBODY)
961     {
962       attr->pointer = 0;
963       attr->proc_pointer = 1;
964     }
965
966   attr->external = 1;
967
968   return check_conflict (attr, NULL, where);
969 }
970
971
972 gfc_try
973 gfc_add_intrinsic (symbol_attribute *attr, locus *where)
974 {
975
976   if (check_used (attr, NULL, where))
977     return FAILURE;
978
979   if (attr->intrinsic)
980     {
981       duplicate_attr ("INTRINSIC", where);
982       return FAILURE;
983     }
984
985   attr->intrinsic = 1;
986
987   return check_conflict (attr, NULL, where);
988 }
989
990
991 gfc_try
992 gfc_add_optional (symbol_attribute *attr, locus *where)
993 {
994
995   if (check_used (attr, NULL, where))
996     return FAILURE;
997
998   if (attr->optional)
999     {
1000       duplicate_attr ("OPTIONAL", where);
1001       return FAILURE;
1002     }
1003
1004   attr->optional = 1;
1005   return check_conflict (attr, NULL, where);
1006 }
1007
1008
1009 gfc_try
1010 gfc_add_pointer (symbol_attribute *attr, locus *where)
1011 {
1012
1013   if (check_used (attr, NULL, where))
1014     return FAILURE;
1015
1016   if (attr->pointer && !(attr->if_source == IFSRC_IFBODY
1017       && gfc_find_state (COMP_INTERFACE) == FAILURE))
1018     {
1019       duplicate_attr ("POINTER", where);
1020       return FAILURE;
1021     }
1022
1023   if (attr->procedure || (attr->external && attr->if_source != IFSRC_IFBODY)
1024       || (attr->if_source == IFSRC_IFBODY
1025       && gfc_find_state (COMP_INTERFACE) == FAILURE))
1026     attr->proc_pointer = 1;
1027   else
1028     attr->pointer = 1;
1029
1030   return check_conflict (attr, NULL, where);
1031 }
1032
1033
1034 gfc_try
1035 gfc_add_cray_pointer (symbol_attribute *attr, locus *where)
1036 {
1037
1038   if (check_used (attr, NULL, where))
1039     return FAILURE;
1040
1041   attr->cray_pointer = 1;
1042   return check_conflict (attr, NULL, where);
1043 }
1044
1045
1046 gfc_try
1047 gfc_add_cray_pointee (symbol_attribute *attr, locus *where)
1048 {
1049
1050   if (check_used (attr, NULL, where))
1051     return FAILURE;
1052
1053   if (attr->cray_pointee)
1054     {
1055       gfc_error ("Cray Pointee at %L appears in multiple pointer()"
1056                  " statements", where);
1057       return FAILURE;
1058     }
1059
1060   attr->cray_pointee = 1;
1061   return check_conflict (attr, NULL, where);
1062 }
1063
1064
1065 gfc_try
1066 gfc_add_protected (symbol_attribute *attr, const char *name, locus *where)
1067 {
1068   if (check_used (attr, name, where))
1069     return FAILURE;
1070
1071   if (attr->is_protected)
1072     {
1073         if (gfc_notify_std (GFC_STD_LEGACY, 
1074                             "Duplicate PROTECTED attribute specified at %L",
1075                             where) 
1076             == FAILURE)
1077           return FAILURE;
1078     }
1079
1080   attr->is_protected = 1;
1081   return check_conflict (attr, name, where);
1082 }
1083
1084
1085 gfc_try
1086 gfc_add_result (symbol_attribute *attr, const char *name, locus *where)
1087 {
1088
1089   if (check_used (attr, name, where))
1090     return FAILURE;
1091
1092   attr->result = 1;
1093   return check_conflict (attr, name, where);
1094 }
1095
1096
1097 gfc_try
1098 gfc_add_save (symbol_attribute *attr, const char *name, locus *where)
1099 {
1100
1101   if (check_used (attr, name, where))
1102     return FAILURE;
1103
1104   if (gfc_pure (NULL))
1105     {
1106       gfc_error
1107         ("SAVE attribute at %L cannot be specified in a PURE procedure",
1108          where);
1109       return FAILURE;
1110     }
1111
1112   if (attr->save == SAVE_EXPLICIT && !attr->vtab)
1113     {
1114         if (gfc_notify_std (GFC_STD_LEGACY, 
1115                             "Duplicate SAVE attribute specified at %L",
1116                             where) 
1117             == FAILURE)
1118           return FAILURE;
1119     }
1120
1121   attr->save = SAVE_EXPLICIT;
1122   return check_conflict (attr, name, where);
1123 }
1124
1125
1126 gfc_try
1127 gfc_add_value (symbol_attribute *attr, const char *name, locus *where)
1128 {
1129
1130   if (check_used (attr, name, where))
1131     return FAILURE;
1132
1133   if (attr->value)
1134     {
1135         if (gfc_notify_std (GFC_STD_LEGACY, 
1136                             "Duplicate VALUE attribute specified at %L",
1137                             where) 
1138             == FAILURE)
1139           return FAILURE;
1140     }
1141
1142   attr->value = 1;
1143   return check_conflict (attr, name, where);
1144 }
1145
1146
1147 gfc_try
1148 gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where)
1149 {
1150   /* No check_used needed as 11.2.1 of the F2003 standard allows
1151      that the local identifier made accessible by a use statement can be
1152      given a VOLATILE attribute - unless it is a coarray (F2008, C560).  */
1153
1154   if (attr->volatile_ && attr->volatile_ns == gfc_current_ns)
1155     if (gfc_notify_std (GFC_STD_LEGACY, 
1156                         "Duplicate VOLATILE attribute specified at %L", where)
1157         == FAILURE)
1158       return FAILURE;
1159
1160   attr->volatile_ = 1;
1161   attr->volatile_ns = gfc_current_ns;
1162   return check_conflict (attr, name, where);
1163 }
1164
1165
1166 gfc_try
1167 gfc_add_asynchronous (symbol_attribute *attr, const char *name, locus *where)
1168 {
1169   /* No check_used needed as 11.2.1 of the F2003 standard allows
1170      that the local identifier made accessible by a use statement can be
1171      given a ASYNCHRONOUS attribute.  */
1172
1173   if (attr->asynchronous && attr->asynchronous_ns == gfc_current_ns)
1174     if (gfc_notify_std (GFC_STD_LEGACY, 
1175                         "Duplicate ASYNCHRONOUS attribute specified at %L",
1176                         where) == FAILURE)
1177       return FAILURE;
1178
1179   attr->asynchronous = 1;
1180   attr->asynchronous_ns = gfc_current_ns;
1181   return check_conflict (attr, name, where);
1182 }
1183
1184
1185 gfc_try
1186 gfc_add_threadprivate (symbol_attribute *attr, const char *name, locus *where)
1187 {
1188
1189   if (check_used (attr, name, where))
1190     return FAILURE;
1191
1192   if (attr->threadprivate)
1193     {
1194       duplicate_attr ("THREADPRIVATE", where);
1195       return FAILURE;
1196     }
1197
1198   attr->threadprivate = 1;
1199   return check_conflict (attr, name, where);
1200 }
1201
1202
1203 gfc_try
1204 gfc_add_target (symbol_attribute *attr, locus *where)
1205 {
1206
1207   if (check_used (attr, NULL, where))
1208     return FAILURE;
1209
1210   if (attr->target)
1211     {
1212       duplicate_attr ("TARGET", where);
1213       return FAILURE;
1214     }
1215
1216   attr->target = 1;
1217   return check_conflict (attr, NULL, where);
1218 }
1219
1220
1221 gfc_try
1222 gfc_add_dummy (symbol_attribute *attr, const char *name, locus *where)
1223 {
1224
1225   if (check_used (attr, name, where))
1226     return FAILURE;
1227
1228   /* Duplicate dummy arguments are allowed due to ENTRY statements.  */
1229   attr->dummy = 1;
1230   return check_conflict (attr, name, where);
1231 }
1232
1233
1234 gfc_try
1235 gfc_add_in_common (symbol_attribute *attr, const char *name, locus *where)
1236 {
1237
1238   if (check_used (attr, name, where))
1239     return FAILURE;
1240
1241   /* Duplicate attribute already checked for.  */
1242   attr->in_common = 1;
1243   return check_conflict (attr, name, where);
1244 }
1245
1246
1247 gfc_try
1248 gfc_add_in_equivalence (symbol_attribute *attr, const char *name, locus *where)
1249 {
1250
1251   /* Duplicate attribute already checked for.  */
1252   attr->in_equivalence = 1;
1253   if (check_conflict (attr, name, where) == FAILURE)
1254     return FAILURE;
1255
1256   if (attr->flavor == FL_VARIABLE)
1257     return SUCCESS;
1258
1259   return gfc_add_flavor (attr, FL_VARIABLE, name, where);
1260 }
1261
1262
1263 gfc_try
1264 gfc_add_data (symbol_attribute *attr, const char *name, locus *where)
1265 {
1266
1267   if (check_used (attr, name, where))
1268     return FAILURE;
1269
1270   attr->data = 1;
1271   return check_conflict (attr, name, where);
1272 }
1273
1274
1275 gfc_try
1276 gfc_add_in_namelist (symbol_attribute *attr, const char *name, locus *where)
1277 {
1278
1279   attr->in_namelist = 1;
1280   return check_conflict (attr, name, where);
1281 }
1282
1283
1284 gfc_try
1285 gfc_add_sequence (symbol_attribute *attr, const char *name, locus *where)
1286 {
1287
1288   if (check_used (attr, name, where))
1289     return FAILURE;
1290
1291   attr->sequence = 1;
1292   return check_conflict (attr, name, where);
1293 }
1294
1295
1296 gfc_try
1297 gfc_add_elemental (symbol_attribute *attr, locus *where)
1298 {
1299
1300   if (check_used (attr, NULL, where))
1301     return FAILURE;
1302
1303   if (attr->elemental)
1304     {
1305       duplicate_attr ("ELEMENTAL", where);
1306       return FAILURE;
1307     }
1308
1309   attr->elemental = 1;
1310   return check_conflict (attr, NULL, where);
1311 }
1312
1313
1314 gfc_try
1315 gfc_add_pure (symbol_attribute *attr, locus *where)
1316 {
1317
1318   if (check_used (attr, NULL, where))
1319     return FAILURE;
1320
1321   if (attr->pure)
1322     {
1323       duplicate_attr ("PURE", where);
1324       return FAILURE;
1325     }
1326
1327   attr->pure = 1;
1328   return check_conflict (attr, NULL, where);
1329 }
1330
1331
1332 gfc_try
1333 gfc_add_recursive (symbol_attribute *attr, locus *where)
1334 {
1335
1336   if (check_used (attr, NULL, where))
1337     return FAILURE;
1338
1339   if (attr->recursive)
1340     {
1341       duplicate_attr ("RECURSIVE", where);
1342       return FAILURE;
1343     }
1344
1345   attr->recursive = 1;
1346   return check_conflict (attr, NULL, where);
1347 }
1348
1349
1350 gfc_try
1351 gfc_add_entry (symbol_attribute *attr, const char *name, locus *where)
1352 {
1353
1354   if (check_used (attr, name, where))
1355     return FAILURE;
1356
1357   if (attr->entry)
1358     {
1359       duplicate_attr ("ENTRY", where);
1360       return FAILURE;
1361     }
1362
1363   attr->entry = 1;
1364   return check_conflict (attr, name, where);
1365 }
1366
1367
1368 gfc_try
1369 gfc_add_function (symbol_attribute *attr, const char *name, locus *where)
1370 {
1371
1372   if (attr->flavor != FL_PROCEDURE
1373       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1374     return FAILURE;
1375
1376   attr->function = 1;
1377   return check_conflict (attr, name, where);
1378 }
1379
1380
1381 gfc_try
1382 gfc_add_subroutine (symbol_attribute *attr, const char *name, locus *where)
1383 {
1384
1385   if (attr->flavor != FL_PROCEDURE
1386       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1387     return FAILURE;
1388
1389   attr->subroutine = 1;
1390   return check_conflict (attr, name, where);
1391 }
1392
1393
1394 gfc_try
1395 gfc_add_generic (symbol_attribute *attr, const char *name, locus *where)
1396 {
1397
1398   if (attr->flavor != FL_PROCEDURE
1399       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1400     return FAILURE;
1401
1402   attr->generic = 1;
1403   return check_conflict (attr, name, where);
1404 }
1405
1406
1407 gfc_try
1408 gfc_add_proc (symbol_attribute *attr, const char *name, locus *where)
1409 {
1410
1411   if (check_used (attr, NULL, where))
1412     return FAILURE;
1413
1414   if (attr->flavor != FL_PROCEDURE
1415       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1416     return FAILURE;
1417
1418   if (attr->procedure)
1419     {
1420       duplicate_attr ("PROCEDURE", where);
1421       return FAILURE;
1422     }
1423
1424   attr->procedure = 1;
1425
1426   return check_conflict (attr, NULL, where);
1427 }
1428
1429
1430 gfc_try
1431 gfc_add_abstract (symbol_attribute* attr, locus* where)
1432 {
1433   if (attr->abstract)
1434     {
1435       duplicate_attr ("ABSTRACT", where);
1436       return FAILURE;
1437     }
1438
1439   attr->abstract = 1;
1440   return SUCCESS;
1441 }
1442
1443
1444 /* Flavors are special because some flavors are not what Fortran
1445    considers attributes and can be reaffirmed multiple times.  */
1446
1447 gfc_try
1448 gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name,
1449                 locus *where)
1450 {
1451
1452   if ((f == FL_PROGRAM || f == FL_BLOCK_DATA || f == FL_MODULE
1453        || f == FL_PARAMETER || f == FL_LABEL || f == FL_DERIVED
1454        || f == FL_NAMELIST) && check_used (attr, name, where))
1455     return FAILURE;
1456
1457   if (attr->flavor == f && f == FL_VARIABLE)
1458     return SUCCESS;
1459
1460   if (attr->flavor != FL_UNKNOWN)
1461     {
1462       if (where == NULL)
1463         where = &gfc_current_locus;
1464
1465       if (name)
1466         gfc_error ("%s attribute of '%s' conflicts with %s attribute at %L",
1467                    gfc_code2string (flavors, attr->flavor), name,
1468                    gfc_code2string (flavors, f), where);
1469       else
1470         gfc_error ("%s attribute conflicts with %s attribute at %L",
1471                    gfc_code2string (flavors, attr->flavor),
1472                    gfc_code2string (flavors, f), where);
1473
1474       return FAILURE;
1475     }
1476
1477   attr->flavor = f;
1478
1479   return check_conflict (attr, name, where);
1480 }
1481
1482
1483 gfc_try
1484 gfc_add_procedure (symbol_attribute *attr, procedure_type t,
1485                    const char *name, locus *where)
1486 {
1487
1488   if (check_used (attr, name, where))
1489     return FAILURE;
1490
1491   if (attr->flavor != FL_PROCEDURE
1492       && gfc_add_flavor (attr, FL_PROCEDURE, name, where) == FAILURE)
1493     return FAILURE;
1494
1495   if (where == NULL)
1496     where = &gfc_current_locus;
1497
1498   if (attr->proc != PROC_UNKNOWN)
1499     {
1500       gfc_error ("%s procedure at %L is already declared as %s procedure",
1501                  gfc_code2string (procedures, t), where,
1502                  gfc_code2string (procedures, attr->proc));
1503
1504       return FAILURE;
1505     }
1506
1507   attr->proc = t;
1508
1509   /* Statement functions are always scalar and functions.  */
1510   if (t == PROC_ST_FUNCTION
1511       && ((!attr->function && gfc_add_function (attr, name, where) == FAILURE)
1512           || attr->dimension))
1513     return FAILURE;
1514
1515   return check_conflict (attr, name, where);
1516 }
1517
1518
1519 gfc_try
1520 gfc_add_intent (symbol_attribute *attr, sym_intent intent, locus *where)
1521 {
1522
1523   if (check_used (attr, NULL, where))
1524     return FAILURE;
1525
1526   if (attr->intent == INTENT_UNKNOWN)
1527     {
1528       attr->intent = intent;
1529       return check_conflict (attr, NULL, where);
1530     }
1531
1532   if (where == NULL)
1533     where = &gfc_current_locus;
1534
1535   gfc_error ("INTENT (%s) conflicts with INTENT(%s) at %L",
1536              gfc_intent_string (attr->intent),
1537              gfc_intent_string (intent), where);
1538
1539   return FAILURE;
1540 }
1541
1542
1543 /* No checks for use-association in public and private statements.  */
1544
1545 gfc_try
1546 gfc_add_access (symbol_attribute *attr, gfc_access access,
1547                 const char *name, locus *where)
1548 {
1549
1550   if (attr->access == ACCESS_UNKNOWN
1551         || (attr->use_assoc && attr->access != ACCESS_PRIVATE))
1552     {
1553       attr->access = access;
1554       return check_conflict (attr, name, where);
1555     }
1556
1557   if (where == NULL)
1558     where = &gfc_current_locus;
1559   gfc_error ("ACCESS specification at %L was already specified", where);
1560
1561   return FAILURE;
1562 }
1563
1564
1565 /* Set the is_bind_c field for the given symbol_attribute.  */
1566
1567 gfc_try
1568 gfc_add_is_bind_c (symbol_attribute *attr, const char *name, locus *where,
1569                    int is_proc_lang_bind_spec)
1570 {
1571
1572   if (is_proc_lang_bind_spec == 0 && attr->flavor == FL_PROCEDURE)
1573     gfc_error_now ("BIND(C) attribute at %L can only be used for "
1574                    "variables or common blocks", where);
1575   else if (attr->is_bind_c)
1576     gfc_error_now ("Duplicate BIND attribute specified at %L", where);
1577   else
1578     attr->is_bind_c = 1;
1579   
1580   if (where == NULL)
1581     where = &gfc_current_locus;
1582    
1583   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BIND(C) at %L", where)
1584       == FAILURE)
1585     return FAILURE;
1586
1587   return check_conflict (attr, name, where);
1588 }
1589
1590
1591 /* Set the extension field for the given symbol_attribute.  */
1592
1593 gfc_try
1594 gfc_add_extension (symbol_attribute *attr, locus *where)
1595 {
1596   if (where == NULL)
1597     where = &gfc_current_locus;
1598
1599   if (attr->extension)
1600     gfc_error_now ("Duplicate EXTENDS attribute specified at %L", where);
1601   else
1602     attr->extension = 1;
1603
1604   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: EXTENDS at %L", where)
1605         == FAILURE)
1606     return FAILURE;
1607
1608   return SUCCESS;
1609 }
1610
1611
1612 gfc_try
1613 gfc_add_explicit_interface (gfc_symbol *sym, ifsrc source,
1614                             gfc_formal_arglist * formal, locus *where)
1615 {
1616
1617   if (check_used (&sym->attr, sym->name, where))
1618     return FAILURE;
1619
1620   if (where == NULL)
1621     where = &gfc_current_locus;
1622
1623   if (sym->attr.if_source != IFSRC_UNKNOWN
1624       && sym->attr.if_source != IFSRC_DECL)
1625     {
1626       gfc_error ("Symbol '%s' at %L already has an explicit interface",
1627                  sym->name, where);
1628       return FAILURE;
1629     }
1630
1631   if (source == IFSRC_IFBODY && (sym->attr.dimension || sym->attr.allocatable))
1632     {
1633       gfc_error ("'%s' at %L has attributes specified outside its INTERFACE "
1634                  "body", sym->name, where);
1635       return FAILURE;
1636     }
1637
1638   sym->formal = formal;
1639   sym->attr.if_source = source;
1640
1641   return SUCCESS;
1642 }
1643
1644
1645 /* Add a type to a symbol.  */
1646
1647 gfc_try
1648 gfc_add_type (gfc_symbol *sym, gfc_typespec *ts, locus *where)
1649 {
1650   sym_flavor flavor;
1651   bt type;
1652
1653   if (where == NULL)
1654     where = &gfc_current_locus;
1655
1656   if (sym->result)
1657     type = sym->result->ts.type;
1658   else
1659     type = sym->ts.type;
1660
1661   if (sym->attr.result && type == BT_UNKNOWN && sym->ns->proc_name)
1662     type = sym->ns->proc_name->ts.type;
1663
1664   if (type != BT_UNKNOWN && !(sym->attr.function && sym->attr.implicit_type))
1665     {
1666       gfc_error ("Symbol '%s' at %L already has basic type of %s", sym->name,
1667                  where, gfc_basic_typename (type));
1668       return FAILURE;
1669     }
1670
1671   if (sym->attr.procedure && sym->ts.interface)
1672     {
1673       gfc_error ("Procedure '%s' at %L may not have basic type of %s",
1674                  sym->name, where, gfc_basic_typename (ts->type));
1675       return FAILURE;
1676     }
1677
1678   flavor = sym->attr.flavor;
1679
1680   if (flavor == FL_PROGRAM || flavor == FL_BLOCK_DATA || flavor == FL_MODULE
1681       || flavor == FL_LABEL
1682       || (flavor == FL_PROCEDURE && sym->attr.subroutine)
1683       || flavor == FL_DERIVED || flavor == FL_NAMELIST)
1684     {
1685       gfc_error ("Symbol '%s' at %L cannot have a type", sym->name, where);
1686       return FAILURE;
1687     }
1688
1689   sym->ts = *ts;
1690   return SUCCESS;
1691 }
1692
1693
1694 /* Clears all attributes.  */
1695
1696 void
1697 gfc_clear_attr (symbol_attribute *attr)
1698 {
1699   memset (attr, 0, sizeof (symbol_attribute));
1700 }
1701
1702
1703 /* Check for missing attributes in the new symbol.  Currently does
1704    nothing, but it's not clear that it is unnecessary yet.  */
1705
1706 gfc_try
1707 gfc_missing_attr (symbol_attribute *attr ATTRIBUTE_UNUSED,
1708                   locus *where ATTRIBUTE_UNUSED)
1709 {
1710
1711   return SUCCESS;
1712 }
1713
1714
1715 /* Copy an attribute to a symbol attribute, bit by bit.  Some
1716    attributes have a lot of side-effects but cannot be present given
1717    where we are called from, so we ignore some bits.  */
1718
1719 gfc_try
1720 gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where)
1721 {
1722   int is_proc_lang_bind_spec;
1723   
1724   /* In line with the other attributes, we only add bits but do not remove
1725      them; cf. also PR 41034.  */
1726   dest->ext_attr |= src->ext_attr;
1727
1728   if (src->allocatable && gfc_add_allocatable (dest, where) == FAILURE)
1729     goto fail;
1730
1731   if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE)
1732     goto fail;
1733   if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE)
1734     goto fail;
1735   if (src->contiguous && gfc_add_contiguous (dest, NULL, where) == FAILURE)
1736     goto fail;
1737   if (src->optional && gfc_add_optional (dest, where) == FAILURE)
1738     goto fail;
1739   if (src->pointer && gfc_add_pointer (dest, where) == FAILURE)
1740     goto fail;
1741   if (src->is_protected && gfc_add_protected (dest, NULL, where) == FAILURE)
1742     goto fail;
1743   if (src->save && gfc_add_save (dest, NULL, where) == FAILURE)
1744     goto fail;
1745   if (src->value && gfc_add_value (dest, NULL, where) == FAILURE)
1746     goto fail;
1747   if (src->volatile_ && gfc_add_volatile (dest, NULL, where) == FAILURE)
1748     goto fail;
1749   if (src->asynchronous && gfc_add_asynchronous (dest, NULL, where) == FAILURE)
1750     goto fail;
1751   if (src->threadprivate
1752       && gfc_add_threadprivate (dest, NULL, where) == FAILURE)
1753     goto fail;
1754   if (src->target && gfc_add_target (dest, where) == FAILURE)
1755     goto fail;
1756   if (src->dummy && gfc_add_dummy (dest, NULL, where) == FAILURE)
1757     goto fail;
1758   if (src->result && gfc_add_result (dest, NULL, where) == FAILURE)
1759     goto fail;
1760   if (src->entry)
1761     dest->entry = 1;
1762
1763   if (src->in_namelist && gfc_add_in_namelist (dest, NULL, where) == FAILURE)
1764     goto fail;
1765
1766   if (src->in_common && gfc_add_in_common (dest, NULL, where) == FAILURE)
1767     goto fail;
1768
1769   if (src->generic && gfc_add_generic (dest, NULL, where) == FAILURE)
1770     goto fail;
1771   if (src->function && gfc_add_function (dest, NULL, where) == FAILURE)
1772     goto fail;
1773   if (src->subroutine && gfc_add_subroutine (dest, NULL, where) == FAILURE)
1774     goto fail;
1775
1776   if (src->sequence && gfc_add_sequence (dest, NULL, where) == FAILURE)
1777     goto fail;
1778   if (src->elemental && gfc_add_elemental (dest, where) == FAILURE)
1779     goto fail;
1780   if (src->pure && gfc_add_pure (dest, where) == FAILURE)
1781     goto fail;
1782   if (src->recursive && gfc_add_recursive (dest, where) == FAILURE)
1783     goto fail;
1784
1785   if (src->flavor != FL_UNKNOWN
1786       && gfc_add_flavor (dest, src->flavor, NULL, where) == FAILURE)
1787     goto fail;
1788
1789   if (src->intent != INTENT_UNKNOWN
1790       && gfc_add_intent (dest, src->intent, where) == FAILURE)
1791     goto fail;
1792
1793   if (src->access != ACCESS_UNKNOWN
1794       && gfc_add_access (dest, src->access, NULL, where) == FAILURE)
1795     goto fail;
1796
1797   if (gfc_missing_attr (dest, where) == FAILURE)
1798     goto fail;
1799
1800   if (src->cray_pointer && gfc_add_cray_pointer (dest, where) == FAILURE)
1801     goto fail;
1802   if (src->cray_pointee && gfc_add_cray_pointee (dest, where) == FAILURE)
1803     goto fail;
1804
1805   is_proc_lang_bind_spec = (src->flavor == FL_PROCEDURE ? 1 : 0);
1806   if (src->is_bind_c
1807       && gfc_add_is_bind_c (dest, NULL, where, is_proc_lang_bind_spec)
1808          != SUCCESS)
1809     return FAILURE;
1810
1811   if (src->is_c_interop)
1812     dest->is_c_interop = 1;
1813   if (src->is_iso_c)
1814     dest->is_iso_c = 1;
1815   
1816   if (src->external && gfc_add_external (dest, where) == FAILURE)
1817     goto fail;
1818   if (src->intrinsic && gfc_add_intrinsic (dest, where) == FAILURE)
1819     goto fail;
1820   if (src->proc_pointer)
1821     dest->proc_pointer = 1;
1822
1823   return SUCCESS;
1824
1825 fail:
1826   return FAILURE;
1827 }
1828
1829
1830 /************** Component name management ************/
1831
1832 /* Component names of a derived type form their own little namespaces
1833    that are separate from all other spaces.  The space is composed of
1834    a singly linked list of gfc_component structures whose head is
1835    located in the parent symbol.  */
1836
1837
1838 /* Add a component name to a symbol.  The call fails if the name is
1839    already present.  On success, the component pointer is modified to
1840    point to the additional component structure.  */
1841
1842 gfc_try
1843 gfc_add_component (gfc_symbol *sym, const char *name,
1844                    gfc_component **component)
1845 {
1846   gfc_component *p, *tail;
1847
1848   tail = NULL;
1849
1850   for (p = sym->components; p; p = p->next)
1851     {
1852       if (strcmp (p->name, name) == 0)
1853         {
1854           gfc_error ("Component '%s' at %C already declared at %L",
1855                      name, &p->loc);
1856           return FAILURE;
1857         }
1858
1859       tail = p;
1860     }
1861
1862   if (sym->attr.extension
1863         && gfc_find_component (sym->components->ts.u.derived, name, true, true))
1864     {
1865       gfc_error ("Component '%s' at %C already in the parent type "
1866                  "at %L", name, &sym->components->ts.u.derived->declared_at);
1867       return FAILURE;
1868     }
1869
1870   /* Allocate a new component.  */
1871   p = gfc_get_component ();
1872
1873   if (tail == NULL)
1874     sym->components = p;
1875   else
1876     tail->next = p;
1877
1878   p->name = gfc_get_string (name);
1879   p->loc = gfc_current_locus;
1880   p->ts.type = BT_UNKNOWN;
1881
1882   *component = p;
1883   return SUCCESS;
1884 }
1885
1886
1887 /* Recursive function to switch derived types of all symbol in a
1888    namespace.  */
1889
1890 static void
1891 switch_types (gfc_symtree *st, gfc_symbol *from, gfc_symbol *to)
1892 {
1893   gfc_symbol *sym;
1894
1895   if (st == NULL)
1896     return;
1897
1898   sym = st->n.sym;
1899   if (sym->ts.type == BT_DERIVED && sym->ts.u.derived == from)
1900     sym->ts.u.derived = to;
1901
1902   switch_types (st->left, from, to);
1903   switch_types (st->right, from, to);
1904 }
1905
1906
1907 /* This subroutine is called when a derived type is used in order to
1908    make the final determination about which version to use.  The
1909    standard requires that a type be defined before it is 'used', but
1910    such types can appear in IMPLICIT statements before the actual
1911    definition.  'Using' in this context means declaring a variable to
1912    be that type or using the type constructor.
1913
1914    If a type is used and the components haven't been defined, then we
1915    have to have a derived type in a parent unit.  We find the node in
1916    the other namespace and point the symtree node in this namespace to
1917    that node.  Further reference to this name point to the correct
1918    node.  If we can't find the node in a parent namespace, then we have
1919    an error.
1920
1921    This subroutine takes a pointer to a symbol node and returns a
1922    pointer to the translated node or NULL for an error.  Usually there
1923    is no translation and we return the node we were passed.  */
1924
1925 gfc_symbol *
1926 gfc_use_derived (gfc_symbol *sym)
1927 {
1928   gfc_symbol *s;
1929   gfc_typespec *t;
1930   gfc_symtree *st;
1931   int i;
1932
1933   if (sym->components != NULL || sym->attr.zero_comp)
1934     return sym;               /* Already defined.  */
1935
1936   if (sym->ns->parent == NULL)
1937     goto bad;
1938
1939   if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
1940     {
1941       gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
1942       return NULL;
1943     }
1944
1945   if (s == NULL || s->attr.flavor != FL_DERIVED)
1946     goto bad;
1947
1948   /* Get rid of symbol sym, translating all references to s.  */
1949   for (i = 0; i < GFC_LETTERS; i++)
1950     {
1951       t = &sym->ns->default_type[i];
1952       if (t->u.derived == sym)
1953         t->u.derived = s;
1954     }
1955
1956   st = gfc_find_symtree (sym->ns->sym_root, sym->name);
1957   st->n.sym = s;
1958
1959   s->refs++;
1960
1961   /* Unlink from list of modified symbols.  */
1962   gfc_commit_symbol (sym);
1963
1964   switch_types (sym->ns->sym_root, sym, s);
1965
1966   /* TODO: Also have to replace sym -> s in other lists like
1967      namelists, common lists and interface lists.  */
1968   gfc_free_symbol (sym);
1969
1970   return s;
1971
1972 bad:
1973   gfc_error ("Derived type '%s' at %C is being used before it is defined",
1974              sym->name);
1975   return NULL;
1976 }
1977
1978
1979 /* Given a derived type node and a component name, try to locate the
1980    component structure.  Returns the NULL pointer if the component is
1981    not found or the components are private.  If noaccess is set, no access
1982    checks are done.  */
1983
1984 gfc_component *
1985 gfc_find_component (gfc_symbol *sym, const char *name,
1986                     bool noaccess, bool silent)
1987 {
1988   gfc_component *p;
1989
1990   if (name == NULL)
1991     return NULL;
1992
1993   sym = gfc_use_derived (sym);
1994
1995   if (sym == NULL)
1996     return NULL;
1997
1998   for (p = sym->components; p; p = p->next)
1999     if (strcmp (p->name, name) == 0)
2000       break;
2001
2002   if (p == NULL
2003         && sym->attr.extension
2004         && sym->components->ts.type == BT_DERIVED)
2005     {
2006       p = gfc_find_component (sym->components->ts.u.derived, name,
2007                               noaccess, silent);
2008       /* Do not overwrite the error.  */
2009       if (p == NULL)
2010         return p;
2011     }
2012
2013   if (p == NULL && !silent)
2014     gfc_error ("'%s' at %C is not a member of the '%s' structure",
2015                name, sym->name);
2016
2017   else if (sym->attr.use_assoc && !noaccess)
2018     {
2019       bool is_parent_comp = sym->attr.extension && (p == sym->components);
2020       if (p->attr.access == ACCESS_PRIVATE ||
2021           (p->attr.access != ACCESS_PUBLIC
2022            && sym->component_access == ACCESS_PRIVATE
2023            && !is_parent_comp))
2024         {
2025           if (!silent)
2026             gfc_error ("Component '%s' at %C is a PRIVATE component of '%s'",
2027                        name, sym->name);
2028           return NULL;
2029         }
2030     }
2031
2032   return p;
2033 }
2034
2035
2036 /* Given a symbol, free all of the component structures and everything
2037    they point to.  */
2038
2039 static void
2040 free_components (gfc_component *p)
2041 {
2042   gfc_component *q;
2043
2044   for (; p; p = q)
2045     {
2046       q = p->next;
2047
2048       gfc_free_array_spec (p->as);
2049       gfc_free_expr (p->initializer);
2050
2051       gfc_free (p);
2052     }
2053 }
2054
2055
2056 /******************** Statement label management ********************/
2057
2058 /* Comparison function for statement labels, used for managing the
2059    binary tree.  */
2060
2061 static int
2062 compare_st_labels (void *a1, void *b1)
2063 {
2064   int a = ((gfc_st_label *) a1)->value;
2065   int b = ((gfc_st_label *) b1)->value;
2066
2067   return (b - a);
2068 }
2069
2070
2071 /* Free a single gfc_st_label structure, making sure the tree is not
2072    messed up.  This function is called only when some parse error
2073    occurs.  */
2074
2075 void
2076 gfc_free_st_label (gfc_st_label *label)
2077 {
2078
2079   if (label == NULL)
2080     return;
2081
2082   gfc_delete_bbt (&gfc_current_ns->st_labels, label, compare_st_labels);
2083
2084   if (label->format != NULL)
2085     gfc_free_expr (label->format);
2086
2087   gfc_free (label);
2088 }
2089
2090
2091 /* Free a whole tree of gfc_st_label structures.  */
2092
2093 static void
2094 free_st_labels (gfc_st_label *label)
2095 {
2096
2097   if (label == NULL)
2098     return;
2099
2100   free_st_labels (label->left);
2101   free_st_labels (label->right);
2102   
2103   if (label->format != NULL)
2104     gfc_free_expr (label->format);
2105   gfc_free (label);
2106 }
2107
2108
2109 /* Given a label number, search for and return a pointer to the label
2110    structure, creating it if it does not exist.  */
2111
2112 gfc_st_label *
2113 gfc_get_st_label (int labelno)
2114 {
2115   gfc_st_label *lp;
2116   gfc_namespace *ns;
2117
2118   /* Find the namespace of the scoping unit:
2119      If we're in a BLOCK construct, jump to the parent namespace.  */
2120   ns = gfc_current_ns;
2121   while (ns->proc_name && ns->proc_name->attr.flavor == FL_LABEL)
2122     ns = ns->parent;
2123
2124   /* First see if the label is already in this namespace.  */
2125   lp = ns->st_labels;
2126   while (lp)
2127     {
2128       if (lp->value == labelno)
2129         return lp;
2130
2131       if (lp->value < labelno)
2132         lp = lp->left;
2133       else
2134         lp = lp->right;
2135     }
2136
2137   lp = XCNEW (gfc_st_label);
2138
2139   lp->value = labelno;
2140   lp->defined = ST_LABEL_UNKNOWN;
2141   lp->referenced = ST_LABEL_UNKNOWN;
2142
2143   gfc_insert_bbt (&ns->st_labels, lp, compare_st_labels);
2144
2145   return lp;
2146 }
2147
2148
2149 /* Called when a statement with a statement label is about to be
2150    accepted.  We add the label to the list of the current namespace,
2151    making sure it hasn't been defined previously and referenced
2152    correctly.  */
2153
2154 void
2155 gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
2156 {
2157   int labelno;
2158
2159   labelno = lp->value;
2160
2161   if (lp->defined != ST_LABEL_UNKNOWN)
2162     gfc_error ("Duplicate statement label %d at %L and %L", labelno,
2163                &lp->where, label_locus);
2164   else
2165     {
2166       lp->where = *label_locus;
2167
2168       switch (type)
2169         {
2170         case ST_LABEL_FORMAT:
2171           if (lp->referenced == ST_LABEL_TARGET)
2172             gfc_error ("Label %d at %C already referenced as branch target",
2173                        labelno);
2174           else
2175             lp->defined = ST_LABEL_FORMAT;
2176
2177           break;
2178
2179         case ST_LABEL_TARGET:
2180           if (lp->referenced == ST_LABEL_FORMAT)
2181             gfc_error ("Label %d at %C already referenced as a format label",
2182                        labelno);
2183           else
2184             lp->defined = ST_LABEL_TARGET;
2185
2186           break;
2187
2188         default:
2189           lp->defined = ST_LABEL_BAD_TARGET;
2190           lp->referenced = ST_LABEL_BAD_TARGET;
2191         }
2192     }
2193 }
2194
2195
2196 /* Reference a label.  Given a label and its type, see if that
2197    reference is consistent with what is known about that label,
2198    updating the unknown state.  Returns FAILURE if something goes
2199    wrong.  */
2200
2201 gfc_try
2202 gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
2203 {
2204   gfc_sl_type label_type;
2205   int labelno;
2206   gfc_try rc;
2207
2208   if (lp == NULL)
2209     return SUCCESS;
2210
2211   labelno = lp->value;
2212
2213   if (lp->defined != ST_LABEL_UNKNOWN)
2214     label_type = lp->defined;
2215   else
2216     {
2217       label_type = lp->referenced;
2218       lp->where = gfc_current_locus;
2219     }
2220
2221   if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
2222     {
2223       gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
2224       rc = FAILURE;
2225       goto done;
2226     }
2227
2228   if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
2229       && type == ST_LABEL_FORMAT)
2230     {
2231       gfc_error ("Label %d at %C previously used as branch target", labelno);
2232       rc = FAILURE;
2233       goto done;
2234     }
2235
2236   lp->referenced = type;
2237   rc = SUCCESS;
2238
2239 done:
2240   return rc;
2241 }
2242
2243
2244 /*******A helper function for creating new expressions*************/
2245
2246
2247 gfc_expr *
2248 gfc_lval_expr_from_sym (gfc_symbol *sym)
2249 {
2250   gfc_expr *lval;
2251   lval = gfc_get_expr ();
2252   lval->expr_type = EXPR_VARIABLE;
2253   lval->where = sym->declared_at;
2254   lval->ts = sym->ts;
2255   lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
2256
2257   /* It will always be a full array.  */
2258   lval->rank = sym->as ? sym->as->rank : 0;
2259   if (lval->rank)
2260     {
2261       lval->ref = gfc_get_ref ();
2262       lval->ref->type = REF_ARRAY;
2263       lval->ref->u.ar.type = AR_FULL;
2264       lval->ref->u.ar.dimen = lval->rank;
2265       lval->ref->u.ar.where = sym->declared_at;
2266       lval->ref->u.ar.as = sym->as;
2267     }
2268
2269   return lval;
2270 }
2271
2272
2273 /************** Symbol table management subroutines ****************/
2274
2275 /* Basic details: Fortran 95 requires a potentially unlimited number
2276    of distinct namespaces when compiling a program unit.  This case
2277    occurs during a compilation of internal subprograms because all of
2278    the internal subprograms must be read before we can start
2279    generating code for the host.
2280
2281    Given the tricky nature of the Fortran grammar, we must be able to
2282    undo changes made to a symbol table if the current interpretation
2283    of a statement is found to be incorrect.  Whenever a symbol is
2284    looked up, we make a copy of it and link to it.  All of these
2285    symbols are kept in a singly linked list so that we can commit or
2286    undo the changes at a later time.
2287
2288    A symtree may point to a symbol node outside of its namespace.  In
2289    this case, that symbol has been used as a host associated variable
2290    at some previous time.  */
2291
2292 /* Allocate a new namespace structure.  Copies the implicit types from
2293    PARENT if PARENT_TYPES is set.  */
2294
2295 gfc_namespace *
2296 gfc_get_namespace (gfc_namespace *parent, int parent_types)
2297 {
2298   gfc_namespace *ns;
2299   gfc_typespec *ts;
2300   int in;
2301   int i;
2302
2303   ns = XCNEW (gfc_namespace);
2304   ns->sym_root = NULL;
2305   ns->uop_root = NULL;
2306   ns->tb_sym_root = NULL;
2307   ns->finalizers = NULL;
2308   ns->default_access = ACCESS_UNKNOWN;
2309   ns->parent = parent;
2310
2311   for (in = GFC_INTRINSIC_BEGIN; in != GFC_INTRINSIC_END; in++)
2312     {
2313       ns->operator_access[in] = ACCESS_UNKNOWN;
2314       ns->tb_op[in] = NULL;
2315     }
2316
2317   /* Initialize default implicit types.  */
2318   for (i = 'a'; i <= 'z'; i++)
2319     {
2320       ns->set_flag[i - 'a'] = 0;
2321       ts = &ns->default_type[i - 'a'];
2322
2323       if (parent_types && ns->parent != NULL)
2324         {
2325           /* Copy parent settings.  */
2326           *ts = ns->parent->default_type[i - 'a'];
2327           continue;
2328         }
2329
2330       if (gfc_option.flag_implicit_none != 0)
2331         {
2332           gfc_clear_ts (ts);
2333           continue;
2334         }
2335
2336       if ('i' <= i && i <= 'n')
2337         {
2338           ts->type = BT_INTEGER;
2339           ts->kind = gfc_default_integer_kind;
2340         }
2341       else
2342         {
2343           ts->type = BT_REAL;
2344           ts->kind = gfc_default_real_kind;
2345         }
2346     }
2347
2348   ns->refs = 1;
2349
2350   return ns;
2351 }
2352
2353
2354 /* Comparison function for symtree nodes.  */
2355
2356 static int
2357 compare_symtree (void *_st1, void *_st2)
2358 {
2359   gfc_symtree *st1, *st2;
2360
2361   st1 = (gfc_symtree *) _st1;
2362   st2 = (gfc_symtree *) _st2;
2363
2364   return strcmp (st1->name, st2->name);
2365 }
2366
2367
2368 /* Allocate a new symtree node and associate it with the new symbol.  */
2369
2370 gfc_symtree *
2371 gfc_new_symtree (gfc_symtree **root, const char *name)
2372 {
2373   gfc_symtree *st;
2374
2375   st = XCNEW (gfc_symtree);
2376   st->name = gfc_get_string (name);
2377
2378   gfc_insert_bbt (root, st, compare_symtree);
2379   return st;
2380 }
2381
2382
2383 /* Delete a symbol from the tree.  Does not free the symbol itself!  */
2384
2385 void
2386 gfc_delete_symtree (gfc_symtree **root, const char *name)
2387 {
2388   gfc_symtree st, *st0;
2389
2390   st0 = gfc_find_symtree (*root, name);
2391
2392   st.name = gfc_get_string (name);
2393   gfc_delete_bbt (root, &st, compare_symtree);
2394
2395   gfc_free (st0);
2396 }
2397
2398
2399 /* Given a root symtree node and a name, try to find the symbol within
2400    the namespace.  Returns NULL if the symbol is not found.  */
2401
2402 gfc_symtree *
2403 gfc_find_symtree (gfc_symtree *st, const char *name)
2404 {
2405   int c;
2406
2407   while (st != NULL)
2408     {
2409       c = strcmp (name, st->name);
2410       if (c == 0)
2411         return st;
2412
2413       st = (c < 0) ? st->left : st->right;
2414     }
2415
2416   return NULL;
2417 }
2418
2419
2420 /* Return a symtree node with a name that is guaranteed to be unique
2421    within the namespace and corresponds to an illegal fortran name.  */
2422
2423 gfc_symtree *
2424 gfc_get_unique_symtree (gfc_namespace *ns)
2425 {
2426   char name[GFC_MAX_SYMBOL_LEN + 1];
2427   static int serial = 0;
2428
2429   sprintf (name, "@%d", serial++);
2430   return gfc_new_symtree (&ns->sym_root, name);
2431 }
2432
2433
2434 /* Given a name find a user operator node, creating it if it doesn't
2435    exist.  These are much simpler than symbols because they can't be
2436    ambiguous with one another.  */
2437
2438 gfc_user_op *
2439 gfc_get_uop (const char *name)
2440 {
2441   gfc_user_op *uop;
2442   gfc_symtree *st;
2443
2444   st = gfc_find_symtree (gfc_current_ns->uop_root, name);
2445   if (st != NULL)
2446     return st->n.uop;
2447
2448   st = gfc_new_symtree (&gfc_current_ns->uop_root, name);
2449
2450   uop = st->n.uop = XCNEW (gfc_user_op);
2451   uop->name = gfc_get_string (name);
2452   uop->access = ACCESS_UNKNOWN;
2453   uop->ns = gfc_current_ns;
2454
2455   return uop;
2456 }
2457
2458
2459 /* Given a name find the user operator node.  Returns NULL if it does
2460    not exist.  */
2461
2462 gfc_user_op *
2463 gfc_find_uop (const char *name, gfc_namespace *ns)
2464 {
2465   gfc_symtree *st;
2466
2467   if (ns == NULL)
2468     ns = gfc_current_ns;
2469
2470   st = gfc_find_symtree (ns->uop_root, name);
2471   return (st == NULL) ? NULL : st->n.uop;
2472 }
2473
2474
2475 /* Remove a gfc_symbol structure and everything it points to.  */
2476
2477 void
2478 gfc_free_symbol (gfc_symbol *sym)
2479 {
2480
2481   if (sym == NULL)
2482     return;
2483
2484   gfc_free_array_spec (sym->as);
2485
2486   free_components (sym->components);
2487
2488   gfc_free_expr (sym->value);
2489
2490   gfc_free_namelist (sym->namelist);
2491
2492   gfc_free_namespace (sym->formal_ns);
2493
2494   if (!sym->attr.generic_copy)
2495     gfc_free_interface (sym->generic);
2496
2497   gfc_free_formal_arglist (sym->formal);
2498
2499   gfc_free_namespace (sym->f2k_derived);
2500
2501   gfc_free (sym);
2502 }
2503
2504
2505 /* Allocate and initialize a new symbol node.  */
2506
2507 gfc_symbol *
2508 gfc_new_symbol (const char *name, gfc_namespace *ns)
2509 {
2510   gfc_symbol *p;
2511
2512   p = XCNEW (gfc_symbol);
2513
2514   gfc_clear_ts (&p->ts);
2515   gfc_clear_attr (&p->attr);
2516   p->ns = ns;
2517
2518   p->declared_at = gfc_current_locus;
2519
2520   if (strlen (name) > GFC_MAX_SYMBOL_LEN)
2521     gfc_internal_error ("new_symbol(): Symbol name too long");
2522
2523   p->name = gfc_get_string (name);
2524
2525   /* Make sure flags for symbol being C bound are clear initially.  */
2526   p->attr.is_bind_c = 0;
2527   p->attr.is_iso_c = 0;
2528   /* Make sure the binding label field has a Nul char to start.  */
2529   p->binding_label[0] = '\0';
2530
2531   /* Clear the ptrs we may need.  */
2532   p->common_block = NULL;
2533   p->f2k_derived = NULL;
2534   p->assoc = NULL;
2535   
2536   return p;
2537 }
2538
2539
2540 /* Generate an error if a symbol is ambiguous.  */
2541
2542 static void
2543 ambiguous_symbol (const char *name, gfc_symtree *st)
2544 {
2545
2546   if (st->n.sym->module)
2547     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2548                "from module '%s'", name, st->n.sym->name, st->n.sym->module);
2549   else
2550     gfc_error ("Name '%s' at %C is an ambiguous reference to '%s' "
2551                "from current program unit", name, st->n.sym->name);
2552 }
2553
2554
2555 /* If we're in a SELECT TYPE block, check if the variable 'st' matches any
2556    selector on the stack. If yes, replace it by the corresponding temporary.  */
2557
2558 static void
2559 select_type_insert_tmp (gfc_symtree **st)
2560 {
2561   gfc_select_type_stack *stack = select_type_stack;
2562   for (; stack; stack = stack->prev)
2563     if ((*st)->n.sym == stack->selector && stack->tmp)
2564       *st = stack->tmp;
2565 }
2566
2567
2568 /* Search for a symtree starting in the current namespace, resorting to
2569    any parent namespaces if requested by a nonzero parent_flag.
2570    Returns nonzero if the name is ambiguous.  */
2571
2572 int
2573 gfc_find_sym_tree (const char *name, gfc_namespace *ns, int parent_flag,
2574                    gfc_symtree **result)
2575 {
2576   gfc_symtree *st;
2577
2578   if (ns == NULL)
2579     ns = gfc_current_ns;
2580
2581   do
2582     {
2583       st = gfc_find_symtree (ns->sym_root, name);
2584       if (st != NULL)
2585         {
2586           select_type_insert_tmp (&st);
2587
2588           *result = st;
2589           /* Ambiguous generic interfaces are permitted, as long
2590              as the specific interfaces are different.  */
2591           if (st->ambiguous && !st->n.sym->attr.generic)
2592             {
2593               ambiguous_symbol (name, st);
2594               return 1;
2595             }
2596
2597           return 0;
2598         }
2599
2600       if (!parent_flag)
2601         break;
2602
2603       ns = ns->parent;
2604     }
2605   while (ns != NULL);
2606
2607   *result = NULL;
2608   return 0;
2609 }
2610
2611
2612 /* Same, but returns the symbol instead.  */
2613
2614 int
2615 gfc_find_symbol (const char *name, gfc_namespace *ns, int parent_flag,
2616                  gfc_symbol **result)
2617 {
2618   gfc_symtree *st;
2619   int i;
2620
2621   i = gfc_find_sym_tree (name, ns, parent_flag, &st);
2622
2623   if (st == NULL)
2624     *result = NULL;
2625   else
2626     *result = st->n.sym;
2627
2628   return i;
2629 }
2630
2631
2632 /* Save symbol with the information necessary to back it out.  */
2633
2634 static void
2635 save_symbol_data (gfc_symbol *sym)
2636 {
2637
2638   if (sym->gfc_new || sym->old_symbol != NULL)
2639     return;
2640
2641   sym->old_symbol = XCNEW (gfc_symbol);
2642   *(sym->old_symbol) = *sym;
2643
2644   sym->tlink = changed_syms;
2645   changed_syms = sym;
2646 }
2647
2648
2649 /* Given a name, find a symbol, or create it if it does not exist yet
2650    in the current namespace.  If the symbol is found we make sure that
2651    it's OK.
2652
2653    The integer return code indicates
2654      0   All OK
2655      1   The symbol name was ambiguous
2656      2   The name meant to be established was already host associated.
2657
2658    So if the return value is nonzero, then an error was issued.  */
2659
2660 int
2661 gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
2662                   bool allow_subroutine)
2663 {
2664   gfc_symtree *st;
2665   gfc_symbol *p;
2666
2667   /* This doesn't usually happen during resolution.  */
2668   if (ns == NULL)
2669     ns = gfc_current_ns;
2670
2671   /* Try to find the symbol in ns.  */
2672   st = gfc_find_symtree (ns->sym_root, name);
2673
2674   if (st == NULL)
2675     {
2676       /* If not there, create a new symbol.  */
2677       p = gfc_new_symbol (name, ns);
2678
2679       /* Add to the list of tentative symbols.  */
2680       p->old_symbol = NULL;
2681       p->tlink = changed_syms;
2682       p->mark = 1;
2683       p->gfc_new = 1;
2684       changed_syms = p;
2685
2686       st = gfc_new_symtree (&ns->sym_root, name);
2687       st->n.sym = p;
2688       p->refs++;
2689
2690     }
2691   else
2692     {
2693       /* Make sure the existing symbol is OK.  Ambiguous
2694          generic interfaces are permitted, as long as the
2695          specific interfaces are different.  */
2696       if (st->ambiguous && !st->n.sym->attr.generic)
2697         {
2698           ambiguous_symbol (name, st);
2699           return 1;
2700         }
2701
2702       p = st->n.sym;
2703       if (p->ns != ns && (!p->attr.function || ns->proc_name != p)
2704           && !(allow_subroutine && p->attr.subroutine)
2705           && !(ns->proc_name && ns->proc_name->attr.if_source == IFSRC_IFBODY
2706           && (ns->has_import_set || p->attr.imported)))
2707         {
2708           /* Symbol is from another namespace.  */
2709           gfc_error ("Symbol '%s' at %C has already been host associated",
2710                      name);
2711           return 2;
2712         }
2713
2714       p->mark = 1;
2715
2716       /* Copy in case this symbol is changed.  */
2717       save_symbol_data (p);
2718     }
2719
2720   *result = st;
2721   return 0;
2722 }
2723
2724
2725 int
2726 gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
2727 {
2728   gfc_symtree *st;
2729   int i;
2730
2731   i = gfc_get_sym_tree (name, ns, &st, false);
2732   if (i != 0)
2733     return i;
2734
2735   if (st)
2736     *result = st->n.sym;
2737   else
2738     *result = NULL;
2739   return i;
2740 }
2741
2742
2743 /* Subroutine that searches for a symbol, creating it if it doesn't
2744    exist, but tries to host-associate the symbol if possible.  */
2745
2746 int
2747 gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
2748 {
2749   gfc_symtree *st;
2750   int i;
2751
2752   i = gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
2753
2754   if (st != NULL)
2755     {
2756       save_symbol_data (st->n.sym);
2757       *result = st;
2758       return i;
2759     }
2760
2761   if (gfc_current_ns->parent != NULL)
2762     {
2763       i = gfc_find_sym_tree (name, gfc_current_ns->parent, 1, &st);
2764       if (i)
2765         return i;
2766
2767       if (st != NULL)
2768         {
2769           *result = st;
2770           return 0;
2771         }
2772     }
2773
2774   return gfc_get_sym_tree (name, gfc_current_ns, result, false);
2775 }
2776
2777
2778 int
2779 gfc_get_ha_symbol (const char *name, gfc_symbol **result)
2780 {
2781   int i;
2782   gfc_symtree *st;
2783
2784   i = gfc_get_ha_sym_tree (name, &st);
2785
2786   if (st)
2787     *result = st->n.sym;
2788   else
2789     *result = NULL;
2790
2791   return i;
2792 }
2793
2794 /* Return true if both symbols could refer to the same data object.  Does
2795    not take account of aliasing due to equivalence statements.  */
2796
2797 int
2798 gfc_symbols_could_alias (gfc_symbol *lsym, gfc_symbol *rsym)
2799 {
2800   /* Aliasing isn't possible if the symbols have different base types.  */
2801   if (gfc_compare_types (&lsym->ts, &rsym->ts) == 0)
2802     return 0;
2803
2804   /* Pointers can point to other pointers, target objects and allocatable
2805      objects.  Two allocatable objects cannot share the same storage.  */
2806   if (lsym->attr.pointer
2807       && (rsym->attr.pointer || rsym->attr.allocatable || rsym->attr.target))
2808     return 1;
2809   if (lsym->attr.target && rsym->attr.pointer)
2810     return 1;
2811   if (lsym->attr.allocatable && rsym->attr.pointer)
2812     return 1;
2813
2814   return 0;
2815 }
2816
2817
2818 /* Undoes all the changes made to symbols in the current statement.
2819    This subroutine is made simpler due to the fact that attributes are
2820    never removed once added.  */
2821
2822 void
2823 gfc_undo_symbols (void)
2824 {
2825   gfc_symbol *p, *q, *old;
2826   tentative_tbp *tbp, *tbq;
2827
2828   for (p = changed_syms; p; p = q)
2829     {
2830       q = p->tlink;
2831
2832       if (p->gfc_new)
2833         {
2834           /* Symbol was new.  */
2835           if (p->attr.in_common && p->common_block && p->common_block->head)
2836             {
2837               /* If the symbol was added to any common block, it
2838                  needs to be removed to stop the resolver looking
2839                  for a (possibly) dead symbol.  */
2840
2841               if (p->common_block->head == p)
2842                 p->common_block->head = p->common_next;
2843               else
2844                 {
2845                   gfc_symbol *cparent, *csym;
2846
2847                   cparent = p->common_block->head;
2848                   csym = cparent->common_next;
2849
2850                   while (csym != p)
2851                     {
2852                       cparent = csym;
2853                       csym = csym->common_next;
2854                     }
2855
2856                   gcc_assert(cparent->common_next == p);
2857
2858                   cparent->common_next = csym->common_next;
2859                 }
2860             }
2861
2862           gfc_delete_symtree (&p->ns->sym_root, p->name);
2863
2864           p->refs--;
2865           if (p->refs < 0)
2866             gfc_internal_error ("gfc_undo_symbols(): Negative refs");
2867           if (p->refs == 0)
2868             gfc_free_symbol (p);
2869           continue;
2870         }
2871
2872       /* Restore previous state of symbol.  Just copy simple stuff.  */
2873       p->mark = 0;
2874       old = p->old_symbol;
2875
2876       p->ts.type = old->ts.type;
2877       p->ts.kind = old->ts.kind;
2878
2879       p->attr = old->attr;
2880
2881       if (p->value != old->value)
2882         {
2883           gfc_free_expr (old->value);
2884           p->value = NULL;
2885         }
2886
2887       if (p->as != old->as)
2888         {
2889           if (p->as)
2890             gfc_free_array_spec (p->as);
2891           p->as = old->as;
2892         }
2893
2894       p->generic = old->generic;
2895       p->component_access = old->component_access;
2896
2897       if (p->namelist != NULL && old->namelist == NULL)
2898         {
2899           gfc_free_namelist (p->namelist);
2900           p->namelist = NULL;
2901         }
2902       else
2903         {
2904           if (p->namelist_tail != old->namelist_tail)
2905             {
2906               gfc_free_namelist (old->namelist_tail);
2907               old->namelist_tail->next = NULL;
2908             }
2909         }
2910
2911       p->namelist_tail = old->namelist_tail;
2912
2913       if (p->formal != old->formal)
2914         {
2915           gfc_free_formal_arglist (p->formal);
2916           p->formal = old->formal;
2917         }
2918
2919       gfc_free (p->old_symbol);
2920       p->old_symbol = NULL;
2921       p->tlink = NULL;
2922     }
2923
2924   changed_syms = NULL;
2925
2926   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2927     {
2928       tbq = tbp->next;
2929       /* Procedure is already marked `error' by default.  */
2930       gfc_free (tbp);
2931     }
2932   tentative_tbp_list = NULL;
2933 }
2934
2935
2936 /* Free sym->old_symbol. sym->old_symbol is mostly a shallow copy of sym; the
2937    components of old_symbol that might need deallocation are the "allocatables"
2938    that are restored in gfc_undo_symbols(), with two exceptions: namelist and
2939    namelist_tail.  In case these differ between old_symbol and sym, it's just
2940    because sym->namelist has gotten a few more items.  */
2941
2942 static void
2943 free_old_symbol (gfc_symbol *sym)
2944 {
2945
2946   if (sym->old_symbol == NULL)
2947     return;
2948
2949   if (sym->old_symbol->as != sym->as) 
2950     gfc_free_array_spec (sym->old_symbol->as);
2951
2952   if (sym->old_symbol->value != sym->value) 
2953     gfc_free_expr (sym->old_symbol->value);
2954
2955   if (sym->old_symbol->formal != sym->formal)
2956     gfc_free_formal_arglist (sym->old_symbol->formal);
2957
2958   gfc_free (sym->old_symbol);
2959   sym->old_symbol = NULL;
2960 }
2961
2962
2963 /* Makes the changes made in the current statement permanent-- gets
2964    rid of undo information.  */
2965
2966 void
2967 gfc_commit_symbols (void)
2968 {
2969   gfc_symbol *p, *q;
2970   tentative_tbp *tbp, *tbq;
2971
2972   for (p = changed_syms; p; p = q)
2973     {
2974       q = p->tlink;
2975       p->tlink = NULL;
2976       p->mark = 0;
2977       p->gfc_new = 0;
2978       free_old_symbol (p);
2979     }
2980   changed_syms = NULL;
2981
2982   for (tbp = tentative_tbp_list; tbp; tbp = tbq)
2983     {
2984       tbq = tbp->next;
2985       tbp->proc->error = 0;
2986       gfc_free (tbp);
2987     }
2988   tentative_tbp_list = NULL;
2989 }
2990
2991
2992 /* Makes the changes made in one symbol permanent -- gets rid of undo
2993    information.  */
2994
2995 void
2996 gfc_commit_symbol (gfc_symbol *sym)
2997 {
2998   gfc_symbol *p;
2999
3000   if (changed_syms == sym)
3001     changed_syms = sym->tlink;
3002   else
3003     {
3004       for (p = changed_syms; p; p = p->tlink)
3005         if (p->tlink == sym)
3006           {
3007             p->tlink = sym->tlink;
3008             break;
3009           }
3010     }
3011
3012   sym->tlink = NULL;
3013   sym->mark = 0;
3014   sym->gfc_new = 0;
3015
3016   free_old_symbol (sym);
3017 }
3018
3019
3020 /* Recursively free trees containing type-bound procedures.  */
3021
3022 static void
3023 free_tb_tree (gfc_symtree *t)
3024 {
3025   if (t == NULL)
3026     return;
3027
3028   free_tb_tree (t->left);
3029   free_tb_tree (t->right);
3030
3031   /* TODO: Free type-bound procedure structs themselves; probably needs some
3032      sort of ref-counting mechanism.  */
3033
3034   gfc_free (t);
3035 }
3036
3037
3038 /* Recursive function that deletes an entire tree and all the common
3039    head structures it points to.  */
3040
3041 static void
3042 free_common_tree (gfc_symtree * common_tree)
3043 {
3044   if (common_tree == NULL)
3045     return;
3046
3047   free_common_tree (common_tree->left);
3048   free_common_tree (common_tree->right);
3049
3050   gfc_free (common_tree);
3051 }  
3052
3053
3054 /* Recursive function that deletes an entire tree and all the user
3055    operator nodes that it contains.  */
3056
3057 static void
3058 free_uop_tree (gfc_symtree *uop_tree)
3059 {
3060   if (uop_tree == NULL)
3061     return;
3062
3063   free_uop_tree (uop_tree->left);
3064   free_uop_tree (uop_tree->right);
3065
3066   gfc_free_interface (uop_tree->n.uop->op);
3067   gfc_free (uop_tree->n.uop);
3068   gfc_free (uop_tree);
3069 }
3070
3071
3072 /* Recursive function that deletes an entire tree and all the symbols
3073    that it contains.  */
3074
3075 static void
3076 free_sym_tree (gfc_symtree *sym_tree)
3077 {
3078   gfc_namespace *ns;
3079   gfc_symbol *sym;
3080
3081   if (sym_tree == NULL)
3082     return;
3083
3084   free_sym_tree (sym_tree->left);
3085   free_sym_tree (sym_tree->right);
3086
3087   sym = sym_tree->n.sym;
3088
3089   sym->refs--;
3090   if (sym->refs < 0)
3091     gfc_internal_error ("free_sym_tree(): Negative refs");
3092
3093   if (sym->formal_ns != NULL && sym->refs == 1)
3094     {
3095       /* As formal_ns contains a reference to sym, delete formal_ns just
3096          before the deletion of sym.  */
3097       ns = sym->formal_ns;
3098       sym->formal_ns = NULL;
3099       gfc_free_namespace (ns);
3100     }
3101   else if (sym->refs == 0)
3102     {
3103       /* Go ahead and delete the symbol.  */
3104       gfc_free_symbol (sym);
3105     }
3106
3107   gfc_free (sym_tree);
3108 }
3109
3110
3111 /* Free the derived type list.  */
3112
3113 void
3114 gfc_free_dt_list (void)
3115 {
3116   gfc_dt_list *dt, *n;
3117
3118   for (dt = gfc_derived_types; dt; dt = n)
3119     {
3120       n = dt->next;
3121       gfc_free (dt);
3122     }
3123
3124   gfc_derived_types = NULL;
3125 }
3126
3127
3128 /* Free the gfc_equiv_info's.  */
3129
3130 static void
3131 gfc_free_equiv_infos (gfc_equiv_info *s)
3132 {
3133   if (s == NULL)
3134     return;
3135   gfc_free_equiv_infos (s->next);
3136   gfc_free (s);
3137 }
3138
3139
3140 /* Free the gfc_equiv_lists.  */
3141
3142 static void
3143 gfc_free_equiv_lists (gfc_equiv_list *l)
3144 {
3145   if (l == NULL)
3146     return;
3147   gfc_free_equiv_lists (l->next);
3148   gfc_free_equiv_infos (l->equiv);
3149   gfc_free (l);
3150 }
3151
3152
3153 /* Free a finalizer procedure list.  */
3154
3155 void
3156 gfc_free_finalizer (gfc_finalizer* el)
3157 {
3158   if (el)
3159     {
3160       if (el->proc_sym)
3161         {
3162           --el->proc_sym->refs;
3163           if (!el->proc_sym->refs)
3164             gfc_free_symbol (el->proc_sym);
3165         }
3166
3167       gfc_free (el);
3168     }
3169 }
3170
3171 static void
3172 gfc_free_finalizer_list (gfc_finalizer* list)
3173 {
3174   while (list)
3175     {
3176       gfc_finalizer* current = list;
3177       list = list->next;
3178       gfc_free_finalizer (current);
3179     }
3180 }
3181
3182
3183 /* Create a new gfc_charlen structure and add it to a namespace.
3184    If 'old_cl' is given, the newly created charlen will be a copy of it.  */
3185
3186 gfc_charlen*
3187 gfc_new_charlen (gfc_namespace *ns, gfc_charlen *old_cl)
3188 {
3189   gfc_charlen *cl;
3190   cl = gfc_get_charlen ();
3191
3192   /* Put into namespace.  */
3193   cl->next = ns->cl_list;
3194   ns->cl_list = cl;
3195
3196   /* Copy old_cl.  */
3197   if (old_cl)
3198     {
3199       cl->length = gfc_copy_expr (old_cl->length);
3200       cl->length_from_typespec = old_cl->length_from_typespec;
3201       cl->backend_decl = old_cl->backend_decl;
3202       cl->passed_length = old_cl->passed_length;
3203       cl->resolved = old_cl->resolved;
3204     }
3205
3206   return cl;
3207 }
3208
3209
3210 /* Free the charlen list from cl to end (end is not freed). 
3211    Free the whole list if end is NULL.  */
3212
3213 void gfc_free_charlen (gfc_charlen *cl, gfc_charlen *end)
3214 {
3215   gfc_charlen *cl2;
3216
3217   for (; cl != end; cl = cl2)
3218     {
3219       gcc_assert (cl);
3220
3221       cl2 = cl->next;
3222       gfc_free_expr (cl->length);
3223       gfc_free (cl);
3224     }
3225 }
3226
3227
3228 /* Free a namespace structure and everything below it.  Interface
3229    lists associated with intrinsic operators are not freed.  These are
3230    taken care of when a specific name is freed.  */
3231
3232 void
3233 gfc_free_namespace (gfc_namespace *ns)
3234 {
3235   gfc_namespace *p, *q;
3236   int i;
3237
3238   if (ns == NULL)
3239     return;
3240
3241   ns->refs--;
3242   if (ns->refs > 0)
3243     return;
3244   gcc_assert (ns->refs == 0);
3245
3246   gfc_free_statements (ns->code);
3247
3248   free_sym_tree (ns->sym_root);
3249   free_uop_tree (ns->uop_root);
3250   free_common_tree (ns->common_root);
3251   free_tb_tree (ns->tb_sym_root);
3252   free_tb_tree (ns->tb_uop_root);
3253   gfc_free_finalizer_list (ns->finalizers);
3254   gfc_free_charlen (ns->cl_list, NULL);
3255   free_st_labels (ns->st_labels);
3256
3257   gfc_free_equiv (ns->equiv);
3258   gfc_free_equiv_lists (ns->equiv_lists);
3259   gfc_free_use_stmts (ns->use_stmts);
3260
3261   for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
3262     gfc_free_interface (ns->op[i]);
3263
3264   gfc_free_data (ns->data);
3265   p = ns->contained;
3266   gfc_free (ns);
3267
3268   /* Recursively free any contained namespaces.  */
3269   while (p != NULL)
3270     {
3271       q = p;
3272       p = p->sibling;
3273       gfc_free_namespace (q);
3274     }
3275 }
3276
3277
3278 void
3279 gfc_symbol_init_2 (void)
3280 {
3281
3282   gfc_current_ns = gfc_get_namespace (NULL, 0);
3283 }
3284
3285
3286 void
3287 gfc_symbol_done_2 (void)
3288 {
3289
3290   gfc_free_namespace (gfc_current_ns);
3291   gfc_current_ns = NULL;
3292   gfc_free_dt_list ();
3293 }
3294
3295
3296 /* Clear mark bits from symbol nodes associated with a symtree node.  */
3297
3298 static void
3299 clear_sym_mark (gfc_symtree *st)
3300 {
3301
3302   st->n.sym->mark = 0;
3303 }
3304
3305
3306 /* Recursively traverse the symtree nodes.  */
3307
3308 void
3309 gfc_traverse_symtree (gfc_symtree *st, void (*func) (gfc_symtree *))
3310 {
3311   if (!st)
3312     return;
3313
3314   gfc_traverse_symtree (st->left, func);
3315   (*func) (st);
3316   gfc_traverse_symtree (st->right, func);
3317 }
3318
3319
3320 /* Recursive namespace traversal function.  */
3321
3322 static void
3323 traverse_ns (gfc_symtree *st, void (*func) (gfc_symbol *))
3324 {
3325
3326   if (st == NULL)
3327     return;
3328
3329   traverse_ns (st->left, func);
3330
3331   if (st->n.sym->mark == 0)
3332     (*func) (st->n.sym);
3333   st->n.sym->mark = 1;
3334
3335   traverse_ns (st->right, func);
3336 }
3337
3338
3339 /* Call a given function for all symbols in the namespace.  We take
3340    care that each gfc_symbol node is called exactly once.  */
3341
3342 void
3343 gfc_traverse_ns (gfc_namespace *ns, void (*func) (gfc_symbol *))
3344 {
3345
3346   gfc_traverse_symtree (ns->sym_root, clear_sym_mark);
3347
3348   traverse_ns (ns->sym_root, func);
3349 }
3350
3351
3352 /* Return TRUE when name is the name of an intrinsic type.  */
3353
3354 bool
3355 gfc_is_intrinsic_typename (const char *name)
3356 {
3357   if (strcmp (name, "integer") == 0
3358       || strcmp (name, "real") == 0
3359       || strcmp (name, "character") == 0
3360       || strcmp (name, "logical") == 0
3361       || strcmp (name, "complex") == 0
3362       || strcmp (name, "doubleprecision") == 0
3363       || strcmp (name, "doublecomplex") == 0)
3364     return true;
3365   else
3366     return false;
3367 }
3368
3369
3370 /* Return TRUE if the symbol is an automatic variable.  */
3371
3372 static bool
3373 gfc_is_var_automatic (gfc_symbol *sym)
3374 {
3375   /* Pointer and allocatable variables are never automatic.  */
3376   if (sym->attr.pointer || sym->attr.allocatable)
3377     return false;
3378   /* Check for arrays with non-constant size.  */
3379   if (sym->attr.dimension && sym->as
3380       && !gfc_is_compile_time_shape (sym->as))
3381     return true;
3382   /* Check for non-constant length character variables.  */
3383   if (sym->ts.type == BT_CHARACTER
3384       && sym->ts.u.cl
3385       && !gfc_is_constant_expr (sym->ts.u.cl->length))
3386     return true;
3387   return false;
3388 }
3389
3390 /* Given a symbol, mark it as SAVEd if it is allowed.  */
3391
3392 static void
3393 save_symbol (gfc_symbol *sym)
3394 {
3395
3396   if (sym->attr.use_assoc)
3397     return;
3398
3399   if (sym->attr.in_common
3400       || sym->attr.dummy
3401       || sym->attr.result
3402       || sym->attr.flavor != FL_VARIABLE)
3403     return;
3404   /* Automatic objects are not saved.  */
3405   if (gfc_is_var_automatic (sym))
3406     return;
3407   gfc_add_save (&sym->attr, sym->name, &sym->declared_at);
3408 }
3409
3410
3411 /* Mark those symbols which can be SAVEd as such.  */
3412
3413 void
3414 gfc_save_all (gfc_namespace *ns)
3415 {
3416   gfc_traverse_ns (ns, save_symbol);
3417 }
3418
3419
3420 #ifdef GFC_DEBUG
3421 /* Make sure that no changes to symbols are pending.  */
3422
3423 void
3424 gfc_symbol_state(void) {
3425
3426   if (changed_syms != NULL)
3427     gfc_internal_error("Symbol changes still pending!");
3428 }
3429 #endif
3430
3431
3432 /************** Global symbol handling ************/
3433
3434
3435 /* Search a tree for the global symbol.  */
3436
3437 gfc_gsymbol *
3438 gfc_find_gsymbol (gfc_gsymbol *symbol, const char *name)
3439 {
3440   int c;
3441
3442   if (symbol == NULL)
3443     return NULL;
3444
3445   while (symbol)
3446     {
3447       c = strcmp (name, symbol->name);
3448       if (!c)
3449         return symbol;
3450
3451       symbol = (c < 0) ? symbol->left : symbol->right;
3452     }
3453
3454   return NULL;
3455 }
3456
3457
3458 /* Compare two global symbols. Used for managing the BB tree.  */
3459
3460 static int
3461 gsym_compare (void *_s1, void *_s2)
3462 {
3463   gfc_gsymbol *s1, *s2;
3464
3465   s1 = (gfc_gsymbol *) _s1;
3466   s2 = (gfc_gsymbol *) _s2;
3467   return strcmp (s1->name, s2->name);
3468 }
3469
3470
3471 /* Get a global symbol, creating it if it doesn't exist.  */
3472
3473 gfc_gsymbol *
3474 gfc_get_gsymbol (const char *name)
3475 {
3476   gfc_gsymbol *s;
3477
3478   s = gfc_find_gsymbol (gfc_gsym_root, name);
3479   if (s != NULL)
3480     return s;
3481
3482   s = XCNEW (gfc_gsymbol);
3483   s->type = GSYM_UNKNOWN;
3484   s->name = gfc_get_string (name);
3485
3486   gfc_insert_bbt (&gfc_gsym_root, s, gsym_compare);
3487
3488   return s;
3489 }
3490
3491
3492 static gfc_symbol *
3493 get_iso_c_binding_dt (int sym_id)
3494 {
3495   gfc_dt_list *dt_list;
3496
3497   dt_list = gfc_derived_types;
3498
3499   /* Loop through the derived types in the name list, searching for
3500      the desired symbol from iso_c_binding.  Search the parent namespaces
3501      if necessary and requested to (parent_flag).  */
3502   while (dt_list != NULL)
3503     {
3504       if (dt_list->derived->from_intmod != INTMOD_NONE
3505           && dt_list->derived->intmod_sym_id == sym_id)
3506         return dt_list->derived;
3507
3508       dt_list = dt_list->next;
3509     }
3510
3511   return NULL;
3512 }
3513
3514
3515 /* Verifies that the given derived type symbol, derived_sym, is interoperable
3516    with C.  This is necessary for any derived type that is BIND(C) and for
3517    derived types that are parameters to functions that are BIND(C).  All
3518    fields of the derived type are required to be interoperable, and are tested
3519    for such.  If an error occurs, the errors are reported here, allowing for
3520    multiple errors to be handled for a single derived type.  */
3521
3522 gfc_try
3523 verify_bind_c_derived_type (gfc_symbol *derived_sym)
3524 {
3525   gfc_component *curr_comp = NULL;
3526   gfc_try is_c_interop = FAILURE;
3527   gfc_try retval = SUCCESS;
3528    
3529   if (derived_sym == NULL)
3530     gfc_internal_error ("verify_bind_c_derived_type(): Given symbol is "
3531                         "unexpectedly NULL");
3532
3533   /* If we've already looked at this derived symbol, do not look at it again
3534      so we don't repeat warnings/errors.  */
3535   if (derived_sym->ts.is_c_interop)
3536     return SUCCESS;
3537   
3538   /* The derived type must have the BIND attribute to be interoperable
3539      J3/04-007, Section 15.2.3.  */
3540   if (derived_sym->attr.is_bind_c != 1)
3541     {
3542       derived_sym->ts.is_c_interop = 0;
3543       gfc_error_now ("Derived type '%s' declared at %L must have the BIND "
3544                      "attribute to be C interoperable", derived_sym->name,
3545                      &(derived_sym->declared_at));
3546       retval = FAILURE;
3547     }
3548   
3549   curr_comp = derived_sym->components;
3550
3551   /* TODO: is this really an error?  */
3552   if (curr_comp == NULL)
3553     {
3554       gfc_error ("Derived type '%s' at %L is empty",
3555                  derived_sym->name, &(derived_sym->declared_at));
3556       return FAILURE;
3557     }
3558
3559   /* Initialize the derived type as being C interoperable.
3560      If we find an error in the components, this will be set false.  */
3561   derived_sym->ts.is_c_interop = 1;
3562   
3563   /* Loop through the list of components to verify that the kind of
3564      each is a C interoperable type.  */
3565   do
3566     {
3567       /* The components cannot be pointers (fortran sense).  
3568          J3/04-007, Section 15.2.3, C1505.      */
3569       if (curr_comp->attr.pointer != 0)
3570         {
3571           gfc_error ("Component '%s' at %L cannot have the "
3572                      "POINTER attribute because it is a member "
3573                      "of the BIND(C) derived type '%s' at %L",
3574                      curr_comp->name, &(curr_comp->loc),
3575                      derived_sym->name, &(derived_sym->declared_at));
3576           retval = FAILURE;
3577         }
3578
3579       if (curr_comp->attr.proc_pointer != 0)
3580         {
3581           gfc_error ("Procedure pointer component '%s' at %L cannot be a member"
3582                      " of the BIND(C) derived type '%s' at %L", curr_comp->name,
3583                      &curr_comp->loc, derived_sym->name,
3584                      &derived_sym->declared_at);
3585           retval = FAILURE;
3586         }
3587
3588       /* The components cannot be allocatable.
3589          J3/04-007, Section 15.2.3, C1505.      */
3590       if (curr_comp->attr.allocatable != 0)
3591         {
3592           gfc_error ("Component '%s' at %L cannot have the "
3593                      "ALLOCATABLE attribute because it is a member "
3594                      "of the BIND(C) derived type '%s' at %L",
3595                      curr_comp->name, &(curr_comp->loc),
3596                      derived_sym->name, &(derived_sym->declared_at));
3597           retval = FAILURE;
3598         }
3599       
3600       /* BIND(C) derived types must have interoperable components.  */
3601       if (curr_comp->ts.type == BT_DERIVED
3602           && curr_comp->ts.u.derived->ts.is_iso_c != 1 
3603           && curr_comp->ts.u.derived != derived_sym)
3604         {
3605           /* This should be allowed; the draft says a derived-type can not
3606              have type parameters if it is has the BIND attribute.  Type
3607              parameters seem to be for making parameterized derived types.
3608              There's no need to verify the type if it is c_ptr/c_funptr.  */
3609           retval = verify_bind_c_derived_type (curr_comp->ts.u.derived);
3610         }
3611       else
3612         {
3613           /* Grab the typespec for the given component and test the kind.  */ 
3614           is_c_interop = verify_c_interop (&(curr_comp->ts));
3615           
3616           if (is_c_interop != SUCCESS)
3617             {
3618               /* Report warning and continue since not fatal.  The
3619                  draft does specify a constraint that requires all fields
3620                  to interoperate, but if the user says real(4), etc., it
3621                  may interoperate with *something* in C, but the compiler
3622                  most likely won't know exactly what.  Further, it may not
3623                  interoperate with the same data type(s) in C if the user
3624                  recompiles with different flags (e.g., -m32 and -m64 on
3625                  x86_64 and using integer(4) to claim interop with a
3626                  C_LONG).  */
3627               if (derived_sym->attr.is_bind_c == 1)
3628                 /* If the derived type is bind(c), all fields must be
3629                    interop.  */
3630                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3631                              "may not be C interoperable, even though "
3632                              "derived type '%s' is BIND(C)",
3633                              curr_comp->name, derived_sym->name,
3634                              &(curr_comp->loc), derived_sym->name);
3635               else
3636                 /* If derived type is param to bind(c) routine, or to one
3637                    of the iso_c_binding procs, it must be interoperable, so
3638                    all fields must interop too.  */
3639                 gfc_warning ("Component '%s' in derived type '%s' at %L "
3640                              "may not be C interoperable",
3641                              curr_comp->name, derived_sym->name,
3642                              &(curr_comp->loc));
3643             }
3644         }
3645       
3646       curr_comp = curr_comp->next;
3647     } while (curr_comp != NULL); 
3648
3649
3650   /* Make sure we don't have conflicts with the attributes.  */
3651   if (derived_sym->attr.access == ACCESS_PRIVATE)
3652     {
3653       gfc_error ("Derived type '%s' at %L cannot be declared with both "
3654                  "PRIVATE and BIND(C) attributes", derived_sym->name,
3655                  &(derived_sym->declared_at));
3656       retval = FAILURE;
3657     }
3658
3659   if (derived_sym->attr.sequence != 0)
3660     {
3661       gfc_error ("Derived type '%s' at %L cannot have the SEQUENCE "
3662                  "attribute because it is BIND(C)", derived_sym->name,
3663                  &(derived_sym->declared_at));
3664       retval = FAILURE;
3665     }
3666
3667   /* Mark the derived type as not being C interoperable if we found an
3668      error.  If there were only warnings, proceed with the assumption
3669      it's interoperable.  */
3670   if (retval == FAILURE)
3671     derived_sym->ts.is_c_interop = 0;
3672   
3673   return retval;
3674 }
3675
3676
3677 /* Generate symbols for the named constants c_null_ptr and c_null_funptr.  */
3678
3679 static gfc_try
3680 gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
3681                            const char *module_name)
3682 {
3683   gfc_symtree *tmp_symtree;
3684   gfc_symbol *tmp_sym;
3685   gfc_constructor *c;
3686
3687   tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
3688          
3689   if (tmp_symtree != NULL)
3690     tmp_sym = tmp_symtree->n.sym;
3691   else
3692     {
3693       tmp_sym = NULL;
3694       gfc_internal_error ("gen_special_c_interop_ptr(): Unable to "
3695                           "create symbol for %s", ptr_name);
3696     }
3697
3698   /* Set up the symbol's important fields.  Save attr required so we can
3699      initialize the ptr to NULL.  */
3700   tmp_sym->attr.save = SAVE_EXPLICIT;
3701   tmp_sym->ts.is_c_interop = 1;
3702   tmp_sym->attr.is_c_interop = 1;
3703   tmp_sym->ts.is_iso_c = 1;
3704   tmp_sym->ts.type = BT_DERIVED;
3705
3706   /* The c_ptr and c_funptr derived types will provide the
3707      definition for c_null_ptr and c_null_funptr, respectively.  */
3708   if (ptr_id == ISOCBINDING_NULL_PTR)
3709     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_PTR);
3710   else
3711     tmp_sym->ts.u.derived = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
3712   if (tmp_sym->ts.u.derived == NULL)
3713     {
3714       /* This can occur if the user forgot to declare c_ptr or
3715          c_funptr and they're trying to use one of the procedures
3716          that has arg(s) of the missing type.  In this case, a
3717          regular version of the thing should have been put in the
3718          current ns.  */
3719       generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR 
3720                                    ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
3721                                    (const char *) (ptr_id == ISOCBINDING_NULL_PTR 
3722                                    ? "_gfortran_iso_c_binding_c_ptr"
3723                                    : "_gfortran_iso_c_binding_c_funptr"));
3724
3725       tmp_sym->ts.u.derived =
3726         get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
3727                               ? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
3728     }
3729
3730   /* Module name is some mangled version of iso_c_binding.  */
3731   tmp_sym->module = gfc_get_string (module_name);
3732   
3733   /* Say it's from the iso_c_binding module.  */
3734   tmp_sym->attr.is_iso_c = 1;
3735   
3736   tmp_sym->attr.use_assoc = 1;
3737   tmp_sym->attr.is_bind_c = 1;
3738   /* Set the binding_label.  */
3739   sprintf (tmp_sym->binding_label, "%s_%s", module_name, tmp_sym->name);
3740   
3741   /* Set the c_address field of c_null_ptr and c_null_funptr to
3742      the value of NULL.  */
3743   tmp_sym->value = gfc_get_expr ();
3744   tmp_sym->value->expr_type = EXPR_STRUCTURE;
3745   tmp_sym->value->ts.type = BT_DERIVED;
3746   tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
3747   gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
3748   c = gfc_constructor_first (tmp_sym->value->value.constructor);
3749   c->expr = gfc_get_expr ();
3750   c->expr->expr_type = EXPR_NULL;
3751   c->expr->ts.is_iso_c = 1;
3752   /* Must declare c_null_ptr and c_null_funptr as having the
3753      PARAMETER attribute so they can be used in init expressions.  */
3754   tmp_sym->attr.flavor = FL_PARAMETER;
3755
3756   return SUCCESS;