OSDN Git Service

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