OSDN Git Service

* trans.h (gfc_conv_cray_pointee): Remove.
[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    After gimplification, pointee variable will disappear in the code.  */
2999
3000 static match
3001 cray_pointer_decl (void)
3002 {
3003   match m;
3004   gfc_array_spec *as;
3005   gfc_symbol *cptr; /* Pointer symbol.  */
3006   gfc_symbol *cpte; /* Pointee symbol.  */
3007   locus var_locus;
3008   bool done = false;
3009
3010   while (!done)
3011     {
3012       if (gfc_match_char ('(') != MATCH_YES)
3013         {
3014           gfc_error ("Expected '(' at %C");
3015           return MATCH_ERROR;   
3016         }
3017  
3018       /* Match pointer.  */
3019       var_locus = gfc_current_locus;
3020       gfc_clear_attr (&current_attr);
3021       gfc_add_cray_pointer (&current_attr, &var_locus);
3022       current_ts.type = BT_INTEGER;
3023       current_ts.kind = gfc_index_integer_kind;
3024
3025       m = gfc_match_symbol (&cptr, 0);  
3026       if (m != MATCH_YES)
3027         {
3028           gfc_error ("Expected variable name at %C");
3029           return m;
3030         }
3031   
3032       if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3033         return MATCH_ERROR;
3034
3035       gfc_set_sym_referenced (cptr);      
3036
3037       if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
3038         {
3039           cptr->ts.type = BT_INTEGER;
3040           cptr->ts.kind = gfc_index_integer_kind; 
3041         }
3042       else if (cptr->ts.type != BT_INTEGER)
3043         {
3044           gfc_error ("Cray pointer at %C must be an integer.");
3045           return MATCH_ERROR;
3046         }
3047       else if (cptr->ts.kind < gfc_index_integer_kind)
3048         gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3049                      " memory addresses require %d bytes.",
3050                      cptr->ts.kind,
3051                      gfc_index_integer_kind);
3052
3053       if (gfc_match_char (',') != MATCH_YES)
3054         {
3055           gfc_error ("Expected \",\" at %C");
3056           return MATCH_ERROR;    
3057         }
3058
3059       /* Match Pointee.  */  
3060       var_locus = gfc_current_locus;
3061       gfc_clear_attr (&current_attr);
3062       gfc_add_cray_pointee (&current_attr, &var_locus);
3063       current_ts.type = BT_UNKNOWN;
3064       current_ts.kind = 0;
3065
3066       m = gfc_match_symbol (&cpte, 0);
3067       if (m != MATCH_YES)
3068         {
3069           gfc_error ("Expected variable name at %C");
3070           return m;
3071         }
3072        
3073       /* Check for an optional array spec.  */
3074       m = gfc_match_array_spec (&as);
3075       if (m == MATCH_ERROR)
3076         {
3077           gfc_free_array_spec (as);
3078           return m;
3079         }
3080       else if (m == MATCH_NO)
3081         {
3082           gfc_free_array_spec (as);
3083           as = NULL;
3084         }   
3085
3086       if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3087         return MATCH_ERROR;
3088
3089       gfc_set_sym_referenced (cpte);
3090
3091       if (cpte->as == NULL)
3092         {
3093           if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3094             gfc_internal_error ("Couldn't set Cray pointee array spec.");
3095         }
3096       else if (as != NULL)
3097         {
3098           gfc_error ("Duplicate array spec for Cray pointee at %C.");
3099           gfc_free_array_spec (as);
3100           return MATCH_ERROR;
3101         }
3102       
3103       as = NULL;
3104     
3105       if (cpte->as != NULL)
3106         {
3107           /* Fix array spec.  */
3108           m = gfc_mod_pointee_as (cpte->as);
3109           if (m == MATCH_ERROR)
3110             return m;
3111         } 
3112    
3113       /* Point the Pointee at the Pointer.  */
3114       cpte->cp_pointer = cptr;
3115
3116       if (gfc_match_char (')') != MATCH_YES)
3117         {
3118           gfc_error ("Expected \")\" at %C");
3119           return MATCH_ERROR;    
3120         }
3121       m = gfc_match_char (',');
3122       if (m != MATCH_YES)
3123         done = true; /* Stop searching for more declarations.  */
3124
3125     }
3126   
3127   if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
3128       || gfc_match_eos () != MATCH_YES)
3129     {
3130       gfc_error ("Expected \",\" or end of statement at %C");
3131       return MATCH_ERROR;
3132     }
3133   return MATCH_YES;
3134 }
3135
3136
3137 match
3138 gfc_match_external (void)
3139 {
3140
3141   gfc_clear_attr (&current_attr);
3142   gfc_add_external (&current_attr, NULL);
3143
3144   return attr_decl ();
3145 }
3146
3147
3148
3149 match
3150 gfc_match_intent (void)
3151 {
3152   sym_intent intent;
3153
3154   intent = match_intent_spec ();
3155   if (intent == INTENT_UNKNOWN)
3156     return MATCH_ERROR;
3157
3158   gfc_clear_attr (&current_attr);
3159   gfc_add_intent (&current_attr, intent, NULL); /* Can't fail */
3160
3161   return attr_decl ();
3162 }
3163
3164
3165 match
3166 gfc_match_intrinsic (void)
3167 {
3168
3169   gfc_clear_attr (&current_attr);
3170   gfc_add_intrinsic (&current_attr, NULL);
3171
3172   return attr_decl ();
3173 }
3174
3175
3176 match
3177 gfc_match_optional (void)
3178 {
3179
3180   gfc_clear_attr (&current_attr);
3181   gfc_add_optional (&current_attr, NULL);
3182
3183   return attr_decl ();
3184 }
3185
3186
3187 match
3188 gfc_match_pointer (void)
3189 {
3190   gfc_gobble_whitespace ();
3191   if (gfc_peek_char () == '(')
3192     {
3193       if (!gfc_option.flag_cray_pointer)
3194         {
3195           gfc_error ("Cray pointer declaration at %C requires -fcray-pointer"
3196                      " flag.");
3197           return MATCH_ERROR;
3198         }
3199       return cray_pointer_decl ();
3200     }
3201   else
3202     {
3203       gfc_clear_attr (&current_attr);
3204       gfc_add_pointer (&current_attr, NULL);
3205     
3206       return attr_decl ();
3207     }
3208 }
3209
3210
3211 match
3212 gfc_match_allocatable (void)
3213 {
3214
3215   gfc_clear_attr (&current_attr);
3216   gfc_add_allocatable (&current_attr, NULL);
3217
3218   return attr_decl ();
3219 }
3220
3221
3222 match
3223 gfc_match_dimension (void)
3224 {
3225
3226   gfc_clear_attr (&current_attr);
3227   gfc_add_dimension (&current_attr, NULL, NULL);
3228
3229   return attr_decl ();
3230 }
3231
3232
3233 match
3234 gfc_match_target (void)
3235 {
3236
3237   gfc_clear_attr (&current_attr);
3238   gfc_add_target (&current_attr, NULL);
3239
3240   return attr_decl ();
3241 }
3242
3243
3244 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3245    statement.  */
3246
3247 static match
3248 access_attr_decl (gfc_statement st)
3249 {
3250   char name[GFC_MAX_SYMBOL_LEN + 1];
3251   interface_type type;
3252   gfc_user_op *uop;
3253   gfc_symbol *sym;
3254   gfc_intrinsic_op operator;
3255   match m;
3256
3257   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3258     goto done;
3259
3260   for (;;)
3261     {
3262       m = gfc_match_generic_spec (&type, name, &operator);
3263       if (m == MATCH_NO)
3264         goto syntax;
3265       if (m == MATCH_ERROR)
3266         return MATCH_ERROR;
3267
3268       switch (type)
3269         {
3270         case INTERFACE_NAMELESS:
3271           goto syntax;
3272
3273         case INTERFACE_GENERIC:
3274           if (gfc_get_symbol (name, NULL, &sym))
3275             goto done;
3276
3277           if (gfc_add_access (&sym->attr,
3278                               (st ==
3279                                ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3280                               sym->name, NULL) == FAILURE)
3281             return MATCH_ERROR;
3282
3283           break;
3284
3285         case INTERFACE_INTRINSIC_OP:
3286           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3287             {
3288               gfc_current_ns->operator_access[operator] =
3289                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3290             }
3291           else
3292             {
3293               gfc_error ("Access specification of the %s operator at %C has "
3294                          "already been specified", gfc_op2string (operator));
3295               goto done;
3296             }
3297
3298           break;
3299
3300         case INTERFACE_USER_OP:
3301           uop = gfc_get_uop (name);
3302
3303           if (uop->access == ACCESS_UNKNOWN)
3304             {
3305               uop->access =
3306                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3307             }
3308           else
3309             {
3310               gfc_error
3311                 ("Access specification of the .%s. operator at %C has "
3312                  "already been specified", sym->name);
3313               goto done;
3314             }
3315
3316           break;
3317         }
3318
3319       if (gfc_match_char (',') == MATCH_NO)
3320         break;
3321     }
3322
3323   if (gfc_match_eos () != MATCH_YES)
3324     goto syntax;
3325   return MATCH_YES;
3326
3327 syntax:
3328   gfc_syntax_error (st);
3329
3330 done:
3331   return MATCH_ERROR;
3332 }
3333
3334
3335 /* The PRIVATE statement is a bit weird in that it can be a attribute
3336    declaration, but also works as a standlone statement inside of a
3337    type declaration or a module.  */
3338
3339 match
3340 gfc_match_private (gfc_statement * st)
3341 {
3342
3343   if (gfc_match ("private") != MATCH_YES)
3344     return MATCH_NO;
3345
3346   if (gfc_current_state () == COMP_DERIVED)
3347     {
3348       if (gfc_match_eos () == MATCH_YES)
3349         {
3350           *st = ST_PRIVATE;
3351           return MATCH_YES;
3352         }
3353
3354       gfc_syntax_error (ST_PRIVATE);
3355       return MATCH_ERROR;
3356     }
3357
3358   if (gfc_match_eos () == MATCH_YES)
3359     {
3360       *st = ST_PRIVATE;
3361       return MATCH_YES;
3362     }
3363
3364   *st = ST_ATTR_DECL;
3365   return access_attr_decl (ST_PRIVATE);
3366 }
3367
3368
3369 match
3370 gfc_match_public (gfc_statement * st)
3371 {
3372
3373   if (gfc_match ("public") != MATCH_YES)
3374     return MATCH_NO;
3375
3376   if (gfc_match_eos () == MATCH_YES)
3377     {
3378       *st = ST_PUBLIC;
3379       return MATCH_YES;
3380     }
3381
3382   *st = ST_ATTR_DECL;
3383   return access_attr_decl (ST_PUBLIC);
3384 }
3385
3386
3387 /* Workhorse for gfc_match_parameter.  */
3388
3389 static match
3390 do_parm (void)
3391 {
3392   gfc_symbol *sym;
3393   gfc_expr *init;
3394   match m;
3395
3396   m = gfc_match_symbol (&sym, 0);
3397   if (m == MATCH_NO)
3398     gfc_error ("Expected variable name at %C in PARAMETER statement");
3399
3400   if (m != MATCH_YES)
3401     return m;
3402
3403   if (gfc_match_char ('=') == MATCH_NO)
3404     {
3405       gfc_error ("Expected = sign in PARAMETER statement at %C");
3406       return MATCH_ERROR;
3407     }
3408
3409   m = gfc_match_init_expr (&init);
3410   if (m == MATCH_NO)
3411     gfc_error ("Expected expression at %C in PARAMETER statement");
3412   if (m != MATCH_YES)
3413     return m;
3414
3415   if (sym->ts.type == BT_UNKNOWN
3416       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
3417     {
3418       m = MATCH_ERROR;
3419       goto cleanup;
3420     }
3421
3422   if (gfc_check_assign_symbol (sym, init) == FAILURE
3423       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
3424     {
3425       m = MATCH_ERROR;
3426       goto cleanup;
3427     }
3428
3429   if (sym->ts.type == BT_CHARACTER
3430       && sym->ts.cl != NULL
3431       && sym->ts.cl->length != NULL
3432       && sym->ts.cl->length->expr_type == EXPR_CONSTANT
3433       && init->expr_type == EXPR_CONSTANT
3434       && init->ts.type == BT_CHARACTER
3435       && init->ts.kind == 1)
3436     gfc_set_constant_character_len (
3437       mpz_get_si (sym->ts.cl->length->value.integer), init);
3438
3439   sym->value = init;
3440   return MATCH_YES;
3441
3442 cleanup:
3443   gfc_free_expr (init);
3444   return m;
3445 }
3446
3447
3448 /* Match a parameter statement, with the weird syntax that these have.  */
3449
3450 match
3451 gfc_match_parameter (void)
3452 {
3453   match m;
3454
3455   if (gfc_match_char ('(') == MATCH_NO)
3456     return MATCH_NO;
3457
3458   for (;;)
3459     {
3460       m = do_parm ();
3461       if (m != MATCH_YES)
3462         break;
3463
3464       if (gfc_match (" )%t") == MATCH_YES)
3465         break;
3466
3467       if (gfc_match_char (',') != MATCH_YES)
3468         {
3469           gfc_error ("Unexpected characters in PARAMETER statement at %C");
3470           m = MATCH_ERROR;
3471           break;
3472         }
3473     }
3474
3475   return m;
3476 }
3477
3478
3479 /* Save statements have a special syntax.  */
3480
3481 match
3482 gfc_match_save (void)
3483 {
3484   char n[GFC_MAX_SYMBOL_LEN+1];
3485   gfc_common_head *c;
3486   gfc_symbol *sym;
3487   match m;
3488
3489   if (gfc_match_eos () == MATCH_YES)
3490     {
3491       if (gfc_current_ns->seen_save)
3492         {
3493           if (gfc_notify_std (GFC_STD_LEGACY, 
3494                               "Blanket SAVE statement at %C follows previous "
3495                               "SAVE statement")
3496               == FAILURE)
3497             return MATCH_ERROR;
3498         }
3499
3500       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
3501       return MATCH_YES;
3502     }
3503
3504   if (gfc_current_ns->save_all)
3505     {
3506       if (gfc_notify_std (GFC_STD_LEGACY, 
3507                           "SAVE statement at %C follows blanket SAVE statement")
3508           == FAILURE)
3509         return MATCH_ERROR;
3510     }
3511
3512   gfc_match (" ::");
3513
3514   for (;;)
3515     {
3516       m = gfc_match_symbol (&sym, 0);
3517       switch (m)
3518         {
3519         case MATCH_YES:
3520           if (gfc_add_save (&sym->attr, sym->name,
3521                             &gfc_current_locus) == FAILURE)
3522             return MATCH_ERROR;
3523           goto next_item;
3524
3525         case MATCH_NO:
3526           break;
3527
3528         case MATCH_ERROR:
3529           return MATCH_ERROR;
3530         }
3531
3532       m = gfc_match (" / %n /", &n);
3533       if (m == MATCH_ERROR)
3534         return MATCH_ERROR;
3535       if (m == MATCH_NO)
3536         goto syntax;
3537
3538       c = gfc_get_common (n, 0);
3539       c->saved = 1;
3540
3541       gfc_current_ns->seen_save = 1;
3542
3543     next_item:
3544       if (gfc_match_eos () == MATCH_YES)
3545         break;
3546       if (gfc_match_char (',') != MATCH_YES)
3547         goto syntax;
3548     }
3549
3550   return MATCH_YES;
3551
3552 syntax:
3553   gfc_error ("Syntax error in SAVE statement at %C");
3554   return MATCH_ERROR;
3555 }
3556
3557
3558 /* Match a module procedure statement.  Note that we have to modify
3559    symbols in the parent's namespace because the current one was there
3560    to receive symbols that are in an interface's formal argument list.  */
3561
3562 match
3563 gfc_match_modproc (void)
3564 {
3565   char name[GFC_MAX_SYMBOL_LEN + 1];
3566   gfc_symbol *sym;
3567   match m;
3568
3569   if (gfc_state_stack->state != COMP_INTERFACE
3570       || gfc_state_stack->previous == NULL
3571       || current_interface.type == INTERFACE_NAMELESS)
3572     {
3573       gfc_error
3574         ("MODULE PROCEDURE at %C must be in a generic module interface");
3575       return MATCH_ERROR;
3576     }
3577
3578   for (;;)
3579     {
3580       m = gfc_match_name (name);
3581       if (m == MATCH_NO)
3582         goto syntax;
3583       if (m != MATCH_YES)
3584         return MATCH_ERROR;
3585
3586       if (gfc_get_symbol (name, gfc_current_ns->parent, &sym))
3587         return MATCH_ERROR;
3588
3589       if (sym->attr.proc != PROC_MODULE
3590           && gfc_add_procedure (&sym->attr, PROC_MODULE,
3591                                 sym->name, NULL) == FAILURE)
3592         return MATCH_ERROR;
3593
3594       if (gfc_add_interface (sym) == FAILURE)
3595         return MATCH_ERROR;
3596
3597       if (gfc_match_eos () == MATCH_YES)
3598         break;
3599       if (gfc_match_char (',') != MATCH_YES)
3600         goto syntax;
3601     }
3602
3603   return MATCH_YES;
3604
3605 syntax:
3606   gfc_syntax_error (ST_MODULE_PROC);
3607   return MATCH_ERROR;
3608 }
3609
3610
3611 /* Match the beginning of a derived type declaration.  If a type name
3612    was the result of a function, then it is possible to have a symbol
3613    already to be known as a derived type yet have no components.  */
3614
3615 match
3616 gfc_match_derived_decl (void)
3617 {
3618   char name[GFC_MAX_SYMBOL_LEN + 1];
3619   symbol_attribute attr;
3620   gfc_symbol *sym;
3621   match m;
3622
3623   if (gfc_current_state () == COMP_DERIVED)
3624     return MATCH_NO;
3625
3626   gfc_clear_attr (&attr);
3627
3628 loop:
3629   if (gfc_match (" , private") == MATCH_YES)
3630     {
3631       if (gfc_find_state (COMP_MODULE) == FAILURE)
3632         {
3633           gfc_error
3634             ("Derived type at %C can only be PRIVATE within a MODULE");
3635           return MATCH_ERROR;
3636         }
3637
3638       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
3639         return MATCH_ERROR;
3640       goto loop;
3641     }
3642
3643   if (gfc_match (" , public") == MATCH_YES)
3644     {
3645       if (gfc_find_state (COMP_MODULE) == FAILURE)
3646         {
3647           gfc_error ("Derived type at %C can only be PUBLIC within a MODULE");
3648           return MATCH_ERROR;
3649         }
3650
3651       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
3652         return MATCH_ERROR;
3653       goto loop;
3654     }
3655
3656   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
3657     {
3658       gfc_error ("Expected :: in TYPE definition at %C");
3659       return MATCH_ERROR;
3660     }
3661
3662   m = gfc_match (" %n%t", name);
3663   if (m != MATCH_YES)
3664     return m;
3665
3666   /* Make sure the name isn't the name of an intrinsic type.  The
3667      'double precision' type doesn't get past the name matcher.  */
3668   if (strcmp (name, "integer") == 0
3669       || strcmp (name, "real") == 0
3670       || strcmp (name, "character") == 0
3671       || strcmp (name, "logical") == 0
3672       || strcmp (name, "complex") == 0)
3673     {
3674       gfc_error
3675         ("Type name '%s' at %C cannot be the same as an intrinsic type",
3676          name);
3677       return MATCH_ERROR;
3678     }
3679
3680   if (gfc_get_symbol (name, NULL, &sym))
3681     return MATCH_ERROR;
3682
3683   if (sym->ts.type != BT_UNKNOWN)
3684     {
3685       gfc_error ("Derived type name '%s' at %C already has a basic type "
3686                  "of %s", sym->name, gfc_typename (&sym->ts));
3687       return MATCH_ERROR;
3688     }
3689
3690   /* The symbol may already have the derived attribute without the
3691      components.  The ways this can happen is via a function
3692      definition, an INTRINSIC statement or a subtype in another
3693      derived type that is a pointer.  The first part of the AND clause
3694      is true if a the symbol is not the return value of a function.  */
3695   if (sym->attr.flavor != FL_DERIVED
3696       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
3697     return MATCH_ERROR;
3698
3699   if (sym->components != NULL)
3700     {
3701       gfc_error
3702         ("Derived type definition of '%s' at %C has already been defined",
3703          sym->name);
3704       return MATCH_ERROR;
3705     }
3706
3707   if (attr.access != ACCESS_UNKNOWN
3708       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
3709     return MATCH_ERROR;
3710
3711   gfc_new_block = sym;
3712
3713   return MATCH_YES;
3714 }
3715
3716
3717 /* Cray Pointees can be declared as: 
3718       pointer (ipt, a (n,m,...,*)) 
3719    By default, this is treated as an AS_ASSUMED_SIZE array.  We'll
3720    cheat and set a constant bound of 1 for the last dimension, if this