OSDN Git Service

40622e2e93f0b87fe6ad524ab9af34ea3228b8da
[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 /* Function called by variable_decl() that adds a name to the symbol table.  */
1029
1030 static gfc_try
1031 build_sym (const char *name, gfc_charlen *cl,
1032            gfc_array_spec **as, locus *var_locus)
1033 {
1034   symbol_attribute attr;
1035   gfc_symbol *sym;
1036
1037   if (gfc_get_symbol (name, NULL, &sym))
1038     return FAILURE;
1039
1040   /* Start updating the symbol table.  Add basic type attribute if present.  */
1041   if (current_ts.type != BT_UNKNOWN
1042       && (sym->attr.implicit_type == 0
1043           || !gfc_compare_types (&sym->ts, &current_ts))
1044       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
1045     return FAILURE;
1046
1047   if (sym->ts.type == BT_CHARACTER)
1048     sym->ts.u.cl = cl;
1049
1050   /* Add dimension attribute if present.  */
1051   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
1052     return FAILURE;
1053   *as = NULL;
1054
1055   /* Add attribute to symbol.  The copy is so that we can reset the
1056      dimension attribute.  */
1057   attr = current_attr;
1058   attr.dimension = 0;
1059
1060   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
1061     return FAILURE;
1062
1063   /* Finish any work that may need to be done for the binding label,
1064      if it's a bind(c).  The bind(c) attr is found before the symbol
1065      is made, and before the symbol name (for data decls), so the
1066      current_ts is holding the binding label, or nothing if the
1067      name= attr wasn't given.  Therefore, test here if we're dealing
1068      with a bind(c) and make sure the binding label is set correctly.  */
1069   if (sym->attr.is_bind_c == 1)
1070     {
1071       if (sym->binding_label[0] == '\0')
1072         {
1073           /* Set the binding label and verify that if a NAME= was specified
1074              then only one identifier was in the entity-decl-list.  */
1075           if (set_binding_label (sym->binding_label, sym->name,
1076                                  num_idents_on_line) == FAILURE)
1077             return FAILURE;
1078         }
1079     }
1080
1081   /* See if we know we're in a common block, and if it's a bind(c)
1082      common then we need to make sure we're an interoperable type.  */
1083   if (sym->attr.in_common == 1)
1084     {
1085       /* Test the common block object.  */
1086       if (sym->common_block != NULL && sym->common_block->is_bind_c == 1
1087           && sym->ts.is_c_interop != 1)
1088         {
1089           gfc_error_now ("Variable '%s' in common block '%s' at %C "
1090                          "must be declared with a C interoperable "
1091                          "kind since common block '%s' is BIND(C)",
1092                          sym->name, sym->common_block->name,
1093                          sym->common_block->name);
1094           gfc_clear_error ();
1095         }
1096     }
1097
1098   sym->attr.implied_index = 0;
1099
1100   return SUCCESS;
1101 }
1102
1103
1104 /* Set character constant to the given length. The constant will be padded or
1105    truncated.  If we're inside an array constructor without a typespec, we
1106    additionally check that all elements have the same length; check_len -1
1107    means no checking.  */
1108
1109 void
1110 gfc_set_constant_character_len (int len, gfc_expr *expr, int check_len)
1111 {
1112   gfc_char_t *s;
1113   int slen;
1114
1115   gcc_assert (expr->expr_type == EXPR_CONSTANT);
1116   gcc_assert (expr->ts.type == BT_CHARACTER);
1117
1118   slen = expr->value.character.length;
1119   if (len != slen)
1120     {
1121       s = gfc_get_wide_string (len + 1);
1122       memcpy (s, expr->value.character.string,
1123               MIN (len, slen) * sizeof (gfc_char_t));
1124       if (len > slen)
1125         gfc_wide_memset (&s[slen], ' ', len - slen);
1126
1127       if (gfc_option.warn_character_truncation && slen > len)
1128         gfc_warning_now ("CHARACTER expression at %L is being truncated "
1129                          "(%d/%d)", &expr->where, slen, len);
1130
1131       /* Apply the standard by 'hand' otherwise it gets cleared for
1132          initializers.  */
1133       if (check_len != -1 && slen != check_len
1134           && !(gfc_option.allow_std & GFC_STD_GNU))
1135         gfc_error_now ("The CHARACTER elements of the array constructor "
1136                        "at %L must have the same length (%d/%d)",
1137                         &expr->where, slen, check_len);
1138
1139       s[len] = '\0';
1140       gfc_free (expr->value.character.string);
1141       expr->value.character.string = s;
1142       expr->value.character.length = len;
1143     }
1144 }
1145
1146
1147 /* Function to create and update the enumerator history
1148    using the information passed as arguments.
1149    Pointer "max_enum" is also updated, to point to
1150    enum history node containing largest initializer.
1151
1152    SYM points to the symbol node of enumerator.
1153    INIT points to its enumerator value.  */
1154
1155 static void
1156 create_enum_history (gfc_symbol *sym, gfc_expr *init)
1157 {
1158   enumerator_history *new_enum_history;
1159   gcc_assert (sym != NULL && init != NULL);
1160
1161   new_enum_history = XCNEW (enumerator_history);
1162
1163   new_enum_history->sym = sym;
1164   new_enum_history->initializer = init;
1165   new_enum_history->next = NULL;
1166
1167   if (enum_history == NULL)
1168     {
1169       enum_history = new_enum_history;
1170       max_enum = enum_history;
1171     }
1172   else
1173     {
1174       new_enum_history->next = enum_history;
1175       enum_history = new_enum_history;
1176
1177       if (mpz_cmp (max_enum->initializer->value.integer,
1178                    new_enum_history->initializer->value.integer) < 0)
1179         max_enum = new_enum_history;
1180     }
1181 }
1182
1183
1184 /* Function to free enum kind history.  */
1185
1186 void
1187 gfc_free_enum_history (void)
1188 {
1189   enumerator_history *current = enum_history;
1190   enumerator_history *next;
1191
1192   while (current != NULL)
1193     {
1194       next = current->next;
1195       gfc_free (current);
1196       current = next;
1197     }
1198   max_enum = NULL;
1199   enum_history = NULL;
1200 }
1201
1202
1203 /* Function called by variable_decl() that adds an initialization
1204    expression to a symbol.  */
1205
1206 static gfc_try
1207 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
1208 {
1209   symbol_attribute attr;
1210   gfc_symbol *sym;
1211   gfc_expr *init;
1212
1213   init = *initp;
1214   if (find_special (name, &sym, false))
1215     return FAILURE;
1216
1217   attr = sym->attr;
1218
1219   /* If this symbol is confirming an implicit parameter type,
1220      then an initialization expression is not allowed.  */
1221   if (attr.flavor == FL_PARAMETER
1222       && sym->value != NULL
1223       && *initp != NULL)
1224     {
1225       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
1226                  sym->name);
1227       return FAILURE;
1228     }
1229
1230   if (init == NULL)
1231     {
1232       /* An initializer is required for PARAMETER declarations.  */
1233       if (attr.flavor == FL_PARAMETER)
1234         {
1235           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
1236           return FAILURE;
1237         }
1238     }
1239   else
1240     {
1241       /* If a variable appears in a DATA block, it cannot have an
1242          initializer.  */
1243       if (sym->attr.data)
1244         {
1245           gfc_error ("Variable '%s' at %C with an initializer already "
1246                      "appears in a DATA statement", sym->name);
1247           return FAILURE;
1248         }
1249
1250       /* Check if the assignment can happen. This has to be put off
1251          until later for a derived type variable.  */
1252       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
1253           && gfc_check_assign_symbol (sym, init) == FAILURE)
1254         return FAILURE;
1255
1256       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl
1257             && init->ts.type == BT_CHARACTER)
1258         {
1259           /* Update symbol character length according initializer.  */
1260           if (gfc_check_assign_symbol (sym, init) == FAILURE)
1261             return FAILURE;
1262
1263           if (sym->ts.u.cl->length == NULL)
1264             {
1265               int clen;
1266               /* If there are multiple CHARACTER variables declared on the
1267                  same line, we don't want them to share the same length.  */
1268               sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1269
1270               if (sym->attr.flavor == FL_PARAMETER)
1271                 {
1272                   if (init->expr_type == EXPR_CONSTANT)
1273                     {
1274                       clen = init->value.character.length;
1275                       sym->ts.u.cl->length = gfc_int_expr (clen);
1276                     }
1277                   else if (init->expr_type == EXPR_ARRAY)
1278                     {
1279                       gfc_expr *p = init->value.constructor->expr;
1280                       clen = p->value.character.length;
1281                       sym->ts.u.cl->length = gfc_int_expr (clen);
1282                     }
1283                   else if (init->ts.u.cl && init->ts.u.cl->length)
1284                     sym->ts.u.cl->length =
1285                                 gfc_copy_expr (sym->value->ts.u.cl->length);
1286                 }
1287             }
1288           /* Update initializer character length according symbol.  */
1289           else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1290             {
1291               int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
1292               gfc_constructor * p;
1293
1294               if (init->expr_type == EXPR_CONSTANT)
1295                 gfc_set_constant_character_len (len, init, -1);
1296               else if (init->expr_type == EXPR_ARRAY)
1297                 {
1298                   /* Build a new charlen to prevent simplification from
1299                      deleting the length before it is resolved.  */
1300                   init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
1301                   init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
1302
1303                   for (p = init->value.constructor; p; p = p->next)
1304                     gfc_set_constant_character_len (len, p->expr, -1);
1305                 }
1306             }
1307         }
1308
1309       /* Need to check if the expression we initialized this
1310          to was one of the iso_c_binding named constants.  If so,
1311          and we're a parameter (constant), let it be iso_c.
1312          For example:
1313          integer(c_int), parameter :: my_int = c_int
1314          integer(my_int) :: my_int_2
1315          If we mark my_int as iso_c (since we can see it's value
1316          is equal to one of the named constants), then my_int_2
1317          will be considered C interoperable.  */
1318       if (sym->ts.type != BT_CHARACTER && sym->ts.type != BT_DERIVED)
1319         {
1320           sym->ts.is_iso_c |= init->ts.is_iso_c;
1321           sym->ts.is_c_interop |= init->ts.is_c_interop;
1322           /* attr bits needed for module files.  */
1323           sym->attr.is_iso_c |= init->ts.is_iso_c;
1324           sym->attr.is_c_interop |= init->ts.is_c_interop;
1325           if (init->ts.is_iso_c)
1326             sym->ts.f90_type = init->ts.f90_type;
1327         }
1328       
1329       /* Add initializer.  Make sure we keep the ranks sane.  */
1330       if (sym->attr.dimension && init->rank == 0)
1331         {
1332           mpz_t size;
1333           gfc_expr *array;
1334           gfc_constructor *c;
1335           int n;
1336           if (sym->attr.flavor == FL_PARAMETER
1337                 && init->expr_type == EXPR_CONSTANT
1338                 && spec_size (sym->as, &size) == SUCCESS
1339                 && mpz_cmp_si (size, 0) > 0)
1340             {
1341               array = gfc_start_constructor (init->ts.type, init->ts.kind,
1342                                              &init->where);
1343
1344               array->value.constructor = c = NULL;
1345               for (n = 0; n < (int)mpz_get_si (size); n++)
1346                 {
1347                   if (array->value.constructor == NULL)
1348                     {
1349                       array->value.constructor = c = gfc_get_constructor ();
1350                       c->expr = init;
1351                     }
1352                   else
1353                     {
1354                       c->next = gfc_get_constructor ();
1355                       c = c->next;
1356                       c->expr = gfc_copy_expr (init);
1357                     }
1358                 }
1359
1360               array->shape = gfc_get_shape (sym->as->rank);
1361               for (n = 0; n < sym->as->rank; n++)
1362                 spec_dimen_size (sym->as, n, &array->shape[n]);
1363
1364               init = array;
1365               mpz_clear (size);
1366             }
1367           init->rank = sym->as->rank;
1368         }
1369
1370       sym->value = init;
1371       if (sym->attr.save == SAVE_NONE)
1372         sym->attr.save = SAVE_IMPLICIT;
1373       *initp = NULL;
1374     }
1375
1376   return SUCCESS;
1377 }
1378
1379
1380 /* Function called by variable_decl() that adds a name to a structure
1381    being built.  */
1382
1383 static gfc_try
1384 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1385               gfc_array_spec **as)
1386 {
1387   gfc_component *c;
1388
1389   /* If the current symbol is of the same derived type that we're
1390      constructing, it must have the pointer attribute.  */
1391   if (current_ts.type == BT_DERIVED
1392       && current_ts.u.derived == gfc_current_block ()
1393       && current_attr.pointer == 0)
1394     {
1395       gfc_error ("Component at %C must have the POINTER attribute");
1396       return FAILURE;
1397     }
1398
1399   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1400     {
1401       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1402         {
1403           gfc_error ("Array component of structure at %C must have explicit "
1404                      "or deferred shape");
1405           return FAILURE;
1406         }
1407     }
1408
1409   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1410     return FAILURE;
1411
1412   c->ts = current_ts;
1413   if (c->ts.type == BT_CHARACTER)
1414     c->ts.u.cl = cl;
1415   c->attr = current_attr;
1416
1417   c->initializer = *init;
1418   *init = NULL;
1419
1420   c->as = *as;
1421   if (c->as != NULL)
1422     c->attr.dimension = 1;
1423   *as = NULL;
1424
1425   /* Should this ever get more complicated, combine with similar section
1426      in add_init_expr_to_sym into a separate function.  */
1427   if (c->ts.type == BT_CHARACTER && !c->attr.pointer && c->initializer && c->ts.u.cl
1428       && c->ts.u.cl->length && c->ts.u.cl->length->expr_type == EXPR_CONSTANT)
1429     {
1430       int len;
1431
1432       gcc_assert (c->ts.u.cl && c->ts.u.cl->length);
1433       gcc_assert (c->ts.u.cl->length->expr_type == EXPR_CONSTANT);
1434       gcc_assert (c->ts.u.cl->length->ts.type == BT_INTEGER);
1435
1436       len = mpz_get_si (c->ts.u.cl->length->value.integer);
1437
1438       if (c->initializer->expr_type == EXPR_CONSTANT)
1439         gfc_set_constant_character_len (len, c->initializer, -1);
1440       else if (mpz_cmp (c->ts.u.cl->length->value.integer,
1441                         c->initializer->ts.u.cl->length->value.integer))
1442         {
1443           bool has_ts;
1444           gfc_constructor *ctor = c->initializer->value.constructor;
1445
1446           has_ts = (c->initializer->ts.u.cl
1447                     && c->initializer->ts.u.cl->length_from_typespec);
1448
1449           if (ctor)
1450             {
1451               int first_len;
1452
1453               /* Remember the length of the first element for checking
1454                  that all elements *in the constructor* have the same
1455                  length.  This need not be the length of the LHS!  */
1456               gcc_assert (ctor->expr->expr_type == EXPR_CONSTANT);
1457               gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
1458               first_len = ctor->expr->value.character.length;
1459
1460               for (; ctor; ctor = ctor->next)
1461                 {
1462                   if (ctor->expr->expr_type == EXPR_CONSTANT)
1463                     gfc_set_constant_character_len (len, ctor->expr,
1464                                                     has_ts ? -1 : first_len);
1465                 }
1466             }
1467         }
1468     }
1469
1470   /* Check array components.  */
1471   if (!c->attr.dimension)
1472     {
1473       if (c->attr.allocatable)
1474         {
1475           gfc_error ("Allocatable component at %C must be an array");
1476           return FAILURE;
1477         }
1478       else
1479         return SUCCESS;
1480     }
1481
1482   if (c->attr.pointer)
1483     {
1484       if (c->as->type != AS_DEFERRED)
1485         {
1486           gfc_error ("Pointer array component of structure at %C must have a "
1487                      "deferred shape");
1488           return FAILURE;
1489         }
1490     }
1491   else if (c->attr.allocatable)
1492     {
1493       if (c->as->type != AS_DEFERRED)
1494         {
1495           gfc_error ("Allocatable component of structure at %C must have a "
1496                      "deferred shape");
1497           return FAILURE;
1498         }
1499     }
1500   else
1501     {
1502       if (c->as->type != AS_EXPLICIT)
1503         {
1504           gfc_error ("Array component of structure at %C must have an "
1505                      "explicit shape");
1506           return FAILURE;
1507         }
1508     }
1509
1510   return SUCCESS;
1511 }
1512
1513
1514 /* Match a 'NULL()', and possibly take care of some side effects.  */
1515
1516 match
1517 gfc_match_null (gfc_expr **result)
1518 {
1519   gfc_symbol *sym;
1520   gfc_expr *e;
1521   match m;
1522
1523   m = gfc_match (" null ( )");
1524   if (m != MATCH_YES)
1525     return m;
1526
1527   /* The NULL symbol now has to be/become an intrinsic function.  */
1528   if (gfc_get_symbol ("null", NULL, &sym))
1529     {
1530       gfc_error ("NULL() initialization at %C is ambiguous");
1531       return MATCH_ERROR;
1532     }
1533
1534   gfc_intrinsic_symbol (sym);
1535
1536   if (sym->attr.proc != PROC_INTRINSIC
1537       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1538                              sym->name, NULL) == FAILURE
1539           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1540     return MATCH_ERROR;
1541
1542   e = gfc_get_expr ();
1543   e->where = gfc_current_locus;
1544   e->expr_type = EXPR_NULL;
1545   e->ts.type = BT_UNKNOWN;
1546
1547   *result = e;
1548
1549   return MATCH_YES;
1550 }
1551
1552
1553 /* Match a variable name with an optional initializer.  When this
1554    subroutine is called, a variable is expected to be parsed next.
1555    Depending on what is happening at the moment, updates either the
1556    symbol table or the current interface.  */
1557
1558 static match
1559 variable_decl (int elem)
1560 {
1561   char name[GFC_MAX_SYMBOL_LEN + 1];
1562   gfc_expr *initializer, *char_len;
1563   gfc_array_spec *as;
1564   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1565   gfc_charlen *cl;
1566   locus var_locus;
1567   match m;
1568   gfc_try t;
1569   gfc_symbol *sym;
1570   locus old_locus;
1571
1572   initializer = NULL;
1573   as = NULL;
1574   cp_as = NULL;
1575   old_locus = gfc_current_locus;
1576
1577   /* When we get here, we've just matched a list of attributes and
1578      maybe a type and a double colon.  The next thing we expect to see
1579      is the name of the symbol.  */
1580   m = gfc_match_name (name);
1581   if (m != MATCH_YES)
1582     goto cleanup;
1583
1584   var_locus = gfc_current_locus;
1585
1586   /* Now we could see the optional array spec. or character length.  */
1587   m = gfc_match_array_spec (&as);
1588   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1589     cp_as = gfc_copy_array_spec (as);
1590   else if (m == MATCH_ERROR)
1591     goto cleanup;
1592
1593   if (m == MATCH_NO)
1594     as = gfc_copy_array_spec (current_as);
1595
1596   char_len = NULL;
1597   cl = NULL;
1598
1599   if (current_ts.type == BT_CHARACTER)
1600     {
1601       switch (match_char_length (&char_len))
1602         {
1603         case MATCH_YES:
1604           cl = gfc_new_charlen (gfc_current_ns, NULL);
1605
1606           cl->length = char_len;
1607           break;
1608
1609         /* Non-constant lengths need to be copied after the first
1610            element.  Also copy assumed lengths.  */
1611         case MATCH_NO:
1612           if (elem > 1
1613               && (current_ts.u.cl->length == NULL
1614                   || current_ts.u.cl->length->expr_type != EXPR_CONSTANT))
1615             {
1616               cl = gfc_new_charlen (gfc_current_ns, NULL);
1617               cl->length = gfc_copy_expr (current_ts.u.cl->length);
1618             }
1619           else
1620             cl = current_ts.u.cl;
1621
1622           break;
1623
1624         case MATCH_ERROR:
1625           goto cleanup;
1626         }
1627     }
1628
1629   /*  If this symbol has already shown up in a Cray Pointer declaration,
1630       then we want to set the type & bail out.  */
1631   if (gfc_option.flag_cray_pointer)
1632     {
1633       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1634       if (sym != NULL && sym->attr.cray_pointee)
1635         {
1636           sym->ts.type = current_ts.type;
1637           sym->ts.kind = current_ts.kind;
1638           sym->ts.u.cl = cl;
1639           sym->ts.u.derived = current_ts.u.derived;
1640           sym->ts.is_c_interop = current_ts.is_c_interop;
1641           sym->ts.is_iso_c = current_ts.is_iso_c;
1642           m = MATCH_YES;
1643         
1644           /* Check to see if we have an array specification.  */
1645           if (cp_as != NULL)
1646             {
1647               if (sym->as != NULL)
1648                 {
1649                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1650                   gfc_free_array_spec (cp_as);
1651                   m = MATCH_ERROR;
1652                   goto cleanup;
1653                 }
1654               else
1655                 {
1656                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1657                     gfc_internal_error ("Couldn't set pointee array spec.");
1658
1659                   /* Fix the array spec.  */
1660                   m = gfc_mod_pointee_as (sym->as);
1661                   if (m == MATCH_ERROR)
1662                     goto cleanup;
1663                 }
1664             }
1665           goto cleanup;
1666         }
1667       else
1668         {
1669           gfc_free_array_spec (cp_as);
1670         }
1671     }
1672
1673   /* Procedure pointer as function result.  */
1674   if (gfc_current_state () == COMP_FUNCTION
1675       && strcmp ("ppr@", gfc_current_block ()->name) == 0
1676       && strcmp (name, gfc_current_block ()->ns->proc_name->name) == 0)
1677     strcpy (name, "ppr@");
1678
1679   if (gfc_current_state () == COMP_FUNCTION
1680       && strcmp (name, gfc_current_block ()->name) == 0
1681       && gfc_current_block ()->result
1682       && strcmp ("ppr@", gfc_current_block ()->result->name) == 0)
1683     strcpy (name, "ppr@");
1684
1685   /* OK, we've successfully matched the declaration.  Now put the
1686      symbol in the current namespace, because it might be used in the
1687      optional initialization expression for this symbol, e.g. this is
1688      perfectly legal:
1689
1690      integer, parameter :: i = huge(i)
1691
1692      This is only true for parameters or variables of a basic type.
1693      For components of derived types, it is not true, so we don't
1694      create a symbol for those yet.  If we fail to create the symbol,
1695      bail out.  */
1696   if (gfc_current_state () != COMP_DERIVED
1697       && build_sym (name, cl, &as, &var_locus) == FAILURE)
1698     {
1699       m = MATCH_ERROR;
1700       goto cleanup;
1701     }
1702
1703   /* An interface body specifies all of the procedure's
1704      characteristics and these shall be consistent with those
1705      specified in the procedure definition, except that the interface
1706      may specify a procedure that is not pure if the procedure is
1707      defined to be pure(12.3.2).  */
1708   if (current_ts.type == BT_DERIVED
1709       && gfc_current_ns->proc_name
1710       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1711       && current_ts.u.derived->ns != gfc_current_ns)
1712     {
1713       gfc_symtree *st;
1714       st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
1715       if (!(current_ts.u.derived->attr.imported
1716                 && st != NULL
1717                 && st->n.sym == current_ts.u.derived)
1718             && !gfc_current_ns->has_import_set)
1719         {
1720             gfc_error ("the type of '%s' at %C has not been declared within the "
1721                        "interface", name);
1722             m = MATCH_ERROR;
1723             goto cleanup;
1724         }
1725     }
1726
1727   /* In functions that have a RESULT variable defined, the function
1728      name always refers to function calls.  Therefore, the name is
1729      not allowed to appear in specification statements.  */
1730   if (gfc_current_state () == COMP_FUNCTION
1731       && gfc_current_block () != NULL
1732       && gfc_current_block ()->result != NULL
1733       && gfc_current_block ()->result != gfc_current_block ()
1734       && strcmp (gfc_current_block ()->name, name) == 0)
1735     {
1736       gfc_error ("Function name '%s' not allowed at %C", name);
1737       m = MATCH_ERROR;
1738       goto cleanup;
1739     }
1740
1741   /* We allow old-style initializations of the form
1742        integer i /2/, j(4) /3*3, 1/
1743      (if no colon has been seen). These are different from data
1744      statements in that initializers are only allowed to apply to the
1745      variable immediately preceding, i.e.
1746        integer i, j /1, 2/
1747      is not allowed. Therefore we have to do some work manually, that
1748      could otherwise be left to the matchers for DATA statements.  */
1749
1750   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1751     {
1752       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1753                           "initialization at %C") == FAILURE)
1754         return MATCH_ERROR;
1755  
1756       return match_old_style_init (name);
1757     }
1758
1759   /* The double colon must be present in order to have initializers.
1760      Otherwise the statement is ambiguous with an assignment statement.  */
1761   if (colon_seen)
1762     {
1763       if (gfc_match (" =>") == MATCH_YES)
1764         {
1765           if (!current_attr.pointer)
1766             {
1767               gfc_error ("Initialization at %C isn't for a pointer variable");
1768               m = MATCH_ERROR;
1769               goto cleanup;
1770             }
1771
1772           m = gfc_match_null (&initializer);
1773           if (m == MATCH_NO)
1774             {
1775               gfc_error ("Pointer initialization requires a NULL() at %C");
1776               m = MATCH_ERROR;
1777             }
1778
1779           if (gfc_pure (NULL))
1780             {
1781               gfc_error ("Initialization of pointer at %C is not allowed in "
1782                          "a PURE procedure");
1783               m = MATCH_ERROR;
1784             }
1785
1786           if (m != MATCH_YES)
1787             goto cleanup;
1788
1789         }
1790       else if (gfc_match_char ('=') == MATCH_YES)
1791         {
1792           if (current_attr.pointer)
1793             {
1794               gfc_error ("Pointer initialization at %C requires '=>', "
1795                          "not '='");
1796               m = MATCH_ERROR;
1797               goto cleanup;
1798             }
1799
1800           m = gfc_match_init_expr (&initializer);
1801           if (m == MATCH_NO)
1802             {
1803               gfc_error ("Expected an initialization expression at %C");
1804               m = MATCH_ERROR;
1805             }
1806
1807           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1808             {
1809               gfc_error ("Initialization of variable at %C is not allowed in "
1810                          "a PURE procedure");
1811               m = MATCH_ERROR;
1812             }
1813
1814           if (m != MATCH_YES)
1815             goto cleanup;
1816         }
1817     }
1818
1819   if (initializer != NULL && current_attr.allocatable
1820         && gfc_current_state () == COMP_DERIVED)
1821     {
1822       gfc_error ("Initialization of allocatable component at %C is not "
1823                  "allowed");
1824       m = MATCH_ERROR;
1825       goto cleanup;
1826     }
1827
1828   /* Add the initializer.  Note that it is fine if initializer is
1829      NULL here, because we sometimes also need to check if a
1830      declaration *must* have an initialization expression.  */
1831   if (gfc_current_state () != COMP_DERIVED)
1832     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1833   else
1834     {
1835       if (current_ts.type == BT_DERIVED
1836           && !current_attr.pointer && !initializer)
1837         initializer = gfc_default_initializer (&current_ts);
1838       t = build_struct (name, cl, &initializer, &as);
1839     }
1840
1841   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1842
1843 cleanup:
1844   /* Free stuff up and return.  */
1845   gfc_free_expr (initializer);
1846   gfc_free_array_spec (as);
1847
1848   return m;
1849 }
1850
1851
1852 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1853    This assumes that the byte size is equal to the kind number for
1854    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
1855
1856 match
1857 gfc_match_old_kind_spec (gfc_typespec *ts)
1858 {
1859   match m;
1860   int original_kind;
1861
1862   if (gfc_match_char ('*') != MATCH_YES)
1863     return MATCH_NO;
1864
1865   m = gfc_match_small_literal_int (&ts->kind, NULL);
1866   if (m != MATCH_YES)
1867     return MATCH_ERROR;
1868
1869   original_kind = ts->kind;
1870
1871   /* Massage the kind numbers for complex types.  */
1872   if (ts->type == BT_COMPLEX)
1873     {
1874       if (ts->kind % 2)
1875         {
1876           gfc_error ("Old-style type declaration %s*%d not supported at %C",
1877                      gfc_basic_typename (ts->type), original_kind);
1878           return MATCH_ERROR;
1879         }
1880       ts->kind /= 2;
1881     }
1882
1883   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1884     {
1885       gfc_error ("Old-style type declaration %s*%d not supported at %C",
1886                  gfc_basic_typename (ts->type), original_kind);
1887       return MATCH_ERROR;
1888     }
1889
1890   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1891                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
1892     return MATCH_ERROR;
1893
1894   return MATCH_YES;
1895 }
1896
1897
1898 /* Match a kind specification.  Since kinds are generally optional, we
1899    usually return MATCH_NO if something goes wrong.  If a "kind="
1900    string is found, then we know we have an error.  */
1901
1902 match
1903 gfc_match_kind_spec (gfc_typespec *ts, bool kind_expr_only)
1904 {
1905   locus where, loc;
1906   gfc_expr *e;
1907   match m, n;
1908   char c;
1909   const char *msg;
1910
1911   m = MATCH_NO;
1912   n = MATCH_YES;
1913   e = NULL;
1914
1915   where = loc = gfc_current_locus;
1916
1917   if (kind_expr_only)
1918     goto kind_expr;
1919
1920   if (gfc_match_char ('(') == MATCH_NO)
1921     return MATCH_NO;
1922
1923   /* Also gobbles optional text.  */
1924   if (gfc_match (" kind = ") == MATCH_YES)
1925     m = MATCH_ERROR;
1926
1927   loc = gfc_current_locus;
1928
1929 kind_expr:
1930   n = gfc_match_init_expr (&e);
1931
1932   if (n != MATCH_YES)
1933     {
1934       if (gfc_matching_function)
1935         {
1936           /* The function kind expression might include use associated or 
1937              imported parameters and try again after the specification
1938              expressions.....  */
1939           if (gfc_match_char (')') != MATCH_YES)
1940             {
1941               gfc_error ("Missing right parenthesis at %C");
1942               m = MATCH_ERROR;
1943               goto no_match;
1944             }
1945
1946           gfc_free_expr (e);
1947           gfc_undo_symbols ();
1948           return MATCH_YES;
1949         }
1950       else
1951         {
1952           /* ....or else, the match is real.  */
1953           if (n == MATCH_NO)
1954             gfc_error ("Expected initialization expression at %C");
1955           if (n != MATCH_YES)
1956             return MATCH_ERROR;
1957         }
1958     }
1959
1960   if (e->rank != 0)
1961     {
1962       gfc_error ("Expected scalar initialization expression at %C");
1963       m = MATCH_ERROR;
1964       goto no_match;
1965     }
1966
1967   msg = gfc_extract_int (e, &ts->kind);
1968
1969   if (msg != NULL)
1970     {
1971       gfc_error (msg);
1972       m = MATCH_ERROR;
1973       goto no_match;
1974     }
1975
1976   /* Before throwing away the expression, let's see if we had a
1977      C interoperable kind (and store the fact).  */
1978   if (e->ts.is_c_interop == 1)
1979     {
1980       /* Mark this as c interoperable if being declared with one
1981          of the named constants from iso_c_binding.  */
1982       ts->is_c_interop = e->ts.is_iso_c;
1983       ts->f90_type = e->ts.f90_type;
1984     }
1985   
1986   gfc_free_expr (e);
1987   e = NULL;
1988
1989   /* Ignore errors to this point, if we've gotten here.  This means
1990      we ignore the m=MATCH_ERROR from above.  */
1991   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1992     {
1993       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1994                  gfc_basic_typename (ts->type));
1995       gfc_current_locus = where;
1996       return MATCH_ERROR;
1997     }
1998
1999   /* Warn if, e.g., c_int is used for a REAL variable, but not
2000      if, e.g., c_double is used for COMPLEX as the standard
2001      explicitly says that the kind type parameter for complex and real
2002      variable is the same, i.e. c_float == c_float_complex.  */
2003   if (ts->f90_type != BT_UNKNOWN && ts->f90_type != ts->type
2004       && !((ts->f90_type == BT_REAL && ts->type == BT_COMPLEX)
2005            || (ts->f90_type == BT_COMPLEX && ts->type == BT_REAL)))
2006     gfc_warning_now ("C kind type parameter is for type %s but type at %L "
2007                      "is %s", gfc_basic_typename (ts->f90_type), &where,
2008                      gfc_basic_typename (ts->type));
2009
2010   gfc_gobble_whitespace ();
2011   if ((c = gfc_next_ascii_char ()) != ')'
2012       && (ts->type != BT_CHARACTER || c != ','))
2013     {
2014       if (ts->type == BT_CHARACTER)
2015         gfc_error ("Missing right parenthesis or comma at %C");
2016       else
2017         gfc_error ("Missing right parenthesis at %C");
2018       m = MATCH_ERROR;
2019     }
2020   else
2021      /* All tests passed.  */
2022      m = MATCH_YES;
2023
2024   if(m == MATCH_ERROR)
2025      gfc_current_locus = where;
2026   
2027   /* Return what we know from the test(s).  */
2028   return m;
2029
2030 no_match:
2031   gfc_free_expr (e);
2032   gfc_current_locus = where;
2033   return m;
2034 }
2035
2036
2037 static match
2038 match_char_kind (int * kind, int * is_iso_c)
2039 {
2040   locus where;
2041   gfc_expr *e;
2042   match m, n;
2043   const char *msg;
2044
2045   m = MATCH_NO;
2046   e = NULL;
2047   where = gfc_current_locus;
2048
2049   n = gfc_match_init_expr (&e);
2050
2051   if (n != MATCH_YES && gfc_matching_function)
2052     {
2053       /* The expression might include use-associated or imported
2054          parameters and try again after the specification 
2055          expressions.  */
2056       gfc_free_expr (e);
2057       gfc_undo_symbols ();
2058       return MATCH_YES;
2059     }
2060
2061   if (n == MATCH_NO)
2062     gfc_error ("Expected initialization expression at %C");
2063   if (n != MATCH_YES)
2064     return MATCH_ERROR;
2065
2066   if (e->rank != 0)
2067     {
2068       gfc_error ("Expected scalar initialization expression at %C");
2069       m = MATCH_ERROR;
2070       goto no_match;
2071     }
2072
2073   msg = gfc_extract_int (e, kind);
2074   *is_iso_c = e->ts.is_iso_c;
2075   if (msg != NULL)
2076     {
2077       gfc_error (msg);
2078       m = MATCH_ERROR;
2079       goto no_match;
2080     }
2081
2082   gfc_free_expr (e);
2083
2084   /* Ignore errors to this point, if we've gotten here.  This means
2085      we ignore the m=MATCH_ERROR from above.  */
2086   if (gfc_validate_kind (BT_CHARACTER, *kind, true) < 0)
2087     {
2088       gfc_error ("Kind %d is not supported for CHARACTER at %C", *kind);
2089       m = MATCH_ERROR;
2090     }
2091   else
2092      /* All tests passed.  */
2093      m = MATCH_YES;
2094
2095   if (m == MATCH_ERROR)
2096      gfc_current_locus = where;
2097   
2098   /* Return what we know from the test(s).  */
2099   return m;
2100
2101 no_match:
2102   gfc_free_expr (e);
2103   gfc_current_locus = where;
2104   return m;
2105 }
2106
2107
2108 /* Match the various kind/length specifications in a CHARACTER
2109    declaration.  We don't return MATCH_NO.  */
2110
2111 match
2112 gfc_match_char_spec (gfc_typespec *ts)
2113 {
2114   int kind, seen_length, is_iso_c;
2115   gfc_charlen *cl;
2116   gfc_expr *len;
2117   match m;
2118
2119   len = NULL;
2120   seen_length = 0;
2121   kind = 0;
2122   is_iso_c = 0;
2123
2124   /* Try the old-style specification first.  */
2125   old_char_selector = 0;
2126
2127   m = match_char_length (&len);
2128   if (m != MATCH_NO)
2129     {
2130       if (m == MATCH_YES)
2131         old_char_selector = 1;
2132       seen_length = 1;
2133       goto done;
2134     }
2135
2136   m = gfc_match_char ('(');
2137   if (m != MATCH_YES)
2138     {
2139       m = MATCH_YES;    /* Character without length is a single char.  */
2140       goto done;
2141     }
2142
2143   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] ).  */
2144   if (gfc_match (" kind =") == MATCH_YES)
2145     {
2146       m = match_char_kind (&kind, &is_iso_c);
2147        
2148       if (m == MATCH_ERROR)
2149         goto done;
2150       if (m == MATCH_NO)
2151         goto syntax;
2152
2153       if (gfc_match (" , len =") == MATCH_NO)
2154         goto rparen;
2155
2156       m = char_len_param_value (&len);
2157       if (m == MATCH_NO)
2158         goto syntax;
2159       if (m == MATCH_ERROR)
2160         goto done;
2161       seen_length = 1;
2162
2163       goto rparen;
2164     }
2165
2166   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
2167   if (gfc_match (" len =") == MATCH_YES)
2168     {
2169       m = char_len_param_value (&len);
2170       if (m == MATCH_NO)
2171         goto syntax;
2172       if (m == MATCH_ERROR)
2173         goto done;
2174       seen_length = 1;
2175
2176       if (gfc_match_char (')') == MATCH_YES)
2177         goto done;
2178
2179       if (gfc_match (" , kind =") != MATCH_YES)
2180         goto syntax;
2181
2182       if (match_char_kind (&kind, &is_iso_c) == MATCH_ERROR)
2183         goto done;
2184
2185       goto rparen;
2186     }
2187
2188   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
2189   m = char_len_param_value (&len);
2190   if (m == MATCH_NO)
2191     goto syntax;
2192   if (m == MATCH_ERROR)
2193     goto done;
2194   seen_length = 1;
2195
2196   m = gfc_match_char (')');
2197   if (m == MATCH_YES)
2198     goto done;
2199
2200   if (gfc_match_char (',') != MATCH_YES)
2201     goto syntax;
2202
2203   gfc_match (" kind =");        /* Gobble optional text.  */
2204
2205   m = match_char_kind (&kind, &is_iso_c);
2206   if (m == MATCH_ERROR)
2207     goto done;
2208   if (m == MATCH_NO)
2209     goto syntax;
2210
2211 rparen:
2212   /* Require a right-paren at this point.  */
2213   m = gfc_match_char (')');
2214   if (m == MATCH_YES)
2215     goto done;
2216
2217 syntax:
2218   gfc_error ("Syntax error in CHARACTER declaration at %C");
2219   m = MATCH_ERROR;
2220   gfc_free_expr (len);
2221   return m;
2222
2223 done:
2224   /* Deal with character functions after USE and IMPORT statements.  */
2225   if (gfc_matching_function)
2226     {
2227       gfc_free_expr (len);
2228       gfc_undo_symbols ();
2229       return MATCH_YES;
2230     }
2231
2232   if (m != MATCH_YES)
2233     {
2234       gfc_free_expr (len);
2235       return m;
2236     }
2237
2238   /* Do some final massaging of the length values.  */
2239   cl = gfc_new_charlen (gfc_current_ns, NULL);
2240
2241   if (seen_length == 0)
2242     cl->length = gfc_int_expr (1);
2243   else
2244     cl->length = len;
2245
2246   ts->u.cl = cl;
2247   ts->kind = kind == 0 ? gfc_default_character_kind : kind;
2248
2249   /* We have to know if it was a c interoperable kind so we can
2250      do accurate type checking of bind(c) procs, etc.  */
2251   if (kind != 0)
2252     /* Mark this as c interoperable if being declared with one
2253        of the named constants from iso_c_binding.  */
2254     ts->is_c_interop = is_iso_c;
2255   else if (len != NULL)
2256     /* Here, we might have parsed something such as: character(c_char)
2257        In this case, the parsing code above grabs the c_char when
2258        looking for the length (line 1690, roughly).  it's the last
2259        testcase for parsing the kind params of a character variable.
2260        However, it's not actually the length.    this seems like it
2261        could be an error.  
2262        To see if the user used a C interop kind, test the expr
2263        of the so called length, and see if it's C interoperable.  */
2264     ts->is_c_interop = len->ts.is_iso_c;
2265   
2266   return MATCH_YES;
2267 }
2268
2269
2270 /* Matches a type specification.  If successful, sets the ts structure
2271    to the matched specification.  This is necessary for FUNCTION and
2272    IMPLICIT statements.
2273
2274    If implicit_flag is nonzero, then we don't check for the optional
2275    kind specification.  Not doing so is needed for matching an IMPLICIT
2276    statement correctly.  */
2277
2278 match
2279 gfc_match_type_spec (gfc_typespec *ts, int implicit_flag)
2280 {
2281   char name[GFC_MAX_SYMBOL_LEN + 1];
2282   gfc_symbol *sym;
2283   match m;
2284   char c;
2285   bool seen_deferred_kind;
2286
2287   /* A belt and braces check that the typespec is correctly being treated
2288      as a deferred characteristic association.  */
2289   seen_deferred_kind = (gfc_current_state () == COMP_FUNCTION)
2290                           && (gfc_current_block ()->result->ts.kind == -1)
2291                           && (ts->kind == -1);
2292   gfc_clear_ts (ts);
2293   if (seen_deferred_kind)
2294     ts->kind = -1;
2295
2296   /* Clear the current binding label, in case one is given.  */
2297   curr_binding_label[0] = '\0';
2298
2299   if (gfc_match (" byte") == MATCH_YES)
2300     {
2301       if (gfc_notify_std (GFC_STD_GNU, "Extension: BYTE type at %C")
2302           == FAILURE)
2303         return MATCH_ERROR;
2304
2305       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
2306         {
2307           gfc_error ("BYTE type used at %C "
2308                      "is not available on the target machine");
2309           return MATCH_ERROR;
2310         }
2311
2312       ts->type = BT_INTEGER;
2313       ts->kind = 1;
2314       return MATCH_YES;
2315     }
2316
2317   if (gfc_match (" integer") == MATCH_YES)
2318     {
2319       ts->type = BT_INTEGER;
2320       ts->kind = gfc_default_integer_kind;
2321       goto get_kind;
2322     }
2323
2324   if (gfc_match (" character") == MATCH_YES)
2325     {
2326       ts->type = BT_CHARACTER;
2327       if (implicit_flag == 0)
2328         return gfc_match_char_spec (ts);
2329       else
2330         return MATCH_YES;
2331     }
2332
2333   if (gfc_match (" real") == MATCH_YES)
2334     {
2335       ts->type = BT_REAL;
2336       ts->kind = gfc_default_real_kind;
2337       goto get_kind;
2338     }
2339
2340   if (gfc_match (" double precision") == MATCH_YES)
2341     {
2342       ts->type = BT_REAL;
2343       ts->kind = gfc_default_double_kind;
2344       return MATCH_YES;
2345     }
2346
2347   if (gfc_match (" complex") == MATCH_YES)
2348     {
2349       ts->type = BT_COMPLEX;
2350       ts->kind = gfc_default_complex_kind;
2351       goto get_kind;
2352     }
2353
2354   if (gfc_match (" double complex") == MATCH_YES)
2355     {
2356       if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
2357                           "conform to the Fortran 95 standard") == FAILURE)
2358         return MATCH_ERROR;
2359
2360       ts->type = BT_COMPLEX;
2361       ts->kind = gfc_default_double_kind;
2362       return MATCH_YES;
2363     }
2364
2365   if (gfc_match (" logical") == MATCH_YES)
2366     {
2367       ts->type = BT_LOGICAL;
2368       ts->kind = gfc_default_logical_kind;
2369       goto get_kind;
2370     }
2371
2372   m = gfc_match (" type ( %n )", name);
2373   if (m != MATCH_YES)
2374     {
2375       m = gfc_match (" class ( %n )", name);
2376       if (m != MATCH_YES)
2377         return m;
2378       ts->is_class = 1;
2379
2380       /* TODO: Implement Polymorphism.  */
2381       gfc_warning ("Polymorphic entities are not yet implemented. "
2382                    "CLASS will be treated like TYPE at %C");
2383     }
2384
2385   ts->type = BT_DERIVED;
2386
2387   /* Defer association of the derived type until the end of the
2388      specification block.  However, if the derived type can be
2389      found, add it to the typespec.  */  
2390   if (gfc_matching_function)
2391     {
2392       ts->u.derived = NULL;
2393       if (gfc_current_state () != COMP_INTERFACE
2394             && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2395         ts->u.derived = sym;
2396       return MATCH_YES;
2397     }
2398
2399   /* Search for the name but allow the components to be defined later.  If
2400      type = -1, this typespec has been seen in a function declaration but
2401      the type could not be accessed at that point.  */
2402   sym = NULL;
2403   if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2404     {
2405       gfc_error ("Type name '%s' at %C is ambiguous", name);
2406       return MATCH_ERROR;
2407     }
2408   else if (ts->kind == -1)
2409     {
2410       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2411                     || gfc_current_ns->has_import_set;
2412       if (gfc_find_symbol (name, NULL, iface, &sym))
2413         {       
2414           gfc_error ("Type name '%s' at %C is ambiguous", name);
2415           return MATCH_ERROR;
2416         }
2417
2418       ts->kind = 0;
2419       if (sym == NULL)
2420         return MATCH_NO;
2421     }
2422
2423   if (sym->attr.flavor != FL_DERIVED
2424       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2425     return MATCH_ERROR;
2426
2427   gfc_set_sym_referenced (sym);
2428   ts->u.derived = sym;
2429
2430   return MATCH_YES;
2431
2432 get_kind:
2433   /* For all types except double, derived and character, look for an
2434      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2435   if (implicit_flag == 1)
2436     return MATCH_YES;
2437
2438   if (gfc_current_form == FORM_FREE)
2439     {
2440       c = gfc_peek_ascii_char ();
2441       if (!gfc_is_whitespace (c) && c != '*' && c != '('
2442           && c != ':' && c != ',')
2443        return MATCH_NO;
2444     }
2445
2446   m = gfc_match_kind_spec (ts, false);
2447   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2448     m = gfc_match_old_kind_spec (ts);
2449
2450   /* Defer association of the KIND expression of function results
2451      until after USE and IMPORT statements.  */
2452   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2453          || gfc_matching_function)
2454     return MATCH_YES;
2455
2456   if (m == MATCH_NO)
2457     m = MATCH_YES;              /* No kind specifier found.  */
2458
2459   return m;
2460 }
2461
2462
2463 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2464    already matched in parse.c, or we would not end up here in the
2465    first place.  So the only thing we need to check, is if there is
2466    trailing garbage.  If not, the match is successful.  */
2467
2468 match
2469 gfc_match_implicit_none (void)
2470 {
2471   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2472 }
2473
2474
2475 /* Match the letter range(s) of an IMPLICIT statement.  */
2476
2477 static match
2478 match_implicit_range (void)
2479 {
2480   char c, c1, c2;
2481   int inner;
2482   locus cur_loc;
2483
2484   cur_loc = gfc_current_locus;
2485
2486   gfc_gobble_whitespace ();
2487   c = gfc_next_ascii_char ();
2488   if (c != '(')
2489     {
2490       gfc_error ("Missing character range in IMPLICIT at %C");
2491       goto bad;
2492     }
2493
2494   inner = 1;
2495   while (inner)
2496     {
2497       gfc_gobble_whitespace ();
2498       c1 = gfc_next_ascii_char ();
2499       if (!ISALPHA (c1))
2500         goto bad;
2501
2502       gfc_gobble_whitespace ();
2503       c = gfc_next_ascii_char ();
2504
2505       switch (c)
2506         {
2507         case ')':
2508           inner = 0;            /* Fall through.  */
2509
2510         case ',':
2511           c2 = c1;
2512           break;
2513
2514         case '-':
2515           gfc_gobble_whitespace ();
2516           c2 = gfc_next_ascii_char ();
2517           if (!ISALPHA (c2))
2518             goto bad;
2519
2520           gfc_gobble_whitespace ();
2521           c = gfc_next_ascii_char ();
2522
2523           if ((c != ',') && (c != ')'))
2524             goto bad;
2525           if (c == ')')
2526             inner = 0;
2527
2528           break;
2529
2530         default:
2531           goto bad;
2532         }
2533
2534       if (c1 > c2)
2535         {
2536           gfc_error ("Letters must be in alphabetic order in "
2537                      "IMPLICIT statement at %C");
2538           goto bad;
2539         }
2540
2541       /* See if we can add the newly matched range to the pending
2542          implicits from this IMPLICIT statement.  We do not check for
2543          conflicts with whatever earlier IMPLICIT statements may have
2544          set.  This is done when we've successfully finished matching
2545          the current one.  */
2546       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2547         goto bad;
2548     }
2549
2550   return MATCH_YES;
2551
2552 bad:
2553   gfc_syntax_error (ST_IMPLICIT);
2554
2555   gfc_current_locus = cur_loc;
2556   return MATCH_ERROR;
2557 }
2558
2559
2560 /* Match an IMPLICIT statement, storing the types for
2561    gfc_set_implicit() if the statement is accepted by the parser.
2562    There is a strange looking, but legal syntactic construction
2563    possible.  It looks like:
2564
2565      IMPLICIT INTEGER (a-b) (c-d)
2566
2567    This is legal if "a-b" is a constant expression that happens to
2568    equal one of the legal kinds for integers.  The real problem
2569    happens with an implicit specification that looks like:
2570
2571      IMPLICIT INTEGER (a-b)
2572
2573    In this case, a typespec matcher that is "greedy" (as most of the
2574    matchers are) gobbles the character range as a kindspec, leaving
2575    nothing left.  We therefore have to go a bit more slowly in the
2576    matching process by inhibiting the kindspec checking during
2577    typespec matching and checking for a kind later.  */
2578
2579 match
2580 gfc_match_implicit (void)
2581 {
2582   gfc_typespec ts;
2583   locus cur_loc;
2584   char c;
2585   match m;
2586
2587   gfc_clear_ts (&ts);
2588
2589   /* We don't allow empty implicit statements.  */
2590   if (gfc_match_eos () == MATCH_YES)
2591     {
2592       gfc_error ("Empty IMPLICIT statement at %C");
2593       return MATCH_ERROR;
2594     }
2595
2596   do
2597     {
2598       /* First cleanup.  */
2599       gfc_clear_new_implicit ();
2600
2601       /* A basic type is mandatory here.  */
2602       m = gfc_match_type_spec (&ts, 1);
2603       if (m == MATCH_ERROR)
2604         goto error;
2605       if (m == MATCH_NO)
2606         goto syntax;
2607
2608       cur_loc = gfc_current_locus;
2609       m = match_implicit_range ();
2610
2611       if (m == MATCH_YES)
2612         {
2613           /* We may have <TYPE> (<RANGE>).  */
2614           gfc_gobble_whitespace ();
2615           c = gfc_next_ascii_char ();
2616           if ((c == '\n') || (c == ','))
2617             {
2618               /* Check for CHARACTER with no length parameter.  */
2619               if (ts.type == BT_CHARACTER && !ts.u.cl)
2620                 {
2621                   ts.kind = gfc_default_character_kind;
2622                   ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2623                   ts.u.cl->length = gfc_int_expr (1);
2624                 }
2625
2626               /* Record the Successful match.  */
2627               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2628                 return MATCH_ERROR;
2629               continue;
2630             }
2631
2632           gfc_current_locus = cur_loc;
2633         }
2634
2635       /* Discard the (incorrectly) matched range.  */
2636       gfc_clear_new_implicit ();
2637
2638       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2639       if (ts.type == BT_CHARACTER)
2640         m = gfc_match_char_spec (&ts);
2641       else
2642         {
2643           m = gfc_match_kind_spec (&ts, false);
2644           if (m == MATCH_NO)
2645             {
2646               m = gfc_match_old_kind_spec (&ts);
2647               if (m == MATCH_ERROR)
2648                 goto error;
2649               if (m == MATCH_NO)
2650                 goto syntax;
2651             }
2652         }
2653       if (m == MATCH_ERROR)
2654         goto error;
2655
2656       m = match_implicit_range ();
2657       if (m == MATCH_ERROR)
2658         goto error;
2659       if (m == MATCH_NO)
2660         goto syntax;
2661
2662       gfc_gobble_whitespace ();
2663       c = gfc_next_ascii_char ();
2664       if ((c != '\n') && (c != ','))
2665         goto syntax;
2666
2667       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2668         return MATCH_ERROR;
2669     }
2670   while (c == ',');
2671
2672   return MATCH_YES;
2673
2674 syntax:
2675   gfc_syntax_error (ST_IMPLICIT);
2676
2677 error:
2678   return MATCH_ERROR;
2679 }
2680
2681
2682 match
2683 gfc_match_import (void)
2684 {
2685   char name[GFC_MAX_SYMBOL_LEN + 1];
2686   match m;
2687   gfc_symbol *sym;
2688   gfc_symtree *st;
2689
2690   if (gfc_current_ns->proc_name == NULL
2691       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2692     {
2693       gfc_error ("IMPORT statement at %C only permitted in "
2694                  "an INTERFACE body");
2695       return MATCH_ERROR;
2696     }
2697
2698   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2699       == FAILURE)
2700     return MATCH_ERROR;
2701
2702   if (gfc_match_eos () == MATCH_YES)
2703     {
2704       /* All host variables should be imported.  */
2705       gfc_current_ns->has_import_set = 1;
2706       return MATCH_YES;
2707     }
2708
2709   if (gfc_match (" ::") == MATCH_YES)
2710     {
2711       if (gfc_match_eos () == MATCH_YES)
2712         {
2713            gfc_error ("Expecting list of named entities at %C");
2714            return MATCH_ERROR;
2715         }
2716     }
2717
2718   for(;;)
2719     {
2720       m = gfc_match (" %n", name);
2721       switch (m)
2722         {
2723         case MATCH_YES:
2724           if (gfc_current_ns->parent !=  NULL
2725               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2726             {
2727                gfc_error ("Type name '%s' at %C is ambiguous", name);
2728                return MATCH_ERROR;
2729             }
2730           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2731                    && gfc_find_symbol (name,
2732                                        gfc_current_ns->proc_name->ns->parent,
2733                                        1, &sym))
2734             {
2735                gfc_error ("Type name '%s' at %C is ambiguous", name);
2736                return MATCH_ERROR;
2737             }
2738
2739           if (sym == NULL)
2740             {
2741               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2742                          "at %C - does not exist.", name);
2743               return MATCH_ERROR;
2744             }
2745
2746           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2747             {
2748               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2749                            "at %C.", name);
2750               goto next_item;
2751             }
2752
2753           st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name);
2754           st->n.sym = sym;
2755           sym->refs++;
2756           sym->attr.imported = 1;
2757
2758           goto next_item;
2759
2760         case MATCH_NO:
2761           break;
2762
2763         case MATCH_ERROR:
2764           return MATCH_ERROR;
2765         }
2766
2767     next_item:
2768       if (gfc_match_eos () == MATCH_YES)
2769         break;
2770       if (gfc_match_char (',') != MATCH_YES)
2771         goto syntax;
2772     }
2773
2774   return MATCH_YES;
2775
2776 syntax:
2777   gfc_error ("Syntax error in IMPORT statement at %C");
2778   return MATCH_ERROR;
2779 }
2780
2781
2782 /* A minimal implementation of gfc_match without whitespace, escape
2783    characters or variable arguments.  Returns true if the next
2784    characters match the TARGET template exactly.  */
2785
2786 static bool
2787 match_string_p (const char *target)
2788 {
2789   const char *p;
2790
2791   for (p = target; *p; p++)
2792     if ((char) gfc_next_ascii_char () != *p)
2793       return false;
2794   return true;
2795 }
2796
2797 /* Matches an attribute specification including array specs.  If
2798    successful, leaves the variables current_attr and current_as
2799    holding the specification.  Also sets the colon_seen variable for
2800    later use by matchers associated with initializations.
2801
2802    This subroutine is a little tricky in the sense that we don't know
2803    if we really have an attr-spec until we hit the double colon.
2804    Until that time, we can only return MATCH_NO.  This forces us to
2805    check for duplicate specification at this level.  */
2806
2807 static match
2808 match_attr_spec (void)
2809 {
2810   /* Modifiers that can exist in a type statement.  */
2811   typedef enum
2812   { GFC_DECL_BEGIN = 0,
2813     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2814     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2815     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2816     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2817     DECL_IS_BIND_C, DECL_NONE,
2818     GFC_DECL_END /* Sentinel */
2819   }
2820   decl_types;
2821
2822 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2823 #define NUM_DECL GFC_DECL_END
2824
2825   locus start, seen_at[NUM_DECL];
2826   int seen[NUM_DECL];
2827   unsigned int d;
2828   const char *attr;
2829   match m;
2830   gfc_try t;
2831
2832   gfc_clear_attr (&current_attr);
2833   start = gfc_current_locus;
2834
2835   current_as = NULL;
2836   colon_seen = 0;
2837
2838   /* See if we get all of the keywords up to the final double colon.  */
2839   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2840     seen[d] = 0;
2841
2842   for (;;)
2843     {
2844       char ch;
2845
2846       d = DECL_NONE;
2847       gfc_gobble_whitespace ();
2848
2849       ch = gfc_next_ascii_char ();
2850       if (ch == ':')
2851         {
2852           /* This is the successful exit condition for the loop.  */
2853           if (gfc_next_ascii_char () == ':')
2854             break;
2855         }
2856       else if (ch == ',')
2857         {
2858           gfc_gobble_whitespace ();
2859           switch (gfc_peek_ascii_char ())
2860             {
2861             case 'a':
2862               if (match_string_p ("allocatable"))
2863                 d = DECL_ALLOCATABLE;
2864               break;
2865
2866             case 'b':
2867               /* Try and match the bind(c).  */
2868               m = gfc_match_bind_c (NULL, true);
2869               if (m == MATCH_YES)
2870                 d = DECL_IS_BIND_C;
2871               else if (m == MATCH_ERROR)
2872                 goto cleanup;
2873               break;
2874
2875             case 'd':
2876               if (match_string_p ("dimension"))
2877                 d = DECL_DIMENSION;
2878               break;
2879
2880             case 'e':
2881               if (match_string_p ("external"))
2882                 d = DECL_EXTERNAL;
2883               break;
2884
2885             case 'i':
2886               if (match_string_p ("int"))
2887                 {
2888                   ch = gfc_next_ascii_char ();
2889                   if (ch == 'e')
2890                     {
2891                       if (match_string_p ("nt"))
2892                         {
2893                           /* Matched "intent".  */
2894                           /* TODO: Call match_intent_spec from here.  */
2895                           if (gfc_match (" ( in out )") == MATCH_YES)
2896                             d = DECL_INOUT;
2897                           else if (gfc_match (" ( in )") == MATCH_YES)
2898                             d = DECL_IN;
2899                           else if (gfc_match (" ( out )") == MATCH_YES)
2900                             d = DECL_OUT;
2901                         }
2902                     }
2903                   else if (ch == 'r')
2904                     {
2905                       if (match_string_p ("insic"))
2906                         {
2907                           /* Matched "intrinsic".  */
2908                           d = DECL_INTRINSIC;
2909                         }
2910                     }
2911                 }
2912               break;
2913
2914             case 'o':
2915               if (match_string_p ("optional"))
2916                 d = DECL_OPTIONAL;
2917               break;
2918
2919             case 'p':
2920               gfc_next_ascii_char ();
2921               switch (gfc_next_ascii_char ())
2922                 {
2923                 case 'a':
2924                   if (match_string_p ("rameter"))
2925                     {
2926                       /* Matched "parameter".  */
2927                       d = DECL_PARAMETER;
2928                     }
2929                   break;
2930
2931                 case 'o':
2932                   if (match_string_p ("inter"))
2933                     {
2934                       /* Matched "pointer".  */
2935                       d = DECL_POINTER;
2936                     }
2937                   break;
2938
2939                 case 'r':
2940                   ch = gfc_next_ascii_char ();
2941                   if (ch == 'i')
2942                     {
2943                       if (match_string_p ("vate"))
2944                         {
2945                           /* Matched "private".  */
2946                           d = DECL_PRIVATE;
2947                         }
2948                     }
2949                   else if (ch == 'o')
2950                     {
2951                       if (match_string_p ("tected"))
2952                         {
2953                           /* Matched "protected".  */
2954                           d = DECL_PROTECTED;
2955                         }
2956                     }
2957                   break;
2958
2959                 case 'u':
2960                   if (match_string_p ("blic"))
2961                     {
2962                       /* Matched "public".  */
2963                       d = DECL_PUBLIC;
2964                     }
2965                   break;
2966                 }
2967               break;
2968
2969             case 's':
2970               if (match_string_p ("save"))
2971                 d = DECL_SAVE;
2972               break;
2973
2974             case 't':
2975               if (match_string_p ("target"))
2976                 d = DECL_TARGET;
2977               break;
2978
2979             case 'v':
2980               gfc_next_ascii_char ();
2981               ch = gfc_next_ascii_char ();
2982               if (ch == 'a')
2983                 {
2984                   if (match_string_p ("lue"))
2985                     {
2986                       /* Matched "value".  */
2987                       d = DECL_VALUE;
2988                     }
2989                 }
2990               else if (ch == 'o')
2991                 {
2992                   if (match_string_p ("latile"))
2993                     {
2994                       /* Matched "volatile".  */
2995                       d = DECL_VOLATILE;
2996                     }
2997                 }
2998               break;
2999             }
3000         }
3001
3002       /* No double colon and no recognizable decl_type, so assume that
3003          we've been looking at something else the whole time.  */
3004       if (d == DECL_NONE)
3005         {
3006           m = MATCH_NO;
3007           goto cleanup;
3008         }
3009
3010       /* Check to make sure any parens are paired up correctly.  */
3011       if (gfc_match_parens () == MATCH_ERROR)
3012         {
3013           m = MATCH_ERROR;
3014           goto cleanup;
3015         }
3016
3017       seen[d]++;
3018       seen_at[d] = gfc_current_locus;
3019
3020       if (d == DECL_DIMENSION)
3021         {
3022           m = gfc_match_array_spec (&current_as);
3023
3024           if (m == MATCH_NO)
3025             {
3026               gfc_error ("Missing dimension specification at %C");
3027               m = MATCH_ERROR;
3028             }
3029
3030           if (m == MATCH_ERROR)
3031             goto cleanup;
3032         }
3033     }
3034
3035   /* Since we've seen a double colon, we have to be looking at an
3036      attr-spec.  This means that we can now issue errors.  */
3037   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3038     if (seen[d] > 1)
3039       {
3040         switch (d)
3041           {
3042           case DECL_ALLOCATABLE:
3043             attr = "ALLOCATABLE";
3044             break;
3045           case DECL_DIMENSION:
3046             attr = "DIMENSION";
3047             break;
3048           case DECL_EXTERNAL:
3049             attr = "EXTERNAL";
3050             break;
3051           case DECL_IN:
3052             attr = "INTENT (IN)";
3053             break;
3054           case DECL_OUT:
3055             attr = "INTENT (OUT)";
3056             break;
3057           case DECL_INOUT:
3058             attr = "INTENT (IN OUT)";
3059             break;
3060           case DECL_INTRINSIC:
3061             attr = "INTRINSIC";
3062             break;
3063           case DECL_OPTIONAL:
3064             attr = "OPTIONAL";
3065             break;
3066           case DECL_PARAMETER:
3067             attr = "PARAMETER";
3068             break;
3069           case DECL_POINTER:
3070             attr = "POINTER";
3071             break;
3072           case DECL_PROTECTED:
3073             attr = "PROTECTED";
3074             break;
3075           case DECL_PRIVATE:
3076             attr = "PRIVATE";
3077             break;
3078           case DECL_PUBLIC:
3079             attr = "PUBLIC";
3080             break;
3081           case DECL_SAVE:
3082             attr = "SAVE";
3083             break;
3084           case DECL_TARGET:
3085             attr = "TARGET";
3086             break;
3087           case DECL_IS_BIND_C:
3088             attr = "IS_BIND_C";
3089             break;
3090           case DECL_VALUE:
3091             attr = "VALUE";
3092             break;
3093           case DECL_VOLATILE:
3094             attr = "VOLATILE";
3095             break;
3096           default:
3097             attr = NULL;        /* This shouldn't happen.  */
3098           }
3099
3100         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3101         m = MATCH_ERROR;
3102         goto cleanup;
3103       }
3104
3105   /* Now that we've dealt with duplicate attributes, add the attributes
3106      to the current attribute.  */
3107   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3108     {
3109       if (seen[d] == 0)
3110         continue;
3111
3112       if (gfc_current_state () == COMP_DERIVED
3113           && d != DECL_DIMENSION && d != DECL_POINTER
3114           && d != DECL_PRIVATE   && d != DECL_PUBLIC
3115           && d != DECL_NONE)
3116         {
3117           if (d == DECL_ALLOCATABLE)
3118             {
3119               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3120                                   "attribute at %C in a TYPE definition")
3121                   == FAILURE)
3122                 {
3123                   m = MATCH_ERROR;
3124                   goto cleanup;
3125                 }
3126             }
3127           else
3128             {
3129               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3130                          &seen_at[d]);
3131               m = MATCH_ERROR;
3132               goto cleanup;
3133             }
3134         }
3135
3136       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3137           && gfc_current_state () != COMP_MODULE)
3138         {
3139           if (d == DECL_PRIVATE)
3140             attr = "PRIVATE";
3141           else
3142             attr = "PUBLIC";
3143           if (gfc_current_state () == COMP_DERIVED
3144               && gfc_state_stack->previous
3145               && gfc_state_stack->previous->state == COMP_MODULE)
3146             {
3147               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3148                                   "at %L in a TYPE definition", attr,
3149                                   &seen_at[d])
3150                   == FAILURE)
3151                 {
3152                   m = MATCH_ERROR;
3153                   goto cleanup;
3154                 }
3155             }
3156           else
3157             {
3158               gfc_error ("%s attribute at %L is not allowed outside of the "
3159                          "specification part of a module", attr, &seen_at[d]);
3160               m = MATCH_ERROR;
3161               goto cleanup;
3162             }
3163         }
3164
3165       switch (d)
3166         {
3167         case DECL_ALLOCATABLE:
3168           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
3169           break;
3170
3171         case DECL_DIMENSION:
3172           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
3173           break;
3174
3175         case DECL_EXTERNAL:
3176           t = gfc_add_external (&current_attr, &seen_at[d]);
3177           break;
3178
3179         case DECL_IN:
3180           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
3181           break;
3182
3183         case DECL_OUT:
3184           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
3185           break;
3186
3187         case DECL_INOUT:
3188           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
3189           break;
3190
3191         case DECL_INTRINSIC:
3192           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
3193           break;
3194
3195         case DECL_OPTIONAL:
3196           t = gfc_add_optional (&current_attr, &seen_at[d]);
3197           break;
3198
3199         case DECL_PARAMETER:
3200           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
3201           break;
3202
3203         case DECL_POINTER:
3204           t = gfc_add_pointer (&current_attr, &seen_at[d]);
3205           break;
3206
3207         case DECL_PROTECTED:
3208           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3209             {
3210                gfc_error ("PROTECTED at %C only allowed in specification "
3211                           "part of a module");
3212                t = FAILURE;
3213                break;
3214             }
3215
3216           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3217                               "attribute at %C")
3218               == FAILURE)
3219             t = FAILURE;
3220           else
3221             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
3222           break;
3223
3224         case DECL_PRIVATE:
3225           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
3226                               &seen_at[d]);
3227           break;
3228
3229         case DECL_PUBLIC:
3230           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
3231                               &seen_at[d]);
3232           break;
3233
3234         case DECL_SAVE:
3235           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
3236           break;
3237
3238         case DECL_TARGET:
3239           t = gfc_add_target (&current_attr, &seen_at[d]);
3240           break;
3241
3242         case DECL_IS_BIND_C:
3243            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
3244            break;
3245            
3246         case DECL_VALUE:
3247           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3248                               "at %C")
3249               == FAILURE)
3250             t = FAILURE;
3251           else
3252             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
3253           break;
3254
3255         case DECL_VOLATILE:
3256           if (gfc_notify_std (GFC_STD_F2003,
3257                               "Fortran 2003: VOLATILE attribute at %C")
3258               == FAILURE)
3259             t = FAILURE;
3260           else
3261             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
3262           break;
3263
3264         default:
3265           gfc_internal_error ("match_attr_spec(): Bad attribute");
3266         }
3267
3268       if (t == FAILURE)
3269         {
3270           m = MATCH_ERROR;
3271           goto cleanup;
3272         }
3273     }
3274
3275   colon_seen = 1;
3276   return MATCH_YES;
3277
3278 cleanup:
3279   gfc_current_locus = start;
3280   gfc_free_array_spec (current_as);
3281   current_as = NULL;
3282   return m;
3283 }
3284
3285
3286 /* Set the binding label, dest_label, either with the binding label
3287    stored in the given gfc_typespec, ts, or if none was provided, it
3288    will be the symbol name in all lower case, as required by the draft
3289    (J3/04-007, section 15.4.1).  If a binding label was given and
3290    there is more than one argument (num_idents), it is an error.  */
3291
3292 gfc_try
3293 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3294 {
3295   if (num_idents > 1 && has_name_equals)
3296     {
3297       gfc_error ("Multiple identifiers provided with "
3298                  "single NAME= specifier at %C");
3299       return FAILURE;
3300     }
3301
3302   if (curr_binding_label[0] != '\0')
3303     {
3304       /* Binding label given; store in temp holder til have sym.  */
3305       strcpy (dest_label, curr_binding_label);
3306     }
3307   else
3308     {
3309       /* No binding label given, and the NAME= specifier did not exist,
3310          which means there was no NAME="".  */
3311       if (sym_name != NULL && has_name_equals == 0)
3312         strcpy (dest_label, sym_name);
3313     }
3314    
3315   return SUCCESS;
3316 }
3317
3318
3319 /* Set the status of the given common block as being BIND(C) or not,
3320    depending on the given parameter, is_bind_c.  */
3321
3322 void
3323 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3324 {
3325   com_block->is_bind_c = is_bind_c;
3326   return;
3327 }
3328
3329
3330 /* Verify that the given gfc_typespec is for a C interoperable type.  */
3331
3332 gfc_try
3333 verify_c_interop (gfc_typespec *ts)
3334 {
3335   if (ts->type == BT_DERIVED && ts->u.derived != NULL)
3336     return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
3337   else if (ts->is_c_interop != 1)
3338     return FAILURE;
3339   
3340   return SUCCESS;
3341 }
3342
3343
3344 /* Verify that the variables of a given common block, which has been
3345    defined with the attribute specifier bind(c), to be of a C
3346    interoperable type.  Errors will be reported here, if
3347    encountered.  */
3348
3349 gfc_try
3350 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3351 {
3352   gfc_symbol *curr_sym = NULL;
3353   gfc_try retval = SUCCESS;
3354
3355   curr_sym = com_block->head;
3356   
3357   /* Make sure we have at least one symbol.  */
3358   if (curr_sym == NULL)
3359     return retval;
3360
3361   /* Here we know we have a symbol, so we'll execute this loop
3362      at least once.  */
3363   do
3364     {
3365       /* The second to last param, 1, says this is in a common block.  */
3366       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3367       curr_sym = curr_sym->common_next;
3368     } while (curr_sym != NULL); 
3369
3370   return retval;
3371 }
3372
3373
3374 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
3375    an appropriate error message is reported.  */
3376
3377 gfc_try
3378 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3379                    int is_in_common, gfc_common_head *com_block)
3380 {
3381   bool bind_c_function = false;
3382   gfc_try retval = SUCCESS;
3383
3384   if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
3385     bind_c_function = true;
3386
3387   if (tmp_sym->attr.function && tmp_sym->result != NULL)
3388     {
3389       tmp_sym = tmp_sym->result;
3390       /* Make sure it wasn't an implicitly typed result.  */
3391       if (tmp_sym->attr.implicit_type)
3392         {
3393           gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3394                        "%L may not be C interoperable", tmp_sym->name,
3395                        &tmp_sym->declared_at);
3396           tmp_sym->ts.f90_type = tmp_sym->ts.type;
3397           /* Mark it as C interoperable to prevent duplicate warnings.  */
3398           tmp_sym->ts.is_c_interop = 1;
3399           tmp_sym->attr.is_c_interop = 1;
3400         }
3401     }
3402
3403   /* Here, we know we have the bind(c) attribute, so if we have
3404      enough type info, then verify that it's a C interop kind.
3405      The info could be in the symbol already, or possibly still in
3406      the given ts (current_ts), so look in both.  */
3407   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 
3408     {
3409       if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
3410         {
3411           /* See if we're dealing with a sym in a common block or not.  */
3412           if (is_in_common == 1)
3413             {
3414               gfc_warning ("Variable '%s' in common block '%s' at %L "
3415                            "may not be a C interoperable "
3416                            "kind though common block '%s' is BIND(C)",
3417                            tmp_sym->name, com_block->name,
3418                            &(tmp_sym->declared_at), com_block->name);
3419             }
3420           else
3421             {
3422               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3423                 gfc_error ("Type declaration '%s' at %L is not C "
3424                            "interoperable but it is BIND(C)",
3425                            tmp_sym->name, &(tmp_sym->declared_at));
3426               else
3427                 gfc_warning ("Variable '%s' at %L "
3428                              "may not be a C interoperable "
3429                              "kind but it is bind(c)",
3430                              tmp_sym->name, &(tmp_sym->declared_at));
3431             }
3432         }
3433       
3434       /* Variables declared w/in a common block can't be bind(c)
3435          since there's no way for C to see these variables, so there's
3436          semantically no reason for the attribute.  */
3437       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3438         {
3439           gfc_error ("Variable '%s' in common block '%s' at "
3440                      "%L cannot be declared with BIND(C) "
3441                      "since it is not a global",
3442                      tmp_sym->name, com_block->name,
3443                      &(tmp_sym->declared_at));
3444           retval = FAILURE;
3445         }
3446       
3447       /* Scalar variables that are bind(c) can not have the pointer
3448          or allocatable attributes.  */
3449       if (tmp_sym->attr.is_bind_c == 1)
3450         {
3451           if (tmp_sym->attr.pointer == 1)
3452             {
3453               gfc_error ("Variable '%s' at %L cannot have both the "
3454                          "POINTER and BIND(C) attributes",
3455                          tmp_sym->name, &(tmp_sym->declared_at));
3456               retval = FAILURE;
3457             }
3458
3459           if (tmp_sym->attr.allocatable == 1)
3460             {
3461               gfc_error ("Variable '%s' at %L cannot have both the "
3462                          "ALLOCATABLE and BIND(C) attributes",
3463                          tmp_sym->name, &(tmp_sym->declared_at));
3464               retval = FAILURE;
3465             }
3466
3467         }
3468
3469       /* If it is a BIND(C) function, make sure the return value is a
3470          scalar value.  The previous tests in this function made sure
3471          the type is interoperable.  */
3472       if (bind_c_function && tmp_sym->as != NULL)
3473         gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3474                    "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3475
3476       /* BIND(C) functions can not return a character string.  */
3477       if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
3478         if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
3479             || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
3480             || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
3481           gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3482                          "be a character string", tmp_sym->name,
3483                          &(tmp_sym->declared_at));
3484     }
3485
3486   /* See if the symbol has been marked as private.  If it has, make sure
3487      there is no binding label and warn the user if there is one.  */
3488   if (tmp_sym->attr.access == ACCESS_PRIVATE
3489       && tmp_sym->binding_label[0] != '\0')
3490       /* Use gfc_warning_now because we won't say that the symbol fails
3491          just because of this.  */
3492       gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3493                        "given the binding label '%s'", tmp_sym->name,
3494                        &(tmp_sym->declared_at), tmp_sym->binding_label);
3495
3496   return retval;
3497 }
3498
3499
3500 /* Set the appropriate fields for a symbol that's been declared as
3501    BIND(C) (the is_bind_c flag and the binding label), and verify that
3502    the type is C interoperable.  Errors are reported by the functions
3503    used to set/test these fields.  */
3504
3505 gfc_try
3506 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3507 {
3508   gfc_try retval = SUCCESS;
3509   
3510   /* TODO: Do we need to make sure the vars aren't marked private?  */
3511
3512   /* Set the is_bind_c bit in symbol_attribute.  */
3513   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);
3514
3515   if (set_binding_label (tmp_sym->binding_label, tmp_sym->name, 
3516                          num_idents) != SUCCESS)
3517     return FAILURE;
3518
3519   return retval;
3520 }
3521
3522
3523 /* Set the fields marking the given common block as BIND(C), including
3524    a binding label, and report any errors encountered.  */
3525
3526 gfc_try
3527 set_verify_bind_c_com_block (gfc_common_head *com_block, int num_idents)
3528 {
3529   gfc_try retval = SUCCESS;
3530   
3531   /* destLabel, common name, typespec (which may have binding label).  */
3532   if (set_binding_label (com_block->binding_label, com_block->name, num_idents)
3533       != SUCCESS)
3534     return FAILURE;
3535
3536   /* Set the given common block (com_block) to being bind(c) (1).  */
3537   set_com_block_bind_c (com_block, 1);
3538
3539   return retval;
3540 }
3541
3542
3543 /* Retrieve the list of one or more identifiers that the given bind(c)
3544    attribute applies to.  */
3545
3546 gfc_try
3547 get_bind_c_idents (void)
3548 {
3549   char name[GFC_MAX_SYMBOL_LEN + 1];
3550   int num_idents = 0;
3551   gfc_symbol *tmp_sym = NULL;
3552   match found_id;
3553   gfc_common_head *com_block = NULL;
3554   
3555   if (gfc_match_name (name) == MATCH_YES)
3556     {
3557       found_id = MATCH_YES;
3558       gfc_get_ha_symbol (name, &tmp_sym);
3559     }
3560   else if (match_common_name (name) == MATCH_YES)
3561     {
3562       found_id = MATCH_YES;
3563       com_block = gfc_get_common (name, 0);
3564     }
3565   else
3566     {
3567       gfc_error ("Need either entity or common block name for "
3568                  "attribute specification statement at %C");
3569       return FAILURE;
3570     }
3571    
3572   /* Save the current identifier and look for more.  */
3573   do
3574     {
3575       /* Increment the number of identifiers found for this spec stmt.  */
3576       num_idents++;
3577
3578       /* Make sure we have a sym or com block, and verify that it can
3579          be bind(c).  Set the appropriate field(s) and look for more
3580          identifiers.  */
3581       if (tmp_sym != NULL || com_block != NULL)         
3582         {
3583           if (tmp_sym != NULL)
3584             {
3585               if (set_verify_bind_c_sym (tmp_sym, num_idents)
3586                   != SUCCESS)
3587                 return FAILURE;
3588             }
3589           else
3590             {
3591               if (set_verify_bind_c_com_block(com_block, num_idents)
3592                   != SUCCESS)
3593                 return FAILURE;
3594             }
3595          
3596           /* Look to see if we have another identifier.  */
3597           tmp_sym = NULL;
3598           if (gfc_match_eos () == MATCH_YES)
3599             found_id = MATCH_NO;
3600           else if (gfc_match_char (',') != MATCH_YES)
3601             found_id = MATCH_NO;
3602           else if (gfc_match_name (name) == MATCH_YES)
3603             {
3604               found_id = MATCH_YES;
3605               gfc_get_ha_symbol (name, &tmp_sym);
3606             }
3607           else if (match_common_name (name) == MATCH_YES)
3608             {
3609               found_id = MATCH_YES;
3610               com_block = gfc_get_common (name, 0);
3611             }
3612           else
3613             {
3614               gfc_error ("Missing entity or common block name for "
3615                          "attribute specification statement at %C");
3616               return FAILURE;
3617             }
3618         }
3619       else
3620         {
3621           gfc_internal_error ("Missing symbol");
3622         }
3623     } while (found_id == MATCH_YES);
3624
3625   /* if we get here we were successful */
3626   return SUCCESS;
3627 }
3628
3629
3630 /* Try and match a BIND(C) attribute specification statement.  */
3631    
3632 match
3633 gfc_match_bind_c_stmt (void)
3634 {
3635   match found_match = MATCH_NO;
3636   gfc_typespec *ts;
3637
3638   ts = &current_ts;
3639   
3640   /* This may not be necessary.  */
3641   gfc_clear_ts (ts);
3642   /* Clear the temporary binding label holder.  */
3643   curr_binding_label[0] = '\0';
3644
3645   /* Look for the bind(c).  */
3646   found_match = gfc_match_bind_c (NULL, true);
3647
3648   if (found_match == MATCH_YES)
3649     {
3650       /* Look for the :: now, but it is not required.  */
3651       gfc_match (" :: ");
3652
3653       /* Get the identifier(s) that needs to be updated.  This may need to
3654          change to hand the flag(s) for the attr specified so all identifiers
3655          found can have all appropriate parts updated (assuming that the same
3656          spec stmt can have multiple attrs, such as both bind(c) and
3657          allocatable...).  */
3658       if (get_bind_c_idents () != SUCCESS)
3659         /* Error message should have printed already.  */
3660         return MATCH_ERROR;
3661     }
3662
3663   return found_match;
3664 }
3665
3666
3667 /* Match a data declaration statement.  */
3668
3669 match
3670 gfc_match_data_decl (void)
3671 {
3672   gfc_symbol *sym;
3673   match m;
3674   int elem;
3675
3676   num_idents_on_line = 0;
3677   
3678   m = gfc_match_type_spec (&current_ts, 0);
3679   if (m != MATCH_YES)
3680     return m;
3681
3682   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
3683     {
3684       sym = gfc_use_derived (current_ts.u.derived);
3685
3686       if (sym == NULL)
3687         {
3688           m = MATCH_ERROR;
3689           goto cleanup;
3690         }
3691
3692       current_ts.u.derived = sym;
3693     }
3694
3695   m = match_attr_spec ();
3696   if (m == MATCH_ERROR)
3697     {
3698       m = MATCH_NO;
3699       goto cleanup;
3700     }
3701
3702   if (current_ts.type == BT_DERIVED && current_ts.u.derived->components == NULL
3703       && !current_ts.u.derived->attr.zero_comp)
3704     {
3705
3706       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
3707         goto ok;
3708
3709       gfc_find_symbol (current_ts.u.derived->name,
3710                        current_ts.u.derived->ns->parent, 1, &sym);
3711
3712       /* Any symbol that we find had better be a type definition
3713          which has its components defined.  */
3714       if (sym != NULL && sym->attr.flavor == FL_DERIVED
3715           && (current_ts.u.derived->components != NULL
3716               || current_ts.u.derived->attr.zero_comp))
3717         goto ok;
3718
3719       /* Now we have an error, which we signal, and then fix up
3720          because the knock-on is plain and simple confusing.  */
3721       gfc_error_now ("Derived type at %C has not been previously defined "
3722                      "and so cannot appear in a derived type definition");
3723       current_attr.pointer = 1;
3724       goto ok;
3725     }
3726
3727 ok:
3728   /* If we have an old-style character declaration, and no new-style
3729      attribute specifications, then there a comma is optional between
3730      the type specification and the variable list.  */
3731   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
3732     gfc_match_char (',');
3733
3734   /* Give the types/attributes to symbols that follow. Give the element
3735      a number so that repeat character length expressions can be copied.  */
3736   elem = 1;
3737   for (;;)
3738     {
3739       num_idents_on_line++;
3740       m = variable_decl (elem++);
3741       if (m == MATCH_ERROR)
3742         goto cleanup;
3743       if (m == MATCH_NO)
3744         break;
3745
3746       if (gfc_match_eos () == MATCH_YES)
3747         goto cleanup;
3748       if (gfc_match_char (',') != MATCH_YES)
3749         break;
3750     }
3751
3752   if (gfc_error_flag_test () == 0)
3753     gfc_error ("Syntax error in data declaration at %C");
3754   m = MATCH_ERROR;
3755
3756   gfc_free_data_all (gfc_current_ns);
3757
3758 cleanup:
3759   gfc_free_array_spec (current_as);
3760   current_as = NULL;
3761   return m;
3762 }
3763
3764
3765 /* Match a prefix associated with a function or subroutine
3766    declaration.  If the typespec pointer is nonnull, then a typespec
3767    can be matched.  Note that if nothing matches, MATCH_YES is
3768    returned (the null string was matched).  */
3769
3770 match
3771 gfc_match_prefix (gfc_typespec *ts)
3772 {
3773   bool seen_type;
3774
3775   gfc_clear_attr (&current_attr);
3776   seen_type = 0;
3777
3778   gcc_assert (!gfc_matching_prefix);
3779   gfc_matching_prefix = true;
3780
3781 loop:
3782   if (!seen_type && ts != NULL
3783       && gfc_match_type_spec (ts, 0) == MATCH_YES
3784       && gfc_match_space () == MATCH_YES)
3785     {
3786
3787       seen_type = 1;
3788       goto loop;
3789     }
3790
3791   if (gfc_match ("elemental% ") == MATCH_YES)
3792     {
3793       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
3794         goto error;
3795
3796       goto loop;
3797     }
3798
3799   if (gfc_match ("pure% ") == MATCH_YES)
3800     {
3801       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
3802         goto error;
3803
3804       goto loop;
3805     }
3806
3807   if (gfc_match ("recursive% ") == MATCH_YES)
3808     {
3809       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
3810         goto error;
3811
3812       goto loop;
3813     }
3814
3815   /* At this point, the next item is not a prefix.  */
3816   gcc_assert (gfc_matching_prefix);
3817   gfc_matching_prefix = false;
3818   return MATCH_YES;
3819
3820 error:
3821   gcc_assert (gfc_matching_prefix);
3822   gfc_matching_prefix = false;
3823   return MATCH_ERROR;
3824 }
3825
3826
3827 /* Copy attributes matched by gfc_match_prefix() to attributes on a symbol.  */
3828
3829 static gfc_try
3830 copy_prefix (symbol_attribute *dest, locus *where)
3831 {
3832   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
3833     return FAILURE;
3834
3835   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
3836     return FAILURE;
3837
3838   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
3839     return FAILURE;
3840
3841   return SUCCESS;
3842 }
3843
3844
3845 /* Match a formal argument list.  */
3846
3847 match
3848 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
3849 {
3850   gfc_formal_arglist *head, *tail, *p, *q;
3851   char name[GFC_MAX_SYMBOL_LEN + 1];
3852   gfc_symbol *sym;
3853   match m;
3854
3855   head = tail = NULL;
3856
3857   if (gfc_match_char ('(') != MATCH_YES)
3858     {
3859       if (null_flag)
3860         goto ok;
3861       return MATCH_NO;
3862     }
3863
3864   if (gfc_match_char (')') == MATCH_YES)
3865     goto ok;
3866
3867   for (;;)
3868     {
3869       if (gfc_match_char ('*') == MATCH_YES)
3870         sym = NULL;
3871       else
3872         {
3873           m = gfc_match_name (name);
3874           if (m != MATCH_YES)
3875             goto cleanup;
3876
3877           if (gfc_get_symbol (name, NULL, &sym))
3878             goto cleanup;
3879         }
3880
3881       p = gfc_get_formal_arglist ();
3882
3883       if (head == NULL)
3884         head = tail = p;
3885       else
3886         {
3887           tail->next = p;
3888           tail = p;
3889         }
3890
3891       tail->sym = sym;
3892
3893       /* We don't add the VARIABLE flavor because the name could be a
3894          dummy procedure.  We don't apply these attributes to formal
3895          arguments of statement functions.  */
3896       if (sym != NULL && !st_flag
3897           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
3898               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
3899         {
3900           m = MATCH_ERROR;
3901           goto cleanup;
3902         }
3903
3904       /* The name of a program unit can be in a different namespace,
3905          so check for it explicitly.  After the statement is accepted,
3906          the name is checked for especially in gfc_get_symbol().  */
3907       if (gfc_new_block != NULL && sym != NULL
3908           && strcmp (sym->name, gfc_new_block->name) == 0)
3909         {
3910           gfc_error ("Name '%s' at %C is the name of the procedure",
3911                      sym->name);
3912           m = MATCH_ERROR;
3913           goto cleanup;
3914         }
3915
3916       if (gfc_match_char (')') == MATCH_YES)
3917         goto ok;
3918
3919       m = gfc_match_char (',');
3920       if (m != MATCH_YES)
3921         {
3922           gfc_error ("Unexpected junk in formal argument list at %C");
3923           goto cleanup;
3924         }
3925     }
3926
3927 ok:
3928   /* Check for duplicate symbols in the formal argument list.  */
3929   if (head != NULL)
3930     {
3931       for (p = head; p->next; p = p->next)
3932         {
3933           if (p->sym == NULL)
3934             continue;
3935
3936           for (q = p->next; q; q = q->next)
3937             if (p->sym == q->sym)
3938               {
3939                 gfc_error ("Duplicate symbol '%s' in formal argument list "
3940                            "at %C", p->sym->name);
3941
3942                 m = MATCH_ERROR;
3943                 goto cleanup;
3944               }
3945         }
3946     }
3947
3948   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
3949       == FAILURE)
3950     {
3951       m = MATCH_ERROR;
3952       goto cleanup;
3953     }
3954
3955   return MATCH_YES;
3956
3957 cleanup:
3958   gfc_free_formal_arglist (head);
3959   return m;
3960 }
3961
3962
3963 /* Match a RESULT specification following a function declaration or
3964    ENTRY statement.  Also matches the end-of-statement.  */
3965
3966 static match
3967 match_result (gfc_symbol *function, gfc_symbol **result)
3968 {
3969   char name[GFC_MAX_SYMBOL_LEN + 1];
3970   gfc_symbol *r;
3971   match m;
3972
3973   if (gfc_match (" result (") != MATCH_YES)
3974     return MATCH_NO;
3975
3976   m = gfc_match_name (name);
3977   if (m != MATCH_YES)
3978     return m;
3979
3980   /* Get the right paren, and that's it because there could be the
3981      bind(c) attribute after the result clause.  */
3982   if (gfc_match_char(')') != MATCH_YES)
3983     {
3984      /* TODO: should report the missing right paren here.  */
3985       return MATCH_ERROR;
3986     }
3987
3988   if (strcmp (function->name, name) == 0)
3989     {
3990       gfc_error ("RESULT variable at %C must be different than function name");
3991       return MATCH_ERROR;
3992     }
3993
3994   if (gfc_get_symbol (name, NULL, &r))
3995     return MATCH_ERROR;
3996
3997   if (gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
3998     return MATCH_ERROR;
3999
4000   *result = r;
4001
4002   return MATCH_YES;
4003 }
4004
4005
4006 /* Match a function suffix, which could be a combination of a result
4007    clause and BIND(C), either one, or neither.  The draft does not
4008    require them to come in a specific order.  */
4009
4010 match
4011 gfc_match_suffix (gfc_symbol *sym, gfc_symbol **result)
4012 {
4013   match is_bind_c;   /* Found bind(c).  */
4014   match is_result;   /* Found result clause.  */
4015   match found_match; /* Status of whether we've found a good match.  */
4016   char peek_char;    /* Character we're going to peek at.  */
4017   bool allow_binding_name;
4018
4019   /* Initialize to having found nothing.  */
4020   found_match = MATCH_NO;
4021   is_bind_c = MATCH_NO; 
4022   is_result = MATCH_NO;
4023
4024   /* Get the next char to narrow between result and bind(c).  */
4025   gfc_gobble_whitespace ();
4026   peek_char = gfc_peek_ascii_char ();
4027
4028   /* C binding names are not allowed for internal procedures.  */
4029   if (gfc_current_state () == COMP_CONTAINS
4030       && sym->ns->proc_name->attr.flavor != FL_MODULE)
4031     allow_binding_name = false;
4032   else
4033     allow_binding_name = true;
4034
4035   switch (peek_char)
4036     {
4037     case 'r':
4038       /* Look for result clause.  */
4039       is_result = match_result (sym, result);
4040       if (is_result == MATCH_YES)
4041         {
4042           /* Now see if there is a bind(c) after it.  */
4043           is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
4044           /* We've found the result clause and possibly bind(c).  */
4045           found_match = MATCH_YES;
4046         }
4047       else
4048         /* This should only be MATCH_ERROR.  */
4049         found_match = is_result; 
4050       break;
4051     case 'b':
4052       /* Look for bind(c) first.  */
4053       is_bind_c = gfc_match_bind_c (sym, allow_binding_name);
4054       if (is_bind_c == MATCH_YES)
4055         {
4056           /* Now see if a result clause followed it.  */
4057           is_result = match_result (sym, result);
4058           found_match = MATCH_YES;
4059         }
4060       else
4061         {
4062           /* Should only be a MATCH_ERROR if we get here after seeing 'b'.  */
4063           found_match = MATCH_ERROR;
4064         }
4065       break;
4066     default:
4067       gfc_error ("Unexpected junk after function declaration at %C");
4068       found_match = MATCH_ERROR;
4069       break;
4070     }
4071
4072   if (is_bind_c == MATCH_YES)
4073     {
4074       /* Fortran 2008 draft allows BIND(C) for internal procedures.  */
4075       if (gfc_current_state () == COMP_CONTAINS
4076           && sym->ns->proc_name->attr.flavor != FL_MODULE
4077           && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BIND(C) attribute "
4078                              "at %L may not be specified for an internal "
4079                              "procedure", &gfc_current_locus)
4080              == FAILURE)
4081         return MATCH_ERROR;
4082
4083       if (gfc_add_is_bind_c (&(sym->attr), sym->name, &gfc_current_locus, 1)
4084           == FAILURE)
4085         return MATCH_ERROR;
4086     }
4087   
4088   return found_match;
4089 }
4090
4091
4092 /* Procedure pointer return value without RESULT statement:
4093    Add "hidden" result variable named "ppr@".  */
4094
4095 static gfc_try
4096 add_hidden_procptr_result (gfc_symbol *sym)
4097 {
4098   bool case1,case2;
4099
4100   if (gfc_notification_std (GFC_STD_F2003) == ERROR)
4101     return FAILURE;
4102
4103   /* First usage case: PROCEDURE and EXTERNAL statements.  */
4104   case1 = gfc_current_state () == COMP_FUNCTION && gfc_current_block ()
4105           && strcmp (gfc_current_block ()->name, sym->name) == 0
4106           && sym->attr.external;
4107   /* Second usage case: INTERFACE statements.  */
4108   case2 = gfc_current_state () == COMP_INTERFACE && gfc_state_stack->previous
4109           && gfc_state_stack->previous->state == COMP_FUNCTION
4110           && strcmp (gfc_state_stack->previous->sym->name, sym->name) == 0;
4111
4112   if (case1 || case2)
4113     {
4114       gfc_symtree *stree;
4115       if (case1)
4116         gfc_get_sym_tree ("ppr@", gfc_current_ns, &stree, false);
4117       else if (case2)
4118         {
4119           gfc_symtree *st2;
4120           gfc_get_sym_tree ("ppr@", gfc_current_ns->parent, &stree, false);
4121           st2 = gfc_new_symtree (&gfc_current_ns->sym_root, "ppr@");
4122           st2->n.sym = stree->n.sym;
4123         }
4124       sym->result = stree->n.sym;
4125
4126       sym->result->attr.proc_pointer = sym->attr.proc_pointer;
4127       sym->result->attr.pointer = sym->attr.pointer;
4128       sym->result->attr.external = sym->attr.external;
4129       sym->result->attr.referenced = sym->attr.referenced;
4130       sym->result->ts = sym->ts;
4131       sym->attr.proc_pointer = 0;
4132       sym->attr.pointer = 0;
4133       sym->attr.external = 0;
4134       if (sym->result->attr.external && sym->result->attr.pointer)
4135         {
4136           sym->result->attr.pointer = 0;
4137           sym->result->attr.proc_pointer = 1;
4138         }
4139
4140       return gfc_add_result (&sym->result->attr, sym->result->name, NULL);
4141     }
4142   /* POINTER after PROCEDURE/EXTERNAL/INTERFACE statement.  */
4143   else if (sym->attr.function && !sym->attr.external && sym->attr.pointer
4144            && sym->result && sym->result != sym && sym->result->attr.external
4145            && sym == gfc_current_ns->proc_name
4146            && sym == sym->result->ns->proc_name
4147            && strcmp ("ppr@", sym->result->name) == 0)
4148     {
4149       sym->result->attr.proc_pointer = 1;
4150       sym->attr.pointer = 0;
4151       return SUCCESS;
4152     }
4153   else
4154     return FAILURE;
4155 }
4156
4157
4158 /* Match the interface for a PROCEDURE declaration,
4159    including brackets (R1212).  */
416