OSDN Git Service

3e7c6e618aa944615d13f8dbe29d0d7dd4863026
[pf3gnuchains/gcc-fork.git] / gcc / fortran / decl.c
1 /* Declaration statement matcher
2    Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3.  If not see
20 <http://www.gnu.org/licenses/>.  */
21
22 #include "config.h"
23 #include "system.h"
24 #include "gfortran.h"
25 #include "match.h"
26 #include "parse.h"
27 #include "flags.h"
28 #include "constructor.h"
29 #include "tree.h"
30
31 /* Macros to access allocate memory for gfc_data_variable,
32    gfc_data_value and gfc_data.  */
33 #define gfc_get_data_variable() XCNEW (gfc_data_variable)
34 #define gfc_get_data_value() XCNEW (gfc_data_value)
35 #define gfc_get_data() XCNEW (gfc_data)
36
37
38 static gfc_try set_binding_label (const char **, const char *, int);
39
40
41 /* This flag is set if an old-style length selector is matched
42    during a type-declaration statement.  */
43
44 static int old_char_selector;
45
46 /* When variables acquire types and attributes from a declaration
47    statement, they get them from the following static variables.  The
48    first part of a declaration sets these variables and the second
49    part copies these into symbol structures.  */
50
51 static gfc_typespec current_ts;
52
53 static symbol_attribute current_attr;
54 static gfc_array_spec *current_as;
55 static int colon_seen;
56
57 /* The current binding label (if any).  */
58 static const char* curr_binding_label;
59 /* Need to know how many identifiers are on the current data declaration
60    line in case we're given the BIND(C) attribute with a NAME= specifier.  */
61 static int num_idents_on_line;
62 /* Need to know if a NAME= specifier was found during gfc_match_bind_c so we
63    can supply a name if the curr_binding_label is nil and NAME= was not.  */
64 static int has_name_equals = 0;
65
66 /* Initializer of the previous enumerator.  */
67
68 static gfc_expr *last_initializer;
69
70 /* History of all the enumerators is maintained, so that
71    kind values of all the enumerators could be updated depending
72    upon the maximum initialized value.  */
73
74 typedef struct enumerator_history
75 {
76   gfc_symbol *sym;
77   gfc_expr *initializer;
78   struct enumerator_history *next;
79 }
80 enumerator_history;
81
82 /* Header of enum history chain.  */
83
84 static enumerator_history *enum_history = NULL;
85
86 /* Pointer of enum history node containing largest initializer.  */
87
88 static enumerator_history *max_enum = NULL;
89
90 /* gfc_new_block points to the symbol of a newly matched block.  */
91
92 gfc_symbol *gfc_new_block;
93
94 bool gfc_matching_function;
95
96
97 /********************* DATA statement subroutines *********************/
98
99 static bool in_match_data = false;
100
101 bool
102 gfc_in_match_data (void)
103 {
104   return in_match_data;
105 }
106
107 static void
108 set_in_match_data (bool set_value)
109 {
110   in_match_data = set_value;
111 }
112
113 /* Free a gfc_data_variable structure and everything beneath it.  */
114
115 static void
116 free_variable (gfc_data_variable *p)
117 {
118   gfc_data_variable *q;
119
120   for (; p; p = q)
121     {
122       q = p->next;
123       gfc_free_expr (p->expr);
124       gfc_free_iterator (&p->iter, 0);
125       free_variable (p->list);
126       free (p);
127     }
128 }
129
130
131 /* Free a gfc_data_value structure and everything beneath it.  */
132
133 static void
134 free_value (gfc_data_value *p)
135 {
136   gfc_data_value *q;
137
138   for (; p; p = q)
139     {
140       q = p->next;
141       mpz_clear (p->repeat);
142       gfc_free_expr (p->expr);
143       free (p);
144     }
145 }
146
147
148 /* Free a list of gfc_data structures.  */
149
150 void
151 gfc_free_data (gfc_data *p)
152 {
153   gfc_data *q;
154
155   for (; p; p = q)
156     {
157       q = p->next;
158       free_variable (p->var);
159       free_value (p->value);
160       free (p);
161     }
162 }
163
164
165 /* Free all data in a namespace.  */
166
167 static void
168 gfc_free_data_all (gfc_namespace *ns)
169 {
170   gfc_data *d;
171
172   for (;ns->data;)
173     {
174       d = ns->data->next;
175       free (ns->data);
176       ns->data = d;
177     }
178 }
179
180
181 static match var_element (gfc_data_variable *);
182
183 /* Match a list of variables terminated by an iterator and a right
184    parenthesis.  */
185
186 static match
187 var_list (gfc_data_variable *parent)
188 {
189   gfc_data_variable *tail, var;
190   match m;
191
192   m = var_element (&var);
193   if (m == MATCH_ERROR)
194     return MATCH_ERROR;
195   if (m == MATCH_NO)
196     goto syntax;
197
198   tail = gfc_get_data_variable ();
199   *tail = var;
200
201   parent->list = tail;
202
203   for (;;)
204     {
205       if (gfc_match_char (',') != MATCH_YES)
206         goto syntax;
207
208       m = gfc_match_iterator (&parent->iter, 1);
209       if (m == MATCH_YES)
210         break;
211       if (m == MATCH_ERROR)
212         return MATCH_ERROR;
213
214       m = var_element (&var);
215       if (m == MATCH_ERROR)
216         return MATCH_ERROR;
217       if (m == MATCH_NO)
218         goto syntax;
219
220       tail->next = gfc_get_data_variable ();
221       tail = tail->next;
222
223       *tail = var;
224     }
225
226   if (gfc_match_char (')') != MATCH_YES)
227     goto syntax;
228   return MATCH_YES;
229
230 syntax:
231   gfc_syntax_error (ST_DATA);
232   return MATCH_ERROR;
233 }
234
235
236 /* Match a single element in a data variable list, which can be a
237    variable-iterator list.  */
238
239 static match
240 var_element (gfc_data_variable *new_var)
241 {
242   match m;
243   gfc_symbol *sym;
244
245   memset (new_var, 0, sizeof (gfc_data_variable));
246
247   if (gfc_match_char ('(') == MATCH_YES)
248     return var_list (new_var);
249
250   m = gfc_match_variable (&new_var->expr, 0);
251   if (m != MATCH_YES)
252     return m;
253
254   sym = new_var->expr->symtree->n.sym;
255
256   /* Symbol should already have an associated type.  */
257   if (gfc_check_symbol_typed (sym, gfc_current_ns,
258                               false, gfc_current_locus) == FAILURE)
259     return MATCH_ERROR;
260
261   if (!sym->attr.function && gfc_current_ns->parent
262       && gfc_current_ns->parent == sym->ns)
263     {
264       gfc_error ("Host associated variable '%s' may not be in the DATA "
265                  "statement at %C", sym->name);
266       return MATCH_ERROR;
267     }
268
269   if (gfc_current_state () != COMP_BLOCK_DATA
270       && sym->attr.in_common
271       && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
272                          "common block variable '%s' in DATA statement at %C",
273                          sym->name) == FAILURE)
274     return MATCH_ERROR;
275
276   if (gfc_add_data (&sym->attr, sym->name, &new_var->expr->where) == FAILURE)
277     return MATCH_ERROR;
278
279   return MATCH_YES;
280 }
281
282
283 /* Match the top-level list of data variables.  */
284
285 static match
286 top_var_list (gfc_data *d)
287 {
288   gfc_data_variable var, *tail, *new_var;
289   match m;
290
291   tail = NULL;
292
293   for (;;)
294     {
295       m = var_element (&var);
296       if (m == MATCH_NO)
297         goto syntax;
298       if (m == MATCH_ERROR)
299         return MATCH_ERROR;
300
301       new_var = gfc_get_data_variable ();
302       *new_var = var;
303
304       if (tail == NULL)
305         d->var = new_var;
306       else
307         tail->next = new_var;
308
309       tail = new_var;
310
311       if (gfc_match_char ('/') == MATCH_YES)
312         break;
313       if (gfc_match_char (',') != MATCH_YES)
314         goto syntax;
315     }
316
317   return MATCH_YES;
318
319 syntax:
320   gfc_syntax_error (ST_DATA);
321   gfc_free_data_all (gfc_current_ns);
322   return MATCH_ERROR;
323 }
324
325
326 static match
327 match_data_constant (gfc_expr **result)
328 {
329   char name[GFC_MAX_SYMBOL_LEN + 1];
330   gfc_symbol *sym, *dt_sym = NULL;
331   gfc_expr *expr;
332   match m;
333   locus old_loc;
334
335   m = gfc_match_literal_constant (&expr, 1);
336   if (m == MATCH_YES)
337     {
338       *result = expr;
339       return MATCH_YES;
340     }
341
342   if (m == MATCH_ERROR)
343     return MATCH_ERROR;
344
345   m = gfc_match_null (result);
346   if (m != MATCH_NO)
347     return m;
348
349   old_loc = gfc_current_locus;
350
351   /* Should this be a structure component, try to match it
352      before matching a name.  */
353   m = gfc_match_rvalue (result);
354   if (m == MATCH_ERROR)
355     return m;
356
357   if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
358     {
359       if (gfc_simplify_expr (*result, 0) == FAILURE)
360         m = MATCH_ERROR;
361       return m;
362     }
363
364   gfc_current_locus = old_loc;
365
366   m = gfc_match_name (name);
367   if (m != MATCH_YES)
368     return m;
369
370   if (gfc_find_symbol (name, NULL, 1, &sym))
371     return MATCH_ERROR;
372
373   if (sym && sym->attr.generic)
374     dt_sym = gfc_find_dt_in_generic (sym);
375
376   if (sym == NULL
377       || (sym->attr.flavor != FL_PARAMETER
378           && (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
379     {
380       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
381                  name);
382       return MATCH_ERROR;
383     }
384   else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
385     return gfc_match_structure_constructor (dt_sym, result);
386
387   /* Check to see if the value is an initialization array expression.  */
388   if (sym->value->expr_type == EXPR_ARRAY)
389     {
390       gfc_current_locus = old_loc;
391
392       m = gfc_match_init_expr (result);
393       if (m == MATCH_ERROR)
394         return m;
395
396       if (m == MATCH_YES)
397         {
398           if (gfc_simplify_expr (*result, 0) == FAILURE)
399             m = MATCH_ERROR;
400
401           if ((*result)->expr_type == EXPR_CONSTANT)
402             return m;
403           else
404             {
405               gfc_error ("Invalid initializer %s in Data statement at %C", name);
406               return MATCH_ERROR;
407             }
408         }
409     }
410
411   *result = gfc_copy_expr (sym->value);
412   return MATCH_YES;
413 }
414
415
416 /* Match a list of values in a DATA statement.  The leading '/' has
417    already been seen at this point.  */
418
419 static match
420 top_val_list (gfc_data *data)
421 {
422   gfc_data_value *new_val, *tail;
423   gfc_expr *expr;
424   match m;
425
426   tail = NULL;
427
428   for (;;)
429     {
430       m = match_data_constant (&expr);
431       if (m == MATCH_NO)
432         goto syntax;
433       if (m == MATCH_ERROR)
434         return MATCH_ERROR;
435
436       new_val = gfc_get_data_value ();
437       mpz_init (new_val->repeat);
438
439       if (tail == NULL)
440         data->value = new_val;
441       else
442         tail->next = new_val;
443
444       tail = new_val;
445
446       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
447         {
448           tail->expr = expr;
449           mpz_set_ui (tail->repeat, 1);
450         }
451       else
452         {
453           if (expr->ts.type == BT_INTEGER)
454             mpz_set (tail->repeat, expr->value.integer);
455           gfc_free_expr (expr);
456
457           m = match_data_constant (&tail->expr);
458           if (m == MATCH_NO)
459             goto syntax;
460           if (m == MATCH_ERROR)
461             return MATCH_ERROR;
462         }
463
464       if (gfc_match_char ('/') == MATCH_YES)
465         break;
466       if (gfc_match_char (',') == MATCH_NO)
467         goto syntax;
468     }
469
470   return MATCH_YES;
471
472 syntax:
473   gfc_syntax_error (ST_DATA);
474   gfc_free_data_all (gfc_current_ns);
475   return MATCH_ERROR;
476 }
477
478
479 /* Matches an old style initialization.  */
480
481 static match
482 match_old_style_init (const char *name)
483 {
484   match m;
485   gfc_symtree *st;
486   gfc_symbol *sym;
487   gfc_data *newdata;
488
489   /* Set up data structure to hold initializers.  */
490   gfc_find_sym_tree (name, NULL, 0, &st);
491   sym = st->n.sym;
492
493   newdata = gfc_get_data ();
494   newdata->var = gfc_get_data_variable ();
495   newdata->var->expr = gfc_get_variable_expr (st);
496   newdata->where = gfc_current_locus;
497
498   /* Match initial value list. This also eats the terminal '/'.  */
499   m = top_val_list (newdata);
500   if (m != MATCH_YES)
501     {
502       free (newdata);
503       return m;
504     }
505
506   if (gfc_pure (NULL))
507     {
508       gfc_error ("Initialization at %C is not allowed in a PURE procedure");
509       free (newdata);
510       return MATCH_ERROR;
511     }
512
513   if (gfc_implicit_pure (NULL))
514     gfc_current_ns->proc_name->attr.implicit_pure = 0;
515
516   /* Mark the variable as having appeared in a data statement.  */
517   if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
518     {
519       free (newdata);
520       return MATCH_ERROR;
521     }
522
523   /* Chain in namespace list of DATA initializers.  */
524   newdata->next = gfc_current_ns->data;
525   gfc_current_ns->data = newdata;
526
527   return m;
528 }
529
530
531 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
532    we are matching a DATA statement and are therefore issuing an error
533    if we encounter something unexpected, if not, we're trying to match
534    an old-style initialization expression of the form INTEGER I /2/.  */
535
536 match
537 gfc_match_data (void)
538 {
539   gfc_data *new_data;
540   match m;
541
542   set_in_match_data (true);
543
544   for (;;)
545     {
546       new_data = gfc_get_data ();
547       new_data->where = gfc_current_locus;
548
549       m = top_var_list (new_data);
550       if (m != MATCH_YES)
551         goto cleanup;
552
553       m = top_val_list (new_data);
554       if (m != MATCH_YES)
555         goto cleanup;
556
557       new_data->next = gfc_current_ns->data;
558       gfc_current_ns->data = new_data;
559
560       if (gfc_match_eos () == MATCH_YES)
561         break;
562
563       gfc_match_char (',');     /* Optional comma */
564     }
565
566   set_in_match_data (false);
567
568   if (gfc_pure (NULL))
569     {
570       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
571       return MATCH_ERROR;
572     }
573
574   if (gfc_implicit_pure (NULL))
575     gfc_current_ns->proc_name->attr.implicit_pure = 0;
576
577   return MATCH_YES;
578
579 cleanup:
580   set_in_match_data (false);
581   gfc_free_data (new_data);
582   return MATCH_ERROR;
583 }
584
585
586 /************************ Declaration statements *********************/
587
588
589 /* Auxilliary function to merge DIMENSION and CODIMENSION array specs.  */
590
591 static void
592 merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
593 {
594   int i;
595
596   if (to->rank == 0 && from->rank > 0)
597     {
598       to->rank = from->rank;
599       to->type = from->type;
600       to->cray_pointee = from->cray_pointee;
601       to->cp_was_assumed = from->cp_was_assumed;
602
603       for (i = 0; i < to->corank; i++)
604         {
605           to->lower[from->rank + i] = to->lower[i];
606           to->upper[from->rank + i] = to->upper[i];
607         }
608       for (i = 0; i < from->rank; i++)
609         {
610           if (copy)
611             {
612               to->lower[i] = gfc_copy_expr (from->lower[i]);
613               to->upper[i] = gfc_copy_expr (from->upper[i]);
614             }
615           else
616             {
617               to->lower[i] = from->lower[i];
618               to->upper[i] = from->upper[i];
619             }
620         }
621     }
622   else if (to->corank == 0 && from->corank > 0)
623     {
624       to->corank = from->corank;
625       to->cotype = from->cotype;
626
627       for (i = 0; i < from->corank; i++)
628         {
629           if (copy)
630             {
631               to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
632               to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
633             }
634           else
635             {
636               to->lower[to->rank + i] = from->lower[i];
637               to->upper[to->rank + i] = from->upper[i];
638             }
639         }
640     }
641 }
642
643
644 /* Match an intent specification.  Since this can only happen after an
645    INTENT word, a legal intent-spec must follow.  */
646
647 static sym_intent
648 match_intent_spec (void)
649 {
650
651   if (gfc_match (" ( in out )") == MATCH_YES)
652     return INTENT_INOUT;
653   if (gfc_match (" ( in )") == MATCH_YES)
654     return INTENT_IN;
655   if (gfc_match (" ( out )") == MATCH_YES)
656     return INTENT_OUT;
657
658   gfc_error ("Bad INTENT specification at %C");
659   return INTENT_UNKNOWN;
660 }
661
662
663 /* Matches a character length specification, which is either a
664    specification expression, '*', or ':'.  */
665
666 static match
667 char_len_param_value (gfc_expr **expr, bool *deferred)
668 {
669   match m;
670
671   *expr = NULL;
672   *deferred = false;
673
674   if (gfc_match_char ('*') == MATCH_YES)
675     return MATCH_YES;
676
677   if (gfc_match_char (':') == MATCH_YES)
678     {
679       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: deferred type "
680                           "parameter at %C") == FAILURE)
681         return MATCH_ERROR;
682
683       *deferred = true;
684
685       return MATCH_YES;
686     }
687
688   m = gfc_match_expr (expr);
689
690   if (m == MATCH_YES
691       && gfc_expr_check_typed (*expr, gfc_current_ns, false) == FAILURE)
692     return MATCH_ERROR;
693
694   if (m == MATCH_YES && (*expr)->expr_type == EXPR_FUNCTION)
695     {
696       if ((*expr)->value.function.actual
697           && (*expr)->value.function.actual->expr->symtree)
698         {
699           gfc_expr *e;
700           e = (*expr)->value.function.actual->expr;
701           if (e->symtree->n.sym->attr.flavor == FL_PROCEDURE
702               && e->expr_type == EXPR_VARIABLE)
703             {
704               if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
705                 goto syntax;
706               if (e->symtree->n.sym->ts.type == BT_CHARACTER
707                   && e->symtree->n.sym->ts.u.cl
708                   && e->symtree->n.sym->ts.u.cl->length->ts.type == BT_UNKNOWN)
709                 goto syntax;
710             }
711         }
712     }
713   return m;
714
715 syntax:
716   gfc_error ("Conflict in attributes of function argument at %C");
717   return MATCH_ERROR;
718 }
719
720
721 /* A character length is a '*' followed by a literal integer or a
722    char_len_param_value in parenthesis.  */
723
724 static match
725 match_char_length (gfc_expr **expr, bool *deferred)
726 {
727   int length;
728   match m;
729
730   *deferred = false; 
731   m = gfc_match_char ('*');
732   if (m != MATCH_YES)
733     return m;
734
735   m = gfc_match_small_literal_int (&length, NULL);
736   if (m == MATCH_ERROR)
737     return m;
738
739   if (m == MATCH_YES)
740     {
741       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
742                           "Old-style character length at %C") == FAILURE)
743         return MATCH_ERROR;
744       *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
745       return m;
746     }
747
748   if (gfc_match_char ('(') == MATCH_NO)
749     goto syntax;
750
751   m = char_len_param_value (expr, deferred);
752   if (m != MATCH_YES && gfc_matching_function)
753     {
754       gfc_undo_symbols ();
755       m = MATCH_YES;
756     }
757
758   if (m == MATCH_ERROR)
759     return m;
760   if (m == MATCH_NO)
761     goto syntax;
762
763   if (gfc_match_char (')') == MATCH_NO)
764     {
765       gfc_free_expr (*expr);
766       *expr = NULL;
767       goto syntax;
768     }
769
770   return MATCH_YES;
771
772 syntax:
773   gfc_error ("Syntax error in character length specification at %C");
774   return MATCH_ERROR;
775 }
776
777
778 /* Special subroutine for finding a symbol.  Check if the name is found
779    in the current name space.  If not, and we're compiling a function or
780    subroutine and the parent compilation unit is an interface, then check
781    to see if the name we've been given is the name of the interface
782    (located in another namespace).  */
783
784 static int
785 find_special (const char *name, gfc_symbol **result, bool allow_subroutine)
786 {
787   gfc_state_data *s;
788   gfc_symtree *st;
789   int i;
790
791   i = gfc_get_sym_tree (name, NULL, &st, allow_subroutine);
792   if (i == 0)
793     {
794       *result = st ? st->n.sym : NULL;
795       goto end;
796     }
797
798   if (gfc_current_state () != COMP_SUBROUTINE
799       && gfc_current_state () != COMP_FUNCTION)
800     goto end;
801
802   s = gfc_state_stack->previous;
803   if (s == NULL)
804     goto end;
805
806   if (s->state != COMP_INTERFACE)
807     goto end;
808   if (s->sym == NULL)
809     goto end;             /* Nameless interface.  */
810
811   if (strcmp (name, s->sym->name) == 0)
812     {
813       *result = s->sym;
814       return 0;
815     }
816
817 end:
818   return i;
819 }
820
821
822 /* Special subroutine for getting a symbol node associated with a
823    procedure name, used in SUBROUTINE and FUNCTION statements.  The
824    symbol is created in the parent using with symtree node in the
825    child unit pointing to the symbol.  If the current namespace has no
826    parent, then the symbol is just created in the current unit.  */
827
828 static int
829 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
830 {
831   gfc_symtree *st;
832   gfc_symbol *sym;
833   int rc = 0;
834
835   /* Module functions have to be left in their own namespace because
836      they have potentially (almost certainly!) already been referenced.
837      In this sense, they are rather like external functions.  This is
838      fixed up in resolve.c(resolve_entries), where the symbol name-
839      space is set to point to the master function, so that the fake
840      result mechanism can work.  */
841   if (module_fcn_entry)
842     {
843       /* Present if entry is declared to be a module procedure.  */
844       rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
845
846       if (*result == NULL)
847         rc = gfc_get_symbol (name, NULL, result);
848       else if (!gfc_get_symbol (name, NULL, &sym) && sym
849                  && (*result)->ts.type == BT_UNKNOWN
850                  && sym->attr.flavor == FL_UNKNOWN)
851         /* Pick up the typespec for the entry, if declared in the function
852            body.  Note that this symbol is FL_UNKNOWN because it will
853            only have appeared in a type declaration.  The local symtree
854            is set to point to the module symbol and a unique symtree
855            to the local version.  This latter ensures a correct clearing
856            of the symbols.  */
857         {
858           /* If the ENTRY proceeds its specification, we need to ensure
859              that this does not raise a "has no IMPLICIT type" error.  */
860           if (sym->ts.type == BT_UNKNOWN)
861             sym->attr.untyped = 1;
862
863           (*result)->ts = sym->ts;
864
865           /* Put the symbol in the procedure namespace so that, should
866              the ENTRY precede its specification, the specification
867              can be applied.  */
868           (*result)->ns = gfc_current_ns;
869
870           gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
871           st->n.sym = *result;
872           st = gfc_get_unique_symtree (gfc_current_ns);
873           st->n.sym = sym;
874         }
875     }
876   else
877     rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
878
879   if (rc)
880     return rc;
881
882   sym = *result;
883   gfc_current_ns->refs++;
884
885   if (sym && !sym->gfc_new && gfc_current_state () != COMP_INTERFACE)
886     {
887       /* Trap another encompassed procedure with the same name.  All
888          these conditions are necessary to avoid picking up an entry
889          whose name clashes with that of the encompassing procedure;
890          this is handled using gsymbols to register unique,globally
891          accessible names.  */
892       if (sym->attr.flavor != 0
893           && sym->attr.proc != 0
894           && (sym->attr.subroutine || sym->attr.function)
895           && sym->attr.if_source != IFSRC_UNKNOWN)
896         gfc_error_now ("Procedure '%s' at %C is already defined at %L",
897                        name, &sym->declared_at);
898
899       /* Trap a procedure with a name the same as interface in the
900          encompassing scope.  */
901       if (sym->attr.generic != 0
902           && (sym->attr.subroutine || sym->attr.function)
903           && !sym->attr.mod_proc)
904         gfc_error_now ("Name '%s' at %C is already defined"
905                        " as a generic interface at %L",
906                        name, &sym->declared_at);
907
908       /* Trap declarations of attributes in encompassing scope.  The
909          signature for this is that ts.kind is set.  Legitimate
910          references only set ts.type.  */
911       if (sym->ts.kind != 0
912           && !sym->attr.implicit_type
913           && sym->attr.proc == 0
914           && gfc_current_ns->parent != NULL
915           && sym->attr.access == 0
916           && !module_fcn_entry)
917         gfc_error_now ("Procedure '%s' at %C has an explicit interface "
918                        "and must not have attributes declared at %L",
919                        name, &sym->declared_at);
920     }
921
922   if (gfc_current_ns->parent == NULL || *result == NULL)
923     return rc;
924
925   /* Module function entries will already have a symtree in
926      the current namespace but will need one at module level.  */
927   if (module_fcn_entry)
928     {
929       /* Present if entry is declared to be a module procedure.  */
930       rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
931       if (st == NULL)
932         st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
933     }
934   else
935     st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
936
937   st->n.sym = sym;
938   sym->refs++;
939
940   /* See if the procedure should be a module procedure.  */
941
942   if (((sym->ns->proc_name != NULL
943                 && sym->ns->proc_name->attr.flavor == FL_MODULE
944                 && sym->attr.proc != PROC_MODULE)
945             || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
946         && gfc_add_procedure (&sym->attr, PROC_MODULE,
947                               sym->name, NULL) == FAILURE)
948     rc = 2;
949
950   return rc;
951 }
952
953
954 /* Verify that the given symbol representing a parameter is C
955    interoperable, by checking to see if it was marked as such after
956    its declaration.  If the given symbol is not interoperable, a
957    warning is reported, thus removing the need to return the status to
958    the calling function.  The standard does not require the user use
959    one of the iso_c_binding named constants to declare an
960    interoperable parameter, but we can't be sure if the param is C
961    interop or not if the user doesn't.  For example, integer(4) may be
962    legal Fortran, but doesn't have meaning in C.  It may interop with
963    a number of the C types, which causes a problem because the
964    compiler can't know which one.  This code is almost certainly not
965    portable, and the user will get what they deserve if the C type
966    across platforms isn't always interoperable with integer(4).  If
967    the user had used something like integer(c_int) or integer(c_long),
968    the compiler could have automatically handled the varying sizes
969    across platforms.  */
970
971 gfc_try
972 gfc_verify_c_interop_param (gfc_symbol *sym)
973 {
974   int is_c_interop = 0;
975   gfc_try retval = SUCCESS;
976
977   /* We check implicitly typed variables in symbol.c:gfc_set_default_type().
978      Don't repeat the checks here.  */
979   if (sym->attr.implicit_type)
980     return SUCCESS;
981   
982   /* For subroutines or functions that are passed to a BIND(C) procedure,
983      they're interoperable if they're BIND(C) and their params are all
984      interoperable.  */
985   if (sym->attr.flavor == FL_PROCEDURE)
986     {
987       if (sym->attr.is_bind_c == 0)
988         {
989           gfc_error_now ("Procedure '%s' at %L must have the BIND(C) "
990                          "attribute to be C interoperable", sym->name,
991                          &(sym->declared_at));
992                          
993           return FAILURE;
994         }
995       else
996         {
997           if (sym->attr.is_c_interop == 1)
998             /* We've already checked this procedure; don't check it again.  */
999             return SUCCESS;
1000           else
1001             return verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
1002                                       sym->common_block);
1003         }
1004     }
1005   
1006   /* See if we've stored a reference to a procedure that owns sym.  */
1007   if (sym->ns != NULL && sym->ns->proc_name != NULL)
1008     {
1009       if (sym->ns->proc_name->attr.is_bind_c == 1)
1010         {
1011           is_c_interop = (gfc_verify_c_interop (&(sym->ts)) == SUCCESS ? 1 : 0);
1012
1013           if (is_c_interop != 1)
1014             {
1015               /* Make personalized messages to give better feedback.  */
1016               if (sym->ts.type == BT_DERIVED)
1017                 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1018                            "BIND(C) procedure '%s' but is not C interoperable "
1019                            "because derived type '%s' is not C interoperable",
1020                            sym->name, &(sym->declared_at),
1021                            sym->ns->proc_name->name, 
1022                            sym->ts.u.derived->name);
1023               else if (sym->ts.type == BT_CLASS)
1024                 gfc_error ("Variable '%s' at %L is a dummy argument to the "
1025                            "BIND(C) procedure '%s' but is not C interoperable "
1026                            "because it is polymorphic",
1027                            sym->name, &(sym->declared_at),
1028                            sym->ns->proc_name->name);
1029               else
1030                 gfc_warning ("Variable '%s' at %L is a parameter to the "
1031                              "BIND(C) procedure '%s' but may not be C "
1032                              "interoperable",
1033                              sym->name, &(sym->declared_at),
1034                              sym->ns->proc_name->name);
1035             }
1036
1037           /* Character strings are only C interoperable if they have a
1038              length of 1.  */
1039           if (sym->ts.type == BT_CHARACTER)
1040             {
1041               gfc_charlen *cl = sym->ts.u.cl;
1042               if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
1043                   || mpz_cmp_si (cl->length->value.integer, 1) != 0)
1044                 {
1045                   gfc_error ("Character argument '%s' at %L "
1046                              "must be length 1 because "
1047                              "procedure '%s' is BIND(C)",
1048                              sym->name, &sym->declared_at,
1049                              sym->ns->proc_name->name);
1050                   retval = FAILURE;
1051                 }
1052             }
1053
1054           /* We have to make sure that any param to a bind(c) routine does
1055              not have the allocatable, pointer, or optional attributes,
1056              according to J3/04-007, section 5.1.  */
1057           if (sym->attr.allocatable == 1)
1058             {
1059               gfc_error ("Variable '%s' at %L cannot have the "
1060                          "ALLOCATABLE attribute because procedure '%s'"
1061                          " is BIND(C)", sym->name, &(sym->declared_at),
1062                          sym->ns->proc_name->name);
1063               retval = FAILURE;
1064             }
1065
1066           if (sym->attr.pointer == 1)
1067             {
1068               gfc_error ("Variable '%s' at %L cannot have the "
1069                          "POINTER attribute because procedure '%s'"
1070                          " is BIND(C)", sym->name, &(sym->declared_at),
1071                          sym->ns->proc_name->name);
1072               retval = FAILURE;
1073             }
1074
1075           if (sym->attr.optional == 1 && sym->attr.value)
1076             {
1077               gfc_error ("Variable '%s' at %L cannot have both the OPTIONAL "
1078                          "and the VALUE attribute because procedure '%s' "
1079                          "is BIND(C)", sym->name, &(sym->declared_at),
1080                          sym->ns->proc_name->name);
1081               retval = FAILURE;
1082             }
1083           else if (sym->attr.optional == 1
1084                    && gfc_notify_std (GFC_STD_F2008_TS, "TS29113: Variable '%s' "
1085                                       "at %L with OPTIONAL attribute in "
1086                                       "procedure '%s' which is BIND(C)",
1087                                       sym->name, &(sym->declared_at),
1088                                       sym->ns->proc_name->name)
1089                       == FAILURE)
1090             retval = FAILURE;
1091
1092           /* Make sure that if it has the dimension attribute, that it is
1093              either assumed size or explicit shape.  */
1094           if (sym->as != NULL)
1095             {
1096               if (sym->as->type == AS_ASSUMED_SHAPE)
1097                 {
1098                   gfc_error ("Assumed-shape array '%s' at %L cannot be an "
1099                              "argument to the procedure '%s' at %L because "
1100                              "the procedure is BIND(C)", sym->name,
1101                              &(sym->declared_at), sym->ns->proc_name->name,
1102                              &(sym->ns->proc_name->declared_at));
1103                   retval = FAILURE;
1104                 }
1105
1106               if (sym->as->type == AS_DEFERRED)
1107                 {
1108                   gfc_error ("Deferred-shape array '%s' at %L cannot be an "
1109                              "argument to the procedure '%s' at %L because "
1110                              "the procedure is BIND(C)", sym->name,
1111                              &(sym->declared_at), sym->ns->proc_name->name,
1112                              &(sym->ns->proc_name->declared_at));
1113                   retval = FAILURE;
1114                 }
1115           }
1116         }
1117     }
1118
1119   return retval;
1120 }
1121
1122
1123
1124 /* Function called by variable_decl() that adds a name to the symbol table.  */
1125
1126 static gfc_try
1127 build_sym (const char *name, gfc_charlen *cl, bool cl_deferred,
1128            gfc_array_spec **as, locus *var_locus)
1129 {
1130   symbol_attribute attr;
1131   gfc_symbol *sym;
1132
1133   if (gfc_get_symbol (name, NULL, &sym))
1134     return FAILURE;
1135
1136   /* Start updating the symbol table.  Add basic type attribute if present.  */
1137   if (current_ts.type != BT_UNKNOWN
1138       && (sym->attr.implicit_type == 0
1139           || !gfc_compare_types (&sym->ts, &current_ts))
1140       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
1141     return FAILURE;
1142
1143   if (sym->ts.type == BT_CHARACTER)
1144     {
1145       sym->ts.u.cl = cl;
1146       sym->ts.deferred = cl_deferred;
1147     }
1148
1149   /* Add dimension attribute if present.  */
1150   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
1151     return FAILURE;
1152   *as = NULL;
1153
1154   /* Add attribute to symbol.  The copy is so that we can reset the
1155      dimension attribute.  */
1156   attr = current_attr;
1157   attr.dimension = 0;
1158   attr.codimension = 0;
1159
1160   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
1161     return FAILURE;
1162
1163   /* Finish any work that may need to be done for the binding label,
1164      if it's a bind(c).  The bind(c) attr is found before the symbol
1165      is made, and before the symbol name (for data decls), so the
1166      current_ts is holding the binding label, or nothing if the
1167      name= attr wasn't given.  Therefore, test here if we're dealing
1168      with a bind(c) and make sure the binding label is set correctly.  */
1169   if (sym->attr.is_bind_c == 1)
1170     {
1171       if (!sym->binding_label)
1172         {
1173           /* Set the binding label and verify that if a NAME= was specified
1174              then only one identifier was in the entity-decl-list.  */
1175           if (set_binding_label (&sym->binding_label, sym->name,
1176                                  num_idents_on_line) == FAILURE)
1177             return FAILURE;
1178         }
1179     }
1180
1181   /* See if we know we're in a common block, and if it's a bind(c)
1182      common then we need to make sure we're an interoperable type.  */
1183   if (sym->attr.in_common == 1)
1184     {
1185       /* Test the common block object.  */
1186       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1187           && sym->ts.is_c_interop != 1)
1188         {
1189           gfc_error_now ("Variable '%s' in common block '%s' at %C "
1190                          "must be declared with a C interoperable "
1191                          "kind since common block '%s' is BIND(C)",
1192                          sym->name, sym->common_block->name,
1193                          sym->common_block->name);
1194           gfc_clear_error ();
1195         }
1196     }
1197
1198   sym->attr.implied_index = 0;
1199
1200   if (sym->ts.type == BT_CLASS)
1201     return gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
1202
1203   return SUCCESS;
1204 }
1205
1206
1207 /* Set character constant to the given length. The constant will be padded or
1208    truncated.  If we're inside an array constructor without a typespec, we
1209    additionally check that all elements have the same length; check_len -1
1210    means no checking.  */
1211
1212 void
1213 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1214 {
1215   gfc_char_t *s;
1216   int slen;
1217
1218   gcc_assert (expr->expr_type == EXPR_CONSTANT);
1219   gcc_assert (expr->ts.type == BT_CHARACTER);
1220
1221   slen = expr->value.character.length;
1222   if (len != slen)
1223     {
1224       s = gfc_get_wide_string (len + 1);
1225       memcpy (s, expr->value.character.string,
1226               MIN (len, slen) * sizeof (gfc_char_t));
1227       if (len > slen)
1228         gfc_wide_memset (&s[slen], ' ', len - slen);
1229
1230       if (gfc_option.warn_character_truncation && slen > len)
1231         gfc_warning_now ("CHARACTER expression at %L is being truncated "
1232                          "(%d/%d)", &expr->where, slen, len);
1233
1234       /* Apply the standard by 'hand' otherwise it gets cleared for
1235          initializers.  */
1236       if (check_len != -1 && slen != check_len
1237           && !(gfc_option.allow_std & GFC_STD_GNU))
1238         gfc_error_now ("The CHARACTER elements of the array constructor "
1239                        "at %L must have the same length (%d/%d)",
1240                         &expr->where, slen, check_len);
1241
1242       s[len] = '\0';
1243       free (expr->value.character.string);
1244       expr->value.character.string = s;
1245       expr->value.character.length = len;
1246     }
1247 }
1248
1249
1250 /* Function to create and update the enumerator history
1251    using the information passed as arguments.
1252    Pointer "max_enum" is also updated, to point to
1253    enum history node containing largest initializer.
1254
1255    SYM points to the symbol node of enumerator.
1256    INIT points to its enumerator value.  */
1257
1258 static void
1259 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1260 {
1261   enumerator_history *new_enum_history;
1262   gcc_assert (sym != NULL && init != NULL);
1263
1264   new_enum_history = XCNEW (enumerator_history);
1265
1266   new_enum_history->sym = sym;
1267   new_enum_history->initializer = init;
1268   new_enum_history->next = NULL;
1269
1270   if (enum_history == NULL)
1271     {
1272       enum_history = new_enum_history;
1273       max_enum = enum_history;
1274     }
1275   else
1276     {
1277       new_enum_history->next = enum_history;
1278       enum_history = new_enum_history;
1279
1280       if (mpz_cmp (max_enum->initializer->value.integer,
1281                    new_enum_history->initializer->value.integer) < 0)
1282         max_enum = new_enum_history;
1283     }
1284 }
1285
1286
1287 /* Function to free enum kind history.  */
1288
1289 void
1290 gfc_free_enum_history (void)
1291 {
1292   enumerator_history *current = enum_history;
1293   enumerator_history *next;
1294
1295   while (current != NULL)
1296     {
1297       next = current->next;
1298       free (current);
1299       current = next;
1300     }
1301   max_enum = NULL;
1302   enum_history = NULL;
1303 }
1304
1305
1306 /* Function called by variable_decl() that adds an initialization
1307    expression to a symbol.  */
1308
1309 static gfc_try
1310 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1311 {
1312   symbol_attribute attr;
1313   gfc_symbol *sym;
1314   gfc_expr *init;
1315
1316   init = *initp;
1317   if (find_special (name, &sym, false))
1318     return FAILURE;
1319
1320   attr = sym->attr;
1321
1322   /* If this symbol is confirming an implicit parameter type,
1323      then an initialization expression is not allowed.  */
1324   if (attr.flavor == FL_PARAMETER
1325       && sym->value != NULL
1326       && *initp != NULL)
1327     {
1328       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1329                  sym->name);
1330       return FAILURE;
1331     }
1332
1333   if (init == NULL)
1334     {
1335       /* An initializer is required for PARAMETER declarations.  */
1336       if (attr.flavor == FL_PARAMETER)
1337         {
1338           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1339           return FAILURE;
1340         }
1341     }
1342   else
1343     {
1344       /* If a variable appears in a DATA block, it cannot have an
1345          initializer.  */
1346       if (sym->attr.data)
1347         {
1348           gfc_error ("Variable '%s' at %C with an initializer already "
1349                      "appears in a DATA statement", sym->name);
1350           return FAILURE;
1351         }
1352
1353       /* Check if the assignment can happen. This has to be put off
1354          until later for derived type variables and procedure pointers.  */
1355       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1356           && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1357           && !sym->attr.proc_pointer 
1358           && gfc_check_assign_symbol (sym, init) == FAILURE)
1359         return FAILURE;
1360
1361       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1362             && init->ts.type == BT_CHARACTER)
1363         {
1364           /* Update symbol character length according initializer.  */
1365           if (gfc_check_assign_symbol (sym, init) == FAILURE)
1366             return FAILURE;
1367
1368           if (sym->ts.u.cl->length == NULL)
1369             {
1370               int clen;
1371               /* If there are multiple CHARACTER variables declared on the
1372                  same line, we don't want them to share the same length.  */
1373               sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1374
1375               if (sym->attr.flavor == FL_PARAMETER)
1376                 {
1377                   if (init->expr_type == EXPR_CONSTANT)
1378                     {
1379                       clen = init->value.character.length;
1380                       sym->ts.u.cl->length
1381                                 = gfc_get_int_expr (gfc_default_integer_kind,
1382                                                     NULL, clen);
1383                     }
1384                   else if (init->expr_type == EXPR_ARRAY)
1385                     {
1386                       gfc_constructor *c;
1387                       c = gfc_constructor_first (init->value.constructor);
1388                       clen = c->expr->value.character.length;
1389                       sym->ts.u.cl->length
1390                                 = gfc_get_int_expr (gfc_default_integer_kind,
1391                                                     NULL, clen);
1392                     }
1393                   else if (init->ts.u.cl && init->ts.u.cl->length)
1394                     sym->ts.u.cl->length =
1395                                 gfc_copy_expr (sym->value->ts.u.cl->length);
1396                 }
1397             }
1398           /* Update initializer character length according symbol.  */
1399           else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1400             {
1401               int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1402
1403               if (init->expr_type == EXPR_CONSTANT)
1404                 gfc_set_constant_character_len (len, init, -1);
1405               else if (init->expr_type == EXPR_ARRAY)
1406                 {
1407                   gfc_constructor *c;
1408
1409                   /* Build a new charlen to prevent simplification from
1410                      deleting the length before it is resolved.  */
1411                   init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1412                   init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1413
1414                   for (c = gfc_constructor_first (init->value.constructor);
1415                        c; c = gfc_constructor_next (c))
1416                     gfc_set_constant_character_len (len, c->expr, -1);
1417                 }
1418             }
1419         }
1420
1421       /* If sym is implied-shape, set its upper bounds from init.  */
1422       if (sym->attr.flavor == FL_PARAMETER && sym->attr.dimension
1423           && sym->as->type == AS_IMPLIED_SHAPE)
1424         {
1425           int dim;
1426
1427           if (init->rank == 0)
1428             {
1429               gfc_error ("Can't initialize implied-shape array at %L"
1430                          " with scalar", &sym->declared_at);
1431               return FAILURE;
1432             }
1433           gcc_assert (sym->as->rank == init->rank);
1434
1435           /* Shape should be present, we get an initialization expression.  */
1436           gcc_assert (init->shape);
1437
1438           for (dim = 0; dim < sym->as->rank; ++dim)
1439             {
1440               int k;
1441               gfc_expr* lower;
1442               gfc_expr* e;
1443               
1444               lower = sym->as->lower[dim];
1445               if (lower->expr_type != EXPR_CONSTANT)
1446                 {
1447                   gfc_error ("Non-constant lower bound in implied-shape"
1448                              " declaration at %L", &lower->where);
1449                   return FAILURE;
1450                 }
1451
1452               /* All dimensions must be without upper bound.  */
1453               gcc_assert (!sym->as->upper[dim]);
1454
1455               k = lower->ts.kind;
1456               e = gfc_get_constant_expr (BT_INTEGER, k, &sym->declared_at);
1457               mpz_add (e->value.integer,
1458                        lower->value.integer, init->shape[dim]);
1459               mpz_sub_ui (e->value.integer, e->value.integer, 1);
1460               sym->as->upper[dim] = e;
1461             }
1462
1463           sym->as->type = AS_EXPLICIT;
1464         }
1465
1466       /* Need to check if the expression we initialized this
1467          to was one of the iso_c_binding named constants.  If so,
1468          and we're a parameter (constant), let it be iso_c.
1469          For example:
1470          integer(c_int), parameter :: my_int = c_int
1471          integer(my_int) :: my_int_2
1472          If we mark my_int as iso_c (since we can see it's value
1473          is equal to one of the named constants), then my_int_2
1474          will be considered C interoperable.  */
1475       if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1476         {
1477           sym->ts.is_iso_c |= init->ts.is_iso_c;
1478           sym->ts.is_c_interop |= init->ts.is_c_interop;
1479           /* attr bits needed for module files.  */
1480           sym->attr.is_iso_c |= init->ts.is_iso_c;
1481           sym->attr.is_c_interop |= init->ts.is_c_interop;
1482           if (init->ts.is_iso_c)
1483             sym->ts.f90_type = init->ts.f90_type;
1484         }
1485
1486       /* Add initializer.  Make sure we keep the ranks sane.  */
1487       if (sym->attr.dimension && init->rank == 0)
1488         {
1489           mpz_t size;
1490           gfc_expr *array;
1491           int n;
1492           if (sym->attr.flavor == FL_PARAMETER
1493                 && init->expr_type == EXPR_CONSTANT
1494                 && spec_size (sym->as, &size) == SUCCESS
1495                 && mpz_cmp_si (size, 0) > 0)
1496             {
1497               array = gfc_get_array_expr (init->ts.type, init->ts.kind,
1498                                           &init->where);
1499               for (n = 0; n < (int)mpz_get_si (size); n++)
1500                 gfc_constructor_append_expr (&array->value.constructor,
1501                                              n == 0
1502                                                 ? init
1503                                                 : gfc_copy_expr (init),
1504                                              &init->where);
1505                 
1506               array->shape = gfc_get_shape (sym->as->rank);
1507               for (n = 0; n < sym->as->rank; n++)
1508                 spec_dimen_size (sym->as, n, &array->shape[n]);
1509
1510               init = array;
1511               mpz_clear (size);
1512             }
1513           init->rank = sym->as->rank;
1514         }
1515
1516       sym->value = init;
1517       if (sym->attr.save == SAVE_NONE)
1518         sym->attr.save = SAVE_IMPLICIT;
1519       *initp = NULL;
1520     }
1521
1522   return SUCCESS;
1523 }
1524
1525
1526 /* Function called by variable_decl() that adds a name to a structure
1527    being built.  */
1528
1529 static gfc_try
1530 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1531               gfc_array_spec **as)
1532 {
1533   gfc_component *c;
1534   gfc_try t = SUCCESS;
1535
1536   /* F03:C438/C439. If the current symbol is of the same derived type that we're
1537      constructing, it must have the pointer attribute.  */
1538   if ((current_ts.type == BT_DERIVED || current_ts.type == BT_CLASS)
1539       && current_ts.u.derived == gfc_current_block ()
1540       && current_attr.pointer == 0)
1541     {
1542       gfc_error ("Component at %C must have the POINTER attribute");
1543       return FAILURE;
1544     }
1545
1546   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1547     {
1548       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1549         {
1550           gfc_error ("Array component of structure at %C must have explicit "
1551                      "or deferred shape");
1552           return FAILURE;
1553         }
1554     }
1555
1556   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1557     return FAILURE;
1558
1559   c->ts = current_ts;
1560   if (c->ts.type == BT_CHARACTER)
1561     c->ts.u.cl = cl;
1562   c->attr = current_attr;
1563
1564   c->initializer = *init;
1565   *init = NULL;
1566
1567   c->as = *as;
1568   if (c->as != NULL)
1569     {
1570       if (c->as->corank)
1571         c->attr.codimension = 1;
1572       if (c->as->rank)
1573         c->attr.dimension = 1;
1574     }
1575   *as = NULL;
1576
1577   /* Should this ever get more complicated, combine with similar section
1578      in add_init_expr_to_sym into a separate function.  */
1579   if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer
1580       && c->ts.u.cl
1581       && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1582     {
1583       int len;
1584
1585       gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
1586       gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
1587       gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
1588
1589       len = mpz_get_si (c->ts.u.cl->length->value.integer);
1590
1591       if (c->initializer->expr_type == EXPR_CONSTANT)
1592         gfc_set_constant_character_len (len, c->initializer, -1);
1593       else if (mpz_cmp (c->ts.u.cl->length->value.integer,
1594                         c->initializer->ts.u.cl->length->value.integer))
1595         {
1596           gfc_constructor *ctor;
1597           ctor = gfc_constructor_first (c->initializer->value.constructor);
1598
1599           if (ctor)
1600             {
1601               int first_len;
1602               bool has_ts = (c->initializer->ts.u.cl
1603                              && c->initializer->ts.u.cl->length_from_typespec);
1604
1605               /* Remember the length of the first element for checking
1606                  that all elements *in the constructor* have the same
1607                  length.  This need not be the length of the LHS!  */
1608               gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
1609               gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
1610               first_len = ctor->expr->value.character.length;
1611
1612               for ( ; ctor; ctor = gfc_constructor_next (ctor))
1613                 if (ctor->expr->expr_type == EXPR_CONSTANT)
1614                 {
1615                   gfc_set_constant_character_len (len, ctor->expr,
1616                                                   has_ts ? -1 : first_len);
1617                   ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
1618                 }
1619             }
1620         }
1621     }
1622
1623   /* Check array components.  */
1624   if (!c->attr.dimension)
1625     goto scalar;
1626
1627   if (c->attr.pointer)
1628     {
1629       if (c->as->type != AS_DEFERRED)
1630         {
1631           gfc_error ("Pointer array component of structure at %C must have a "
1632                      "deferred shape");
1633           t = FAILURE;
1634         }
1635     }
1636   else if (c->attr.allocatable)
1637     {
1638       if (c->as->type != AS_DEFERRED)
1639         {
1640           gfc_error ("Allocatable component of structure at %C must have a "
1641                      "deferred shape");
1642           t = FAILURE;
1643         }
1644     }
1645   else
1646     {
1647       if (c->as->type != AS_EXPLICIT)
1648         {
1649           gfc_error ("Array component of structure at %C must have an "
1650                      "explicit shape");
1651           t = FAILURE;
1652         }
1653     }
1654
1655 scalar:
1656   if (c->ts.type == BT_CLASS)
1657     {
1658       bool delayed = (gfc_state_stack->sym == c->ts.u.derived)
1659                      || (!c->ts.u.derived->components
1660                          && !c->ts.u.derived->attr.zero_comp);
1661       return gfc_build_class_symbol (&c->ts, &c->attr, &c->as, delayed);
1662     }
1663
1664   return t;
1665 }
1666
1667
1668 /* Match a 'NULL()', and possibly take care of some side effects.  */
1669
1670 match
1671 gfc_match_null (gfc_expr **result)
1672 {
1673   gfc_symbol *sym;
1674   match m;
1675
1676   m = gfc_match (" null ( )");
1677   if (m != MATCH_YES)
1678     return m;
1679
1680   /* The NULL symbol now has to be/become an intrinsic function.  */
1681   if (gfc_get_symbol ("null", NULL, &sym))
1682     {
1683       gfc_error ("NULL() initialization at %C is ambiguous");
1684       return MATCH_ERROR;
1685     }
1686
1687   gfc_intrinsic_symbol (sym);
1688
1689   if (sym->attr.proc != PROC_INTRINSIC
1690       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1691                              sym->name, NULL) == FAILURE
1692           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1693     return MATCH_ERROR;
1694
1695   *result = gfc_get_null_expr (&gfc_current_locus);
1696
1697   return MATCH_YES;
1698 }
1699
1700
1701 /* Match the initialization expr for a data pointer or procedure pointer.  */
1702
1703 static match
1704 match_pointer_init (gfc_expr **init, int procptr)
1705 {
1706   match m;
1707
1708   if (gfc_pure (NULL) && gfc_state_stack->state != COMP_DERIVED)
1709     {
1710       gfc_error ("Initialization of pointer at %C is not allowed in "
1711                  "a PURE procedure");
1712       return MATCH_ERROR;
1713     }
1714
1715   /* Match NULL() initilization.  */
1716   m = gfc_match_null (init);
1717   if (m != MATCH_NO)
1718     return m;
1719
1720   /* Match non-NULL initialization.  */
1721   gfc_matching_ptr_assignment = !procptr;
1722   gfc_matching_procptr_assignment = procptr;
1723   m = gfc_match_rvalue (init);
1724   gfc_matching_ptr_assignment = 0;
1725   gfc_matching_procptr_assignment = 0;
1726   if (m == MATCH_ERROR)
1727     return MATCH_ERROR;
1728   else if (m == MATCH_NO)
1729     {
1730       gfc_error ("Error in pointer initialization at %C");
1731       return MATCH_ERROR;
1732     }
1733
1734   if (!procptr)
1735     gfc_resolve_expr (*init);
1736   
1737   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: non-NULL pointer "
1738                       "initialization at %C") == FAILURE)
1739     return MATCH_ERROR;
1740
1741   return MATCH_YES;
1742 }
1743
1744
1745 static gfc_try
1746 check_function_name (char *name)
1747 {
1748   /* In functions that have a RESULT variable defined, the function name always
1749      refers to function calls.  Therefore, the name is not allowed to appear in
1750      specification statements. When checking this, be careful about
1751      'hidden' procedure pointer results ('ppr@').  */
1752
1753   if (gfc_current_state () == COMP_FUNCTION)
1754     {
1755       gfc_symbol *block = gfc_current_block ();
1756       if (block && block->result && block->result != block
1757           && strcmp (block->result->name, "ppr@") != 0
1758           && strcmp (block->name, name) == 0)
1759         {
1760           gfc_error ("Function name '%s' not allowed at %C", name);
1761           return FAILURE;
1762         }
1763     }
1764
1765   return SUCCESS;
1766 }
1767
1768
1769 /* Match a variable name with an optional initializer.  When this
1770    subroutine is called, a variable is expected to be parsed next.
1771    Depending on what is happening at the moment, updates either the
1772    symbol table or the current interface.  */
1773
1774 static match
1775 variable_decl (int elem)
1776 {
1777   char name[GFC_MAX_SYMBOL_LEN + 1];
1778   gfc_expr *initializer, *char_len;
1779   gfc_array_spec *as;
1780   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1781   gfc_charlen *cl;
1782   bool cl_deferred;
1783   locus var_locus;
1784   match m;
1785   gfc_try t;
1786   gfc_symbol *sym;
1787
1788   initializer = NULL;
1789   as = NULL;
1790   cp_as = NULL;
1791
1792   /* When we get here, we've just matched a list of attributes and
1793      maybe a type and a double colon.  The next thing we expect to see
1794      is the name of the symbol.  */
1795   m = gfc_match_name (name);
1796   if (m != MATCH_YES)
1797     goto cleanup;
1798
1799   var_locus = gfc_current_locus;
1800
1801   /* Now we could see the optional array spec. or character length.  */
1802   m = gfc_match_array_spec (&as, true, true);
1803   if (m == MATCH_ERROR)
1804     goto cleanup;
1805
1806   if (m == MATCH_NO)
1807     as = gfc_copy_array_spec (current_as);
1808   else if (current_as)
1809     merge_array_spec (current_as, as, true);
1810
1811   if (gfc_option.flag_cray_pointer)
1812     cp_as = gfc_copy_array_spec (as);
1813
1814   /* At this point, we know for sure if the symbol is PARAMETER and can thus
1815      determine (and check) whether it can be implied-shape.  If it
1816      was parsed as assumed-size, change it because PARAMETERs can not
1817      be assumed-size.  */
1818   if (as)
1819     {
1820       if (as->type == AS_IMPLIED_SHAPE && current_attr.flavor != FL_PARAMETER)
1821         {
1822           m = MATCH_ERROR;
1823           gfc_error ("Non-PARAMETER symbol '%s' at %L can't be implied-shape",
1824                      name, &var_locus);
1825           goto cleanup;
1826         }
1827
1828       if (as->type == AS_ASSUMED_SIZE && as->rank == 1
1829           && current_attr.flavor == FL_PARAMETER)
1830         as->type = AS_IMPLIED_SHAPE;
1831
1832       if (as->type == AS_IMPLIED_SHAPE
1833           && gfc_notify_std (GFC_STD_F2008,
1834                              "Fortran 2008: Implied-shape array at %L",
1835                              &var_locus) == FAILURE)
1836         {
1837           m = MATCH_ERROR;
1838           goto cleanup;
1839         }
1840     }
1841
1842   char_len = NULL;
1843   cl = NULL;
1844   cl_deferred = false;
1845
1846   if (current_ts.type == BT_CHARACTER)
1847     {
1848       switch (match_char_length (&char_len, &cl_deferred))
1849         {
1850         case MATCH_YES:
1851           cl = gfc_new_charlen (gfc_current_ns, NULL);
1852
1853           cl->length = char_len;
1854           break;
1855
1856         /* Non-constant lengths need to be copied after the first
1857            element.  Also copy assumed lengths.  */
1858         case MATCH_NO:
1859           if (elem > 1
1860               && (current_ts.u.cl->length == NULL
1861                   || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
1862             {
1863               cl = gfc_new_charlen (gfc_current_ns, NULL);
1864               cl->length = gfc_copy_expr (current_ts.u.cl->length);
1865             }
1866           else
1867             cl = current_ts.u.cl;
1868
1869           cl_deferred = current_ts.deferred;
1870
1871           break;
1872
1873         case MATCH_ERROR:
1874           goto cleanup;
1875         }
1876     }
1877
1878   /*  If this symbol has already shown up in a Cray Pointer declaration,
1879       then we want to set the type & bail out.  */
1880   if (gfc_option.flag_cray_pointer)
1881     {
1882       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1883       if (sym != NULL && sym->attr.cray_pointee)
1884         {
1885           sym->ts.type = current_ts.type;
1886           sym->ts.kind = current_ts.kind;
1887           sym->ts.u.cl = cl;
1888           sym->ts.u.derived = current_ts.u.derived;
1889           sym->ts.is_c_interop = current_ts.is_c_interop;
1890           sym->ts.is_iso_c = current_ts.is_iso_c;
1891           m = MATCH_YES;
1892         
1893           /* Check to see if we have an array specification.  */
1894           if (cp_as != NULL)
1895             {
1896               if (sym->as != NULL)
1897                 {
1898                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1899                   gfc_free_array_spec (cp_as);
1900                   m = MATCH_ERROR;
1901                   goto cleanup;
1902                 }
1903               else
1904                 {
1905                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1906                     gfc_internal_error ("Couldn't set pointee array spec.");
1907
1908                   /* Fix the array spec.  */
1909                   m = gfc_mod_pointee_as (sym->as);
1910                   if (m == MATCH_ERROR)
1911                     goto cleanup;
1912                 }
1913             }
1914           goto cleanup;
1915         }
1916       else
1917         {
1918           gfc_free_array_spec (cp_as);
1919         }
1920     }
1921
1922   /* Procedure pointer as function result.  */
1923   if (gfc_current_state () == COMP_FUNCTION
1924       && strcmp ("ppr@", gfc_current_block ()->name) == 0
1925       && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
1926     strcpy (name, "ppr@");
1927
1928   if (gfc_current_state () == COMP_FUNCTION
1929       && strcmp (name, gfc_current_block ()->name) == 0
1930       && gfc_current_block ()->result
1931       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
1932     strcpy (name, "ppr@");
1933
1934   /* OK, we've successfully matched the declaration.  Now put the
1935      symbol in the current namespace, because it might be used in the
1936      optional initialization expression for this symbol, e.g. this is
1937      perfectly legal:
1938
1939      integer, parameter :: i = huge(i)
1940
1941      This is only true for parameters or variables of a basic type.
1942      For components of derived types, it is not true, so we don't
1943      create a symbol for those yet.  If we fail to create the symbol,
1944      bail out.  */
1945   if (gfc_current_state () != COMP_DERIVED
1946       && build_sym (name, cl, cl_deferred, &as, &var_locus) == FAILURE)
1947     {
1948       m = MATCH_ERROR;
1949       goto cleanup;
1950     }
1951
1952   if (check_function_name (name) == FAILURE)
1953     {
1954       m = MATCH_ERROR;
1955       goto cleanup;
1956     }
1957
1958   /* We allow old-style initializations of the form
1959        integer i /2/, j(4) /3*3, 1/
1960      (if no colon has been seen). These are different from data
1961      statements in that initializers are only allowed to apply to the
1962      variable immediately preceding, i.e.
1963        integer i, j /1, 2/
1964      is not allowed. Therefore we have to do some work manually, that
1965      could otherwise be left to the matchers for DATA statements.  */
1966
1967   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1968     {
1969       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1970                           "initialization at %C") == FAILURE)
1971         return MATCH_ERROR;
1972  
1973       return match_old_style_init (name);
1974     }
1975
1976   /* The double colon must be present in order to have initializers.
1977      Otherwise the statement is ambiguous with an assignment statement.  */
1978   if (colon_seen)
1979     {
1980       if (gfc_match (" =>") == MATCH_YES)
1981         {
1982           if (!current_attr.pointer)
1983             {
1984               gfc_error ("Initialization at %C isn't for a pointer variable");
1985               m = MATCH_ERROR;
1986               goto cleanup;
1987             }
1988
1989           m = match_pointer_init (&initializer, 0);
1990           if (m != MATCH_YES)
1991             goto cleanup;
1992         }
1993       else if (gfc_match_char ('=') == MATCH_YES)
1994         {
1995           if (current_attr.pointer)
1996             {
1997               gfc_error ("Pointer initialization at %C requires '=>', "
1998                          "not '='");
1999               m = MATCH_ERROR;
2000               goto cleanup;
2001             }
2002
2003           m = gfc_match_init_expr (&initializer);
2004           if (m == MATCH_NO)
2005             {
2006               gfc_error ("Expected an initialization expression at %C");
2007               m = MATCH_ERROR;
2008             }
2009
2010           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL)
2011               && gfc_state_stack->state != COMP_DERIVED)
2012             {
2013               gfc_error ("Initialization of variable at %C is not allowed in "
2014                          "a PURE procedure");
2015               m = MATCH_ERROR;
2016             }
2017
2018           if (m != MATCH_YES)
2019             goto cleanup;
2020         }
2021     }
2022
2023   if (initializer != NULL && current_attr.allocatable
2024         && gfc_current_state () == COMP_DERIVED)
2025     {
2026       gfc_error ("Initialization of allocatable component at %C is not "
2027                  "allowed");
2028       m = MATCH_ERROR;
2029       goto cleanup;
2030     }
2031
2032   /* Add the initializer.  Note that it is fine if initializer is
2033      NULL here, because we sometimes also need to check if a
2034      declaration *must* have an initialization expression.  */
2035   if (gfc_current_state () != COMP_DERIVED)
2036     t = add_init_expr_to_sym (name, &initializer, &var_locus);
2037   else
2038     {
2039       if (current_ts.type == BT_DERIVED
2040           && !current_attr.pointer && !initializer)
2041         initializer = gfc_default_initializer (&current_ts);
2042       t = build_struct (name, cl, &initializer, &as);
2043     }
2044
2045   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
2046
2047 cleanup:
2048   /* Free stuff up and return.  */
2049   gfc_free_expr (initializer);
2050   gfc_free_array_spec (as);
2051
2052   return m;
2053 }
2054
2055
2056 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
2057    This assumes that the byte size is equal to the kind number for
2058    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
2059
2060 match
2061 gfc_match_old_kind_spec (gfc_typespec *ts)
2062 {
2063   match m;
2064   int original_kind;
2065
2066   if (gfc_match_char ('*') != MATCH_YES)
2067     return MATCH_NO;
2068
2069   m = gfc_match_small_literal_int (&ts->kind, NULL);
2070   if (m != MATCH_YES)
2071     return MATCH_ERROR;
2072
2073   original_kind = ts->kind;
2074
2075   /* Massage the kind numbers for complex types.  */
2076   if (ts->type == BT_COMPLEX)
2077     {
2078       if (ts->kind % 2)
2079         {
2080           gfc_error ("Old-style type declaration %s*%d not supported at %C",
2081                      gfc_basic_typename (ts->type), original_kind);
2082           return MATCH_ERROR;
2083         }
2084       ts->kind /= 2;
2085
2086     }
2087
2088   if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
2089     ts->kind = 8;
2090
2091   if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2092     {
2093       if (ts->kind == 4)
2094         {
2095           if (gfc_option.flag_real4_kind == 8)
2096             ts->kind =  8;
2097           if (gfc_option.flag_real4_kind == 10)
2098             ts->kind = 10;
2099           if (gfc_option.flag_real4_kind == 16)
2100             ts->kind = 16;
2101         }
2102
2103       if (ts->kind == 8)
2104         {
2105           if (gfc_option.flag_real8_kind == 4)
2106             ts->kind = 4;
2107           if (gfc_option.flag_real8_kind == 10)
2108             ts->kind = 10;
2109           if (gfc_option.flag_real8_kind == 16)
2110             ts->kind = 16;
2111         }
2112     }
2113
2114   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2115     {
2116       gfc_error ("Old-style type declaration %s*%d not supported at %C",
2117                  gfc_basic_typename (ts->type), original_kind);
2118       return MATCH_ERROR;
2119     }
2120
2121   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
2122                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
2123     return MATCH_ERROR;
2124
2125   return MATCH_YES;
2126 }
2127
2128
2129 /* Match a kind specification.  Since kinds are generally optional, we
2130    usually return MATCH_NO if something goes wrong.  If a "kind="
2131    string is found, then we know we have an error.  */
2132
2133 match
2134 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
2135 {
2136   locus where, loc;
2137   gfc_expr *e;
2138   match m, n;
2139   char c;
2140   const char *msg;
2141
2142   m = MATCH_NO;
2143   n = MATCH_YES;
2144   e = NULL;
2145
2146   where = loc = gfc_current_locus;
2147
2148   if (kind_expr_only)
2149     goto kind_expr;
2150
2151   if (gfc_match_char ('(') == MATCH_NO)
2152     return MATCH_NO;
2153
2154   /* Also gobbles optional text.  */
2155   if (gfc_match (" kind = ") == MATCH_YES)
2156     m = MATCH_ERROR;
2157
2158   loc = gfc_current_locus;
2159
2160 kind_expr:
2161   n = gfc_match_init_expr (&e);
2162
2163   if (n != MATCH_YES)
2164     {
2165       if (gfc_matching_function)
2166         {
2167           /* The function kind expression might include use associated or 
2168              imported parameters and try again after the specification
2169              expressions.....  */
2170           if (gfc_match_char (')') != MATCH_YES)
2171             {
2172               gfc_error ("Missing right parenthesis at %C");
2173               m = MATCH_ERROR;
2174               goto no_match;
2175             }
2176
2177           gfc_free_expr (e);
2178           gfc_undo_symbols ();
2179           return MATCH_YES;
2180         }
2181       else
2182         {
2183           /* ....or else, the match is real.  */
2184           if (n == MATCH_NO)
2185             gfc_error ("Expected initialization expression at %C");
2186           if (n != MATCH_YES)
2187             return MATCH_ERROR;
2188         }
2189     }
2190
2191   if (e->rank != 0)
2192     {
2193       gfc_error ("Expected scalar initialization expression at %C");
2194       m = MATCH_ERROR;
2195       goto no_match;
2196     }
2197
2198   msg = gfc_extract_int (e, &ts->kind);
2199
2200   if (msg != NULL)
2201     {
2202       gfc_error (msg);
2203       m = MATCH_ERROR;
2204       goto no_match;
2205     }
2206
2207   /* Before throwing away the expression, let's see if we had a
2208      C interoperable kind (and store the fact).  */
2209   if (e->ts.is_c_interop == 1)
2210     {
2211       /* Mark this as c interoperable if being declared with one
2212          of the named constants from iso_c_binding.  */
2213       ts->is_c_interop = e->ts.is_iso_c;
2214       ts->f90_type = e->ts.f90_type;
2215     }
2216   
2217   gfc_free_expr (e);
2218   e = NULL;
2219
2220   /* Ignore errors to this point, if we've gotten here.  This means
2221      we ignore the m=MATCH_ERROR from above.  */
2222   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2223     {
2224       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2225                  gfc_basic_typename (ts->type));
2226       gfc_current_locus = where;
2227       return MATCH_ERROR;
2228     }
2229
2230   /* Warn if, e.g., c_int is used for a REAL variable, but not
2231      if, e.g., c_double is used for COMPLEX as the standard
2232      explicitly says that the kind type parameter for complex and real
2233      variable is the same, i.e. c_float == c_float_complex.  */
2234   if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2235       && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2236            || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2237     gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2238                      "is %s", gfc_basic_typename (ts->f90_type), &where,
2239                      gfc_basic_typename (ts->type));
2240
2241   gfc_gobble_whitespace ();
2242   if ((c = gfc_next_ascii_char ()) != ')'
2243       && (ts->type != BT_CHARACTER || c != ','))
2244     {
2245       if (ts->type == BT_CHARACTER)
2246         gfc_error ("Missing right parenthesis or comma at %C");
2247       else
2248         gfc_error ("Missing right parenthesis at %C");
2249       m = MATCH_ERROR;
2250     }
2251   else
2252      /* All tests passed.  */
2253      m = MATCH_YES;
2254
2255   if(m == MATCH_ERROR)
2256      gfc_current_locus = where;
2257
2258   if (ts->type == BT_INTEGER && ts->kind == 4 && gfc_option.flag_integer4_kind == 8)
2259     ts->kind =  8;
2260
2261   if (ts->type == BT_REAL || ts->type == BT_COMPLEX)
2262     {
2263       if (ts->kind == 4)
2264         {
2265           if (gfc_option.flag_real4_kind == 8)
2266             ts->kind =  8;
2267           if (gfc_option.flag_real4_kind == 10)
2268             ts->kind = 10;
2269           if (gfc_option.flag_real4_kind == 16)
2270             ts->kind = 16;
2271         }
2272
2273       if (ts->kind == 8)
2274         {
2275           if (gfc_option.flag_real8_kind == 4)
2276             ts->kind = 4;
2277           if (gfc_option.flag_real8_kind == 10)
2278             ts->kind = 10;
2279           if (gfc_option.flag_real8_kind == 16)
2280             ts->kind = 16;
2281         }
2282     }
2283
2284   /* Return what we know from the test(s).  */
2285   return m;
2286
2287 no_match:
2288   gfc_free_expr (e);
2289   gfc_current_locus = where;
2290   return m;
2291 }
2292
2293
2294 static match
2295 match_char_kind (int * kind, int * is_iso_c)
2296 {
2297   locus where;
2298   gfc_expr *e;
2299   match m, n;
2300   const char *msg;
2301
2302   m = MATCH_NO;
2303   e = NULL;
2304   where = gfc_current_locus;
2305
2306   n = gfc_match_init_expr (&e);
2307
2308   if (n != MATCH_YES && gfc_matching_function)
2309     {
2310       /* The expression might include use-associated or imported
2311          parameters and try again after the specification 
2312          expressions.  */
2313       gfc_free_expr (e);
2314       gfc_undo_symbols ();
2315       return MATCH_YES;
2316     }
2317
2318   if (n == MATCH_NO)
2319     gfc_error ("Expected initialization expression at %C");
2320   if (n != MATCH_YES)
2321     return MATCH_ERROR;
2322
2323   if (e->rank != 0)
2324     {
2325       gfc_error ("Expected scalar initialization expression at %C");
2326       m = MATCH_ERROR;
2327       goto no_match;
2328     }
2329
2330   msg = gfc_extract_int (e, kind);
2331   *is_iso_c = e->ts.is_iso_c;
2332   if (msg != NULL)
2333     {
2334       gfc_error (msg);
2335       m = MATCH_ERROR;
2336       goto no_match;
2337     }
2338
2339   gfc_free_expr (e);
2340
2341   /* Ignore errors to this point, if we've gotten here.  This means
2342      we ignore the m=MATCH_ERROR from above.  */
2343   if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2344     {
2345       gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2346       m = MATCH_ERROR;
2347     }
2348   else
2349      /* All tests passed.  */
2350      m = MATCH_YES;
2351
2352   if (m == MATCH_ERROR)
2353      gfc_current_locus = where;
2354   
2355   /* Return what we know from the test(s).  */
2356   return m;
2357
2358 no_match:
2359   gfc_free_expr (e);
2360   gfc_current_locus = where;
2361   return m;
2362 }
2363
2364
2365 /* Match the various kind/length specifications in a CHARACTER
2366    declaration.  We don't return MATCH_NO.  */
2367
2368 match
2369 gfc_match_char_spec (gfc_typespec *ts)
2370 {
2371   int kind, seen_length, is_iso_c;
2372   gfc_charlen *cl;
2373   gfc_expr *len;
2374   match m;
2375   bool deferred;
2376
2377   len = NULL;
2378   seen_length = 0;
2379   kind = 0;
2380   is_iso_c = 0;
2381   deferred = false;
2382
2383   /* Try the old-style specification first.  */
2384   old_char_selector = 0;
2385
2386   m = match_char_length (&len, &deferred);
2387   if (m != MATCH_NO)
2388     {
2389       if (m == MATCH_YES)
2390         old_char_selector = 1;
2391       seen_length = 1;
2392       goto done;
2393     }
2394
2395   m = gfc_match_char ('(');
2396   if (m != MATCH_YES)
2397     {
2398       m = MATCH_YES;    /* Character without length is a single char.  */
2399       goto done;
2400     }
2401
2402   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
2403   if (gfc_match (" kind =") == MATCH_YES)
2404     {
2405       m = match_char_kind (&kind, &is_iso_c);
2406        
2407       if (m == MATCH_ERROR)
2408         goto done;
2409       if (m == MATCH_NO)
2410         goto syntax;
2411
2412       if (gfc_match (" , len =") == MATCH_NO)
2413         goto rparen;
2414
2415       m = char_len_param_value (&len, &deferred);
2416       if (m == MATCH_NO)
2417         goto syntax;
2418       if (m == MATCH_ERROR)
2419         goto done;
2420       seen_length = 1;
2421
2422       goto rparen;
2423     }
2424
2425   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
2426   if (gfc_match (" len =") == MATCH_YES)
2427     {
2428       m = char_len_param_value (&len, &deferred);
2429       if (m == MATCH_NO)
2430         goto syntax;
2431       if (m == MATCH_ERROR)
2432         goto done;
2433       seen_length = 1;
2434
2435       if (gfc_match_char (')') == MATCH_YES)
2436         goto done;
2437
2438       if (gfc_match (" , kind =") != MATCH_YES)
2439         goto syntax;
2440
2441       if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2442         goto done;
2443
2444       goto rparen;
2445     }
2446
2447   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
2448   m = char_len_param_value (&len, &deferred);
2449   if (m == MATCH_NO)
2450     goto syntax;
2451   if (m == MATCH_ERROR)
2452     goto done;
2453   seen_length = 1;
2454
2455   m = gfc_match_char (')');
2456   if (m == MATCH_YES)
2457     goto done;
2458
2459   if (gfc_match_char (',') != MATCH_YES)
2460     goto syntax;
2461
2462   gfc_match (" kind =");        /* Gobble optional text.  */
2463
2464   m = match_char_kind (&kind, &is_iso_c);
2465   if (m == MATCH_ERROR)
2466     goto done;
2467   if (m == MATCH_NO)
2468     goto syntax;
2469
2470 rparen:
2471   /* Require a right-paren at this point.  */
2472   m = gfc_match_char (')');
2473   if (m == MATCH_YES)
2474     goto done;
2475
2476 syntax:
2477   gfc_error ("Syntax error in CHARACTER declaration at %C");
2478   m = MATCH_ERROR;
2479   gfc_free_expr (len);
2480   return m;
2481
2482 done:
2483   /* Deal with character functions after USE and IMPORT statements.  */
2484   if (gfc_matching_function)
2485     {
2486       gfc_free_expr (len);
2487       gfc_undo_symbols ();
2488       return MATCH_YES;
2489     }
2490
2491   if (m != MATCH_YES)
2492     {
2493       gfc_free_expr (len);
2494       return m;
2495     }
2496
2497   /* Do some final massaging of the length values.  */
2498   cl = gfc_new_charlen (gfc_current_ns, NULL);
2499
2500   if (seen_length == 0)
2501     cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
2502   else
2503     cl->length = len;
2504
2505   ts->u.cl = cl;
2506   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2507   ts->deferred = deferred;
2508
2509   /* We have to know if it was a c interoperable kind so we can
2510      do accurate type checking of bind(c) procs, etc.  */
2511   if (kind != 0)
2512     /* Mark this as c interoperable if being declared with one
2513        of the named constants from iso_c_binding.  */
2514     ts->is_c_interop = is_iso_c;
2515   else if (len != NULL)
2516     /* Here, we might have parsed something such as: character(c_char)
2517        In this case, the parsing code above grabs the c_char when
2518        looking for the length (line 1690, roughly).  it's the last
2519        testcase for parsing the kind params of a character variable.
2520        However, it's not actually the length.    this seems like it
2521        could be an error.  
2522        To see if the user used a C interop kind, test the expr
2523        of the so called length, and see if it's C interoperable.  */
2524     ts->is_c_interop = len->ts.is_iso_c;
2525   
2526   return MATCH_YES;
2527 }
2528
2529
2530 /* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
2531    structure to the matched specification.  This is necessary for FUNCTION and
2532    IMPLICIT statements.
2533
2534    If implicit_flag is nonzero, then we don't check for the optional
2535    kind specification.  Not doing so is needed for matching an IMPLICIT
2536    statement correctly.  */
2537
2538 match
2539 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2540 {
2541   char name[GFC_MAX_SYMBOL_LEN + 1];
2542   gfc_symbol *sym, *dt_sym;
2543   match m;
2544   char c;
2545   bool seen_deferred_kind, matched_type;
2546   const char *dt_name;
2547
2548   /* A belt and braces check that the typespec is correctly being treated
2549      as a deferred characteristic association.  */
2550   seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2551                           && (gfc_current_block ()->result->ts.kind == -1)
2552                           && (ts->kind == -1);
2553   gfc_clear_ts (ts);
2554   if (seen_deferred_kind)
2555     ts->kind = -1;
2556
2557   /* Clear the current binding label, in case one is given.  */
2558   curr_binding_label = NULL;
2559
2560   if (gfc_match (" byte") == MATCH_YES)
2561     {
2562       if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
2563           == FAILURE)
2564         return MATCH_ERROR;
2565
2566       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2567         {
2568           gfc_error ("BYTE type used at %C "
2569                      "is not available on the target machine");
2570           return MATCH_ERROR;
2571         }
2572
2573       ts->type = BT_INTEGER;
2574       ts->kind = 1;
2575       return MATCH_YES;
2576     }
2577
2578
2579   m = gfc_match (" type ( %n", name);
2580   matched_type = (m == MATCH_YES);
2581   
2582   if ((matched_type && strcmp ("integer", name) == 0)
2583       || (!matched_type && gfc_match (" integer") == MATCH_YES))
2584     {
2585       ts->type = BT_INTEGER;
2586       ts->kind = gfc_default_integer_kind;
2587       goto get_kind;
2588     }
2589
2590   if ((matched_type && strcmp ("character", name) == 0)
2591       || (!matched_type && gfc_match (" character") == MATCH_YES))
2592     {
2593       if (matched_type
2594           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2595                           "intrinsic-type-spec at %C") == FAILURE)
2596         return MATCH_ERROR;
2597
2598       ts->type = BT_CHARACTER;
2599       if (implicit_flag == 0)
2600         m = gfc_match_char_spec (ts);
2601       else
2602         m = MATCH_YES;
2603
2604       if (matched_type && m == MATCH_YES && gfc_match_char (')') != MATCH_YES)
2605         m = MATCH_ERROR;
2606
2607       return m;
2608     }
2609
2610   if ((matched_type && strcmp ("real", name) == 0)
2611       || (!matched_type && gfc_match (" real") == MATCH_YES))
2612     {
2613       ts->type = BT_REAL;
2614       ts->kind = gfc_default_real_kind;
2615       goto get_kind;
2616     }
2617
2618   if ((matched_type
2619        && (strcmp ("doubleprecision", name) == 0
2620            || (strcmp ("double", name) == 0
2621                && gfc_match (" precision") == MATCH_YES)))
2622       || (!matched_type && gfc_match (" double precision") == MATCH_YES))
2623     {
2624       if (matched_type
2625           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2626                           "intrinsic-type-spec at %C") == FAILURE)
2627         return MATCH_ERROR;
2628       if (matched_type && gfc_match_char (')') != MATCH_YES)
2629         return MATCH_ERROR;
2630
2631       ts->type = BT_REAL;
2632       ts->kind = gfc_default_double_kind;
2633       return MATCH_YES;
2634     }
2635
2636   if ((matched_type && strcmp ("complex", name) == 0)
2637       || (!matched_type && gfc_match (" complex") == MATCH_YES))
2638     {
2639       ts->type = BT_COMPLEX;
2640       ts->kind = gfc_default_complex_kind;
2641       goto get_kind;
2642     }
2643
2644   if ((matched_type
2645        && (strcmp ("doublecomplex", name) == 0
2646            || (strcmp ("double", name) == 0
2647                && gfc_match (" complex") == MATCH_YES)))
2648       || (!matched_type && gfc_match (" double complex") == MATCH_YES))
2649     {
2650       if (gfc_notify_std (GFC_STD_GNU, "Extension: DOUBLE COMPLEX at %C")
2651           == FAILURE)
2652         return MATCH_ERROR;
2653
2654       if (matched_type
2655           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2656                           "intrinsic-type-spec at %C") == FAILURE)
2657         return MATCH_ERROR;
2658
2659       if (matched_type && gfc_match_char (')') != MATCH_YES)
2660         return MATCH_ERROR;
2661
2662       ts->type = BT_COMPLEX;
2663       ts->kind = gfc_default_double_kind;
2664       return MATCH_YES;
2665     }
2666
2667   if ((matched_type && strcmp ("logical", name) == 0)
2668       || (!matched_type && gfc_match (" logical") == MATCH_YES))
2669     {
2670       ts->type = BT_LOGICAL;
2671       ts->kind = gfc_default_logical_kind;
2672       goto get_kind;
2673     }
2674
2675   if (matched_type)
2676     m = gfc_match_char (')');
2677
2678   if (m == MATCH_YES)
2679     ts->type = BT_DERIVED;
2680   else
2681     {
2682       /* Match CLASS declarations.  */
2683       m = gfc_match (" class ( * )");
2684       if (m == MATCH_ERROR)
2685         return MATCH_ERROR;
2686       else if (m == MATCH_YES)
2687         {
2688           gfc_fatal_error ("Unlimited polymorphism at %C not yet supported");
2689           return MATCH_ERROR;
2690         }
2691
2692       m = gfc_match (" class ( %n )", name);
2693       if (m != MATCH_YES)
2694         return m;
2695       ts->type = BT_CLASS;
2696
2697       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
2698                           == FAILURE)
2699         return MATCH_ERROR;
2700     }
2701
2702   /* Defer association of the derived type until the end of the
2703      specification block.  However, if the derived type can be
2704      found, add it to the typespec.  */  
2705   if (gfc_matching_function)
2706     {
2707       ts->u.derived = NULL;
2708       if (gfc_current_state () != COMP_INTERFACE
2709             && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2710         {
2711           sym = gfc_find_dt_in_generic (sym);
2712           ts->u.derived = sym;
2713         }
2714       return MATCH_YES;
2715     }
2716
2717   /* Search for the name but allow the components to be defined later.  If
2718      type = -1, this typespec has been seen in a function declaration but
2719      the type could not be accessed at that point.  The actual derived type is
2720      stored in a symtree with the first letter of the name captialized; the
2721      symtree with the all lower-case name contains the associated
2722      generic function.  */
2723   dt_name = gfc_get_string ("%c%s",
2724                             (char) TOUPPER ((unsigned char) name[0]),
2725                             (const char*)&name[1]);
2726   sym = NULL;
2727   dt_sym = NULL;
2728   if (ts->kind != -1)
2729     {
2730       gfc_get_ha_symbol (name, &sym);
2731       if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
2732         {
2733           gfc_error ("Type name '%s' at %C is ambiguous", name);
2734           return MATCH_ERROR;
2735         }
2736       if (sym->generic && !dt_sym)
2737         dt_sym = gfc_find_dt_in_generic (sym);
2738     }
2739   else if (ts->kind == -1)
2740     {
2741       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2742                     || gfc_current_ns->has_import_set;
2743       gfc_find_symbol (name, NULL, iface, &sym);
2744       if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
2745         {       
2746           gfc_error ("Type name '%s' at %C is ambiguous", name);
2747           return MATCH_ERROR;
2748         }
2749       if (sym && sym->generic && !dt_sym)
2750         dt_sym = gfc_find_dt_in_generic (sym);
2751
2752       ts->kind = 0;
2753       if (sym == NULL)
2754         return MATCH_NO;
2755     }
2756
2757   if ((sym->attr.flavor != FL_UNKNOWN
2758        && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
2759       || sym->attr.subroutine)
2760     {
2761       gfc_error ("Type name '%s' at %C conflicts with previously declared "
2762                  "entity at %L, which has the same name", name,
2763                  &sym->declared_at);
2764       return MATCH_ERROR;
2765     }
2766
2767   gfc_set_sym_referenced (sym);
2768   if (!sym->attr.generic
2769       && gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
2770     return MATCH_ERROR;
2771
2772   if (!sym->attr.function
2773       && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2774     return MATCH_ERROR;
2775
2776   if (!dt_sym)
2777     {
2778       gfc_interface *intr, *head;
2779
2780       /* Use upper case to save the actual derived-type symbol.  */
2781       gfc_get_symbol (dt_name, NULL, &dt_sym);
2782       dt_sym->name = gfc_get_string (sym->name);
2783       head = sym->generic;
2784       intr = gfc_get_interface ();
2785       intr->sym = dt_sym;
2786       intr->where = gfc_current_locus;
2787       intr->next = head;
2788       sym->generic = intr;
2789       sym->attr.if_source = IFSRC_DECL;
2790     }
2791
2792   gfc_set_sym_referenced (dt_sym);
2793
2794   if (dt_sym->attr.flavor != FL_DERIVED
2795       && gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
2796                          == FAILURE)
2797     return MATCH_ERROR;
2798
2799   ts->u.derived = dt_sym;
2800
2801   return MATCH_YES;
2802
2803 get_kind:
2804   if (matched_type
2805       && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: TYPE with "
2806                          "intrinsic-type-spec at %C") == FAILURE)
2807     return MATCH_ERROR;
2808
2809   /* For all types except double, derived and character, look for an
2810      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2811   if (implicit_flag == 1)
2812     {
2813         if (matched_type && gfc_match_char (')') != MATCH_YES)
2814           return MATCH_ERROR;
2815
2816         return MATCH_YES;
2817     }
2818
2819   if (gfc_current_form == FORM_FREE)
2820     {
2821       c = gfc_peek_ascii_char ();
2822       if (!gfc_is_whitespace (c) && c != '*' && c != '('
2823           && c != ':' && c != ',')
2824         {
2825           if (matched_type && c == ')')
2826             {
2827               gfc_next_ascii_char ();
2828               return MATCH_YES;
2829             }
2830           return MATCH_NO;
2831         }
2832     }
2833
2834   m = gfc_match_kind_spec (ts, false);
2835   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2836     m = gfc_match_old_kind_spec (ts);
2837
2838   if (matched_type && gfc_match_char (')') != MATCH_YES)
2839     return MATCH_ERROR;
2840
2841   /* Defer association of the KIND expression of function results
2842      until after USE and IMPORT statements.  */
2843   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2844          || gfc_matching_function)
2845     return MATCH_YES;
2846
2847   if (m == MATCH_NO)
2848     m = MATCH_YES;              /* No kind specifier found.  */
2849
2850   return m;
2851 }
2852
2853
2854 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2855    already matched in parse.c, or we would not end up here in the
2856    first place.  So the only thing we need to check, is if there is
2857    trailing garbage.  If not, the match is successful.  */
2858
2859 match
2860 gfc_match_implicit_none (void)
2861 {
2862   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2863 }
2864
2865
2866 /* Match the letter range(s) of an IMPLICIT statement.  */
2867
2868 static match
2869 match_implicit_range (void)
2870 {
2871   char c, c1, c2;
2872   int inner;
2873   locus cur_loc;
2874
2875   cur_loc = gfc_current_locus;
2876
2877   gfc_gobble_whitespace ();
2878   c = gfc_next_ascii_char ();
2879   if (c != '(')
2880     {
2881       gfc_error ("Missing character range in IMPLICIT at %C");
2882       goto bad;
2883     }
2884
2885   inner = 1;
2886   while (inner)
2887     {
2888       gfc_gobble_whitespace ();
2889       c1 = gfc_next_ascii_char ();
2890       if (!ISALPHA (c1))
2891         goto bad;
2892
2893       gfc_gobble_whitespace ();
2894       c = gfc_next_ascii_char ();
2895
2896       switch (c)
2897         {
2898         case ')':
2899           inner = 0;            /* Fall through.  */
2900
2901         case ',':
2902           c2 = c1;
2903           break;
2904
2905         case '-':
2906           gfc_gobble_whitespace ();
2907           c2 = gfc_next_ascii_char ();
2908           if (!ISALPHA (c2))
2909             goto bad;
2910
2911           gfc_gobble_whitespace ();
2912           c = gfc_next_ascii_char ();
2913
2914           if ((c != ',') && (c != ')'))
2915             goto bad;
2916           if (c == ')')
2917             inner = 0;
2918
2919           break;
2920
2921         default:
2922           goto bad;
2923         }
2924
2925       if (c1 > c2)
2926         {
2927           gfc_error ("Letters must be in alphabetic order in "
2928                      "IMPLICIT statement at %C");
2929           goto bad;
2930         }
2931
2932       /* See if we can add the newly matched range to the pending
2933          implicits from this IMPLICIT statement.  We do not check for
2934          conflicts with whatever earlier IMPLICIT statements may have
2935          set.  This is done when we've successfully finished matching
2936          the current one.  */
2937       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2938         goto bad;
2939     }
2940
2941   return MATCH_YES;
2942
2943 bad:
2944   gfc_syntax_error (ST_IMPLICIT);
2945
2946   gfc_current_locus = cur_loc;
2947   return MATCH_ERROR;
2948 }
2949
2950
2951 /* Match an IMPLICIT statement, storing the types for
2952    gfc_set_implicit() if the statement is accepted by the parser.
2953    There is a strange looking, but legal syntactic construction
2954    possible.  It looks like:
2955
2956      IMPLICIT INTEGER (a-b) (c-d)
2957
2958    This is legal if "a-b" is a constant expression that happens to
2959    equal one of the legal kinds for integers.  The real problem
2960    happens with an implicit specification that looks like:
2961
2962      IMPLICIT INTEGER (a-b)
2963
2964    In this case, a typespec matcher that is "greedy" (as most of the
2965    matchers are) gobbles the character range as a kindspec, leaving
2966    nothing left.  We therefore have to go a bit more slowly in the
2967    matching process by inhibiting the kindspec checking during
2968    typespec matching and checking for a kind later.  */
2969
2970 match
2971 gfc_match_implicit (void)
2972 {
2973   gfc_typespec ts;
2974   locus cur_loc;
2975   char c;
2976   match m;
2977
2978   gfc_clear_ts (&ts);
2979
2980   /* We don't allow empty implicit statements.  */
2981   if (gfc_match_eos () == MATCH_YES)
2982     {
2983       gfc_error ("Empty IMPLICIT statement at %C");
2984       return MATCH_ERROR;
2985     }
2986
2987   do
2988     {
2989       /* First cleanup.  */
2990       gfc_clear_new_implicit ();
2991
2992       /* A basic type is mandatory here.  */
2993       m = gfc_match_decl_type_spec (&ts, 1);
2994       if (m == MATCH_ERROR)
2995         goto error;
2996       if (m == MATCH_NO)
2997         goto syntax;
2998
2999       cur_loc = gfc_current_locus;
3000       m = match_implicit_range ();
3001
3002       if (m == MATCH_YES)
3003         {
3004           /* We may have <TYPE> (<RANGE>).  */
3005           gfc_gobble_whitespace ();
3006           c = gfc_next_ascii_char ();
3007           if ((c == '\n') || (c == ','))
3008             {
3009               /* Check for CHARACTER with no length parameter.  */
3010               if (ts.type == BT_CHARACTER && !ts.u.cl)
3011                 {
3012                   ts.kind = gfc_default_character_kind;
3013                   ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
3014                   ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
3015                                                       NULL, 1);
3016                 }
3017
3018               /* Record the Successful match.  */
3019               if (gfc_merge_new_implicit (&ts) != SUCCESS)
3020                 return MATCH_ERROR;
3021               continue;
3022             }
3023
3024           gfc_current_locus = cur_loc;
3025         }
3026
3027       /* Discard the (incorrectly) matched range.  */
3028       gfc_clear_new_implicit ();
3029
3030       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
3031       if (ts.type == BT_CHARACTER)
3032         m = gfc_match_char_spec (&ts);
3033       else
3034         {
3035           m = gfc_match_kind_spec (&ts, false);
3036           if (m == MATCH_NO)
3037             {
3038               m = gfc_match_old_kind_spec (&ts);
3039               if (m == MATCH_ERROR)
3040                 goto error;
3041               if (m == MATCH_NO)
3042                 goto syntax;
3043             }
3044         }
3045       if (m == MATCH_ERROR)
3046         goto error;
3047
3048       m = match_implicit_range ();
3049       if (m == MATCH_ERROR)
3050         goto error;
3051       if (m == MATCH_NO)
3052         goto syntax;
3053
3054       gfc_gobble_whitespace ();
3055       c = gfc_next_ascii_char ();
3056       if ((c != '\n') && (c != ','))
3057         goto syntax;
3058
3059       if (gfc_merge_new_implicit (&ts) != SUCCESS)
3060         return MATCH_ERROR;
3061     }
3062   while (c == ',');
3063
3064   return MATCH_YES;
3065
3066 syntax:
3067   gfc_syntax_error (ST_IMPLICIT);
3068
3069 error:
3070   return MATCH_ERROR;
3071 }
3072
3073
3074 match
3075 gfc_match_import (void)
3076 {
3077   char name[GFC_MAX_SYMBOL_LEN + 1];
3078   match m;
3079   gfc_symbol *sym;
3080   gfc_symtree *st;
3081
3082   if (gfc_current_ns->proc_name == NULL
3083       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
3084     {
3085       gfc_error ("IMPORT statement at %C only permitted in "
3086                  "an INTERFACE body");
3087       return MATCH_ERROR;
3088     }
3089
3090   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
3091       == FAILURE)
3092     return MATCH_ERROR;
3093
3094   if (gfc_match_eos () == MATCH_YES)
3095     {
3096       /* All host variables should be imported.  */
3097       gfc_current_ns->has_import_set = 1;
3098       return MATCH_YES;
3099     }
3100
3101   if (gfc_match (" ::") == MATCH_YES)
3102     {
3103       if (gfc_match_eos () == MATCH_YES)
3104         {
3105            gfc_error ("Expecting list of named entities at %C");
3106            return MATCH_ERROR;
3107         }
3108     }
3109
3110   for(;;)
3111     {
3112       sym = NULL;
3113       m = gfc_match (" %n", name);
3114       switch (m)
3115         {
3116         case MATCH_YES:
3117           if (gfc_current_ns->parent !=  NULL
3118               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
3119             {
3120                gfc_error ("Type name '%s' at %C is ambiguous", name);
3121                return MATCH_ERROR;
3122             }
3123           else if (!sym && gfc_current_ns->proc_name->ns->parent !=  NULL
3124                    && gfc_find_symbol (name,
3125                                        gfc_current_ns->proc_name->ns->parent,
3126                                        1, &sym))
3127             {
3128                gfc_error ("Type name '%s' at %C is ambiguous", name);
3129                return MATCH_ERROR;
3130             }
3131
3132           if (sym == NULL)
3133             {
3134               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
3135                          "at %C - does not exist.", name);
3136               return MATCH_ERROR;
3137             }
3138
3139           if (gfc_find_symtree (gfc_current_ns->sym_root, name))
3140             {
3141               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
3142                            "at %C.", name);
3143               goto next_item;
3144             }
3145
3146           st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
3147           st->n.sym = sym;
3148           sym->refs++;
3149           sym->attr.imported = 1;
3150
3151           if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
3152             {
3153               /* The actual derived type is stored in a symtree with the first
3154                  letter of the name captialized; the symtree with the all
3155                  lower-case name contains the associated generic function. */
3156               st = gfc_new_symtree (&gfc_current_ns->sym_root,
3157                         gfc_get_string ("%c%s",
3158                                 (char) TOUPPER ((unsigned char) name[0]),
3159                                 &name[1]));
3160               st->n.sym = sym;
3161               sym->refs++;
3162               sym->attr.imported = 1;
3163             }
3164
3165           goto next_item;
3166
3167         case MATCH_NO:
3168           break;
3169
3170         case MATCH_ERROR:
3171           return MATCH_ERROR;
3172         }
3173
3174     next_item:
3175       if (gfc_match_eos () == MATCH_YES)
3176         break;
3177       if (gfc_match_char (',') != MATCH_YES)
3178         goto syntax;
3179     }
3180
3181   return MATCH_YES;
3182
3183 syntax:
3184   gfc_error ("Syntax error in IMPORT statement at %C");
3185   return MATCH_ERROR;
3186 }
3187
3188
3189 /* A minimal implementation of gfc_match without whitespace, escape
3190    characters or variable arguments.  Returns true if the next
3191    characters match the TARGET template exactly.  */
3192
3193 static bool
3194 match_string_p (const char *target)
3195 {
3196   const char *p;
3197
3198   for (p = target; *p; p++)
3199     if ((char) gfc_next_ascii_char () != *p)
3200       return false;
3201   return true;
3202 }
3203
3204 /* Matches an attribute specification including array specs.  If
3205    successful, leaves the variables current_attr and current_as
3206    holding the specification.  Also sets the colon_seen variable for
3207    later use by matchers associated with initializations.
3208
3209    This subroutine is a little tricky in the sense that we don't know
3210    if we really have an attr-spec until we hit the double colon.
3211    Until that time, we can only return MATCH_NO.  This forces us to
3212    check for duplicate specification at this level.  */
3213
3214 static match
3215 match_attr_spec (void)
3216 {
3217   /* Modifiers that can exist in a type statement.  */
3218   typedef enum
3219   { GFC_DECL_BEGIN = 0,
3220     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
3221     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
3222     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
3223     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
3224     DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_CONTIGUOUS,
3225     DECL_NONE, GFC_DECL_END /* Sentinel */
3226   }
3227   decl_types;
3228
3229 /* GFC_DECL_END is the sentinel, index starts at 0.  */
3230 #define NUM_DECL GFC_DECL_END
3231
3232   locus start, seen_at[NUM_DECL];
3233   int seen[NUM_DECL];
3234   unsigned int d;
3235   const char *attr;
3236   match m;
3237   gfc_try t;
3238
3239   gfc_clear_attr (&current_attr);
3240   start = gfc_current_locus;
3241
3242   current_as = NULL;
3243   colon_seen = 0;
3244
3245   /* See if we get all of the keywords up to the final double colon.  */
3246   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3247     seen[d] = 0;
3248
3249   for (;;)
3250     {
3251       char ch;
3252
3253       d = DECL_NONE;
3254       gfc_gobble_whitespace ();
3255
3256       ch = gfc_next_ascii_char ();
3257       if (ch == ':')
3258         {
3259           /* This is the successful exit condition for the loop.  */
3260           if (gfc_next_ascii_char () == ':')
3261             break;
3262         }
3263       else if (ch == ',')
3264         {
3265           gfc_gobble_whitespace ();
3266           switch (gfc_peek_ascii_char ())
3267             {
3268             case 'a':
3269               gfc_next_ascii_char ();
3270               switch (gfc_next_ascii_char ())
3271                 {
3272                 case 'l':
3273                   if (match_string_p ("locatable"))
3274                     {
3275                       /* Matched "allocatable".  */
3276                       d = DECL_ALLOCATABLE;
3277                     }
3278                   break;
3279
3280                 case 's':
3281                   if (match_string_p ("ynchronous"))
3282                     {
3283                       /* Matched "asynchronous".  */
3284                       d = DECL_ASYNCHRONOUS;
3285                     }
3286                   break;
3287                 }
3288               break;
3289
3290             case 'b':
3291               /* Try and match the bind(c).  */
3292               m = gfc_match_bind_c (NULL, true);
3293               if (m == MATCH_YES)
3294                 d = DECL_IS_BIND_C;
3295               else if (m == MATCH_ERROR)
3296                 goto cleanup;
3297               break;
3298
3299             case 'c':
3300               gfc_next_ascii_char ();
3301               if ('o' != gfc_next_ascii_char ())
3302                 break;
3303               switch (gfc_next_ascii_char ())
3304                 {
3305                 case 'd':
3306                   if (match_string_p ("imension"))
3307                     {
3308                       d = DECL_CODIMENSION;
3309                       break;
3310                     }
3311                 case 'n':
3312                   if (match_string_p ("tiguous"))
3313                     {
3314                       d = DECL_CONTIGUOUS;
3315                       break;
3316                     }
3317                 }
3318               break;
3319
3320             case 'd':
3321               if (match_string_p ("dimension"))
3322                 d = DECL_DIMENSION;
3323               break;
3324
3325             case 'e':
3326               if (match_string_p ("external"))
3327                 d = DECL_EXTERNAL;
3328               break;
3329
3330             case 'i':
3331               if (match_string_p ("int"))
3332                 {
3333                   ch = gfc_next_ascii_char ();
3334                   if (ch == 'e')
3335                     {
3336                       if (match_string_p ("nt"))
3337                         {
3338                           /* Matched "intent".  */
3339                           /* TODO: Call match_intent_spec from here.  */
3340                           if (gfc_match (" ( in out )") == MATCH_YES)
3341                             d = DECL_INOUT;
3342                           else if (gfc_match (" ( in )") == MATCH_YES)
3343                             d = DECL_IN;
3344                           else if (gfc_match (" ( out )") == MATCH_YES)
3345                             d = DECL_OUT;
3346                         }
3347                     }
3348                   else if (ch == 'r')
3349                     {
3350                       if (match_string_p ("insic"))
3351                         {
3352                           /* Matched "intrinsic".  */
3353                           d = DECL_INTRINSIC;
3354                         }
3355                     }
3356                 }
3357               break;
3358
3359             case 'o':
3360               if (match_string_p ("optional"))
3361                 d = DECL_OPTIONAL;
3362               break;
3363
3364             case 'p':
3365               gfc_next_ascii_char ();
3366               switch (gfc_next_ascii_char ())
3367                 {
3368                 case 'a':
3369                   if (match_string_p ("rameter"))
3370                     {
3371                       /* Matched "parameter".  */
3372                       d = DECL_PARAMETER;
3373                     }
3374                   break;
3375
3376                 case 'o':
3377                   if (match_string_p ("inter"))
3378                     {
3379                       /* Matched "pointer".  */
3380                       d = DECL_POINTER;
3381                     }
3382                   break;
3383
3384                 case 'r':
3385                   ch = gfc_next_ascii_char ();
3386                   if (ch == 'i')
3387                     {
3388                       if (match_string_p ("vate"))
3389                         {
3390                           /* Matched "private".  */
3391                           d = DECL_PRIVATE;
3392                         }
3393                     }
3394                   else if (ch == 'o')
3395                     {
3396                       if (match_string_p ("tected"))
3397                         {
3398                           /* Matched "protected".  */
3399                           d = DECL_PROTECTED;
3400                         }
3401                     }
3402                   break;
3403
3404                 case 'u':
3405                   if (match_string_p ("blic"))
3406                     {
3407                       /* Matched "public".  */
3408                       d = DECL_PUBLIC;
3409                     }
3410                   break;
3411                 }
3412               break;
3413
3414             case 's':
3415               if (match_string_p ("save"))
3416                 d = DECL_SAVE;
3417               break;
3418
3419             case 't':
3420               if (match_string_p ("target"))
3421                 d = DECL_TARGET;
3422               break;
3423
3424             case 'v':
3425               gfc_next_ascii_char ();
3426               ch = gfc_next_ascii_char ();
3427               if (ch == 'a')
3428                 {
3429                   if (match_string_p ("lue"))
3430                     {
3431                       /* Matched "value".  */
3432                       d = DECL_VALUE;
3433                     }
3434                 }
3435               else if (ch == 'o')
3436                 {
3437                   if (match_string_p ("latile"))
3438                     {
3439                       /* Matched "volatile".  */
3440                       d = DECL_VOLATILE;
3441                     }
3442                 }
3443               break;
3444             }
3445         }
3446
3447       /* No double colon and no recognizable decl_type, so assume that
3448          we've been looking at something else the whole time.  */
3449       if (d == DECL_NONE)
3450         {
3451           m = MATCH_NO;
3452           goto cleanup;
3453         }
3454
3455       /* Check to make sure any parens are paired up correctly.  */
3456       if (gfc_match_parens () == MATCH_ERROR)
3457         {
3458           m = MATCH_ERROR;
3459           goto cleanup;
3460         }
3461
3462       seen[d]++;
3463       seen_at[d] = gfc_current_locus;
3464
3465       if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
3466         {
3467           gfc_array_spec *as = NULL;
3468
3469           m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
3470                                     d == DECL_CODIMENSION);
3471
3472           if (current_as == NULL)
3473             current_as = as;
3474           else if (m == MATCH_YES)
3475             {
3476               merge_array_spec (as, current_as, false);
3477               free (as);
3478             }
3479
3480           if (m == MATCH_NO)
3481             {
3482               if (d == DECL_CODIMENSION)
3483                 gfc_error ("Missing codimension specification at %C");
3484               else
3485                 gfc_error ("Missing dimension specification at %C");
3486               m = MATCH_ERROR;
3487             }
3488
3489           if (m == MATCH_ERROR)
3490             goto cleanup;
3491         }
3492     }
3493
3494   /* Since we've seen a double colon, we have to be looking at an
3495      attr-spec.  This means that we can now issue errors.  */
3496   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3497     if (seen[d] > 1)
3498       {
3499         switch (d)
3500           {
3501           case DECL_ALLOCATABLE:
3502             attr = "ALLOCATABLE";
3503             break;
3504           case DECL_ASYNCHRONOUS:
3505             attr = "ASYNCHRONOUS";
3506             break;
3507           case DECL_CODIMENSION:
3508             attr = "CODIMENSION";
3509             break;
3510           case DECL_CONTIGUOUS:
3511             attr = "CONTIGUOUS";
3512             break;
3513           case DECL_DIMENSION:
3514             attr = "DIMENSION";
3515             break;
3516           case DECL_EXTERNAL:
3517             attr = "EXTERNAL";
3518             break;
3519           case DECL_IN:
3520             attr = "INTENT (IN)";
3521             break;
3522           case DECL_OUT:
3523             attr = "INTENT (OUT)";
3524             break;
3525           case DECL_INOUT:
3526             attr = "INTENT (IN OUT)";
3527             break;
3528           case DECL_INTRINSIC:
3529             attr = "INTRINSIC";
3530             break;
3531           case DECL_OPTIONAL:
3532             attr = "OPTIONAL";
3533             break;
3534           case DECL_PARAMETER:
3535             attr = "PARAMETER";
3536             break;
3537           case DECL_POINTER:
3538             attr = "POINTER";
3539             break;
3540           case DECL_PROTECTED:
3541             attr = "PROTECTED";
3542             break;
3543           case DECL_PRIVATE:
3544             attr = "PRIVATE";
3545             break;
3546           case DECL_PUBLIC:
3547             attr = "PUBLIC";
3548             break;
3549           case DECL_SAVE:
3550             attr = "SAVE";
3551             break;
3552           case DECL_TARGET:
3553             attr = "TARGET";
3554             break;
3555           case DECL_IS_BIND_C:
3556             attr = "IS_BIND_C";
3557             break;
3558           case DECL_VALUE:
3559             attr = "VALUE";
3560             break;
3561           case DECL_VOLATILE:
3562             attr = "VOLATILE";
3563             break;
3564           default:
3565             attr = NULL;        /* This shouldn't happen.  */
3566           }
3567
3568         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3569         m = MATCH_ERROR;
3570         goto cleanup;
3571       }
3572
3573   /* Now that we've dealt with duplicate attributes, add the attributes
3574      to the current attribute.  */
3575   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3576     {
3577       if (seen[d] == 0)
3578         continue;
3579
3580       if (gfc_current_state () == COMP_DERIVED
3581           && d != DECL_DIMENSION && d != DECL_CODIMENSION
3582           && d != DECL_POINTER   && d != DECL_PRIVATE
3583           && d != DECL_PUBLIC && d != DECL_CONTIGUOUS && d != DECL_NONE)
3584         {
3585           if (d == DECL_ALLOCATABLE)
3586             {
3587               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3588                                   "attribute at %C in a TYPE definition")
3589                   == FAILURE)
3590                 {
3591                   m = MATCH_ERROR;
3592                   goto cleanup;
3593                 }
3594             }
3595           else
3596             {
3597               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3598                          &seen_at[d]);
3599               m = MATCH_ERROR;
3600               goto cleanup;
3601             }
3602         }
3603
3604       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3605           && gfc_current_state () != COMP_MODULE)
3606         {
3607           if (d == DECL_PRIVATE)
3608             attr = "PRIVATE";
3609           else
3610             attr = "PUBLIC";
3611           if (gfc_current_state () == COMP_DERIVED
3612               && gfc_state_stack->previous
3613               && gfc_state_stack->previous->state == COMP_MODULE)
3614             {
3615               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3616                                   "at %L in a TYPE definition", attr,
3617                                   &seen_at[d])
3618                   == FAILURE)
3619                 {
3620                   m = MATCH_ERROR;
3621                   goto cleanup;
3622                 }
3623             }
3624           else
3625             {
3626               gfc_error ("%s attribute at %L is not allowed outside of the "
3627                          "specification part of a module", attr, &seen_at[d]);
3628               m = MATCH_ERROR;
3629               goto cleanup;
3630             }
3631         }
3632
3633       switch (d)
3634         {
3635         case DECL_ALLOCATABLE:
3636           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
3637           break;
3638
3639         case DECL_ASYNCHRONOUS:
3640           if (gfc_notify_std (GFC_STD_F2003,
3641                               "Fortran 2003: ASYNCHRONOUS attribute at %C")
3642               == FAILURE)
3643             t = FAILURE;
3644           else
3645             t = gfc_add_asynchronous (&current_attr, NULL, &seen_at[d]);
3646           break;
3647
3648         case DECL_CODIMENSION:
3649           t = gfc_add_codimension (&current_attr, NULL, &seen_at[d]);
3650           break;
3651
3652         case DECL_CONTIGUOUS:
3653           if (gfc_notify_std (GFC_STD_F2008,
3654                               "Fortran 2008: CONTIGUOUS attribute at %C")
3655               == FAILURE)
3656             t = FAILURE;
3657           else
3658             t = gfc_add_contiguous (&current_attr, NULL, &seen_at[d]);
3659           break;
3660
3661         case DECL_DIMENSION:
3662           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
3663           break;
3664
3665         case DECL_EXTERNAL:
3666           t = gfc_add_external (&current_attr, &seen_at[d]);
3667           break;
3668
3669         case DECL_IN:
3670           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
3671           break;
3672
3673         case DECL_OUT:
3674           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
3675           break;
3676
3677         case DECL_INOUT:
3678           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
3679           break;
3680
3681         case DECL_INTRINSIC:
3682           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
3683           break;
3684
3685         case DECL_OPTIONAL:
3686           t = gfc_add_optional (&current_attr, &seen_at[d]);
3687           break;
3688
3689         case DECL_PARAMETER:
3690           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
3691           break;
3692
3693         case DECL_POINTER:
3694           t = gfc_add_pointer (&current_attr, &seen_at[d]);
3695           break;
3696
3697         case DECL_PROTECTED:
3698           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3699             {
3700                gfc_error ("PROTECTED at %C only allowed in specification "
3701                           "part of a module");
3702                t = FAILURE;
3703                break;
3704             }
3705
3706           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3707                               "attribute at %C")
3708               == FAILURE)
3709             t = FAILURE;
3710           else
3711             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
3712           break;
3713
3714         case DECL_PRIVATE:
3715           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
3716                               &seen_at[d]);
3717           break;
3718
3719         case DECL_PUBLIC:
3720           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
3721                               &seen_at[d]);
3722           break;
3723
3724         case DECL_SAVE:
3725           t = gfc_add_save (&current_attr, SAVE_EXPLICIT, NULL, &seen_at[d]);
3726           break;
3727
3728         case DECL_TARGET:
3729           t = gfc_add_target (&current_attr, &seen_at[d]);
3730           break;
3731
3732         case DECL_IS_BIND_C:
3733            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
3734            break;
3735            
3736         case DECL_VALUE:
3737           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3738                               "at %C")
3739               == FAILURE)
3740             t = FAILURE;
3741           else
3742             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
3743           break;
3744
3745         case DECL_VOLATILE:
3746           if (gfc_notify_std (GFC_STD_F2003,
3747                               "Fortran 2003: VOLATILE attribute at %C")
3748               == FAILURE)
3749             t = FAILURE;
3750           else
3751             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
3752           break;
3753
3754         default:
3755           gfc_internal_error ("match_attr_spec(): Bad attribute");
3756         }
3757
3758       if (t == FAILURE)
3759         {
3760           m = MATCH_ERROR;
3761           goto cleanup;
3762         }
3763     }
3764
3765   /* Since Fortran 2008 module variables implicitly have the SAVE attribute.  */
3766   if (gfc_current_state () == COMP_MODULE && !current_attr.save
3767       && (gfc_option.allow_std & GFC_STD_F2008) != 0)
3768     current_attr.save = SAVE_IMPLICIT;
3769
3770   colon_seen = 1;
3771   return MATCH_YES;
3772
3773 cleanup:
3774   gfc_current_locus = start;
3775   gfc_free_array_spec (current_as);
3776   current_as = NULL;
3777   return m;
3778 }
3779
3780
3781 /* Set the binding label, dest_label, either with the binding label
3782    stored in the given gfc_typespec, ts, or if none was provided, it
3783    will be the symbol name in all lower case, as required by the draft
3784    (J3/04-007, section 15.4.1).  If a binding label was given and
3785    there is more than one argument (num_idents), it is an error.  */
3786
3787 static gfc_try
3788 set_binding_label (const char **dest_label, const char *sym_name, 
3789                    int num_idents)
3790 {
3791   if (num_idents > 1 && has_name_equals)
3792     {
3793       gfc_error ("Multiple identifiers provided with "
3794                  "single NAME= specifier at %C");
3795       return FAILURE;
3796     }
3797
3798   if (curr_binding_label)
3799     /* Binding label given; store in temp holder til have sym.  */
3800     *dest_label = curr_binding_label;
3801   else
3802     {
3803       /* No binding label given, and the NAME= specifier did not exist,
3804          which means there was no NAME="".  */
3805       if (sym_name != NULL && has_name_equals == 0)
3806         *dest_label = IDENTIFIER_POINTER (get_identifier (sym_name));
3807     }
3808    
3809   return SUCCESS;
3810 }
3811
3812
3813 /* Set the status of the given common block as being BIND(C) or not,
3814    depending on the given parameter, is_bind_c.  */
3815
3816 void
3817 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3818 {
3819   com_block->is_bind_c = is_bind_c;
3820   return;
3821 }
3822
3823
3824 /* Verify that the given gfc_typespec is for a C interoperable type.  */
3825
3826 gfc_try
3827 gfc_verify_c_interop (gfc_typespec *ts)
3828 {
3829   if (ts->type == BT_DERIVED && ts->u.derived != NULL)
3830     return (ts->u.derived->ts.is_c_interop || ts->u.derived->attr.is_bind_c)
3831            ? SUCCESS : FAILURE;
3832   else if (ts->type == BT_CLASS)
3833     return FAILURE;
3834   else if (ts->is_c_interop != 1)
3835     return FAILURE;
3836   
3837   return SUCCESS;
3838 }
3839
3840
3841 /* Verify that the variables of a given common block, which has been
3842    defined with the attribute specifier bind(c), to be of a C
3843    interoperable type.  Errors will be reported here, if
3844    encountered.  */
3845
3846 gfc_try
3847 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3848 {
3849   gfc_symbol *curr_sym = NULL;
3850   gfc_try retval = SUCCESS;
3851
3852   curr_sym = com_block->head;
3853   
3854   /* Make sure we have at least one symbol.  */
3855   if (curr_sym == NULL)
3856     return retval;
3857
3858   /* Here we know we have a symbol, so we'll execute this loop
3859      at least once.  */
3860   do
3861     {
3862       /* The second to last param, 1, says this is in a common block.  */
3863       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3864       curr_sym = curr_sym->common_next;
3865     } while (curr_sym != NULL); 
3866
3867   return retval;
3868 }
3869
3870
3871 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
3872    an appropriate error message is reported.  */
3873
3874 gfc_try
3875 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3876                    int is_in_common, gfc_common_head *com_block)
3877 {
3878   bool bind_c_function = false;
3879   gfc_try retval = SUCCESS;
3880
3881   if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
3882     bind_c_function = true;
3883
3884   if (tmp_sym->attr.function && tmp_sym->result != NULL)
3885     {
3886       tmp_sym = tmp_sym->result;
3887       /* Make sure it wasn't an implicitly typed result.  */
3888       if (tmp_sym->attr.implicit_type)
3889         {
3890           gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3891                        "%L may not be C interoperable", tmp_sym->name,
3892                        &tmp_sym->declared_at);
3893           tmp_sym->ts.f90_type = tmp_sym->ts.type;
3894           /* Mark it as C interoperable to prevent duplicate warnings.  */
3895           tmp_sym->ts.is_c_interop = 1;
3896           tmp_sym->attr.is_c_interop = 1;
3897         }
3898     }
3899
3900   /* Here, we know we have the bind(c) attribute, so if we have
3901      enough type info, then verify that it's a C interop kind.
3902      The info could be in the symbol already, or possibly still in
3903      the given ts (current_ts), so look in both.  */
3904   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 
3905     {
3906       if (gfc_verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
3907         {
3908           /* See if we're dealing with a sym in a common block or not.  */
3909           if (is_in_common == 1)
3910             {
3911               gfc_warning ("Variable '%s' in common block '%s' at %L "
3912                            "may not be a C interoperable "
3913                            "kind though common block '%s' is BIND(C)",
3914                            tmp_sym->name, com_block->name,
3915                            &(tmp_sym->declared_at), com_block->name);
3916             }
3917           else
3918             {
3919               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3920                 gfc_error ("Type declaration '%s' at %L is not C "
3921                            "interoperable but it is BIND(C)",
3922                            tmp_sym->name, &(tmp_sym->declared_at));
3923               else
3924                 gfc_warning ("Variable '%s' at %L "
3925                              "may not be a C interoperable "
3926                              "kind but it is bind(c)",
3927                              tmp_sym->name, &(tmp_sym->declared_at));
3928             }
3929         }
3930       
3931       /* Variables declared w/in a common block can't be bind(c)
3932          since there's no way for C to see these variables, so there's
3933          semantically no reason for the attribute.  */
3934       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3935         {
3936           gfc_error ("Variable '%s' in common block '%s' at "
3937                      "%L cannot be declared with BIND(C) "
3938                      "since it is not a global",
3939                      tmp_sym->name, com_block->name,
3940                      &(tmp_sym->declared_at));
3941           retval = FAILURE;
3942         }
3943       
3944       /* Scalar variables that are bind(c) can not have the pointer
3945          or allocatable attributes.  */
3946       if (tmp_sym->attr.is_bind_c == 1)
3947         {
3948           if (tmp_sym->attr.pointer == 1)
3949             {
3950               gfc_error ("Variable '%s' at %L cannot have both the "
3951                          "POINTER and BIND(C) attributes",
3952                          tmp_sym->name, &(tmp_sym->declared_at));
3953               retval = FAILURE;
3954             }
3955
3956           if (tmp_sym->attr.allocatable == 1)
3957             {
3958               gfc_error ("Variable '%s' at %L cannot have both the "
3959                          "ALLOCATABLE and BIND(C) attributes",
3960                          tmp_sym->name, &(tmp_sym->declared_at));
3961               retval = FAILURE;
3962             }
3963
3964         }
3965
3966       /* If it is a BIND(C) function, make sure the return value is a
3967          scalar value.  The previous tests in this function made sure
3968          the type is interoperable.  */
3969       if (bind_c_function && tmp_sym->as != NULL)
3970         gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3971                    "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3972
3973       /* BIND(C) functions can not return a character string.  */
3974       if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
3975         if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
3976             || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
3977             || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
3978           gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3979                          "be a character string", tmp_sym->name,
3980                          &(tmp_sym->declared_at));
3981     }
3982
3983   /* See if the symbol has been marked as private.  If it has, make sure
3984      there is no binding label and warn the user if there is one.  */
3985   if (tmp_sym->attr.access == ACCESS_PRIVATE
3986       && tmp_sym->binding_label)
3987       /* Use gfc_warning_now because we won't say that the symbol fails
3988          just because of this.  */
3989       gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3990                        "given the binding label '%s'", tmp_sym->name,
3991                        &(tmp_sym->declared_at), tmp_sym->binding_label);
3992
3993   return retval;
3994 }
3995
3996
3997 /* Set the appropriate fields for a symbol that's been declared as
3998    BIND(C) (the is_bind_c flag and the binding label), and verify that
3999    the type is C interoperable.  Errors are reported by the functions
4000    used to set/test these fields.  */
4001
4002 gfc_try
4003 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
4004 {
4005   gfc_try retval = SUCCESS;
4006   
4007   /* TODO: Do we need to make sure the vars aren't marked private?  */
4008
4009   /* Set the is_bind_c bit in symbol_attribute.  */
4010   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
4011
4012   if (set_binding_label (&tmp_sym->binding_label, tmp_sym->name,
4013                          num_idents) != SUCCESS)
4014     return FAILURE;
4015
4016   return retval;
4017 }
4018
4019
4020 /* Set the fields marking the given common block as BIND(C), including
4021    a binding label, and report any errors encountered.  */
4022
4023 gfc_try
4024 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
4025 {
4026   gfc_try retval = SUCCESS;
4027   
4028   /* destLabel, common name, typespec (which may have binding label).  */
4029   if (set_binding_label (&com_block->binding_label, com_block->name, 
4030                          num_idents)
4031       != SUCCESS)
4032     return FAILURE;
4033
4034   /* Set the given common block (com_block) to being bind(c) (1).  */
4035   set_com_block_bind_c (com_block, 1);
4036
4037   return retval;
4038 }
4039
4040
4041 /* Retrieve the list of one or more identifiers that the given bind(c)
4042    attribute applies to.  */
4043
4044 gfc_try
4045 get_bind_c_idents (void)
4046 {
4047   char name[GFC_MAX_SYMBOL_LEN + 1];
4048   int num_idents = 0;
4049   gfc_symbol *tmp_sym = NULL;
4050   match found_id;
4051   gfc_common_head *com_block = NULL;
4052   
4053   if (gfc_match_name (name) == MATCH_YES)
4054     {
4055       found_id = MATCH_YES;
4056       gfc_get_ha_symbol (name, &tmp_sym);
4057     }
4058   else if (match_common_name (name) == MATCH_YES)
4059     {
4060       found_id = MATCH_YES;
4061       com_block = gfc_get_common (name, 0);
4062     }
4063   else
4064     {
4065       gfc_error ("Need either entity or common block name for "
4066                  "attribute specification statement at %C");
4067       return FAILURE;
4068     }
4069    
4070   /* Save the current identifier and look for more.  */
4071   do
4072     {
4073       /* Increment the number of identifiers found for this spec stmt.  */
4074       num_idents++;
4075
4076       /* Make sure we have a sym or com block, and verify that it can
4077          be bind(c).  Set the appropriate field(s) and look for more
4078          identifiers.  */
4079       if (tmp_sym != NULL || com_block != NULL)         
4080         {
4081           if (tmp_sym != NULL)
4082             {
4083               if (set_verify_bind_c_sym (tmp_sym, num_idents)
4084                   != SUCCESS)
4085                 return FAILURE;
4086             }
4087           else
4088             {
4089               if (set_verify_bind_c_com_block(com_block, num_idents)
4090                   != SUCCESS)
4091                 return FAILURE;
4092             }
4093          
4094           /* Look to see if we have another identifier.  */
4095           tmp_sym = NULL;
4096           if (gfc_match_eos () == MATCH_YES)
4097             found_id = MATCH_NO;
4098           else if (gfc_match_char (',') != MATCH_YES)
4099             found_id = MATCH_NO;