OSDN Git Service

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