OSDN Git Service

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