OSDN Git Service

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