OSDN Git Service

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