OSDN Git Service

2009-10-09 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
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 /* Build a polymorphic CLASS entity, using the symbol that comes from build_sym.
1029    A CLASS entity is represented by an encapsulating type, which contains the
1030    declared type as '$data' component, plus an integer component '$vindex'
1031    which determines the dynamic type.  */
1032
1033 static gfc_try
1034 encapsulate_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
1035                           gfc_array_spec **as)
1036 {
1037   char name[GFC_MAX_SYMBOL_LEN + 5];
1038   gfc_symbol *fclass;
1039   gfc_component *c;
1040
1041   /* Determine the name of the encapsulating type.  */
1042   if ((*as) && (*as)->rank && attr->allocatable)
1043     sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
1044   else if ((*as) && (*as)->rank)
1045     sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
1046   else if (attr->allocatable)
1047     sprintf (name, ".class.%s.a", ts->u.derived->name);
1048   else
1049     sprintf (name, ".class.%s", ts->u.derived->name);
1050
1051   gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
1052   if (fclass == NULL)
1053     {
1054       gfc_symtree *st;
1055       /* If not there, create a new symbol.  */
1056       fclass = gfc_new_symbol (name, ts->u.derived->ns);
1057       st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
1058       st->n.sym = fclass;
1059       gfc_set_sym_referenced (fclass);
1060       fclass->refs++;
1061       fclass->ts.type = BT_UNKNOWN;
1062       fclass->vindex = ts->u.derived->vindex;
1063       fclass->attr.abstract = ts->u.derived->attr.abstract;
1064       if (ts->u.derived->f2k_derived)
1065         fclass->f2k_derived = gfc_get_namespace (NULL, 0);
1066       if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
1067           NULL, &gfc_current_locus) == FAILURE)
1068         return FAILURE;
1069
1070       /* Add component '$data'.  */
1071       if (gfc_add_component (fclass, "$data", &c) == FAILURE)
1072         return FAILURE;
1073       c->ts = *ts;
1074       c->ts.type = BT_DERIVED;
1075       c->attr.access = ACCESS_PRIVATE;
1076       c->ts.u.derived = ts->u.derived;
1077       c->attr.pointer = attr->pointer || attr->dummy;
1078       c->attr.allocatable = attr->allocatable;
1079       c->attr.dimension = attr->dimension;
1080       c->attr.abstract = ts->u.derived->attr.abstract;
1081       c->as = (*as);
1082       c->initializer = gfc_get_expr ();
1083       c->initializer->expr_type = EXPR_NULL;
1084
1085       /* Add component '$vindex'.  */
1086       if (gfc_add_component (fclass, "$vindex", &c) == FAILURE)
1087         return FAILURE;
1088       c->ts.type = BT_INTEGER;
1089       c->ts.kind = 4;
1090       c->attr.access = ACCESS_PRIVATE;
1091       c->initializer = gfc_int_expr (0);
1092     }
1093
1094   fclass->attr.extension = 1;
1095   fclass->attr.is_class = 1;
1096   ts->u.derived = fclass;
1097   attr->allocatable = attr->pointer = attr->dimension = 0;
1098   (*as) = NULL;  /* XXX */
1099   return SUCCESS;
1100 }
1101
1102 /* Function called by variable_decl() that adds a name to the symbol table.  */
1103
1104 static gfc_try
1105 build_sym (const char *name, gfc_charlen *cl,
1106            gfc_array_spec **as, locus *var_locus)
1107 {
1108   symbol_attribute attr;
1109   gfc_symbol *sym;
1110
1111   if (gfc_get_symbol (name, NULL, &sym))
1112     return FAILURE;
1113
1114   /* Start updating the symbol table.  Add basic type attribute if present.  */
1115   if (current_ts.type != BT_UNKNOWN
1116       && (sym->attr.implicit_type == 0
1117           || !gfc_compare_types (&sym->ts, &current_ts))
1118       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
1119     return FAILURE;
1120
1121   if (sym->ts.type == BT_CHARACTER)
1122     sym->ts.u.cl = cl;
1123
1124   /* Add dimension attribute if present.  */
1125   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
1126     return FAILURE;
1127   *as = NULL;
1128
1129   /* Add attribute to symbol.  The copy is so that we can reset the
1130      dimension attribute.  */
1131   attr = current_attr;
1132   attr.dimension = 0;
1133
1134   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
1135     return FAILURE;
1136
1137   /* Finish any work that may need to be done for the binding label,
1138      if it's a bind(c).  The bind(c) attr is found before the symbol
1139      is made, and before the symbol name (for data decls), so the
1140      current_ts is holding the binding label, or nothing if the
1141      name= attr wasn't given.  Therefore, test here if we're dealing
1142      with a bind(c) and make sure the binding label is set correctly.  */
1143   if (sym->attr.is_bind_c == 1)
1144     {
1145       if (sym->binding_label[0] == '\0')
1146         {
1147           /* Set the binding label and verify that if a NAME= was specified
1148              then only one identifier was in the entity-decl-list.  */
1149           if (set_binding_label (sym->binding_label, sym->name,
1150                                  num_idents_on_line) == FAILURE)
1151             return FAILURE;
1152         }
1153     }
1154
1155   /* See if we know we're in a common block, and if it's a bind(c)
1156      common then we need to make sure we're an interoperable type.  */
1157   if (sym->attr.in_common == 1)
1158     {
1159       /* Test the common block object.  */
1160       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1161           && sym->ts.is_c_interop != 1)
1162         {
1163           gfc_error_now ("Variable '%s' in common block '%s' at %C "
1164                          "must be declared with a C interoperable "
1165                          "kind since common block '%s' is BIND(C)",
1166                          sym->name, sym->common_block->name,
1167                          sym->common_block->name);
1168           gfc_clear_error ();
1169         }
1170     }
1171
1172   sym->attr.implied_index = 0;
1173
1174   if (sym->ts.type == BT_CLASS)
1175     encapsulate_class_symbol (&sym->ts, &sym->attr, &sym->as);
1176
1177   return SUCCESS;
1178 }
1179
1180
1181 /* Set character constant to the given length. The constant will be padded or
1182    truncated.  If we're inside an array constructor without a typespec, we
1183    additionally check that all elements have the same length; check_len -1
1184    means no checking.  */
1185
1186 void
1187 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1188 {
1189   gfc_char_t *s;
1190   int slen;
1191
1192   gcc_assert (expr->expr_type == EXPR_CONSTANT);
1193   gcc_assert (expr->ts.type == BT_CHARACTER);
1194
1195   slen = expr->value.character.length;
1196   if (len != slen)
1197     {
1198       s = gfc_get_wide_string (len + 1);
1199       memcpy (s, expr->value.character.string,
1200               MIN (len, slen) * sizeof (gfc_char_t));
1201       if (len > slen)
1202         gfc_wide_memset (&s[slen], ' ', len - slen);
1203
1204       if (gfc_option.warn_character_truncation && slen > len)
1205         gfc_warning_now ("CHARACTER expression at %L is being truncated "
1206                          "(%d/%d)", &expr->where, slen, len);
1207
1208       /* Apply the standard by 'hand' otherwise it gets cleared for
1209          initializers.  */
1210       if (check_len != -1 && slen != check_len
1211           && !(gfc_option.allow_std & GFC_STD_GNU))
1212         gfc_error_now ("The CHARACTER elements of the array constructor "
1213                        "at %L must have the same length (%d/%d)",
1214                         &expr->where, slen, check_len);
1215
1216       s[len] = '\0';
1217       gfc_free (expr->value.character.string);
1218       expr->value.character.string = s;
1219       expr->value.character.length = len;
1220     }
1221 }
1222
1223
1224 /* Function to create and update the enumerator history
1225    using the information passed as arguments.
1226    Pointer "max_enum" is also updated, to point to
1227    enum history node containing largest initializer.
1228
1229    SYM points to the symbol node of enumerator.
1230    INIT points to its enumerator value.  */
1231
1232 static void
1233 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1234 {
1235   enumerator_history *new_enum_history;
1236   gcc_assert (sym != NULL && init != NULL);
1237
1238   new_enum_history = XCNEW (enumerator_history);
1239
1240   new_enum_history->sym = sym;
1241   new_enum_history->initializer = init;
1242   new_enum_history->next = NULL;
1243
1244   if (enum_history == NULL)
1245     {
1246       enum_history = new_enum_history;
1247       max_enum = enum_history;
1248     }
1249   else
1250     {
1251       new_enum_history->next = enum_history;
1252       enum_history = new_enum_history;
1253
1254       if (mpz_cmp (max_enum->initializer->value.integer,
1255                    new_enum_history->initializer->value.integer) < 0)
1256         max_enum = new_enum_history;
1257     }
1258 }
1259
1260
1261 /* Function to free enum kind history.  */
1262
1263 void
1264 gfc_free_enum_history (void)
1265 {
1266   enumerator_history *current = enum_history;
1267   enumerator_history *next;
1268
1269   while (current != NULL)
1270     {
1271       next = current->next;
1272       gfc_free (current);
1273       current = next;
1274     }
1275   max_enum = NULL;
1276   enum_history = NULL;
1277 }
1278
1279
1280 /* Function called by variable_decl() that adds an initialization
1281    expression to a symbol.  */
1282
1283 static gfc_try
1284 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1285 {
1286   symbol_attribute attr;
1287   gfc_symbol *sym;
1288   gfc_expr *init;
1289
1290   init = *initp;
1291   if (find_special (name, &sym, false))
1292     return FAILURE;
1293
1294   attr = sym->attr;
1295
1296   /* If this symbol is confirming an implicit parameter type,
1297      then an initialization expression is not allowed.  */
1298   if (attr.flavor == FL_PARAMETER
1299       && sym->value != NULL
1300       && *initp != NULL)
1301     {
1302       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1303                  sym->name);
1304       return FAILURE;
1305     }
1306
1307   if (init == NULL)
1308     {
1309       /* An initializer is required for PARAMETER declarations.  */
1310       if (attr.flavor == FL_PARAMETER)
1311         {
1312           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1313           return FAILURE;
1314         }
1315     }
1316   else
1317     {
1318       /* If a variable appears in a DATA block, it cannot have an
1319          initializer.  */
1320       if (sym->attr.data)
1321         {
1322           gfc_error ("Variable '%s' at %C with an initializer already "
1323                      "appears in a DATA statement", sym->name);
1324           return FAILURE;
1325         }
1326
1327       /* Check if the assignment can happen. This has to be put off
1328          until later for a derived type variable.  */
1329       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1330           && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS
1331           && gfc_check_assign_symbol (sym, init) == FAILURE)
1332         return FAILURE;
1333
1334       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1335             && init->ts.type == BT_CHARACTER)
1336         {
1337           /* Update symbol character length according initializer.  */
1338           if (gfc_check_assign_symbol (sym, init) == FAILURE)
1339             return FAILURE;
1340
1341           if (sym->ts.u.cl->length == NULL)
1342             {
1343               int clen;
1344               /* If there are multiple CHARACTER variables declared on the
1345                  same line, we don't want them to share the same length.  */
1346               sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1347
1348               if (sym->attr.flavor == FL_PARAMETER)
1349                 {
1350                   if (init->expr_type == EXPR_CONSTANT)
1351                     {
1352                       clen = init->value.character.length;
1353                       sym->ts.u.cl->length = gfc_int_expr (clen);
1354                     }
1355                   else if (init->expr_type == EXPR_ARRAY)
1356                     {
1357                       gfc_expr *p = init->value.constructor->expr;
1358                       clen = p->value.character.length;
1359                       sym->ts.u.cl->length = gfc_int_expr (clen);
1360                     }
1361                   else if (init->ts.u.cl && init->ts.u.cl->length)
1362                     sym->ts.u.cl->length =
1363                                 gfc_copy_expr (sym->value->ts.u.cl->length);
1364                 }
1365             }
1366           /* Update initializer character length according symbol.  */
1367           else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1368             {
1369               int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1370               gfc_constructor * p;
1371
1372               if (init->expr_type == EXPR_CONSTANT)
1373                 gfc_set_constant_character_len (len, init, -1);
1374               else if (init->expr_type == EXPR_ARRAY)
1375                 {
1376                   /* Build a new charlen to prevent simplification from
1377                      deleting the length before it is resolved.  */
1378                   init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1379                   init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1380
1381                   for (p = init->value.constructor; p; p = p->next)
1382                     gfc_set_constant_character_len (len, p->expr, -1);
1383                 }
1384             }
1385         }
1386
1387       /* Need to check if the expression we initialized this
1388          to was one of the iso_c_binding named constants.  If so,
1389          and we're a parameter (constant), let it be iso_c.
1390          For example:
1391          integer(c_int), parameter :: my_int = c_int
1392          integer(my_int) :: my_int_2
1393          If we mark my_int as iso_c (since we can see it's value
1394          is equal to one of the named constants), then my_int_2
1395          will be considered C interoperable.  */
1396       if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1397         {
1398           sym->ts.is_iso_c |= init->ts.is_iso_c;
1399           sym->ts.is_c_interop |= init->ts.is_c_interop;
1400           /* attr bits needed for module files.  */
1401           sym->attr.is_iso_c |= init->ts.is_iso_c;
1402           sym->attr.is_c_interop |= init->ts.is_c_interop;
1403           if (init->ts.is_iso_c)
1404             sym->ts.f90_type = init->ts.f90_type;
1405         }
1406       
1407       /* Add initializer.  Make sure we keep the ranks sane.  */
1408       if (sym->attr.dimension && init->rank == 0)
1409         {
1410           mpz_t size;
1411           gfc_expr *array;
1412           gfc_constructor *c;
1413           int n;
1414           if (sym->attr.flavor == FL_PARAMETER
1415                 && init->expr_type == EXPR_CONSTANT
1416                 && spec_size (sym->as, &size) == SUCCESS
1417                 && mpz_cmp_si (size, 0) > 0)
1418             {
1419               array = gfc_start_constructor (init->ts.type, init->ts.kind,
1420                                              &init->where);
1421
1422               array->value.constructor = c = NULL;
1423               for (n = 0; n < (int)mpz_get_si (size); n++)
1424                 {
1425                   if (array->value.constructor == NULL)
1426                     {
1427                       array->value.constructor = c = gfc_get_constructor ();
1428                       c->expr = init;
1429                     }
1430                   else
1431                     {
1432                       c->next = gfc_get_constructor ();
1433                       c = c->next;
1434                       c->expr = gfc_copy_expr (init);
1435                     }
1436                 }
1437
1438               array->shape = gfc_get_shape (sym->as->rank);
1439               for (n = 0; n < sym->as->rank; n++)
1440                 spec_dimen_size (sym->as, n, &array->shape[n]);
1441
1442               init = array;
1443               mpz_clear (size);
1444             }
1445           init->rank = sym->as->rank;
1446         }
1447
1448       sym->value = init;
1449       if (sym->attr.save == SAVE_NONE)
1450         sym->attr.save = SAVE_IMPLICIT;
1451       *initp = NULL;
1452     }
1453
1454   return SUCCESS;
1455 }
1456
1457
1458 /* Function called by variable_decl() that adds a name to a structure
1459    being built.  */
1460
1461 static gfc_try
1462 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1463               gfc_array_spec **as)
1464 {
1465   gfc_component *c;
1466
1467   /* If the current symbol is of the same derived type that we're
1468      constructing, it must have the pointer attribute.  */
1469   if (current_ts.type == BT_DERIVED
1470       && current_ts.u.derived == gfc_current_block ()
1471       && current_attr.pointer == 0)
1472     {
1473       gfc_error ("Component at %C must have the POINTER attribute");
1474       return FAILURE;
1475     }
1476
1477   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1478     {
1479       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1480         {
1481           gfc_error ("Array component of structure at %C must have explicit "
1482                      "or deferred shape");
1483           return FAILURE;
1484         }
1485     }
1486
1487   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1488     return FAILURE;
1489
1490   c->ts = current_ts;
1491   if (c->ts.type == BT_CHARACTER)
1492     c->ts.u.cl = cl;
1493   c->attr = current_attr;
1494
1495   c->initializer = *init;
1496   *init = NULL;
1497
1498   c->as = *as;
1499   if (c->as != NULL)
1500     c->attr.dimension = 1;
1501   *as = NULL;
1502
1503   /* Should this ever get more complicated, combine with similar section
1504      in add_init_expr_to_sym into a separate function.  */
1505   if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.u.cl
1506       && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1507     {
1508       int len;
1509
1510       gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
1511       gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
1512       gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
1513
1514       len = mpz_get_si (c->ts.u.cl->length->value.integer);
1515
1516       if (c->initializer->expr_type == EXPR_CONSTANT)
1517         gfc_set_constant_character_len (len, c->initializer, -1);
1518       else if (mpz_cmp (c->ts.u.cl->length->value.integer,
1519                         c->initializer->ts.u.cl->length->value.integer))
1520         {
1521           bool has_ts;
1522           gfc_constructor *ctor = c->initializer->value.constructor;
1523
1524           has_ts = (c->initializer->ts.u.cl
1525                     && c->initializer->ts.u.cl->length_from_typespec);
1526
1527           if (ctor)
1528             {
1529               int first_len;
1530
1531               /* Remember the length of the first element for checking
1532                  that all elements *in the constructor* have the same
1533                  length.  This need not be the length of the LHS!  */
1534               gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
1535               gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
1536               first_len = ctor->expr->value.character.length;
1537
1538               for (; ctor; ctor = ctor->next)
1539                 {
1540                   if (ctor->expr->expr_type == EXPR_CONSTANT)
1541                     gfc_set_constant_character_len (len, ctor->expr,
1542                                                     has_ts ? -1 : first_len);
1543                 }
1544             }
1545         }
1546     }
1547
1548   if (c->ts.type == BT_CLASS)
1549     encapsulate_class_symbol (&c->ts, &c->attr, &c->as);
1550
1551   /* Check array components.  */
1552   if (!c->attr.dimension)
1553     return SUCCESS;
1554
1555   if (c->attr.pointer)
1556     {
1557       if (c->as->type != AS_DEFERRED)
1558         {
1559           gfc_error ("Pointer array component of structure at %C must have a "
1560                      "deferred shape");
1561           return FAILURE;
1562         }
1563     }
1564   else if (c->attr.allocatable)
1565     {
1566       if (c->as->type != AS_DEFERRED)
1567         {
1568           gfc_error ("Allocatable component of structure at %C must have a "
1569                      "deferred shape");
1570           return FAILURE;
1571         }
1572     }
1573   else
1574     {
1575       if (c->as->type != AS_EXPLICIT)
1576         {
1577           gfc_error ("Array component of structure at %C must have an "
1578                      "explicit shape");
1579           return FAILURE;
1580         }
1581     }
1582
1583   return SUCCESS;
1584 }
1585
1586
1587 /* Match a 'NULL()', and possibly take care of some side effects.  */
1588
1589 match
1590 gfc_match_null (gfc_expr **result)
1591 {
1592   gfc_symbol *sym;
1593   gfc_expr *e;
1594   match m;
1595
1596   m = gfc_match (" null ( )");
1597   if (m != MATCH_YES)
1598     return m;
1599
1600   /* The NULL symbol now has to be/become an intrinsic function.  */
1601   if (gfc_get_symbol ("null", NULL, &sym))
1602     {
1603       gfc_error ("NULL() initialization at %C is ambiguous");
1604       return MATCH_ERROR;
1605     }
1606
1607   gfc_intrinsic_symbol (sym);
1608
1609   if (sym->attr.proc != PROC_INTRINSIC
1610       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1611                              sym->name, NULL) == FAILURE
1612           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1613     return MATCH_ERROR;
1614
1615   e = gfc_get_expr ();
1616   e->where = gfc_current_locus;
1617   e->expr_type = EXPR_NULL;
1618   e->ts.type = BT_UNKNOWN;
1619
1620   *result = e;
1621
1622   return MATCH_YES;
1623 }
1624
1625
1626 /* Match a variable name with an optional initializer.  When this
1627    subroutine is called, a variable is expected to be parsed next.
1628    Depending on what is happening at the moment, updates either the
1629    symbol table or the current interface.  */
1630
1631 static match
1632 variable_decl (int elem)
1633 {
1634   char name[GFC_MAX_SYMBOL_LEN + 1];
1635   gfc_expr *initializer, *char_len;
1636   gfc_array_spec *as;
1637   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1638   gfc_charlen *cl;
1639   locus var_locus;
1640   match m;
1641   gfc_try t;
1642   gfc_symbol *sym;
1643   locus old_locus;
1644
1645   initializer = NULL;
1646   as = NULL;
1647   cp_as = NULL;
1648   old_locus = gfc_current_locus;
1649
1650   /* When we get here, we've just matched a list of attributes and
1651      maybe a type and a double colon.  The next thing we expect to see
1652      is the name of the symbol.  */
1653   m = gfc_match_name (name);
1654   if (m != MATCH_YES)
1655     goto cleanup;
1656
1657   var_locus = gfc_current_locus;
1658
1659   /* Now we could see the optional array spec. or character length.  */
1660   m = gfc_match_array_spec (&as);
1661   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1662     cp_as = gfc_copy_array_spec (as);
1663   else if (m == MATCH_ERROR)
1664     goto cleanup;
1665
1666   if (m == MATCH_NO)
1667     as = gfc_copy_array_spec (current_as);
1668
1669   char_len = NULL;
1670   cl = NULL;
1671
1672   if (current_ts.type == BT_CHARACTER)
1673     {
1674       switch (match_char_length (&char_len))
1675         {
1676         case MATCH_YES:
1677           cl = gfc_new_charlen (gfc_current_ns, NULL);
1678
1679           cl->length = char_len;
1680           break;
1681
1682         /* Non-constant lengths need to be copied after the first
1683            element.  Also copy assumed lengths.  */
1684         case MATCH_NO:
1685           if (elem > 1
1686               && (current_ts.u.cl->length == NULL
1687                   || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
1688             {
1689               cl = gfc_new_charlen (gfc_current_ns, NULL);
1690               cl->length = gfc_copy_expr (current_ts.u.cl->length);
1691             }
1692           else
1693             cl = current_ts.u.cl;
1694
1695           break;
1696
1697         case MATCH_ERROR:
1698           goto cleanup;
1699         }
1700     }
1701
1702   /*  If this symbol has already shown up in a Cray Pointer declaration,
1703       then we want to set the type & bail out.  */
1704   if (gfc_option.flag_cray_pointer)
1705     {
1706       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1707       if (sym != NULL && sym->attr.cray_pointee)
1708         {
1709           sym->ts.type = current_ts.type;
1710           sym->ts.kind = current_ts.kind;
1711           sym->ts.u.cl = cl;
1712           sym->ts.u.derived = current_ts.u.derived;
1713           sym->ts.is_c_interop = current_ts.is_c_interop;
1714           sym->ts.is_iso_c = current_ts.is_iso_c;
1715           m = MATCH_YES;
1716         
1717           /* Check to see if we have an array specification.  */
1718           if (cp_as != NULL)
1719             {
1720               if (sym->as != NULL)
1721                 {
1722                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1723                   gfc_free_array_spec (cp_as);
1724                   m = MATCH_ERROR;
1725                   goto cleanup;
1726                 }
1727               else
1728                 {
1729                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1730                     gfc_internal_error ("Couldn't set pointee array spec.");
1731
1732                   /* Fix the array spec.  */
1733                   m = gfc_mod_pointee_as (sym->as);
1734                   if (m == MATCH_ERROR)
1735                     goto cleanup;
1736                 }
1737             }
1738           goto cleanup;
1739         }
1740       else
1741         {
1742           gfc_free_array_spec (cp_as);
1743         }
1744     }
1745
1746   /* Procedure pointer as function result.  */
1747   if (gfc_current_state () == COMP_FUNCTION
1748       && strcmp ("ppr@", gfc_current_block ()->name) == 0
1749       && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
1750     strcpy (name, "ppr@");
1751
1752   if (gfc_current_state () == COMP_FUNCTION
1753       && strcmp (name, gfc_current_block ()->name) == 0
1754       && gfc_current_block ()->result
1755       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
1756     strcpy (name, "ppr@");
1757
1758   /* OK, we've successfully matched the declaration.  Now put the
1759      symbol in the current namespace, because it might be used in the
1760      optional initialization expression for this symbol, e.g. this is
1761      perfectly legal:
1762
1763      integer, parameter :: i = huge(i)
1764
1765      This is only true for parameters or variables of a basic type.
1766      For components of derived types, it is not true, so we don't
1767      create a symbol for those yet.  If we fail to create the symbol,
1768      bail out.  */
1769   if (gfc_current_state () != COMP_DERIVED
1770       && build_sym (name, cl, &as, &var_locus) == FAILURE)
1771     {
1772       m = MATCH_ERROR;
1773       goto cleanup;
1774     }
1775
1776   /* An interface body specifies all of the procedure's
1777      characteristics and these shall be consistent with those
1778      specified in the procedure definition, except that the interface
1779      may specify a procedure that is not pure if the procedure is
1780      defined to be pure(12.3.2).  */
1781   if (current_ts.type == BT_DERIVED
1782       && gfc_current_ns->proc_name
1783       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1784       && current_ts.u.derived->ns != gfc_current_ns)
1785     {
1786       gfc_symtree *st;
1787       st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
1788       if (!(current_ts.u.derived->attr.imported
1789                 && st != NULL
1790                 && st->n.sym == current_ts.u.derived)
1791             && !gfc_current_ns->has_import_set)
1792         {
1793             gfc_error ("the type of '%s' at %C has not been declared within the "
1794                        "interface", name);
1795             m = MATCH_ERROR;
1796             goto cleanup;
1797         }
1798     }
1799
1800   /* In functions that have a RESULT variable defined, the function
1801      name always refers to function calls.  Therefore, the name is
1802      not allowed to appear in specification statements.  */
1803   if (gfc_current_state () == COMP_FUNCTION
1804       && gfc_current_block () != NULL
1805       && gfc_current_block ()->result != NULL
1806       && gfc_current_block ()->result != gfc_current_block ()
1807       && strcmp (gfc_current_block ()->name, name) == 0)
1808     {
1809       gfc_error ("Function name '%s' not allowed at %C", name);
1810       m = MATCH_ERROR;
1811       goto cleanup;
1812     }
1813
1814   /* We allow old-style initializations of the form
1815        integer i /2/, j(4) /3*3, 1/
1816      (if no colon has been seen). These are different from data
1817      statements in that initializers are only allowed to apply to the
1818      variable immediately preceding, i.e.
1819        integer i, j /1, 2/
1820      is not allowed. Therefore we have to do some work manually, that
1821      could otherwise be left to the matchers for DATA statements.  */
1822
1823   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1824     {
1825       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1826                           "initialization at %C") == FAILURE)
1827         return MATCH_ERROR;
1828  
1829       return match_old_style_init (name);
1830     }
1831
1832   /* The double colon must be present in order to have initializers.
1833      Otherwise the statement is ambiguous with an assignment statement.  */
1834   if (colon_seen)
1835     {
1836       if (gfc_match (" =>") == MATCH_YES)
1837         {
1838           if (!current_attr.pointer)
1839             {
1840               gfc_error ("Initialization at %C isn't for a pointer variable");
1841               m = MATCH_ERROR;
1842               goto cleanup;
1843             }
1844
1845           m = gfc_match_null (&initializer);
1846           if (m == MATCH_NO)
1847             {
1848               gfc_error ("Pointer initialization requires a NULL() at %C");
1849               m = MATCH_ERROR;
1850             }
1851
1852           if (gfc_pure (NULL))
1853             {
1854               gfc_error ("Initialization of pointer at %C is not allowed in "
1855                          "a PURE procedure");
1856               m = MATCH_ERROR;
1857             }
1858
1859           if (m != MATCH_YES)
1860             goto cleanup;
1861
1862         }
1863       else if (gfc_match_char ('=') == MATCH_YES)
1864         {
1865           if (current_attr.pointer)
1866             {
1867               gfc_error ("Pointer initialization at %C requires '=>', "
1868                          "not '='");
1869               m = MATCH_ERROR;
1870               goto cleanup;
1871             }
1872
1873           m = gfc_match_init_expr (&initializer);
1874           if (m == MATCH_NO)
1875             {
1876               gfc_error ("Expected an initialization expression at %C");
1877               m = MATCH_ERROR;
1878             }
1879
1880           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1881             {
1882               gfc_error ("Initialization of variable at %C is not allowed in "
1883                          "a PURE procedure");
1884               m = MATCH_ERROR;
1885             }
1886
1887           if (m != MATCH_YES)
1888             goto cleanup;
1889         }
1890     }
1891
1892   if (initializer != NULL && current_attr.allocatable
1893         && gfc_current_state () == COMP_DERIVED)
1894     {
1895       gfc_error ("Initialization of allocatable component at %C is not "
1896                  "allowed");
1897       m = MATCH_ERROR;
1898       goto cleanup;
1899     }
1900
1901   /* Add the initializer.  Note that it is fine if initializer is
1902      NULL here, because we sometimes also need to check if a
1903      declaration *must* have an initialization expression.  */
1904   if (gfc_current_state () != COMP_DERIVED)
1905     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1906   else
1907     {
1908       if (current_ts.type == BT_DERIVED
1909           && !current_attr.pointer && !initializer)
1910         initializer = gfc_default_initializer (&current_ts);
1911       t = build_struct (name, cl, &initializer, &as);
1912     }
1913
1914   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1915
1916 cleanup:
1917   /* Free stuff up and return.  */
1918   gfc_free_expr (initializer);
1919   gfc_free_array_spec (as);
1920
1921   return m;
1922 }
1923
1924
1925 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1926    This assumes that the byte size is equal to the kind number for
1927    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
1928
1929 match
1930 gfc_match_old_kind_spec (gfc_typespec *ts)
1931 {
1932   match m;
1933   int original_kind;
1934
1935   if (gfc_match_char ('*') != MATCH_YES)
1936     return MATCH_NO;
1937
1938   m = gfc_match_small_literal_int (&ts->kind, NULL);
1939   if (m != MATCH_YES)
1940     return MATCH_ERROR;
1941
1942   original_kind = ts->kind;
1943
1944   /* Massage the kind numbers for complex types.  */
1945   if (ts->type == BT_COMPLEX)
1946     {
1947       if (ts->kind % 2)
1948         {
1949           gfc_error ("Old-style type declaration %s*%d not supported at %C",
1950                      gfc_basic_typename (ts->type), original_kind);
1951           return MATCH_ERROR;
1952         }
1953       ts->kind /= 2;
1954     }
1955
1956   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1957     {
1958       gfc_error ("Old-style type declaration %s*%d not supported at %C",
1959                  gfc_basic_typename (ts->type), original_kind);
1960       return MATCH_ERROR;
1961     }
1962
1963   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1964                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
1965     return MATCH_ERROR;
1966
1967   return MATCH_YES;
1968 }
1969
1970
1971 /* Match a kind specification.  Since kinds are generally optional, we
1972    usually return MATCH_NO if something goes wrong.  If a "kind="
1973    string is found, then we know we have an error.  */
1974
1975 match
1976 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
1977 {
1978   locus where, loc;
1979   gfc_expr *e;
1980   match m, n;
1981   char c;
1982   const char *msg;
1983
1984   m = MATCH_NO;
1985   n = MATCH_YES;
1986   e = NULL;
1987
1988   where = loc = gfc_current_locus;
1989
1990   if (kind_expr_only)
1991     goto kind_expr;
1992
1993   if (gfc_match_char ('(') == MATCH_NO)
1994     return MATCH_NO;
1995
1996   /* Also gobbles optional text.  */
1997   if (gfc_match (" kind = ") == MATCH_YES)
1998     m = MATCH_ERROR;
1999
2000   loc = gfc_current_locus;
2001
2002 kind_expr:
2003   n = gfc_match_init_expr (&e);
2004
2005   if (n != MATCH_YES)
2006     {
2007       if (gfc_matching_function)
2008         {
2009           /* The function kind expression might include use associated or 
2010              imported parameters and try again after the specification
2011              expressions.....  */
2012           if (gfc_match_char (')') != MATCH_YES)
2013             {
2014               gfc_error ("Missing right parenthesis at %C");
2015               m = MATCH_ERROR;
2016               goto no_match;
2017             }
2018
2019           gfc_free_expr (e);
2020           gfc_undo_symbols ();
2021           return MATCH_YES;
2022         }
2023       else
2024         {
2025           /* ....or else, the match is real.  */
2026           if (n == MATCH_NO)
2027             gfc_error ("Expected initialization expression at %C");
2028           if (n != MATCH_YES)
2029             return MATCH_ERROR;
2030         }
2031     }
2032
2033   if (e->rank != 0)
2034     {
2035       gfc_error ("Expected scalar initialization expression at %C");
2036       m = MATCH_ERROR;
2037       goto no_match;
2038     }
2039
2040   msg = gfc_extract_int (e, &ts->kind);
2041
2042   if (msg != NULL)
2043     {
2044       gfc_error (msg);
2045       m = MATCH_ERROR;
2046       goto no_match;
2047     }
2048
2049   /* Before throwing away the expression, let's see if we had a
2050      C interoperable kind (and store the fact).  */
2051   if (e->ts.is_c_interop == 1)
2052     {
2053       /* Mark this as c interoperable if being declared with one
2054          of the named constants from iso_c_binding.  */
2055       ts->is_c_interop = e->ts.is_iso_c;
2056       ts->f90_type = e->ts.f90_type;
2057     }
2058   
2059   gfc_free_expr (e);
2060   e = NULL;
2061
2062   /* Ignore errors to this point, if we've gotten here.  This means
2063      we ignore the m=MATCH_ERROR from above.  */
2064   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
2065     {
2066       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
2067                  gfc_basic_typename (ts->type));
2068       gfc_current_locus = where;
2069       return MATCH_ERROR;
2070     }
2071
2072   /* Warn if, e.g., c_int is used for a REAL variable, but not
2073      if, e.g., c_double is used for COMPLEX as the standard
2074      explicitly says that the kind type parameter for complex and real
2075      variable is the same, i.e. c_float == c_float_complex.  */
2076   if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2077       && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2078            || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2079     gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2080                      "is %s", gfc_basic_typename (ts->f90_type), &where,
2081                      gfc_basic_typename (ts->type));
2082
2083   gfc_gobble_whitespace ();
2084   if ((c = gfc_next_ascii_char ()) != ')'
2085       && (ts->type != BT_CHARACTER || c != ','))
2086     {
2087       if (ts->type == BT_CHARACTER)
2088         gfc_error ("Missing right parenthesis or comma at %C");
2089       else
2090         gfc_error ("Missing right parenthesis at %C");
2091       m = MATCH_ERROR;
2092     }
2093   else
2094      /* All tests passed.  */
2095      m = MATCH_YES;
2096
2097   if(m == MATCH_ERROR)
2098      gfc_current_locus = where;
2099   
2100   /* Return what we know from the test(s).  */
2101   return m;
2102
2103 no_match:
2104   gfc_free_expr (e);
2105   gfc_current_locus = where;
2106   return m;
2107 }
2108
2109
2110 static match
2111 match_char_kind (int * kind, int * is_iso_c)
2112 {
2113   locus where;
2114   gfc_expr *e;
2115   match m, n;
2116   const char *msg;
2117
2118   m = MATCH_NO;
2119   e = NULL;
2120   where = gfc_current_locus;
2121
2122   n = gfc_match_init_expr (&e);
2123
2124   if (n != MATCH_YES && gfc_matching_function)
2125     {
2126       /* The expression might include use-associated or imported
2127          parameters and try again after the specification 
2128          expressions.  */
2129       gfc_free_expr (e);
2130       gfc_undo_symbols ();
2131       return MATCH_YES;
2132     }
2133
2134   if (n == MATCH_NO)
2135     gfc_error ("Expected initialization expression at %C");
2136   if (n != MATCH_YES)
2137     return MATCH_ERROR;
2138
2139   if (e->rank != 0)
2140     {
2141       gfc_error ("Expected scalar initialization expression at %C");
2142       m = MATCH_ERROR;
2143       goto no_match;
2144     }
2145
2146   msg = gfc_extract_int (e, kind);
2147   *is_iso_c = e->ts.is_iso_c;
2148   if (msg != NULL)
2149     {
2150       gfc_error (msg);
2151       m = MATCH_ERROR;
2152       goto no_match;
2153     }
2154
2155   gfc_free_expr (e);
2156
2157   /* Ignore errors to this point, if we've gotten here.  This means
2158      we ignore the m=MATCH_ERROR from above.  */
2159   if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2160     {
2161       gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2162       m = MATCH_ERROR;
2163     }
2164   else
2165      /* All tests passed.  */
2166      m = MATCH_YES;
2167
2168   if (m == MATCH_ERROR)
2169      gfc_current_locus = where;
2170   
2171   /* Return what we know from the test(s).  */
2172   return m;
2173
2174 no_match:
2175   gfc_free_expr (e);
2176   gfc_current_locus = where;
2177   return m;
2178 }
2179
2180
2181 /* Match the various kind/length specifications in a CHARACTER
2182    declaration.  We don't return MATCH_NO.  */
2183
2184 match
2185 gfc_match_char_spec (gfc_typespec *ts)
2186 {
2187   int kind, seen_length, is_iso_c;
2188   gfc_charlen *cl;
2189   gfc_expr *len;
2190   match m;
2191
2192   len = NULL;
2193   seen_length = 0;
2194   kind = 0;
2195   is_iso_c = 0;
2196
2197   /* Try the old-style specification first.  */
2198   old_char_selector = 0;
2199
2200   m = match_char_length (&len);
2201   if (m != MATCH_NO)
2202     {
2203       if (m == MATCH_YES)
2204         old_char_selector = 1;
2205       seen_length = 1;
2206       goto done;
2207     }
2208
2209   m = gfc_match_char ('(');
2210   if (m != MATCH_YES)
2211     {
2212       m = MATCH_YES;    /* Character without length is a single char.  */
2213       goto done;
2214     }
2215
2216   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
2217   if (gfc_match (" kind =") == MATCH_YES)
2218     {
2219       m = match_char_kind (&kind, &is_iso_c);
2220        
2221       if (m == MATCH_ERROR)
2222         goto done;
2223       if (m == MATCH_NO)
2224         goto syntax;
2225
2226       if (gfc_match (" , len =") == MATCH_NO)
2227         goto rparen;
2228
2229       m = char_len_param_value (&len);
2230       if (m == MATCH_NO)
2231         goto syntax;
2232       if (m == MATCH_ERROR)
2233         goto done;
2234       seen_length = 1;
2235
2236       goto rparen;
2237     }
2238
2239   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
2240   if (gfc_match (" len =") == MATCH_YES)
2241     {
2242       m = char_len_param_value (&len);
2243       if (m == MATCH_NO)
2244         goto syntax;
2245       if (m == MATCH_ERROR)
2246         goto done;
2247       seen_length = 1;
2248
2249       if (gfc_match_char (')') == MATCH_YES)
2250         goto done;
2251
2252       if (gfc_match (" , kind =") != MATCH_YES)
2253         goto syntax;
2254
2255       if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2256         goto done;
2257
2258       goto rparen;
2259     }
2260
2261   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
2262   m = char_len_param_value (&len);
2263   if (m == MATCH_NO)
2264     goto syntax;
2265   if (m == MATCH_ERROR)
2266     goto done;
2267   seen_length = 1;
2268
2269   m = gfc_match_char (')');
2270   if (m == MATCH_YES)
2271     goto done;
2272
2273   if (gfc_match_char (',') != MATCH_YES)
2274     goto syntax;
2275
2276   gfc_match (" kind =");        /* Gobble optional text.  */
2277
2278   m = match_char_kind (&kind, &is_iso_c);
2279   if (m == MATCH_ERROR)
2280     goto done;
2281   if (m == MATCH_NO)
2282     goto syntax;
2283
2284 rparen:
2285   /* Require a right-paren at this point.  */
2286   m = gfc_match_char (')');
2287   if (m == MATCH_YES)
2288     goto done;
2289
2290 syntax:
2291   gfc_error ("Syntax error in CHARACTER declaration at %C");
2292   m = MATCH_ERROR;
2293   gfc_free_expr (len);
2294   return m;
2295
2296 done:
2297   /* Deal with character functions after USE and IMPORT statements.  */
2298   if (gfc_matching_function)
2299     {
2300       gfc_free_expr (len);
2301       gfc_undo_symbols ();
2302       return MATCH_YES;
2303     }
2304
2305   if (m != MATCH_YES)
2306     {
2307       gfc_free_expr (len);
2308       return m;
2309     }
2310
2311   /* Do some final massaging of the length values.  */
2312   cl = gfc_new_charlen (gfc_current_ns, NULL);
2313
2314   if (seen_length == 0)
2315     cl->length = gfc_int_expr (1);
2316   else
2317     cl->length = len;
2318
2319   ts->u.cl = cl;
2320   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2321
2322   /* We have to know if it was a c interoperable kind so we can
2323      do accurate type checking of bind(c) procs, etc.  */
2324   if (kind != 0)
2325     /* Mark this as c interoperable if being declared with one
2326        of the named constants from iso_c_binding.  */
2327     ts->is_c_interop = is_iso_c;
2328   else if (len != NULL)
2329     /* Here, we might have parsed something such as: character(c_char)
2330        In this case, the parsing code above grabs the c_char when
2331        looking for the length (line 1690, roughly).  it's the last
2332        testcase for parsing the kind params of a character variable.
2333        However, it's not actually the length.    this seems like it
2334        could be an error.  
2335        To see if the user used a C interop kind, test the expr
2336        of the so called length, and see if it's C interoperable.  */
2337     ts->is_c_interop = len->ts.is_iso_c;
2338   
2339   return MATCH_YES;
2340 }
2341
2342
2343 /* Matches a declaration-type-spec (F03:R502).  If successful, sets the ts
2344    structure to the matched specification.  This is necessary for FUNCTION and
2345    IMPLICIT statements.
2346
2347    If implicit_flag is nonzero, then we don't check for the optional
2348    kind specification.  Not doing so is needed for matching an IMPLICIT
2349    statement correctly.  */
2350
2351 match
2352 gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
2353 {
2354   char name[GFC_MAX_SYMBOL_LEN + 1];
2355   gfc_symbol *sym;
2356   match m;
2357   char c;
2358   bool seen_deferred_kind;
2359
2360   /* A belt and braces check that the typespec is correctly being treated
2361      as a deferred characteristic association.  */
2362   seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2363                           && (gfc_current_block ()->result->ts.kind == -1)
2364                           && (ts->kind == -1);
2365   gfc_clear_ts (ts);
2366   if (seen_deferred_kind)
2367     ts->kind = -1;
2368
2369   /* Clear the current binding label, in case one is given.  */
2370   curr_binding_label[0] = '\0';
2371
2372   if (gfc_match (" byte") == MATCH_YES)
2373     {
2374       if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
2375           == FAILURE)
2376         return MATCH_ERROR;
2377
2378       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2379         {
2380           gfc_error ("BYTE type used at %C "
2381                      "is not available on the target machine");
2382           return MATCH_ERROR;
2383         }
2384
2385       ts->type = BT_INTEGER;
2386       ts->kind = 1;
2387       return MATCH_YES;
2388     }
2389
2390   if (gfc_match (" integer") == MATCH_YES)
2391     {
2392       ts->type = BT_INTEGER;
2393       ts->kind = gfc_default_integer_kind;
2394       goto get_kind;
2395     }
2396
2397   if (gfc_match (" character") == MATCH_YES)
2398     {
2399       ts->type = BT_CHARACTER;
2400       if (implicit_flag == 0)
2401         return gfc_match_char_spec (ts);
2402       else
2403         return MATCH_YES;
2404     }
2405
2406   if (gfc_match (" real") == MATCH_YES)
2407     {
2408       ts->type = BT_REAL;
2409       ts->kind = gfc_default_real_kind;
2410       goto get_kind;
2411     }
2412
2413   if (gfc_match (" double precision") == MATCH_YES)
2414     {
2415       ts->type = BT_REAL;
2416       ts->kind = gfc_default_double_kind;
2417       return MATCH_YES;
2418     }
2419
2420   if (gfc_match (" complex") == MATCH_YES)
2421     {
2422       ts->type = BT_COMPLEX;
2423       ts->kind = gfc_default_complex_kind;
2424       goto get_kind;
2425     }
2426
2427   if (gfc_match (" double complex") == MATCH_YES)
2428     {
2429       if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2430                           "conform to the Fortran 95 standard") == FAILURE)
2431         return MATCH_ERROR;
2432
2433       ts->type = BT_COMPLEX;
2434       ts->kind = gfc_default_double_kind;
2435       return MATCH_YES;
2436     }
2437
2438   if (gfc_match (" logical") == MATCH_YES)
2439     {
2440       ts->type = BT_LOGICAL;
2441       ts->kind = gfc_default_logical_kind;
2442       goto get_kind;
2443     }
2444
2445   m = gfc_match (" type ( %n )", name);
2446   if (m == MATCH_YES)
2447     ts->type = BT_DERIVED;
2448   else
2449     {
2450       m = gfc_match (" class ( %n )", name);
2451       if (m != MATCH_YES)
2452         return m;
2453       ts->type = BT_CLASS;
2454
2455       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
2456                           == FAILURE)
2457         return MATCH_ERROR;
2458     }
2459
2460   /* Defer association of the derived type until the end of the
2461      specification block.  However, if the derived type can be
2462      found, add it to the typespec.  */  
2463   if (gfc_matching_function)
2464     {
2465       ts->u.derived = NULL;
2466       if (gfc_current_state () != COMP_INTERFACE
2467             && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2468         ts->u.derived = sym;
2469       return MATCH_YES;
2470     }
2471
2472   /* Search for the name but allow the components to be defined later.  If
2473      type = -1, this typespec has been seen in a function declaration but
2474      the type could not be accessed at that point.  */
2475   sym = NULL;
2476   if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2477     {
2478       gfc_error ("Type name '%s' at %C is ambiguous", name);
2479       return MATCH_ERROR;
2480     }
2481   else if (ts->kind == -1)
2482     {
2483       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2484                     || gfc_current_ns->has_import_set;
2485       if (gfc_find_symbol (name, NULL, iface, &sym))
2486         {       
2487           gfc_error ("Type name '%s' at %C is ambiguous", name);
2488           return MATCH_ERROR;
2489         }
2490
2491       ts->kind = 0;
2492       if (sym == NULL)
2493         return MATCH_NO;
2494     }
2495
2496   if (sym->attr.flavor != FL_DERIVED
2497       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2498     return MATCH_ERROR;
2499
2500   gfc_set_sym_referenced (sym);
2501   ts->u.derived = sym;
2502
2503   return MATCH_YES;
2504
2505 get_kind:
2506   /* For all types except double, derived and character, look for an
2507      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2508   if (implicit_flag == 1)
2509     return MATCH_YES;
2510
2511   if (gfc_current_form == FORM_FREE)
2512     {
2513       c = gfc_peek_ascii_char ();
2514       if (!gfc_is_whitespace (c) && c != '*' && c != '('
2515           && c != ':' && c != ',')
2516        return MATCH_NO;
2517     }
2518
2519   m = gfc_match_kind_spec (ts, false);
2520   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2521     m = gfc_match_old_kind_spec (ts);
2522
2523   /* Defer association of the KIND expression of function results
2524      until after USE and IMPORT statements.  */
2525   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2526          || gfc_matching_function)
2527     return MATCH_YES;
2528
2529   if (m == MATCH_NO)
2530     m = MATCH_YES;              /* No kind specifier found.  */
2531
2532   return m;
2533 }
2534
2535
2536 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2537    already matched in parse.c, or we would not end up here in the
2538    first place.  So the only thing we need to check, is if there is
2539    trailing garbage.  If not, the match is successful.  */
2540
2541 match
2542 gfc_match_implicit_none (void)
2543 {
2544   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2545 }
2546
2547
2548 /* Match the letter range(s) of an IMPLICIT statement.  */
2549
2550 static match
2551 match_implicit_range (void)
2552 {
2553   char c, c1, c2;
2554   int inner;
2555   locus cur_loc;
2556
2557   cur_loc = gfc_current_locus;
2558
2559   gfc_gobble_whitespace ();
2560   c = gfc_next_ascii_char ();
2561   if (c != '(')
2562     {
2563       gfc_error ("Missing character range in IMPLICIT at %C");
2564       goto bad;
2565     }
2566
2567   inner = 1;
2568   while (inner)
2569     {
2570       gfc_gobble_whitespace ();
2571       c1 = gfc_next_ascii_char ();
2572       if (!ISALPHA (c1))
2573         goto bad;
2574
2575       gfc_gobble_whitespace ();
2576       c = gfc_next_ascii_char ();
2577
2578       switch (c)
2579         {
2580         case ')':
2581           inner = 0;            /* Fall through.  */
2582
2583         case ',':
2584           c2 = c1;
2585           break;
2586
2587         case '-':
2588           gfc_gobble_whitespace ();
2589           c2 = gfc_next_ascii_char ();
2590           if (!ISALPHA (c2))
2591             goto bad;
2592
2593           gfc_gobble_whitespace ();
2594           c = gfc_next_ascii_char ();
2595
2596           if ((c != ',') && (c != ')'))
2597             goto bad;
2598           if (c == ')')
2599             inner = 0;
2600
2601           break;
2602
2603         default:
2604           goto bad;
2605         }
2606
2607       if (c1 > c2)
2608         {
2609           gfc_error ("Letters must be in alphabetic order in "
2610                      "IMPLICIT statement at %C");
2611           goto bad;
2612         }
2613
2614       /* See if we can add the newly matched range to the pending
2615          implicits from this IMPLICIT statement.  We do not check for
2616          conflicts with whatever earlier IMPLICIT statements may have
2617          set.  This is done when we've successfully finished matching
2618          the current one.  */
2619       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2620         goto bad;
2621     }
2622
2623   return MATCH_YES;
2624
2625 bad:
2626   gfc_syntax_error (ST_IMPLICIT);
2627
2628   gfc_current_locus = cur_loc;
2629   return MATCH_ERROR;
2630 }
2631
2632
2633 /* Match an IMPLICIT statement, storing the types for
2634    gfc_set_implicit() if the statement is accepted by the parser.
2635    There is a strange looking, but legal syntactic construction
2636    possible.  It looks like:
2637
2638      IMPLICIT INTEGER (a-b) (c-d)
2639
2640    This is legal if "a-b" is a constant expression that happens to
2641    equal one of the legal kinds for integers.  The real problem
2642    happens with an implicit specification that looks like:
2643
2644      IMPLICIT INTEGER (a-b)
2645
2646    In this case, a typespec matcher that is "greedy" (as most of the
2647    matchers are) gobbles the character range as a kindspec, leaving
2648    nothing left.  We therefore have to go a bit more slowly in the
2649    matching process by inhibiting the kindspec checking during
2650    typespec matching and checking for a kind later.  */
2651
2652 match
2653 gfc_match_implicit (void)
2654 {
2655   gfc_typespec ts;
2656   locus cur_loc;
2657   char c;
2658   match m;
2659
2660   gfc_clear_ts (&ts);
2661
2662   /* We don't allow empty implicit statements.  */
2663   if (gfc_match_eos () == MATCH_YES)
2664     {
2665       gfc_error ("Empty IMPLICIT statement at %C");
2666       return MATCH_ERROR;
2667     }
2668
2669   do
2670     {
2671       /* First cleanup.  */
2672       gfc_clear_new_implicit ();
2673
2674       /* A basic type is mandatory here.  */
2675       m = gfc_match_decl_type_spec (&ts, 1);
2676       if (m == MATCH_ERROR)
2677         goto error;
2678       if (m == MATCH_NO)
2679         goto syntax;
2680
2681       cur_loc = gfc_current_locus;
2682       m = match_implicit_range ();
2683
2684       if (m == MATCH_YES)
2685         {
2686           /* We may have <TYPE> (<RANGE>).  */
2687           gfc_gobble_whitespace ();
2688           c = gfc_next_ascii_char ();
2689           if ((c == '\n') || (c == ','))
2690             {
2691               /* Check for CHARACTER with no length parameter.  */
2692               if (ts.type == BT_CHARACTER && !ts.u.cl)
2693                 {
2694                   ts.kind = gfc_default_character_kind;
2695                   ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2696                   ts.u.cl->length = gfc_int_expr (1);
2697                 }
2698
2699               /* Record the Successful match.  */
2700               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2701                 return MATCH_ERROR;
2702               continue;
2703             }
2704
2705           gfc_current_locus = cur_loc;
2706         }
2707
2708       /* Discard the (incorrectly) matched range.  */
2709       gfc_clear_new_implicit ();
2710
2711       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2712       if (ts.type == BT_CHARACTER)
2713         m = gfc_match_char_spec (&ts);
2714       else
2715         {
2716           m = gfc_match_kind_spec (&ts, false);
2717           if (m == MATCH_NO)
2718             {
2719               m = gfc_match_old_kind_spec (&ts);
2720               if (m == MATCH_ERROR)
2721                 goto error;
2722               if (m == MATCH_NO)
2723                 goto syntax;
2724             }
2725         }
2726       if (m == MATCH_ERROR)
2727         goto error;
2728
2729       m = match_implicit_range ();
2730       if (m == MATCH_ERROR)
2731         goto error;
2732       if (m == MATCH_NO)
2733         goto syntax;
2734
2735       gfc_gobble_whitespace ();
2736       c = gfc_next_ascii_char ();
2737       if ((c != '\n') && (c != ','))
2738         goto syntax;
2739
2740       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2741         return MATCH_ERROR;
2742     }
2743   while (c == ',');
2744
2745   return MATCH_YES;
2746
2747 syntax:
2748   gfc_syntax_error (ST_IMPLICIT);
2749
2750 error:
2751   return MATCH_ERROR;
2752 }
2753
2754
2755 match
2756 gfc_match_import (void)
2757 {
2758   char name[GFC_MAX_SYMBOL_LEN + 1];
2759   match m;
2760   gfc_symbol *sym;
2761   gfc_symtree *st;
2762
2763   if (gfc_current_ns->proc_name == NULL
2764       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2765     {
2766       gfc_error ("IMPORT statement at %C only permitted in "
2767                  "an INTERFACE body");
2768       return MATCH_ERROR;
2769     }
2770
2771   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2772       == FAILURE)
2773     return MATCH_ERROR;
2774
2775   if (gfc_match_eos () == MATCH_YES)
2776     {
2777       /* All host variables should be imported.  */
2778       gfc_current_ns->has_import_set = 1;
2779       return MATCH_YES;
2780     }
2781
2782   if (gfc_match (" ::") == MATCH_YES)
2783     {
2784       if (gfc_match_eos () == MATCH_YES)
2785         {
2786            gfc_error ("Expecting list of named entities at %C");
2787            return MATCH_ERROR;
2788         }
2789     }
2790
2791   for(;;)
2792     {
2793       m = gfc_match (" %n", name);
2794       switch (m)
2795         {
2796         case MATCH_YES:
2797           if (gfc_current_ns->parent !=  NULL
2798               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2799             {
2800                gfc_error ("Type name '%s' at %C is ambiguous", name);
2801                return MATCH_ERROR;
2802             }
2803           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2804                    && gfc_find_symbol (name,
2805                                        gfc_current_ns->proc_name->ns->parent,
2806                                        1, &sym))
2807             {
2808                gfc_error ("Type name '%s' at %C is ambiguous", name);
2809                return MATCH_ERROR;
2810             }
2811
2812           if (sym == NULL)
2813             {
2814               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2815                          "at %C - does not exist.", name);
2816               return MATCH_ERROR;
2817             }
2818
2819           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2820             {
2821               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2822                            "at %C.", name);
2823               goto next_item;
2824             }
2825
2826           st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name);
2827           st->n.sym = sym;
2828           sym->refs++;
2829           sym->attr.imported = 1;
2830
2831           goto next_item;
2832
2833         case MATCH_NO:
2834           break;
2835
2836         case MATCH_ERROR:
2837           return MATCH_ERROR;
2838         }
2839
2840     next_item:
2841       if (gfc_match_eos () == MATCH_YES)
2842         break;
2843       if (gfc_match_char (',') != MATCH_YES)
2844         goto syntax;
2845     }
2846
2847   return MATCH_YES;
2848
2849 syntax:
2850   gfc_error ("Syntax error in IMPORT statement at %C");
2851   return MATCH_ERROR;
2852 }
2853
2854
2855 /* A minimal implementation of gfc_match without whitespace, escape
2856    characters or variable arguments.  Returns true if the next
2857    characters match the TARGET template exactly.  */
2858
2859 static bool
2860 match_string_p (const char *target)
2861 {
2862   const char *p;
2863
2864   for (p = target; *p; p++)
2865     if ((char) gfc_next_ascii_char () != *p)
2866       return false;
2867   return true;
2868 }
2869
2870 /* Matches an attribute specification including array specs.  If
2871    successful, leaves the variables current_attr and current_as
2872    holding the specification.  Also sets the colon_seen variable for
2873    later use by matchers associated with initializations.
2874
2875    This subroutine is a little tricky in the sense that we don't know
2876    if we really have an attr-spec until we hit the double colon.
2877    Until that time, we can only return MATCH_NO.  This forces us to
2878    check for duplicate specification at this level.  */
2879
2880 static match
2881 match_attr_spec (void)
2882 {
2883   /* Modifiers that can exist in a type statement.  */
2884   typedef enum
2885   { GFC_DECL_BEGIN = 0,
2886     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2887     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2888     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2889     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2890     DECL_IS_BIND_C, DECL_NONE,
2891     GFC_DECL_END /* Sentinel */
2892   }
2893   decl_types;
2894
2895 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2896 #define NUM_DECL GFC_DECL_END
2897
2898   locus start, seen_at[NUM_DECL];
2899   int seen[NUM_DECL];
2900   unsigned int d;
2901   const char *attr;
2902   match m;
2903   gfc_try t;
2904
2905   gfc_clear_attr (&current_attr);
2906   start = gfc_current_locus;
2907
2908   current_as = NULL;
2909   colon_seen = 0;
2910
2911   /* See if we get all of the keywords up to the final double colon.  */
2912   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2913     seen[d] = 0;
2914
2915   for (;;)
2916     {
2917       char ch;
2918
2919       d = DECL_NONE;
2920       gfc_gobble_whitespace ();
2921
2922       ch = gfc_next_ascii_char ();
2923       if (ch == ':')
2924         {
2925           /* This is the successful exit condition for the loop.  */
2926           if (gfc_next_ascii_char () == ':')
2927             break;
2928         }
2929       else if (ch == ',')
2930         {
2931           gfc_gobble_whitespace ();
2932           switch (gfc_peek_ascii_char ())
2933             {
2934             case 'a':
2935               if (match_string_p ("allocatable"))
2936                 d = DECL_ALLOCATABLE;
2937               break;
2938
2939             case 'b':
2940               /* Try and match the bind(c).  */
2941               m = gfc_match_bind_c (NULL, true);
2942               if (m == MATCH_YES)
2943                 d = DECL_IS_BIND_C;
2944               else if (m == MATCH_ERROR)
2945                 goto cleanup;
2946               break;
2947
2948             case 'd':
2949               if (match_string_p ("dimension"))
2950                 d = DECL_DIMENSION;
2951               break;
2952
2953             case 'e':
2954               if (match_string_p ("external"))
2955                 d = DECL_EXTERNAL;
2956               break;
2957
2958             case 'i':
2959               if (match_string_p ("int"))
2960                 {
2961                   ch = gfc_next_ascii_char ();
2962                   if (ch == 'e')
2963                     {
2964                       if (match_string_p ("nt"))
2965                         {
2966                           /* Matched "intent".  */
2967                           /* TODO: Call match_intent_spec from here.  */
2968                           if (gfc_match (" ( in out )") == MATCH_YES)
2969                             d = DECL_INOUT;
2970                           else if (gfc_match (" ( in )") == MATCH_YES)
2971                             d = DECL_IN;
2972                           else if (gfc_match (" ( out )") == MATCH_YES)
2973                             d = DECL_OUT;
2974                         }
2975                     }
2976                   else if (ch == 'r')
2977                     {
2978                       if (match_string_p ("insic"))
2979                         {
2980                           /* Matched "intrinsic".  */
2981                           d = DECL_INTRINSIC;
2982                         }
2983                     }
2984                 }
2985               break;
2986
2987             case 'o':
2988               if (match_string_p ("optional"))
2989                 d = DECL_OPTIONAL;
2990               break;
2991
2992             case 'p':
2993               gfc_next_ascii_char ();
2994               switch (gfc_next_ascii_char ())
2995                 {
2996                 case 'a':
2997                   if (match_string_p ("rameter"))
2998                     {
2999                       /* Matched "parameter".  */
3000                       d = DECL_PARAMETER;
3001                     }
3002                   break;
3003
3004                 case 'o':
3005                   if (match_string_p ("inter"))
3006                     {
3007                       /* Matched "pointer".  */
3008                       d = DECL_POINTER;
3009                     }
3010                   break;
3011
3012                 case 'r':
3013                   ch = gfc_next_ascii_char ();
3014                   if (ch == 'i')
3015                     {
3016                       if (match_string_p ("vate"))
3017                         {
3018                           /* Matched "private".  */
3019                           d = DECL_PRIVATE;
3020                         }
3021                     }
3022                   else if (ch == 'o')
3023                     {
3024                       if (match_string_p ("tected"))
3025                         {
3026                           /* Matched "protected".  */
3027                           d = DECL_PROTECTED;
3028                         }
3029                     }
3030                   break;
3031
3032                 case 'u':
3033                   if (match_string_p ("blic"))
3034                     {
3035                       /* Matched "public".  */
3036                       d = DECL_PUBLIC;
3037                     }
3038                   break;
3039                 }
3040               break;
3041
3042             case 's':
3043               if (match_string_p ("save"))
3044                 d = DECL_SAVE;
3045               break;
3046
3047             case 't':
3048               if (match_string_p ("target"))
3049                 d = DECL_TARGET;
3050               break;
3051
3052             case 'v':
3053               gfc_next_ascii_char ();
3054               ch = gfc_next_ascii_char ();
3055               if (ch == 'a')
3056                 {
3057                   if (match_string_p ("lue"))
3058                     {
3059                       /* Matched "value".  */
3060                       d = DECL_VALUE;
3061                     }
3062                 }
3063               else if (ch == 'o')
3064                 {
3065                   if (match_string_p ("latile"))
3066                     {
3067                       /* Matched "volatile".  */
3068                       d = DECL_VOLATILE;
3069                     }
3070                 }
3071               break;
3072             }
3073         }
3074
3075       /* No double colon and no recognizable decl_type, so assume that
3076          we've been looking at something else the whole time.  */
3077       if (d == DECL_NONE)
3078         {
3079           m = MATCH_NO;
3080           goto cleanup;
3081         }
3082
3083       /* Check to make sure any parens are paired up correctly.  */
3084       if (gfc_match_parens () == MATCH_ERROR)
3085         {
3086           m = MATCH_ERROR;
3087           goto cleanup;
3088         }
3089
3090       seen[d]++;
3091       seen_at[d] = gfc_current_locus;
3092
3093       if (d == DECL_DIMENSION)
3094         {
3095           m = gfc_match_array_spec (&current_as);
3096
3097           if (m == MATCH_NO)
3098             {
3099               gfc_error ("Missing dimension specification at %C");
3100               m = MATCH_ERROR;
3101             }
3102
3103           if (m == MATCH_ERROR)
3104             goto cleanup;
3105         }
3106     }
3107
3108   /* Since we've seen a double colon, we have to be looking at an
3109      attr-spec.  This means that we can now issue errors.  */
3110   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3111     if (seen[d] > 1)
3112       {
3113         switch (d)
3114           {
3115           case DECL_ALLOCATABLE:
3116             attr = "ALLOCATABLE";
3117             break;
3118           case DECL_DIMENSION:
3119             attr = "DIMENSION";
3120             break;
3121           case DECL_EXTERNAL:
3122             attr = "EXTERNAL";
3123             break;
3124           case DECL_IN:
3125             attr = "INTENT (IN)";
3126             break;
3127           case DECL_OUT:
3128             attr = "INTENT (OUT)";
3129             break;
3130           case DECL_INOUT:
3131             attr = "INTENT (IN OUT)";
3132             break;
3133           case DECL_INTRINSIC:
3134             attr = "INTRINSIC";
3135             break;
3136           case DECL_OPTIONAL:
3137             attr = "OPTIONAL";
3138             break;
3139           case DECL_PARAMETER:
3140             attr = "PARAMETER";
3141             break;
3142           case DECL_POINTER:
3143             attr = "POINTER";
3144             break;
3145           case DECL_PROTECTED:
3146             attr = "PROTECTED";
3147             break;
3148           case DECL_PRIVATE:
3149             attr = "PRIVATE";
3150             break;
3151           case DECL_PUBLIC:
3152             attr = "PUBLIC";
3153             break;
3154           case DECL_SAVE:
3155             attr = "SAVE";
3156             break;
3157           case DECL_TARGET:
3158             attr = "TARGET";
3159             break;
3160           case DECL_IS_BIND_C:
3161             attr = "IS_BIND_C";
3162             break;
3163           case DECL_VALUE:
3164             attr = "VALUE";
3165             break;
3166           case DECL_VOLATILE:
3167             attr = "VOLATILE";
3168             break;
3169           default:
3170             attr = NULL;        /* This shouldn't happen.  */
3171           }
3172
3173         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3174         m = MATCH_ERROR;
3175         goto cleanup;
3176       }
3177
3178   /* Now that we've dealt with duplicate attributes, add the attributes
3179      to the current attribute.  */
3180   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3181     {
3182       if (seen[d] == 0)
3183         continue;
3184
3185       if (gfc_current_state () == COMP_DERIVED
3186           && d != DECL_DIMENSION && d != DECL_POINTER
3187           && d != DECL_PRIVATE   && d != DECL_PUBLIC
3188           && d != DECL_NONE)
3189         {
3190           if (d == DECL_ALLOCATABLE)
3191             {
3192               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3193                                   "attribute at %C in a TYPE definition")
3194                   == FAILURE)
3195                 {
3196                   m = MATCH_ERROR;
3197                   goto cleanup;
3198                 }
3199             }
3200           else
3201             {
3202               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3203                          &seen_at[d]);
3204               m = MATCH_ERROR;
3205               goto cleanup;
3206             }
3207         }
3208
3209       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3210           && gfc_current_state () != COMP_MODULE)
3211         {
3212           if (d == DECL_PRIVATE)
3213             attr = "PRIVATE";
3214           else
3215             attr = "PUBLIC";
3216           if (gfc_current_state () == COMP_DERIVED
3217               && gfc_state_stack->previous
3218               && gfc_state_stack->previous->state == COMP_MODULE)
3219             {
3220               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3221                                   "at %L in a TYPE definition", attr,
3222                                   &seen_at[d])
3223                   == FAILURE)
3224                 {
3225                   m = MATCH_ERROR;
3226                   goto cleanup;
3227                 }
3228             }
3229           else
3230             {
3231               gfc_error ("%s attribute at %L is not allowed outside of the "
3232                          "specification part of a module", attr, &seen_at[d]);
3233               m = MATCH_ERROR;
3234               goto cleanup;
3235             }
3236         }
3237
3238       switch (d)
3239         {
3240         case DECL_ALLOCATABLE:
3241           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
3242           break;
3243
3244         case DECL_DIMENSION:
3245           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
3246           break;
3247
3248         case DECL_EXTERNAL:
3249           t = gfc_add_external (&current_attr, &seen_at[d]);
3250           break;
3251
3252         case DECL_IN:
3253           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
3254           break;
3255
3256         case DECL_OUT:
3257           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
3258           break;
3259
3260         case DECL_INOUT:
3261           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
3262           break;
3263
3264         case DECL_INTRINSIC:
3265           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
3266           break;
3267
3268         case DECL_OPTIONAL:
3269           t = gfc_add_optional (&current_attr, &seen_at[d]);
3270           break;
3271
3272         case DECL_PARAMETER:
3273           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
3274           break;
3275
3276         case DECL_POINTER:
3277           t = gfc_add_pointer (&current_attr, &seen_at[d]);
3278           break;
3279
3280         case DECL_PROTECTED:
3281           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3282             {
3283                gfc_error ("PROTECTED at %C only allowed in specification "
3284                           "part of a module");
3285                t = FAILURE;
3286                break;
3287             }
3288
3289           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3290                               "attribute at %C")
3291               == FAILURE)
3292             t = FAILURE;
3293           else
3294             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
3295           break;
3296
3297         case DECL_PRIVATE:
3298           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
3299                               &seen_at[d]);
3300           break;
3301
3302         case DECL_PUBLIC:
3303           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
3304                               &seen_at[d]);
3305           break;
3306
3307         case DECL_SAVE:
3308           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
3309           break;
3310
3311         case DECL_TARGET:
3312           t = gfc_add_target (&current_attr, &seen_at[d]);
3313           break;
3314
3315         case DECL_IS_BIND_C:
3316            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
3317            break;
3318            
3319         case DECL_VALUE:
3320           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3321                               "at %C")
3322               == FAILURE)
3323             t = FAILURE;
3324           else
3325             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
3326           break;
3327
3328         case DECL_VOLATILE:
3329           if (gfc_notify_std (GFC_STD_F2003,
3330                               "Fortran 2003: VOLATILE attribute at %C")
3331               == FAILURE)
3332             t = FAILURE;
3333           else
3334             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
3335           break;
3336
3337         default:
3338           gfc_internal_error ("match_attr_spec(): Bad attribute");
3339         }
3340
3341       if (t == FAILURE)
3342         {
3343           m = MATCH_ERROR;
3344           goto cleanup;
3345         }
3346     }
3347
3348   colon_seen = 1;
3349   return MATCH_YES;
3350
3351 cleanup:
3352   gfc_current_locus = start;
3353   gfc_free_array_spec (current_as);
3354   current_as = NULL;
3355   return m;
3356 }
3357
3358
3359 /* Set the binding label, dest_label, either with the binding label
3360    stored in the given gfc_typespec, ts, or if none was provided, it
3361    will be the symbol name in all lower case, as required by the draft
3362    (J3/04-007, section 15.4.1).  If a binding label was given and
3363    there is more than one argument (num_idents), it is an error.  */
3364
3365 gfc_try
3366 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3367 {
3368   if (num_idents > 1 && has_name_equals)
3369     {
3370       gfc_error ("Multiple identifiers provided with "
3371                  "single NAME= specifier at %C");
3372       return FAILURE;
3373     }
3374
3375   if (curr_binding_label[0] != '\0')
3376     {
3377       /* Binding label given; store in temp holder til have sym.  */
3378       strcpy (dest_label, curr_binding_label);
3379     }
3380   else
3381     {
3382       /* No binding label given, and the NAME= specifier did not exist,
3383          which means there was no NAME="".  */
3384       if (sym_name != NULL && has_name_equals == 0)
3385         strcpy (dest_label, sym_name);
3386     }
3387    
3388   return SUCCESS;
3389 }
3390
3391
3392 /* Set the status of the given common block as being BIND(C) or not,
3393    depending on the given parameter, is_bind_c.  */
3394
3395 void
3396 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3397 {
3398   com_block->is_bind_c = is_bind_c;
3399   return;
3400 }
3401
3402
3403 /* Verify that the given gfc_typespec is for a C interoperable type.  */
3404
3405 gfc_try
3406 verify_c_interop (gfc_typespec *ts)
3407 {
3408   if (ts->type == BT_DERIVED && ts->u.derived != NULL)
3409     return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
3410   else if (ts->is_c_interop != 1)
3411     return FAILURE;
3412   
3413   return SUCCESS;
3414 }
3415
3416
3417 /* Verify that the variables of a given common block, which has been
3418    defined with the attribute specifier bind(c), to be of a C
3419    interoperable type.  Errors will be reported here, if
3420    encountered.  */
3421
3422 gfc_try
3423 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3424 {
3425   gfc_symbol *curr_sym = NULL;
3426   gfc_try retval = SUCCESS;
3427
3428   curr_sym = com_block->head;
3429   
3430   /* Make sure we have at least one symbol.  */
3431   if (curr_sym == NULL)
3432     return retval;
3433
3434   /* Here we know we have a symbol, so we'll execute this loop
3435      at least once.  */
3436   do
3437     {
3438       /* The second to last param, 1, says this is in a common block.  */
3439       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3440       curr_sym = curr_sym->common_next;
3441     } while (curr_sym != NULL); 
3442
3443   return retval;
3444 }
3445
3446
3447 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
3448    an appropriate error message is reported.  */
3449
3450 gfc_try
3451 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3452                    int is_in_common, gfc_common_head *com_block)
3453 {
3454   bool bind_c_function = false;
3455   gfc_try retval = SUCCESS;
3456
3457   if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
3458     bind_c_function = true;
3459
3460   if (tmp_sym->attr.function && tmp_sym->result != NULL)
3461     {
3462       tmp_sym = tmp_sym->result;
3463       /* Make sure it wasn't an implicitly typed result.  */
3464       if (tmp_sym->attr.implicit_type)
3465         {
3466           gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3467                        "%L may not be C interoperable", tmp_sym->name,
3468                        &tmp_sym->declared_at);
3469           tmp_sym->ts.f90_type = tmp_sym->ts.type;
3470           /* Mark it as C interoperable to prevent duplicate warnings.  */
3471           tmp_sym->ts.is_c_interop = 1;
3472           tmp_sym->attr.is_c_interop = 1;
3473         }
3474     }
3475
3476   /* Here, we know we have the bind(c) attribute, so if we have
3477      enough type info, then verify that it's a C interop kind.
3478      The info could be in the symbol already, or possibly still in
3479      the given ts (current_ts), so look in both.  */
3480   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 
3481     {
3482       if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
3483         {
3484           /* See if we're dealing with a sym in a common block or not.  */
3485           if (is_in_common == 1)
3486             {
3487               gfc_warning ("Variable '%s' in common block '%s' at %L "
3488                            "may not be a C interoperable "
3489                            "kind though common block '%s' is BIND(C)",
3490                            tmp_sym->name, com_block->name,
3491                            &(tmp_sym->declared_at), com_block->name);
3492             }
3493           else
3494             {
3495               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3496                 gfc_error ("Type declaration '%s' at %L is not C "
3497                            "interoperable but it is BIND(C)",
3498                            tmp_sym->name, &(tmp_sym->declared_at));
3499               else
3500                 gfc_warning ("Variable '%s' at %L "
3501                              "may not be a C interoperable "
3502                              "kind but it is bind(c)",
3503                              tmp_sym->name, &(tmp_sym->declared_at));
3504             }
3505         }
3506       
3507       /* Variables declared w/in a common block can't be bind(c)
3508          since there's no way for C to see these variables, so there's
3509          semantically no reason for the attribute.  */
3510       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3511         {
3512           gfc_error ("Variable '%s' in common block '%s' at "
3513                      "%L cannot be declared with BIND(C) "
3514                      "since it is not a global",
3515                      tmp_sym->name, com_block->name,
3516                      &(tmp_sym->declared_at));
3517           retval = FAILURE;
3518         }
3519       
3520       /* Scalar variables that are bind(c) can not have the pointer
3521          or allocatable attributes.  */
3522       if (tmp_sym->attr.is_bind_c == 1)
3523         {
3524           if (tmp_sym->attr.pointer ==&nbs