OSDN Git Service

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