OSDN Git Service

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