OSDN Git Service

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