OSDN Git Service

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