OSDN Git Service

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