OSDN Git Service

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