OSDN Git Service

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