OSDN Git Service

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