OSDN Git Service

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