OSDN Git Service

2009-08-31 Janus Weil <janus@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / decl.c
1 /* Declaration statement matcher
2    Copyright (C) 2002, 2004, 2005, 2006, 2007, 2008, 2009
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 declaration-type-spec (F03:R502).  If successful, sets the ts
2271    structure 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_decl_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       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: CLASS statement at %C")
2381                           == FAILURE)
2382         return MATCH_ERROR;
2383
2384       /* TODO: Implement Polymorphism.  */
2385       gfc_warning ("Polymorphic entities are not yet implemented. "
2386                    "CLASS will be treated like TYPE at %C");
2387     }
2388
2389   ts->type = BT_DERIVED;
2390
2391   /* Defer association of the derived type until the end of the
2392      specification block.  However, if the derived type can be
2393      found, add it to the typespec.  */  
2394   if (gfc_matching_function)
2395     {
2396       ts->u.derived = NULL;
2397       if (gfc_current_state () != COMP_INTERFACE
2398             && !gfc_find_symbol (name, NULL, 1, &sym) && sym)
2399         ts->u.derived = sym;
2400       return MATCH_YES;
2401     }
2402
2403   /* Search for the name but allow the components to be defined later.  If
2404      type = -1, this typespec has been seen in a function declaration but
2405      the type could not be accessed at that point.  */
2406   sym = NULL;
2407   if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
2408     {
2409       gfc_error ("Type name '%s' at %C is ambiguous", name);
2410       return MATCH_ERROR;
2411     }
2412   else if (ts->kind == -1)
2413     {
2414       int iface = gfc_state_stack->previous->state != COMP_INTERFACE
2415                     || gfc_current_ns->has_import_set;
2416       if (gfc_find_symbol (name, NULL, iface, &sym))
2417         {       
2418           gfc_error ("Type name '%s' at %C is ambiguous", name);
2419           return MATCH_ERROR;
2420         }
2421
2422       ts->kind = 0;
2423       if (sym == NULL)
2424         return MATCH_NO;
2425     }
2426
2427   if (sym->attr.flavor != FL_DERIVED
2428       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
2429     return MATCH_ERROR;
2430
2431   gfc_set_sym_referenced (sym);
2432   ts->u.derived = sym;
2433
2434   return MATCH_YES;
2435
2436 get_kind:
2437   /* For all types except double, derived and character, look for an
2438      optional kind specifier.  MATCH_NO is actually OK at this point.  */
2439   if (implicit_flag == 1)
2440     return MATCH_YES;
2441
2442   if (gfc_current_form == FORM_FREE)
2443     {
2444       c = gfc_peek_ascii_char ();
2445       if (!gfc_is_whitespace (c) && c != '*' && c != '('
2446           && c != ':' && c != ',')
2447        return MATCH_NO;
2448     }
2449
2450   m = gfc_match_kind_spec (ts, false);
2451   if (m == MATCH_NO && ts->type != BT_CHARACTER)
2452     m = gfc_match_old_kind_spec (ts);
2453
2454   /* Defer association of the KIND expression of function results
2455      until after USE and IMPORT statements.  */
2456   if ((gfc_current_state () == COMP_NONE && gfc_error_flag_test ())
2457          || gfc_matching_function)
2458     return MATCH_YES;
2459
2460   if (m == MATCH_NO)
2461     m = MATCH_YES;              /* No kind specifier found.  */
2462
2463   return m;
2464 }
2465
2466
2467 /* Match an IMPLICIT NONE statement.  Actually, this statement is
2468    already matched in parse.c, or we would not end up here in the
2469    first place.  So the only thing we need to check, is if there is
2470    trailing garbage.  If not, the match is successful.  */
2471
2472 match
2473 gfc_match_implicit_none (void)
2474 {
2475   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
2476 }
2477
2478
2479 /* Match the letter range(s) of an IMPLICIT statement.  */
2480
2481 static match
2482 match_implicit_range (void)
2483 {
2484   char c, c1, c2;
2485   int inner;
2486   locus cur_loc;
2487
2488   cur_loc = gfc_current_locus;
2489
2490   gfc_gobble_whitespace ();
2491   c = gfc_next_ascii_char ();
2492   if (c != '(')
2493     {
2494       gfc_error ("Missing character range in IMPLICIT at %C");
2495       goto bad;
2496     }
2497
2498   inner = 1;
2499   while (inner)
2500     {
2501       gfc_gobble_whitespace ();
2502       c1 = gfc_next_ascii_char ();
2503       if (!ISALPHA (c1))
2504         goto bad;
2505
2506       gfc_gobble_whitespace ();
2507       c = gfc_next_ascii_char ();
2508
2509       switch (c)
2510         {
2511         case ')':
2512           inner = 0;            /* Fall through.  */
2513
2514         case ',':
2515           c2 = c1;
2516           break;
2517
2518         case '-':
2519           gfc_gobble_whitespace ();
2520           c2 = gfc_next_ascii_char ();
2521           if (!ISALPHA (c2))
2522             goto bad;
2523
2524           gfc_gobble_whitespace ();
2525           c = gfc_next_ascii_char ();
2526
2527           if ((c != ',') && (c != ')'))
2528             goto bad;
2529           if (c == ')')
2530             inner = 0;
2531
2532           break;
2533
2534         default:
2535           goto bad;
2536         }
2537
2538       if (c1 > c2)
2539         {
2540           gfc_error ("Letters must be in alphabetic order in "
2541                      "IMPLICIT statement at %C");
2542           goto bad;
2543         }
2544
2545       /* See if we can add the newly matched range to the pending
2546          implicits from this IMPLICIT statement.  We do not check for
2547          conflicts with whatever earlier IMPLICIT statements may have
2548          set.  This is done when we've successfully finished matching
2549          the current one.  */
2550       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
2551         goto bad;
2552     }
2553
2554   return MATCH_YES;
2555
2556 bad:
2557   gfc_syntax_error (ST_IMPLICIT);
2558
2559   gfc_current_locus = cur_loc;
2560   return MATCH_ERROR;
2561 }
2562
2563
2564 /* Match an IMPLICIT statement, storing the types for
2565    gfc_set_implicit() if the statement is accepted by the parser.
2566    There is a strange looking, but legal syntactic construction
2567    possible.  It looks like:
2568
2569      IMPLICIT INTEGER (a-b) (c-d)
2570
2571    This is legal if "a-b" is a constant expression that happens to
2572    equal one of the legal kinds for integers.  The real problem
2573    happens with an implicit specification that looks like:
2574
2575      IMPLICIT INTEGER (a-b)
2576
2577    In this case, a typespec matcher that is "greedy" (as most of the
2578    matchers are) gobbles the character range as a kindspec, leaving
2579    nothing left.  We therefore have to go a bit more slowly in the
2580    matching process by inhibiting the kindspec checking during
2581    typespec matching and checking for a kind later.  */
2582
2583 match
2584 gfc_match_implicit (void)
2585 {
2586   gfc_typespec ts;
2587   locus cur_loc;
2588   char c;
2589   match m;
2590
2591   gfc_clear_ts (&ts);
2592
2593   /* We don't allow empty implicit statements.  */
2594   if (gfc_match_eos () == MATCH_YES)
2595     {
2596       gfc_error ("Empty IMPLICIT statement at %C");
2597       return MATCH_ERROR;
2598     }
2599
2600   do
2601     {
2602       /* First cleanup.  */
2603       gfc_clear_new_implicit ();
2604
2605       /* A basic type is mandatory here.  */
2606       m = gfc_match_decl_type_spec (&ts, 1);
2607       if (m == MATCH_ERROR)
2608         goto error;
2609       if (m == MATCH_NO)
2610         goto syntax;
2611
2612       cur_loc = gfc_current_locus;
2613       m = match_implicit_range ();
2614
2615       if (m == MATCH_YES)
2616         {
2617           /* We may have <TYPE> (<RANGE>).  */
2618           gfc_gobble_whitespace ();
2619           c = gfc_next_ascii_char ();
2620           if ((c == '\n') || (c == ','))
2621             {
2622               /* Check for CHARACTER with no length parameter.  */
2623               if (ts.type == BT_CHARACTER && !ts.u.cl)
2624                 {
2625                   ts.kind = gfc_default_character_kind;
2626                   ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
2627                   ts.u.cl->length = gfc_int_expr (1);
2628                 }
2629
2630               /* Record the Successful match.  */
2631               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2632                 return MATCH_ERROR;
2633               continue;
2634             }
2635
2636           gfc_current_locus = cur_loc;
2637         }
2638
2639       /* Discard the (incorrectly) matched range.  */
2640       gfc_clear_new_implicit ();
2641
2642       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2643       if (ts.type == BT_CHARACTER)
2644         m = gfc_match_char_spec (&ts);
2645       else
2646         {
2647           m = gfc_match_kind_spec (&ts, false);
2648           if (m == MATCH_NO)
2649             {
2650               m = gfc_match_old_kind_spec (&ts);
2651               if (m == MATCH_ERROR)
2652                 goto error;
2653               if (m == MATCH_NO)
2654                 goto syntax;
2655             }
2656         }
2657       if (m == MATCH_ERROR)
2658         goto error;
2659
2660       m = match_implicit_range ();
2661       if (m == MATCH_ERROR)
2662         goto error;
2663       if (m == MATCH_NO)
2664         goto syntax;
2665
2666       gfc_gobble_whitespace ();
2667       c = gfc_next_ascii_char ();
2668       if ((c != '\n') && (c != ','))
2669         goto syntax;
2670
2671       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2672         return MATCH_ERROR;
2673     }
2674   while (c == ',');
2675
2676   return MATCH_YES;
2677
2678 syntax:
2679   gfc_syntax_error (ST_IMPLICIT);
2680
2681 error:
2682   return MATCH_ERROR;
2683 }
2684
2685
2686 match
2687 gfc_match_import (void)
2688 {
2689   char name[GFC_MAX_SYMBOL_LEN + 1];
2690   match m;
2691   gfc_symbol *sym;
2692   gfc_symtree *st;
2693
2694   if (gfc_current_ns->proc_name == NULL
2695       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2696     {
2697       gfc_error ("IMPORT statement at %C only permitted in "
2698                  "an INTERFACE body");
2699       return MATCH_ERROR;
2700     }
2701
2702   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2703       == FAILURE)
2704     return MATCH_ERROR;
2705
2706   if (gfc_match_eos () == MATCH_YES)
2707     {
2708       /* All host variables should be imported.  */
2709       gfc_current_ns->has_import_set = 1;
2710       return MATCH_YES;
2711     }
2712
2713   if (gfc_match (" ::") == MATCH_YES)
2714     {
2715       if (gfc_match_eos () == MATCH_YES)
2716         {
2717            gfc_error ("Expecting list of named entities at %C");
2718            return MATCH_ERROR;
2719         }
2720     }
2721
2722   for(;;)
2723     {
2724       m = gfc_match (" %n", name);
2725       switch (m)
2726         {
2727         case MATCH_YES:
2728           if (gfc_current_ns->parent !=  NULL
2729               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2730             {
2731                gfc_error ("Type name '%s' at %C is ambiguous", name);
2732                return MATCH_ERROR;
2733             }
2734           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2735                    && gfc_find_symbol (name,
2736                                        gfc_current_ns->proc_name->ns->parent,
2737                                        1, &sym))
2738             {
2739                gfc_error ("Type name '%s' at %C is ambiguous", name);
2740                return MATCH_ERROR;
2741             }
2742
2743           if (sym == NULL)
2744             {
2745               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2746                          "at %C - does not exist.", name);
2747               return MATCH_ERROR;
2748             }
2749
2750           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2751             {
2752               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2753                            "at %C.", name);
2754               goto next_item;
2755             }
2756
2757           st = gfc_new_symtree (&gfc_current_ns->sym_root, sym->name);
2758           st->n.sym = sym;
2759           sym->refs++;
2760           sym->attr.imported = 1;
2761
2762           goto next_item;
2763
2764         case MATCH_NO:
2765           break;
2766
2767         case MATCH_ERROR:
2768           return MATCH_ERROR;
2769         }
2770
2771     next_item:
2772       if (gfc_match_eos () == MATCH_YES)
2773         break;
2774       if (gfc_match_char (',') != MATCH_YES)
2775         goto syntax;
2776     }
2777
2778   return MATCH_YES;
2779
2780 syntax:
2781   gfc_error ("Syntax error in IMPORT statement at %C");
2782   return MATCH_ERROR;
2783 }
2784
2785
2786 /* A minimal implementation of gfc_match without whitespace, escape
2787    characters or variable arguments.  Returns true if the next
2788    characters match the TARGET template exactly.  */
2789
2790 static bool
2791 match_string_p (const char *target)
2792 {
2793   const char *p;
2794
2795   for (p = target; *p; p++)
2796     if ((char) gfc_next_ascii_char () != *p)
2797       return false;
2798   return true;
2799 }
2800
2801 /* Matches an attribute specification including array specs.  If
2802    successful, leaves the variables current_attr and current_as
2803    holding the specification.  Also sets the colon_seen variable for
2804    later use by matchers associated with initializations.
2805
2806    This subroutine is a little tricky in the sense that we don't know
2807    if we really have an attr-spec until we hit the double colon.
2808    Until that time, we can only return MATCH_NO.  This forces us to
2809    check for duplicate specification at this level.  */
2810
2811 static match
2812 match_attr_spec (void)
2813 {
2814   /* Modifiers that can exist in a type statement.  */
2815   typedef enum
2816   { GFC_DECL_BEGIN = 0,
2817     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2818     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2819     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2820     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2821     DECL_IS_BIND_C, DECL_NONE,
2822     GFC_DECL_END /* Sentinel */
2823   }
2824   decl_types;
2825
2826 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2827 #define NUM_DECL GFC_DECL_END
2828
2829   locus start, seen_at[NUM_DECL];
2830   int seen[NUM_DECL];
2831   unsigned int d;
2832   const char *attr;
2833   match m;
2834   gfc_try t;
2835
2836   gfc_clear_attr (&current_attr);
2837   start = gfc_current_locus;
2838
2839   current_as = NULL;
2840   colon_seen = 0;
2841
2842   /* See if we get all of the keywords up to the final double colon.  */
2843   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2844     seen[d] = 0;
2845
2846   for (;;)
2847     {
2848       char ch;
2849
2850       d = DECL_NONE;
2851       gfc_gobble_whitespace ();
2852
2853       ch = gfc_next_ascii_char ();
2854       if (ch == ':')
2855         {
2856           /* This is the successful exit condition for the loop.  */
2857           if (gfc_next_ascii_char () == ':')
2858             break;
2859         }
2860       else if (ch == ',')
2861         {
2862           gfc_gobble_whitespace ();
2863           switch (gfc_peek_ascii_char ())
2864             {
2865             case 'a':
2866               if (match_string_p ("allocatable"))
2867                 d = DECL_ALLOCATABLE;
2868               break;
2869
2870             case 'b':
2871               /* Try and match the bind(c).  */
2872               m = gfc_match_bind_c (NULL, true);
2873               if (m == MATCH_YES)
2874                 d = DECL_IS_BIND_C;
2875               else if (m == MATCH_ERROR)
2876                 goto cleanup;
2877               break;
2878
2879             case 'd':
2880               if (match_string_p ("dimension"))
2881                 d = DECL_DIMENSION;
2882               break;
2883
2884             case 'e':
2885               if (match_string_p ("external"))
2886                 d = DECL_EXTERNAL;
2887               break;
2888
2889             case 'i':
2890               if (match_string_p ("int"))
2891                 {
2892                   ch = gfc_next_ascii_char ();
2893                   if (ch == 'e')
2894                     {
2895                       if (match_string_p ("nt"))
2896                         {
2897                           /* Matched "intent".  */
2898                           /* TODO: Call match_intent_spec from here.  */
2899                           if (gfc_match (" ( in out )") == MATCH_YES)
2900                             d = DECL_INOUT;
2901                           else if (gfc_match (" ( in )") == MATCH_YES)
2902                             d = DECL_IN;
2903                           else if (gfc_match (" ( out )") == MATCH_YES)
2904                             d = DECL_OUT;
2905                         }
2906                     }
2907                   else if (ch == 'r')
2908                     {
2909                       if (match_string_p ("insic"))
2910                         {
2911                           /* Matched "intrinsic".  */
2912                           d = DECL_INTRINSIC;
2913                         }
2914                     }
2915                 }
2916               break;
2917
2918             case 'o':
2919               if (match_string_p ("optional"))
2920                 d = DECL_OPTIONAL;
2921               break;
2922
2923             case 'p':
2924               gfc_next_ascii_char ();
2925               switch (gfc_next_ascii_char ())
2926                 {
2927                 case 'a':
2928                   if (match_string_p ("rameter"))
2929                     {
2930                       /* Matched "parameter".  */
2931                       d = DECL_PARAMETER;
2932                     }
2933                   break;
2934
2935                 case 'o':
2936                   if (match_string_p ("inter"))
2937                     {
2938                       /* Matched "pointer".  */
2939                       d = DECL_POINTER;
2940                     }
2941                   break;
2942
2943                 case 'r':
2944                   ch = gfc_next_ascii_char ();
2945                   if (ch == 'i')
2946                     {
2947                       if (match_string_p ("vate"))
2948                         {
2949                           /* Matched "private".  */
2950                           d = DECL_PRIVATE;
2951                         }
2952                     }
2953                   else if (ch == 'o')
2954                     {
2955                       if (match_string_p ("tected"))
2956                         {
2957                           /* Matched "protected".  */
2958                           d = DECL_PROTECTED;
2959                         }
2960                     }
2961                   break;
2962
2963                 case 'u':
2964                   if (match_string_p ("blic"))
2965                     {
2966                       /* Matched "public".  */
2967                       d = DECL_PUBLIC;
2968                     }
2969                   break;
2970                 }
2971               break;
2972
2973             case 's':
2974               if (match_string_p ("save"))
2975                 d = DECL_SAVE;
2976               break;
2977
2978             case 't':
2979               if (match_string_p ("target"))
2980                 d = DECL_TARGET;
2981               break;
2982
2983             case 'v':
2984               gfc_next_ascii_char ();
2985               ch = gfc_next_ascii_char ();
2986               if (ch == 'a')
2987                 {
2988                   if (match_string_p ("lue"))
2989                     {
2990                       /* Matched "value".  */
2991                       d = DECL_VALUE;
2992                     }
2993                 }
2994               else if (ch == 'o')
2995                 {
2996                   if (match_string_p ("latile"))
2997                     {
2998                       /* Matched "volatile".  */
2999                       d = DECL_VOLATILE;
3000                     }
3001                 }
3002               break;
3003             }
3004         }
3005
3006       /* No double colon and no recognizable decl_type, so assume that
3007          we've been looking at something else the whole time.  */
3008       if (d == DECL_NONE)
3009         {
3010           m = MATCH_NO;
3011           goto cleanup;
3012         }
3013
3014       /* Check to make sure any parens are paired up correctly.  */
3015       if (gfc_match_parens () == MATCH_ERROR)
3016         {
3017           m = MATCH_ERROR;
3018           goto cleanup;
3019         }
3020
3021       seen[d]++;
3022       seen_at[d] = gfc_current_locus;
3023
3024       if (d == DECL_DIMENSION)
3025         {
3026           m = gfc_match_array_spec (&current_as);
3027
3028           if (m == MATCH_NO)
3029             {
3030               gfc_error ("Missing dimension specification at %C");
3031               m = MATCH_ERROR;
3032             }
3033
3034           if (m == MATCH_ERROR)
3035             goto cleanup;
3036         }
3037     }
3038
3039   /* Since we've seen a double colon, we have to be looking at an
3040      attr-spec.  This means that we can now issue errors.  */
3041   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3042     if (seen[d] > 1)
3043       {
3044         switch (d)
3045           {
3046           case DECL_ALLOCATABLE:
3047             attr = "ALLOCATABLE";
3048             break;
3049           case DECL_DIMENSION:
3050             attr = "DIMENSION";
3051             break;
3052           case DECL_EXTERNAL:
3053             attr = "EXTERNAL";
3054             break;
3055           case DECL_IN:
3056             attr = "INTENT (IN)";
3057             break;
3058           case DECL_OUT:
3059             attr = "INTENT (OUT)";
3060             break;
3061           case DECL_INOUT:
3062             attr = "INTENT (IN OUT)";
3063             break;
3064           case DECL_INTRINSIC:
3065             attr = "INTRINSIC";
3066             break;
3067           case DECL_OPTIONAL:
3068             attr = "OPTIONAL";
3069             break;
3070           case DECL_PARAMETER:
3071             attr = "PARAMETER";
3072             break;
3073           case DECL_POINTER:
3074             attr = "POINTER";
3075             break;
3076           case DECL_PROTECTED:
3077             attr = "PROTECTED";
3078             break;
3079           case DECL_PRIVATE:
3080             attr = "PRIVATE";
3081             break;
3082           case DECL_PUBLIC:
3083             attr = "PUBLIC";
3084             break;
3085           case DECL_SAVE:
3086             attr = "SAVE";
3087             break;
3088           case DECL_TARGET:
3089             attr = "TARGET";
3090             break;
3091           case DECL_IS_BIND_C:
3092             attr = "IS_BIND_C";
3093             break;
3094           case DECL_VALUE:
3095             attr = "VALUE";
3096             break;
3097           case DECL_VOLATILE:
3098             attr = "VOLATILE";
3099             break;
3100           default:
3101             attr = NULL;        /* This shouldn't happen.  */
3102           }
3103
3104         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
3105         m = MATCH_ERROR;
3106         goto cleanup;
3107       }
3108
3109   /* Now that we've dealt with duplicate attributes, add the attributes
3110      to the current attribute.  */
3111   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
3112     {
3113       if (seen[d] == 0)
3114         continue;
3115
3116       if (gfc_current_state () == COMP_DERIVED
3117           && d != DECL_DIMENSION && d != DECL_POINTER
3118           && d != DECL_PRIVATE   && d != DECL_PUBLIC
3119           && d != DECL_NONE)
3120         {
3121           if (d == DECL_ALLOCATABLE)
3122             {
3123               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
3124                                   "attribute at %C in a TYPE definition")
3125                   == FAILURE)
3126                 {
3127                   m = MATCH_ERROR;
3128                   goto cleanup;
3129                 }
3130             }
3131           else
3132             {
3133               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
3134                          &seen_at[d]);
3135               m = MATCH_ERROR;
3136               goto cleanup;
3137             }
3138         }
3139
3140       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
3141           && gfc_current_state () != COMP_MODULE)
3142         {
3143           if (d == DECL_PRIVATE)
3144             attr = "PRIVATE";
3145           else
3146             attr = "PUBLIC";
3147           if (gfc_current_state () == COMP_DERIVED
3148               && gfc_state_stack->previous
3149               && gfc_state_stack->previous->state == COMP_MODULE)
3150             {
3151               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
3152                                   "at %L in a TYPE definition", attr,
3153                                   &seen_at[d])
3154                   == FAILURE)
3155                 {
3156                   m = MATCH_ERROR;
3157                   goto cleanup;
3158                 }
3159             }
3160           else
3161             {
3162               gfc_error ("%s attribute at %L is not allowed outside of the "
3163                          "specification part of a module", attr, &seen_at[d]);
3164               m = MATCH_ERROR;
3165               goto cleanup;
3166             }
3167         }
3168
3169       switch (d)
3170         {
3171         case DECL_ALLOCATABLE:
3172           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
3173           break;
3174
3175         case DECL_DIMENSION:
3176           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
3177           break;
3178
3179         case DECL_EXTERNAL:
3180           t = gfc_add_external (&current_attr, &seen_at[d]);
3181           break;
3182
3183         case DECL_IN:
3184           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
3185           break;
3186
3187         case DECL_OUT:
3188           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
3189           break;
3190
3191         case DECL_INOUT:
3192           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
3193           break;
3194
3195         case DECL_INTRINSIC:
3196           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
3197           break;
3198
3199         case DECL_OPTIONAL:
3200           t = gfc_add_optional (&current_attr, &seen_at[d]);
3201           break;
3202
3203         case DECL_PARAMETER:
3204           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
3205           break;
3206
3207         case DECL_POINTER:
3208           t = gfc_add_pointer (&current_attr, &seen_at[d]);
3209           break;
3210
3211         case DECL_PROTECTED:
3212           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3213             {
3214                gfc_error ("PROTECTED at %C only allowed in specification "
3215                           "part of a module");
3216                t = FAILURE;
3217                break;
3218             }
3219
3220           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
3221                               "attribute at %C")
3222               == FAILURE)
3223             t = FAILURE;
3224           else
3225             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
3226           break;
3227
3228         case DECL_PRIVATE:
3229           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
3230                               &seen_at[d]);
3231           break;
3232
3233         case DECL_PUBLIC:
3234           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
3235                               &seen_at[d]);
3236           break;
3237
3238         case DECL_SAVE:
3239           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
3240           break;
3241
3242         case DECL_TARGET:
3243           t = gfc_add_target (&current_attr, &seen_at[d]);
3244           break;
3245
3246         case DECL_IS_BIND_C:
3247            t = gfc_add_is_bind_c(&current_attr, NULL, &seen_at[d], 0);
3248            break;
3249            
3250         case DECL_VALUE:
3251           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
3252                               "at %C")
3253               == FAILURE)
3254             t = FAILURE;
3255           else
3256             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
3257           break;
3258
3259         case DECL_VOLATILE:
3260           if (gfc_notify_std (GFC_STD_F2003,
3261                               "Fortran 2003: VOLATILE attribute at %C")
3262               == FAILURE)
3263             t = FAILURE;
3264           else
3265             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
3266           break;
3267
3268         default:
3269           gfc_internal_error ("match_attr_spec(): Bad attribute");
3270         }
3271
3272       if (t == FAILURE)
3273         {
3274           m = MATCH_ERROR;
3275           goto cleanup;
3276         }
3277     }
3278
3279   colon_seen = 1;
3280   return MATCH_YES;
3281
3282 cleanup:
3283   gfc_current_locus = start;
3284   gfc_free_array_spec (current_as);
3285   current_as = NULL;
3286   return m;
3287 }
3288
3289
3290 /* Set the binding label, dest_label, either with the binding label
3291    stored in the given gfc_typespec, ts, or if none was provided, it
3292    will be the symbol name in all lower case, as required by the draft
3293    (J3/04-007, section 15.4.1).  If a binding label was given and
3294    there is more than one argument (num_idents), it is an error.  */
3295
3296 gfc_try
3297 set_binding_label (char *dest_label, const char *sym_name, int num_idents)
3298 {
3299   if (num_idents > 1 && has_name_equals)
3300     {
3301       gfc_error ("Multiple identifiers provided with "
3302                  "single NAME= specifier at %C");
3303       return FAILURE;
3304     }
3305
3306   if (curr_binding_label[0] != '\0')
3307     {
3308       /* Binding label given; store in temp holder til have sym.  */
3309       strcpy (dest_label, curr_binding_label);
3310     }
3311   else
3312     {
3313       /* No binding label given, and the NAME= specifier did not exist,
3314          which means there was no NAME="".  */
3315       if (sym_name != NULL && has_name_equals == 0)
3316         strcpy (dest_label, sym_name);
3317     }
3318    
3319   return SUCCESS;
3320 }
3321
3322
3323 /* Set the status of the given common block as being BIND(C) or not,
3324    depending on the given parameter, is_bind_c.  */
3325
3326 void
3327 set_com_block_bind_c (gfc_common_head *com_block, int is_bind_c)
3328 {
3329   com_block->is_bind_c = is_bind_c;
3330   return;
3331 }
3332
3333
3334 /* Verify that the given gfc_typespec is for a C interoperable type.  */
3335
3336 gfc_try
3337 verify_c_interop (gfc_typespec *ts)
3338 {
3339   if (ts->type == BT_DERIVED && ts->u.derived != NULL)
3340     return (ts->u.derived->ts.is_c_interop ? SUCCESS : FAILURE);
3341   else if (ts->is_c_interop != 1)
3342     return FAILURE;
3343   
3344   return SUCCESS;
3345 }
3346
3347
3348 /* Verify that the variables of a given common block, which has been
3349    defined with the attribute specifier bind(c), to be of a C
3350    interoperable type.  Errors will be reported here, if
3351    encountered.  */
3352
3353 gfc_try
3354 verify_com_block_vars_c_interop (gfc_common_head *com_block)
3355 {
3356   gfc_symbol *curr_sym = NULL;
3357   gfc_try retval = SUCCESS;
3358
3359   curr_sym = com_block->head;
3360   
3361   /* Make sure we have at least one symbol.  */
3362   if (curr_sym == NULL)
3363     return retval;
3364
3365   /* Here we know we have a symbol, so we'll execute this loop
3366      at least once.  */
3367   do
3368     {
3369       /* The second to last param, 1, says this is in a common block.  */
3370       retval = verify_bind_c_sym (curr_sym, &(curr_sym->ts), 1, com_block);
3371       curr_sym = curr_sym->common_next;
3372     } while (curr_sym != NULL); 
3373
3374   return retval;
3375 }
3376
3377
3378 /* Verify that a given BIND(C) symbol is C interoperable.  If it is not,
3379    an appropriate error message is reported.  */
3380
3381 gfc_try
3382 verify_bind_c_sym (gfc_symbol *tmp_sym, gfc_typespec *ts,
3383                    int is_in_common, gfc_common_head *com_block)
3384 {
3385   bool bind_c_function = false;
3386   gfc_try retval = SUCCESS;
3387
3388   if (tmp_sym->attr.function && tmp_sym->attr.is_bind_c)
3389     bind_c_function = true;
3390
3391   if (tmp_sym->attr.function && tmp_sym->result != NULL)
3392     {
3393       tmp_sym = tmp_sym->result;
3394       /* Make sure it wasn't an implicitly typed result.  */
3395       if (tmp_sym->attr.implicit_type)
3396         {
3397           gfc_warning ("Implicitly declared BIND(C) function '%s' at "
3398                        "%L may not be C interoperable", tmp_sym->name,
3399                        &tmp_sym->declared_at);
3400           tmp_sym->ts.f90_type = tmp_sym->ts.type;
3401           /* Mark it as C interoperable to prevent duplicate warnings.  */
3402           tmp_sym->ts.is_c_interop = 1;
3403           tmp_sym->attr.is_c_interop = 1;
3404         }
3405     }
3406
3407   /* Here, we know we have the bind(c) attribute, so if we have
3408      enough type info, then verify that it's a C interop kind.
3409      The info could be in the symbol already, or possibly still in
3410      the given ts (current_ts), so look in both.  */
3411   if (tmp_sym->ts.type != BT_UNKNOWN || ts->type != BT_UNKNOWN) 
3412     {
3413       if (verify_c_interop (&(tmp_sym->ts)) != SUCCESS)
3414         {
3415           /* See if we're dealing with a sym in a common block or not.  */
3416           if (is_in_common == 1)
3417             {
3418               gfc_warning ("Variable '%s' in common block '%s' at %L "
3419                            "may not be a C interoperable "
3420                            "kind though common block '%s' is BIND(C)",
3421                            tmp_sym->name, com_block->name,
3422                            &(tmp_sym->declared_at), com_block->name);
3423             }
3424           else
3425             {
3426               if (tmp_sym->ts.type == BT_DERIVED || ts->type == BT_DERIVED)
3427                 gfc_error ("Type declaration '%s' at %L is not C "
3428                            "interoperable but it is BIND(C)",
3429                            tmp_sym->name, &(tmp_sym->declared_at));
3430               else
3431                 gfc_warning ("Variable '%s' at %L "
3432                              "may not be a C interoperable "
3433                              "kind but it is bind(c)",
3434                              tmp_sym->name, &(tmp_sym->declared_at));
3435             }
3436         }
3437       
3438       /* Variables declared w/in a common block can't be bind(c)
3439          since there's no way for C to see these variables, so there's
3440          semantically no reason for the attribute.  */
3441       if (is_in_common == 1 && tmp_sym->attr.is_bind_c == 1)
3442         {
3443           gfc_error ("Variable '%s' in common block '%s' at "
3444                      "%L cannot be declared with BIND(C) "
3445                      "since it is not a global",
3446                      tmp_sym->name, com_block->name,
3447                      &(tmp_sym->declared_at));
3448           retval = FAILURE;
3449         }
3450       
3451       /* Scalar variables that are bind(c) can not have the pointer
3452          or allocatable attributes.  */
3453       if (tmp_sym->attr.is_bind_c == 1)
3454         {
3455           if (tmp_sym->attr.pointer == 1)
3456             {
3457               gfc_error ("Variable '%s' at %L cannot have both the "
3458                          "POINTER and BIND(C) attributes",
3459                          tmp_sym->name, &(tmp_sym->declared_at));
3460               retval = FAILURE;
3461             }
3462
3463           if (tmp_sym->attr.allocatable == 1)
3464             {
3465               gfc_error ("Variable '%s' at %L cannot have both the "
3466                          "ALLOCATABLE and BIND(C) attributes",
3467                          tmp_sym->name, &(tmp_sym->declared_at));
3468               retval = FAILURE;
3469             }
3470
3471         }
3472
3473       /* If it is a BIND(C) function, make sure the return value is a
3474          scalar value.  The previous tests in this function made sure
3475          the type is interoperable.  */
3476       if (bind_c_function && tmp_sym->as != NULL)
3477         gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3478                    "be an array", tmp_sym->name, &(tmp_sym->declared_at));
3479
3480       /* BIND(C) functions can not return a character string.  */
3481       if (bind_c_function && tmp_sym->ts.type == BT_CHARACTER)
3482         if (tmp_sym->ts.u.cl == NULL || tmp_sym->ts.u.cl->length == NULL
3483             || tmp_sym->ts.u.cl->length->expr_type != EXPR_CONSTANT
3484             || mpz_cmp_si (tmp_sym->ts.u.cl->length->value.integer, 1) != 0)
3485           gfc_error ("Return type of BIND(C) function '%s' at %L cannot "
3486                          "be a character string", tmp_sym->name,
3487                          &(tmp_sym->declared_at));
3488     }
3489
3490   /* See if the symbol has been marked as private.  If it has, make sure
3491      there is no binding label and warn the user if there is one.  */
3492   if (tmp_sym->attr.access == ACCESS_PRIVATE
3493       && tmp_sym->binding_label[0] != '\0')
3494       /* Use gfc_warning_now because we won't say that the symbol fails
3495          just because of this.  */
3496       gfc_warning_now ("Symbol '%s' at %L is marked PRIVATE but has been "
3497                        "given the binding label '%s'", tmp_sym->name,
3498                        &(tmp_sym->declared_at), tmp_sym->binding_label);
3499
3500   return retval;
3501 }
3502
3503
3504 /* Set the appropriate fields for a symbol that's been declared as
3505    BIND(C) (the is_bind_c flag and the binding label), and verify that
3506    the type is C interoperable.  Errors are reported by the functions
3507    used to set/test these fields.  */
3508
3509 gfc_try
3510 set_verify_bind_c_sym (gfc_symbol *tmp_sym, int num_idents)
3511 {
3512   gfc_try retval = SUCCESS;
3513   
3514   /* TODO: Do we need to make sure the vars aren't marked private?  */
3515
3516   /* Set the is_bind_c bit in symbol_attribute.  */
3517   gfc_add_is_bind_c (&(tmp_sym->attr), tmp_sym->name, &gfc_current_locus, 0);