OSDN Git Service

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