OSDN Git Service

2007-06-25 Paul Thomas <pault@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / match.c
1 /* Matching subroutines in all sizes, shapes and colors.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
3    Free Software Foundation, Inc.
4    Contributed by Andy Vaught
5
6 This file is part of GCC.
7
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
11 version.
12
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16 for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "match.h"
28 #include "parse.h"
29
30 /* For matching and debugging purposes.  Order matters here!  The
31    unary operators /must/ precede the binary plus and minus, or
32    the expression parser breaks.  */
33
34 mstring intrinsic_operators[] = {
35     minit ("+", INTRINSIC_UPLUS),
36     minit ("-", INTRINSIC_UMINUS),
37     minit ("+", INTRINSIC_PLUS),
38     minit ("-", INTRINSIC_MINUS),
39     minit ("**", INTRINSIC_POWER),
40     minit ("//", INTRINSIC_CONCAT),
41     minit ("*", INTRINSIC_TIMES),
42     minit ("/", INTRINSIC_DIVIDE),
43     minit (".and.", INTRINSIC_AND),
44     minit (".or.", INTRINSIC_OR),
45     minit (".eqv.", INTRINSIC_EQV),
46     minit (".neqv.", INTRINSIC_NEQV),
47     minit (".eq.", INTRINSIC_EQ),
48     minit ("==", INTRINSIC_EQ),
49     minit (".ne.", INTRINSIC_NE),
50     minit ("/=", INTRINSIC_NE),
51     minit (".ge.", INTRINSIC_GE),
52     minit (">=", INTRINSIC_GE),
53     minit (".le.", INTRINSIC_LE),
54     minit ("<=", INTRINSIC_LE),
55     minit (".lt.", INTRINSIC_LT),
56     minit ("<", INTRINSIC_LT),
57     minit (".gt.", INTRINSIC_GT),
58     minit (">", INTRINSIC_GT),
59     minit (".not.", INTRINSIC_NOT),
60     minit ("parens", INTRINSIC_PARENTHESES),
61     minit (NULL, INTRINSIC_NONE)
62 };
63
64
65 /******************** Generic matching subroutines ************************/
66
67 /* See if the next character is a special character that has
68    escaped by a \ via the -fbackslash option.  */
69
70 match
71 gfc_match_special_char (int *c)
72 {
73
74   match m;
75
76   m = MATCH_YES;
77
78   switch (gfc_next_char_literal (1))
79     {
80     case 'a':
81       *c = '\a';
82       break;
83     case 'b':
84       *c = '\b';
85       break;
86     case 't':
87       *c = '\t';
88       break;
89     case 'f':
90       *c = '\f';
91       break;
92     case 'n':
93       *c = '\n';
94       break;
95     case 'r':
96       *c = '\r';
97       break;
98     case 'v':
99       *c = '\v';
100       break;
101     case '\\':
102       *c = '\\';
103       break;
104     case '0':
105       *c = '\0';
106       break;
107     default:
108       /* Unknown backslash codes are simply not expanded.  */
109       m = MATCH_NO;
110       break;
111     }
112
113   return m;
114 }
115
116
117 /* In free form, match at least one space.  Always matches in fixed
118    form.  */
119
120 match
121 gfc_match_space (void)
122 {
123   locus old_loc;
124   int c;
125
126   if (gfc_current_form == FORM_FIXED)
127     return MATCH_YES;
128
129   old_loc = gfc_current_locus;
130
131   c = gfc_next_char ();
132   if (!gfc_is_whitespace (c))
133     {
134       gfc_current_locus = old_loc;
135       return MATCH_NO;
136     }
137
138   gfc_gobble_whitespace ();
139
140   return MATCH_YES;
141 }
142
143
144 /* Match an end of statement.  End of statement is optional
145    whitespace, followed by a ';' or '\n' or comment '!'.  If a
146    semicolon is found, we continue to eat whitespace and semicolons.  */
147
148 match
149 gfc_match_eos (void)
150 {
151   locus old_loc;
152   int flag, c;
153
154   flag = 0;
155
156   for (;;)
157     {
158       old_loc = gfc_current_locus;
159       gfc_gobble_whitespace ();
160
161       c = gfc_next_char ();
162       switch (c)
163         {
164         case '!':
165           do
166             {
167               c = gfc_next_char ();
168             }
169           while (c != '\n');
170
171           /* Fall through.  */
172
173         case '\n':
174           return MATCH_YES;
175
176         case ';':
177           flag = 1;
178           continue;
179         }
180
181       break;
182     }
183
184   gfc_current_locus = old_loc;
185   return (flag) ? MATCH_YES : MATCH_NO;
186 }
187
188
189 /* Match a literal integer on the input, setting the value on
190    MATCH_YES.  Literal ints occur in kind-parameters as well as
191    old-style character length specifications.  If cnt is non-NULL it
192    will be set to the number of digits.  */
193
194 match
195 gfc_match_small_literal_int (int *value, int *cnt)
196 {
197   locus old_loc;
198   char c;
199   int i, j;
200
201   old_loc = gfc_current_locus;
202
203   gfc_gobble_whitespace ();
204   c = gfc_next_char ();
205   if (cnt)
206     *cnt = 0;
207
208   if (!ISDIGIT (c))
209     {
210       gfc_current_locus = old_loc;
211       return MATCH_NO;
212     }
213
214   i = c - '0';
215   j = 1;
216
217   for (;;)
218     {
219       old_loc = gfc_current_locus;
220       c = gfc_next_char ();
221
222       if (!ISDIGIT (c))
223         break;
224
225       i = 10 * i + c - '0';
226       j++;
227
228       if (i > 99999999)
229         {
230           gfc_error ("Integer too large at %C");
231           return MATCH_ERROR;
232         }
233     }
234
235   gfc_current_locus = old_loc;
236
237   *value = i;
238   if (cnt)
239     *cnt = j;
240   return MATCH_YES;
241 }
242
243
244 /* Match a small, constant integer expression, like in a kind
245    statement.  On MATCH_YES, 'value' is set.  */
246
247 match
248 gfc_match_small_int (int *value)
249 {
250   gfc_expr *expr;
251   const char *p;
252   match m;
253   int i;
254
255   m = gfc_match_expr (&expr);
256   if (m != MATCH_YES)
257     return m;
258
259   p = gfc_extract_int (expr, &i);
260   gfc_free_expr (expr);
261
262   if (p != NULL)
263     {
264       gfc_error (p);
265       m = MATCH_ERROR;
266     }
267
268   *value = i;
269   return m;
270 }
271
272
273 /* Matches a statement label.  Uses gfc_match_small_literal_int() to
274    do most of the work.  */
275
276 match
277 gfc_match_st_label (gfc_st_label **label)
278 {
279   locus old_loc;
280   match m;
281   int i, cnt;
282
283   old_loc = gfc_current_locus;
284
285   m = gfc_match_small_literal_int (&i, &cnt);
286   if (m != MATCH_YES)
287     return m;
288
289   if (cnt > 5)
290     {
291       gfc_error ("Too many digits in statement label at %C");
292       goto cleanup;
293     }
294
295   if (i == 0)
296     {
297       gfc_error ("Statement label at %C is zero");
298       goto cleanup;
299     }
300
301   *label = gfc_get_st_label (i);
302   return MATCH_YES;
303
304 cleanup:
305
306   gfc_current_locus = old_loc;
307   return MATCH_ERROR;
308 }
309
310
311 /* Match and validate a label associated with a named IF, DO or SELECT
312    statement.  If the symbol does not have the label attribute, we add
313    it.  We also make sure the symbol does not refer to another
314    (active) block.  A matched label is pointed to by gfc_new_block.  */
315
316 match
317 gfc_match_label (void)
318 {
319   char name[GFC_MAX_SYMBOL_LEN + 1];
320   match m;
321
322   gfc_new_block = NULL;
323
324   m = gfc_match (" %n :", name);
325   if (m != MATCH_YES)
326     return m;
327
328   if (gfc_get_symbol (name, NULL, &gfc_new_block))
329     {
330       gfc_error ("Label name '%s' at %C is ambiguous", name);
331       return MATCH_ERROR;
332     }
333
334   if (gfc_new_block->attr.flavor == FL_LABEL)
335     {
336       gfc_error ("Duplicate construct label '%s' at %C", name);
337       return MATCH_ERROR;
338     }
339
340   if (gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
341                       gfc_new_block->name, NULL) == FAILURE)
342     return MATCH_ERROR;
343
344   return MATCH_YES;
345 }
346
347
348 /* Try and match the input against an array of possibilities.  If one
349    potential matching string is a substring of another, the longest
350    match takes precedence.  Spaces in the target strings are optional
351    spaces that do not necessarily have to be found in the input
352    stream.  In fixed mode, spaces never appear.  If whitespace is
353    matched, it matches unlimited whitespace in the input.  For this
354    reason, the 'mp' member of the mstring structure is used to track
355    the progress of each potential match.
356
357    If there is no match we return the tag associated with the
358    terminating NULL mstring structure and leave the locus pointer
359    where it started.  If there is a match we return the tag member of
360    the matched mstring and leave the locus pointer after the matched
361    character.
362
363    A '%' character is a mandatory space.  */
364
365 int
366 gfc_match_strings (mstring *a)
367 {
368   mstring *p, *best_match;
369   int no_match, c, possibles;
370   locus match_loc;
371
372   possibles = 0;
373
374   for (p = a; p->string != NULL; p++)
375     {
376       p->mp = p->string;
377       possibles++;
378     }
379
380   no_match = p->tag;
381
382   best_match = NULL;
383   match_loc = gfc_current_locus;
384
385   gfc_gobble_whitespace ();
386
387   while (possibles > 0)
388     {
389       c = gfc_next_char ();
390
391       /* Apply the next character to the current possibilities.  */
392       for (p = a; p->string != NULL; p++)
393         {
394           if (p->mp == NULL)
395             continue;
396
397           if (*p->mp == ' ')
398             {
399               /* Space matches 1+ whitespace(s).  */
400               if ((gfc_current_form == FORM_FREE) && gfc_is_whitespace (c))
401                 continue;
402
403               p->mp++;
404             }
405
406           if (*p->mp != c)
407             {
408               /* Match failed.  */
409               p->mp = NULL;
410               possibles--;
411               continue;
412             }
413
414           p->mp++;
415           if (*p->mp == '\0')
416             {
417               /* Found a match.  */
418               match_loc = gfc_current_locus;
419               best_match = p;
420               possibles--;
421               p->mp = NULL;
422             }
423         }
424     }
425
426   gfc_current_locus = match_loc;
427
428   return (best_match == NULL) ? no_match : best_match->tag;
429 }
430
431
432 /* See if the current input looks like a name of some sort.  Modifies
433    the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long.
434    Note that options.c restricts max_identifier_length to not more
435    than GFC_MAX_SYMBOL_LEN.  */
436
437 match
438 gfc_match_name (char *buffer)
439 {
440   locus old_loc;
441   int i, c;
442
443   old_loc = gfc_current_locus;
444   gfc_gobble_whitespace ();
445
446   c = gfc_next_char ();
447   if (!(ISALPHA (c) || (c == '_' && gfc_option.flag_allow_leading_underscore)))
448     {
449       if (gfc_error_flag_test() == 0)
450         gfc_error ("Invalid character in name at %C");
451       gfc_current_locus = old_loc;
452       return MATCH_NO;
453     }
454
455   i = 0;
456
457   do
458     {
459       buffer[i++] = c;
460
461       if (i > gfc_option.max_identifier_length)
462         {
463           gfc_error ("Name at %C is too long");
464           return MATCH_ERROR;
465         }
466
467       old_loc = gfc_current_locus;
468       c = gfc_next_char ();
469     }
470   while (ISALNUM (c) || c == '_' || (gfc_option.flag_dollar_ok && c == '$'));
471
472   buffer[i] = '\0';
473   gfc_current_locus = old_loc;
474
475   return MATCH_YES;
476 }
477
478
479 /* Match a symbol on the input.  Modifies the pointer to the symbol
480    pointer if successful.  */
481
482 match
483 gfc_match_sym_tree (gfc_symtree **matched_symbol, int host_assoc)
484 {
485   char buffer[GFC_MAX_SYMBOL_LEN + 1];
486   match m;
487
488   m = gfc_match_name (buffer);
489   if (m != MATCH_YES)
490     return m;
491
492   if (host_assoc)
493     return (gfc_get_ha_sym_tree (buffer, matched_symbol))
494             ? MATCH_ERROR : MATCH_YES;
495
496   if (gfc_get_sym_tree (buffer, NULL, matched_symbol))
497     return MATCH_ERROR;
498
499   return MATCH_YES;
500 }
501
502
503 match
504 gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc)
505 {
506   gfc_symtree *st;
507   match m;
508
509   m = gfc_match_sym_tree (&st, host_assoc);
510
511   if (m == MATCH_YES)
512     {
513       if (st)
514         *matched_symbol = st->n.sym;
515       else
516         *matched_symbol = NULL;
517     }
518   else
519     *matched_symbol = NULL;
520   return m;
521 }
522
523
524 /* Match an intrinsic operator.  Returns an INTRINSIC enum. While matching, 
525    we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this 
526    in matchexp.c.  */
527
528 match
529 gfc_match_intrinsic_op (gfc_intrinsic_op *result)
530 {
531   gfc_intrinsic_op op;
532
533   op = (gfc_intrinsic_op) gfc_match_strings (intrinsic_operators);
534
535   if (op == INTRINSIC_NONE)
536     return MATCH_NO;
537
538   *result = op;
539   return MATCH_YES;
540 }
541
542
543 /* Match a loop control phrase:
544
545     <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
546
547    If the final integer expression is not present, a constant unity
548    expression is returned.  We don't return MATCH_ERROR until after
549    the equals sign is seen.  */
550
551 match
552 gfc_match_iterator (gfc_iterator *iter, int init_flag)
553 {
554   char name[GFC_MAX_SYMBOL_LEN + 1];
555   gfc_expr *var, *e1, *e2, *e3;
556   locus start;
557   match m;
558
559   /* Match the start of an iterator without affecting the symbol table.  */
560
561   start = gfc_current_locus;
562   m = gfc_match (" %n =", name);
563   gfc_current_locus = start;
564
565   if (m != MATCH_YES)
566     return MATCH_NO;
567
568   m = gfc_match_variable (&var, 0);
569   if (m != MATCH_YES)
570     return MATCH_NO;
571
572   gfc_match_char ('=');
573
574   e1 = e2 = e3 = NULL;
575
576   if (var->ref != NULL)
577     {
578       gfc_error ("Loop variable at %C cannot be a sub-component");
579       goto cleanup;
580     }
581
582   if (var->symtree->n.sym->attr.intent == INTENT_IN)
583     {
584       gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
585                  var->symtree->n.sym->name);
586       goto cleanup;
587     }
588
589   var->symtree->n.sym->attr.implied_index = 1;
590
591   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
592   if (m == MATCH_NO)
593     goto syntax;
594   if (m == MATCH_ERROR)
595     goto cleanup;
596
597   if (gfc_match_char (',') != MATCH_YES)
598     goto syntax;
599
600   m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
601   if (m == MATCH_NO)
602     goto syntax;
603   if (m == MATCH_ERROR)
604     goto cleanup;
605
606   if (gfc_match_char (',') != MATCH_YES)
607     {
608       e3 = gfc_int_expr (1);
609       goto done;
610     }
611
612   m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
613   if (m == MATCH_ERROR)
614     goto cleanup;
615   if (m == MATCH_NO)
616     {
617       gfc_error ("Expected a step value in iterator at %C");
618       goto cleanup;
619     }
620
621 done:
622   iter->var = var;
623   iter->start = e1;
624   iter->end = e2;
625   iter->step = e3;
626   return MATCH_YES;
627
628 syntax:
629   gfc_error ("Syntax error in iterator at %C");
630
631 cleanup:
632   gfc_free_expr (e1);
633   gfc_free_expr (e2);
634   gfc_free_expr (e3);
635
636   return MATCH_ERROR;
637 }
638
639
640 /* Tries to match the next non-whitespace character on the input.
641    This subroutine does not return MATCH_ERROR.  */
642
643 match
644 gfc_match_char (char c)
645 {
646   locus where;
647
648   where = gfc_current_locus;
649   gfc_gobble_whitespace ();
650
651   if (gfc_next_char () == c)
652     return MATCH_YES;
653
654   gfc_current_locus = where;
655   return MATCH_NO;
656 }
657
658
659 /* General purpose matching subroutine.  The target string is a
660    scanf-like format string in which spaces correspond to arbitrary
661    whitespace (including no whitespace), characters correspond to
662    themselves.  The %-codes are:
663
664    %%  Literal percent sign
665    %e  Expression, pointer to a pointer is set
666    %s  Symbol, pointer to the symbol is set
667    %n  Name, character buffer is set to name
668    %t  Matches end of statement.
669    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
670    %l  Matches a statement label
671    %v  Matches a variable expression (an lvalue)
672    %   Matches a required space (in free form) and optional spaces.  */
673
674 match
675 gfc_match (const char *target, ...)
676 {
677   gfc_st_label **label;
678   int matches, *ip;
679   locus old_loc;
680   va_list argp;
681   char c, *np;
682   match m, n;
683   void **vp;
684   const char *p;
685
686   old_loc = gfc_current_locus;
687   va_start (argp, target);
688   m = MATCH_NO;
689   matches = 0;
690   p = target;
691
692 loop:
693   c = *p++;
694   switch (c)
695     {
696     case ' ':
697       gfc_gobble_whitespace ();
698       goto loop;
699     case '\0':
700       m = MATCH_YES;
701       break;
702
703     case '%':
704       c = *p++;
705       switch (c)
706         {
707         case 'e':
708           vp = va_arg (argp, void **);
709           n = gfc_match_expr ((gfc_expr **) vp);
710           if (n != MATCH_YES)
711             {
712               m = n;
713               goto not_yes;
714             }
715
716           matches++;
717           goto loop;
718
719         case 'v':
720           vp = va_arg (argp, void **);
721           n = gfc_match_variable ((gfc_expr **) vp, 0);
722           if (n != MATCH_YES)
723             {
724               m = n;
725               goto not_yes;
726             }
727
728           matches++;
729           goto loop;
730
731         case 's':
732           vp = va_arg (argp, void **);
733           n = gfc_match_symbol ((gfc_symbol **) vp, 0);
734           if (n != MATCH_YES)
735             {
736               m = n;
737               goto not_yes;
738             }
739
740           matches++;
741           goto loop;
742
743         case 'n':
744           np = va_arg (argp, char *);
745           n = gfc_match_name (np);
746           if (n != MATCH_YES)
747             {
748               m = n;
749               goto not_yes;
750             }
751
752           matches++;
753           goto loop;
754
755         case 'l':
756           label = va_arg (argp, gfc_st_label **);
757           n = gfc_match_st_label (label);
758           if (n != MATCH_YES)
759             {
760               m = n;
761               goto not_yes;
762             }
763
764           matches++;
765           goto loop;
766
767         case 'o':
768           ip = va_arg (argp, int *);
769           n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
770           if (n != MATCH_YES)
771             {
772               m = n;
773               goto not_yes;
774             }
775
776           matches++;
777           goto loop;
778
779         case 't':
780           if (gfc_match_eos () != MATCH_YES)
781             {
782               m = MATCH_NO;
783               goto not_yes;
784             }
785           goto loop;
786
787         case ' ':
788           if (gfc_match_space () == MATCH_YES)
789             goto loop;
790           m = MATCH_NO;
791           goto not_yes;
792
793         case '%':
794           break;        /* Fall through to character matcher.  */
795
796         default:
797           gfc_internal_error ("gfc_match(): Bad match code %c", c);
798         }
799
800     default:
801       if (c == gfc_next_char ())
802         goto loop;
803       break;
804     }
805
806 not_yes:
807   va_end (argp);
808
809   if (m != MATCH_YES)
810     {
811       /* Clean up after a failed match.  */
812       gfc_current_locus = old_loc;
813       va_start (argp, target);
814
815       p = target;
816       for (; matches > 0; matches--)
817         {
818           while (*p++ != '%');
819
820           switch (*p++)
821             {
822             case '%':
823               matches++;
824               break;            /* Skip.  */
825
826             /* Matches that don't have to be undone */
827             case 'o':
828             case 'l':
829             case 'n':
830             case 's':
831               (void) va_arg (argp, void **);
832               break;
833
834             case 'e':
835             case 'v':
836               vp = va_arg (argp, void **);
837               gfc_free_expr (*vp);
838               *vp = NULL;
839               break;
840             }
841         }
842
843       va_end (argp);
844     }
845
846   return m;
847 }
848
849
850 /*********************** Statement level matching **********************/
851
852 /* Matches the start of a program unit, which is the program keyword
853    followed by an obligatory symbol.  */
854
855 match
856 gfc_match_program (void)
857 {
858   gfc_symbol *sym;
859   match m;
860
861   m = gfc_match ("% %s%t", &sym);
862
863   if (m == MATCH_NO)
864     {
865       gfc_error ("Invalid form of PROGRAM statement at %C");
866       m = MATCH_ERROR;
867     }
868
869   if (m == MATCH_ERROR)
870     return m;
871
872   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
873     return MATCH_ERROR;
874
875   gfc_new_block = sym;
876
877   return MATCH_YES;
878 }
879
880
881 /* Match a simple assignment statement.  */
882
883 match
884 gfc_match_assignment (void)
885 {
886   gfc_expr *lvalue, *rvalue;
887   locus old_loc;
888   match m;
889
890   old_loc = gfc_current_locus;
891
892   lvalue = NULL;
893   m = gfc_match (" %v =", &lvalue);
894   if (m != MATCH_YES)
895     {
896       gfc_current_locus = old_loc;
897       gfc_free_expr (lvalue);
898       return MATCH_NO;
899     }
900
901   if (lvalue->symtree->n.sym->attr.protected
902       && lvalue->symtree->n.sym->attr.use_assoc)
903     {
904       gfc_current_locus = old_loc;
905       gfc_free_expr (lvalue);
906       gfc_error ("Setting value of PROTECTED variable at %C");
907       return MATCH_ERROR;
908     }
909
910   rvalue = NULL;
911   m = gfc_match (" %e%t", &rvalue);
912   if (m != MATCH_YES)
913     {
914       gfc_current_locus = old_loc;
915       gfc_free_expr (lvalue);
916       gfc_free_expr (rvalue);
917       return m;
918     }
919
920   gfc_set_sym_referenced (lvalue->symtree->n.sym);
921
922   new_st.op = EXEC_ASSIGN;
923   new_st.expr = lvalue;
924   new_st.expr2 = rvalue;
925
926   gfc_check_do_variable (lvalue->symtree);
927
928   return MATCH_YES;
929 }
930
931
932 /* Match a pointer assignment statement.  */
933
934 match
935 gfc_match_pointer_assignment (void)
936 {
937   gfc_expr *lvalue, *rvalue;
938   locus old_loc;
939   match m;
940
941   old_loc = gfc_current_locus;
942
943   lvalue = rvalue = NULL;
944
945   m = gfc_match (" %v =>", &lvalue);
946   if (m != MATCH_YES)
947     {
948       m = MATCH_NO;
949       goto cleanup;
950     }
951
952   m = gfc_match (" %e%t", &rvalue);
953   if (m != MATCH_YES)
954     goto cleanup;
955
956   if (lvalue->symtree->n.sym->attr.protected
957       && lvalue->symtree->n.sym->attr.use_assoc)
958     {
959       gfc_error ("Assigning to a PROTECTED pointer at %C");
960       m = MATCH_ERROR;
961       goto cleanup;
962     }
963
964   new_st.op = EXEC_POINTER_ASSIGN;
965   new_st.expr = lvalue;
966   new_st.expr2 = rvalue;
967
968   return MATCH_YES;
969
970 cleanup:
971   gfc_current_locus = old_loc;
972   gfc_free_expr (lvalue);
973   gfc_free_expr (rvalue);
974   return m;
975 }
976
977
978 /* We try to match an easy arithmetic IF statement. This only happens
979    when just after having encountered a simple IF statement. This code
980    is really duplicate with parts of the gfc_match_if code, but this is
981    *much* easier.  */
982
983 static match
984 match_arithmetic_if (void)
985 {
986   gfc_st_label *l1, *l2, *l3;
987   gfc_expr *expr;
988   match m;
989
990   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
991   if (m != MATCH_YES)
992     return m;
993
994   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
995       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
996       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
997     {
998       gfc_free_expr (expr);
999       return MATCH_ERROR;
1000     }
1001
1002   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF statement "
1003                       "at %C") == FAILURE)
1004     return MATCH_ERROR;
1005
1006   new_st.op = EXEC_ARITHMETIC_IF;
1007   new_st.expr = expr;
1008   new_st.label = l1;
1009   new_st.label2 = l2;
1010   new_st.label3 = l3;
1011
1012   return MATCH_YES;
1013 }
1014
1015
1016 /* The IF statement is a bit of a pain.  First of all, there are three
1017    forms of it, the simple IF, the IF that starts a block and the
1018    arithmetic IF.
1019
1020    There is a problem with the simple IF and that is the fact that we
1021    only have a single level of undo information on symbols.  What this
1022    means is for a simple IF, we must re-match the whole IF statement
1023    multiple times in order to guarantee that the symbol table ends up
1024    in the proper state.  */
1025
1026 static match match_simple_forall (void);
1027 static match match_simple_where (void);
1028
1029 match
1030 gfc_match_if (gfc_statement *if_type)
1031 {
1032   gfc_expr *expr;
1033   gfc_st_label *l1, *l2, *l3;
1034   locus old_loc;
1035   gfc_code *p;
1036   match m, n;
1037
1038   n = gfc_match_label ();
1039   if (n == MATCH_ERROR)
1040     return n;
1041
1042   old_loc = gfc_current_locus;
1043
1044   m = gfc_match (" if ( %e", &expr);
1045   if (m != MATCH_YES)
1046     return m;
1047
1048   if (gfc_match_char (')') != MATCH_YES)
1049     {
1050       gfc_error ("Syntax error in IF-expression at %C");
1051       gfc_free_expr (expr);
1052       return MATCH_ERROR;
1053     }
1054
1055   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1056
1057   if (m == MATCH_YES)
1058     {
1059       if (n == MATCH_YES)
1060         {
1061           gfc_error ("Block label not appropriate for arithmetic IF "
1062                      "statement at %C");
1063           gfc_free_expr (expr);
1064           return MATCH_ERROR;
1065         }
1066
1067       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1068           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1069           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1070         {
1071           gfc_free_expr (expr);
1072           return MATCH_ERROR;
1073         }
1074       
1075       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent: arithmetic IF "
1076                           "statement at %C") == FAILURE)
1077         return MATCH_ERROR;
1078
1079       new_st.op = EXEC_ARITHMETIC_IF;
1080       new_st.expr = expr;
1081       new_st.label = l1;
1082       new_st.label2 = l2;
1083       new_st.label3 = l3;
1084
1085       *if_type = ST_ARITHMETIC_IF;
1086       return MATCH_YES;
1087     }
1088
1089   if (gfc_match (" then%t") == MATCH_YES)
1090     {
1091       new_st.op = EXEC_IF;
1092       new_st.expr = expr;
1093       *if_type = ST_IF_BLOCK;
1094       return MATCH_YES;
1095     }
1096
1097   if (n == MATCH_YES)
1098     {
1099       gfc_error ("Block label is not appropriate IF statement at %C");
1100       gfc_free_expr (expr);
1101       return MATCH_ERROR;
1102     }
1103
1104   /* At this point the only thing left is a simple IF statement.  At
1105      this point, n has to be MATCH_NO, so we don't have to worry about
1106      re-matching a block label.  From what we've got so far, try
1107      matching an assignment.  */
1108
1109   *if_type = ST_SIMPLE_IF;
1110
1111   m = gfc_match_assignment ();
1112   if (m == MATCH_YES)
1113     goto got_match;
1114
1115   gfc_free_expr (expr);
1116   gfc_undo_symbols ();
1117   gfc_current_locus = old_loc;
1118
1119   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1120      assignment was found.  For MATCH_NO, continue to call the various
1121      matchers.  */
1122   if (m == MATCH_ERROR)
1123     return MATCH_ERROR;
1124
1125   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1126
1127   m = gfc_match_pointer_assignment ();
1128   if (m == MATCH_YES)
1129     goto got_match;
1130
1131   gfc_free_expr (expr);
1132   gfc_undo_symbols ();
1133   gfc_current_locus = old_loc;
1134
1135   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1136
1137   /* Look at the next keyword to see which matcher to call.  Matching
1138      the keyword doesn't affect the symbol table, so we don't have to
1139      restore between tries.  */
1140
1141 #define match(string, subr, statement) \
1142   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1143
1144   gfc_clear_error ();
1145
1146   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1147   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1148   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1149   match ("call", gfc_match_call, ST_CALL)
1150   match ("close", gfc_match_close, ST_CLOSE)
1151   match ("continue", gfc_match_continue, ST_CONTINUE)
1152   match ("cycle", gfc_match_cycle, ST_CYCLE)
1153   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1154   match ("end file", gfc_match_endfile, ST_END_FILE)
1155   match ("exit", gfc_match_exit, ST_EXIT)
1156   match ("flush", gfc_match_flush, ST_FLUSH)
1157   match ("forall", match_simple_forall, ST_FORALL)
1158   match ("go to", gfc_match_goto, ST_GOTO)
1159   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1160   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1161   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1162   match ("open", gfc_match_open, ST_OPEN)
1163   match ("pause", gfc_match_pause, ST_NONE)
1164   match ("print", gfc_match_print, ST_WRITE)
1165   match ("read", gfc_match_read, ST_READ)
1166   match ("return", gfc_match_return, ST_RETURN)
1167   match ("rewind", gfc_match_rewind, ST_REWIND)
1168   match ("stop", gfc_match_stop, ST_STOP)
1169   match ("where", match_simple_where, ST_WHERE)
1170   match ("write", gfc_match_write, ST_WRITE)
1171
1172   /* The gfc_match_assignment() above may have returned a MATCH_NO
1173      where the assignment was to a named constant.  Check that 
1174      special case here.  */
1175   m = gfc_match_assignment ();
1176   if (m == MATCH_NO)
1177    {
1178       gfc_error ("Cannot assign to a named constant at %C");
1179       gfc_free_expr (expr);
1180       gfc_undo_symbols ();
1181       gfc_current_locus = old_loc;
1182       return MATCH_ERROR;
1183    }
1184
1185   /* All else has failed, so give up.  See if any of the matchers has
1186      stored an error message of some sort.  */
1187   if (gfc_error_check () == 0)
1188     gfc_error ("Unclassifiable statement in IF-clause at %C");
1189
1190   gfc_free_expr (expr);
1191   return MATCH_ERROR;
1192
1193 got_match:
1194   if (m == MATCH_NO)
1195     gfc_error ("Syntax error in IF-clause at %C");
1196   if (m != MATCH_YES)
1197     {
1198       gfc_free_expr (expr);
1199       return MATCH_ERROR;
1200     }
1201
1202   /* At this point, we've matched the single IF and the action clause
1203      is in new_st.  Rearrange things so that the IF statement appears
1204      in new_st.  */
1205
1206   p = gfc_get_code ();
1207   p->next = gfc_get_code ();
1208   *p->next = new_st;
1209   p->next->loc = gfc_current_locus;
1210
1211   p->expr = expr;
1212   p->op = EXEC_IF;
1213
1214   gfc_clear_new_st ();
1215
1216   new_st.op = EXEC_IF;
1217   new_st.block = p;
1218
1219   return MATCH_YES;
1220 }
1221
1222 #undef match
1223
1224
1225 /* Match an ELSE statement.  */
1226
1227 match
1228 gfc_match_else (void)
1229 {
1230   char name[GFC_MAX_SYMBOL_LEN + 1];
1231
1232   if (gfc_match_eos () == MATCH_YES)
1233     return MATCH_YES;
1234
1235   if (gfc_match_name (name) != MATCH_YES
1236       || gfc_current_block () == NULL
1237       || gfc_match_eos () != MATCH_YES)
1238     {
1239       gfc_error ("Unexpected junk after ELSE statement at %C");
1240       return MATCH_ERROR;
1241     }
1242
1243   if (strcmp (name, gfc_current_block ()->name) != 0)
1244     {
1245       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1246                  name, gfc_current_block ()->name);
1247       return MATCH_ERROR;
1248     }
1249
1250   return MATCH_YES;
1251 }
1252
1253
1254 /* Match an ELSE IF statement.  */
1255
1256 match
1257 gfc_match_elseif (void)
1258 {
1259   char name[GFC_MAX_SYMBOL_LEN + 1];
1260   gfc_expr *expr;
1261   match m;
1262
1263   m = gfc_match (" ( %e ) then", &expr);
1264   if (m != MATCH_YES)
1265     return m;
1266
1267   if (gfc_match_eos () == MATCH_YES)
1268     goto done;
1269
1270   if (gfc_match_name (name) != MATCH_YES
1271       || gfc_current_block () == NULL
1272       || gfc_match_eos () != MATCH_YES)
1273     {
1274       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1275       goto cleanup;
1276     }
1277
1278   if (strcmp (name, gfc_current_block ()->name) != 0)
1279     {
1280       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1281                  name, gfc_current_block ()->name);
1282       goto cleanup;
1283     }
1284
1285 done:
1286   new_st.op = EXEC_IF;
1287   new_st.expr = expr;
1288   return MATCH_YES;
1289
1290 cleanup:
1291   gfc_free_expr (expr);
1292   return MATCH_ERROR;
1293 }
1294
1295
1296 /* Free a gfc_iterator structure.  */
1297
1298 void
1299 gfc_free_iterator (gfc_iterator *iter, int flag)
1300 {
1301
1302   if (iter == NULL)
1303     return;
1304
1305   gfc_free_expr (iter->var);
1306   gfc_free_expr (iter->start);
1307   gfc_free_expr (iter->end);
1308   gfc_free_expr (iter->step);
1309
1310   if (flag)
1311     gfc_free (iter);
1312 }
1313
1314
1315 /* Match a DO statement.  */
1316
1317 match
1318 gfc_match_do (void)
1319 {
1320   gfc_iterator iter, *ip;
1321   locus old_loc;
1322   gfc_st_label *label;
1323   match m;
1324
1325   old_loc = gfc_current_locus;
1326
1327   label = NULL;
1328   iter.var = iter.start = iter.end = iter.step = NULL;
1329
1330   m = gfc_match_label ();
1331   if (m == MATCH_ERROR)
1332     return m;
1333
1334   if (gfc_match (" do") != MATCH_YES)
1335     return MATCH_NO;
1336
1337   m = gfc_match_st_label (&label);
1338   if (m == MATCH_ERROR)
1339     goto cleanup;
1340
1341   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1342
1343   if (gfc_match_eos () == MATCH_YES)
1344     {
1345       iter.end = gfc_logical_expr (1, NULL);
1346       new_st.op = EXEC_DO_WHILE;
1347       goto done;
1348     }
1349
1350   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1351   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1352     return MATCH_NO;
1353
1354   /* See if we have a DO WHILE.  */
1355   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1356     {
1357       new_st.op = EXEC_DO_WHILE;
1358       goto done;
1359     }
1360
1361   /* The abortive DO WHILE may have done something to the symbol
1362      table, so we start over.  */
1363   gfc_undo_symbols ();
1364   gfc_current_locus = old_loc;
1365
1366   gfc_match_label ();           /* This won't error.  */
1367   gfc_match (" do ");           /* This will work.  */
1368
1369   gfc_match_st_label (&label);  /* Can't error out.  */
1370   gfc_match_char (',');         /* Optional comma.  */
1371
1372   m = gfc_match_iterator (&iter, 0);
1373   if (m == MATCH_NO)
1374     return MATCH_NO;
1375   if (m == MATCH_ERROR)
1376     goto cleanup;
1377
1378   gfc_check_do_variable (iter.var->symtree);
1379
1380   if (gfc_match_eos () != MATCH_YES)
1381     {
1382       gfc_syntax_error (ST_DO);
1383       goto cleanup;
1384     }
1385
1386   new_st.op = EXEC_DO;
1387
1388 done:
1389   if (label != NULL
1390       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1391     goto cleanup;
1392
1393   new_st.label = label;
1394
1395   if (new_st.op == EXEC_DO_WHILE)
1396     new_st.expr = iter.end;
1397   else
1398     {
1399       new_st.ext.iterator = ip = gfc_get_iterator ();
1400       *ip = iter;
1401     }
1402
1403   return MATCH_YES;
1404
1405 cleanup:
1406   gfc_free_iterator (&iter, 0);
1407
1408   return MATCH_ERROR;
1409 }
1410
1411
1412 /* Match an EXIT or CYCLE statement.  */
1413
1414 static match
1415 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1416 {
1417   gfc_state_data *p, *o;
1418   gfc_symbol *sym;
1419   match m;
1420
1421   if (gfc_match_eos () == MATCH_YES)
1422     sym = NULL;
1423   else
1424     {
1425       m = gfc_match ("% %s%t", &sym);
1426       if (m == MATCH_ERROR)
1427         return MATCH_ERROR;
1428       if (m == MATCH_NO)
1429         {
1430           gfc_syntax_error (st);
1431           return MATCH_ERROR;
1432         }
1433
1434       if (sym->attr.flavor != FL_LABEL)
1435         {
1436           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1437                      sym->name, gfc_ascii_statement (st));
1438           return MATCH_ERROR;
1439         }
1440     }
1441
1442   /* Find the loop mentioned specified by the label (or lack of a label).  */
1443   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1444     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1445       break;
1446     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1447       o = p;
1448
1449   if (p == NULL)
1450     {
1451       if (sym == NULL)
1452         gfc_error ("%s statement at %C is not within a loop",
1453                    gfc_ascii_statement (st));
1454       else
1455         gfc_error ("%s statement at %C is not within loop '%s'",
1456                    gfc_ascii_statement (st), sym->name);
1457
1458       return MATCH_ERROR;
1459     }
1460
1461   if (o != NULL)
1462     {
1463       gfc_error ("%s statement at %C leaving OpenMP structured block",
1464                  gfc_ascii_statement (st));
1465       return MATCH_ERROR;
1466     }
1467   else if (st == ST_EXIT
1468            && p->previous != NULL
1469            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1470            && (p->previous->head->op == EXEC_OMP_DO
1471                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1472     {
1473       gcc_assert (p->previous->head->next != NULL);
1474       gcc_assert (p->previous->head->next->op == EXEC_DO
1475                   || p->previous->head->next->op == EXEC_DO_WHILE);
1476       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1477       return MATCH_ERROR;
1478     }
1479
1480   /* Save the first statement in the loop - needed by the backend.  */
1481   new_st.ext.whichloop = p->head;
1482
1483   new_st.op = op;
1484
1485   return MATCH_YES;
1486 }
1487
1488
1489 /* Match the EXIT statement.  */
1490
1491 match
1492 gfc_match_exit (void)
1493 {
1494   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1495 }
1496
1497
1498 /* Match the CYCLE statement.  */
1499
1500 match
1501 gfc_match_cycle (void)
1502 {
1503   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1504 }
1505
1506
1507 /* Match a number or character constant after a STOP or PAUSE statement.  */
1508
1509 static match
1510 gfc_match_stopcode (gfc_statement st)
1511 {
1512   int stop_code;
1513   gfc_expr *e;
1514   match m;
1515   int cnt;
1516
1517   stop_code = -1;
1518   e = NULL;
1519
1520   if (gfc_match_eos () != MATCH_YES)
1521     {
1522       m = gfc_match_small_literal_int (&stop_code, &cnt);
1523       if (m == MATCH_ERROR)
1524         goto cleanup;
1525
1526       if (m == MATCH_YES && cnt > 5)
1527         {
1528           gfc_error ("Too many digits in STOP code at %C");
1529           goto cleanup;
1530         }
1531
1532       if (m == MATCH_NO)
1533         {
1534           /* Try a character constant.  */
1535           m = gfc_match_expr (&e);
1536           if (m == MATCH_ERROR)
1537             goto cleanup;
1538           if (m == MATCH_NO)
1539             goto syntax;
1540           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1541             goto syntax;
1542         }
1543
1544       if (gfc_match_eos () != MATCH_YES)
1545         goto syntax;
1546     }
1547
1548   if (gfc_pure (NULL))
1549     {
1550       gfc_error ("%s statement not allowed in PURE procedure at %C",
1551                  gfc_ascii_statement (st));
1552       goto cleanup;
1553     }
1554
1555   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1556   new_st.expr = e;
1557   new_st.ext.stop_code = stop_code;
1558
1559   return MATCH_YES;
1560
1561 syntax:
1562   gfc_syntax_error (st);
1563
1564 cleanup:
1565
1566   gfc_free_expr (e);
1567   return MATCH_ERROR;
1568 }
1569
1570
1571 /* Match the (deprecated) PAUSE statement.  */
1572
1573 match
1574 gfc_match_pause (void)
1575 {
1576   match m;
1577
1578   m = gfc_match_stopcode (ST_PAUSE);
1579   if (m == MATCH_YES)
1580     {
1581       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
1582           " at %C")
1583           == FAILURE)
1584         m = MATCH_ERROR;
1585     }
1586   return m;
1587 }
1588
1589
1590 /* Match the STOP statement.  */
1591
1592 match
1593 gfc_match_stop (void)
1594 {
1595   return gfc_match_stopcode (ST_STOP);
1596 }
1597
1598
1599 /* Match a CONTINUE statement.  */
1600
1601 match
1602 gfc_match_continue (void)
1603 {
1604   if (gfc_match_eos () != MATCH_YES)
1605     {
1606       gfc_syntax_error (ST_CONTINUE);
1607       return MATCH_ERROR;
1608     }
1609
1610   new_st.op = EXEC_CONTINUE;
1611   return MATCH_YES;
1612 }
1613
1614
1615 /* Match the (deprecated) ASSIGN statement.  */
1616
1617 match
1618 gfc_match_assign (void)
1619 {
1620   gfc_expr *expr;
1621   gfc_st_label *label;
1622
1623   if (gfc_match (" %l", &label) == MATCH_YES)
1624     {
1625       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
1626         return MATCH_ERROR;
1627       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
1628         {
1629           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
1630                               "statement at %C")
1631               == FAILURE)
1632             return MATCH_ERROR;
1633
1634           expr->symtree->n.sym->attr.assign = 1;
1635
1636           new_st.op = EXEC_LABEL_ASSIGN;
1637           new_st.label = label;
1638           new_st.expr = expr;
1639           return MATCH_YES;
1640         }
1641     }
1642   return MATCH_NO;
1643 }
1644
1645
1646 /* Match the GO TO statement.  As a computed GOTO statement is
1647    matched, it is transformed into an equivalent SELECT block.  No
1648    tree is necessary, and the resulting jumps-to-jumps are
1649    specifically optimized away by the back end.  */
1650
1651 match
1652 gfc_match_goto (void)
1653 {
1654   gfc_code *head, *tail;
1655   gfc_expr *expr;
1656   gfc_case *cp;
1657   gfc_st_label *label;
1658   int i;
1659   match m;
1660
1661   if (gfc_match (" %l%t", &label) == MATCH_YES)
1662     {
1663       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1664         return MATCH_ERROR;
1665
1666       new_st.op = EXEC_GOTO;
1667       new_st.label = label;
1668       return MATCH_YES;
1669     }
1670
1671   /* The assigned GO TO statement.  */ 
1672
1673   if (gfc_match_variable (&expr, 0) == MATCH_YES)
1674     {
1675       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
1676                           "statement at %C")
1677           == FAILURE)
1678         return MATCH_ERROR;
1679
1680       new_st.op = EXEC_GOTO;
1681       new_st.expr = expr;
1682
1683       if (gfc_match_eos () == MATCH_YES)
1684         return MATCH_YES;
1685
1686       /* Match label list.  */
1687       gfc_match_char (',');
1688       if (gfc_match_char ('(') != MATCH_YES)
1689         {
1690           gfc_syntax_error (ST_GOTO);
1691           return MATCH_ERROR;
1692         }
1693       head = tail = NULL;
1694
1695       do
1696         {
1697           m = gfc_match_st_label (&label);
1698           if (m != MATCH_YES)
1699             goto syntax;
1700
1701           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1702             goto cleanup;
1703
1704           if (head == NULL)
1705             head = tail = gfc_get_code ();
1706           else
1707             {
1708               tail->block = gfc_get_code ();
1709               tail = tail->block;
1710             }
1711
1712           tail->label = label;
1713           tail->op = EXEC_GOTO;
1714         }
1715       while (gfc_match_char (',') == MATCH_YES);
1716
1717       if (gfc_match (")%t") != MATCH_YES)
1718         goto syntax;
1719
1720       if (head == NULL)
1721         {
1722            gfc_error ("Statement label list in GOTO at %C cannot be empty");
1723            goto syntax;
1724         }
1725       new_st.block = head;
1726
1727       return MATCH_YES;
1728     }
1729
1730   /* Last chance is a computed GO TO statement.  */
1731   if (gfc_match_char ('(') != MATCH_YES)
1732     {
1733       gfc_syntax_error (ST_GOTO);
1734       return MATCH_ERROR;
1735     }
1736
1737   head = tail = NULL;
1738   i = 1;
1739
1740   do
1741     {
1742       m = gfc_match_st_label (&label);
1743       if (m != MATCH_YES)
1744         goto syntax;
1745
1746       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1747         goto cleanup;
1748
1749       if (head == NULL)
1750         head = tail = gfc_get_code ();
1751       else
1752         {
1753           tail->block = gfc_get_code ();
1754           tail = tail->block;
1755         }
1756
1757       cp = gfc_get_case ();
1758       cp->low = cp->high = gfc_int_expr (i++);
1759
1760       tail->op = EXEC_SELECT;
1761       tail->ext.case_list = cp;
1762
1763       tail->next = gfc_get_code ();
1764       tail->next->op = EXEC_GOTO;
1765       tail->next->label = label;
1766     }
1767   while (gfc_match_char (',') == MATCH_YES);
1768
1769   if (gfc_match_char (')') != MATCH_YES)
1770     goto syntax;
1771
1772   if (head == NULL)
1773     {
1774       gfc_error ("Statement label list in GOTO at %C cannot be empty");
1775       goto syntax;
1776     }
1777
1778   /* Get the rest of the statement.  */
1779   gfc_match_char (',');
1780
1781   if (gfc_match (" %e%t", &expr) != MATCH_YES)
1782     goto syntax;
1783
1784   /* At this point, a computed GOTO has been fully matched and an
1785      equivalent SELECT statement constructed.  */
1786
1787   new_st.op = EXEC_SELECT;
1788   new_st.expr = NULL;
1789
1790   /* Hack: For a "real" SELECT, the expression is in expr. We put
1791      it in expr2 so we can distinguish then and produce the correct
1792      diagnostics.  */
1793   new_st.expr2 = expr;
1794   new_st.block = head;
1795   return MATCH_YES;
1796
1797 syntax:
1798   gfc_syntax_error (ST_GOTO);
1799 cleanup:
1800   gfc_free_statements (head);
1801   return MATCH_ERROR;
1802 }
1803
1804
1805 /* Frees a list of gfc_alloc structures.  */
1806
1807 void
1808 gfc_free_alloc_list (gfc_alloc *p)
1809 {
1810   gfc_alloc *q;
1811
1812   for (; p; p = q)
1813     {
1814       q = p->next;
1815       gfc_free_expr (p->expr);
1816       gfc_free (p);
1817     }
1818 }
1819
1820
1821 /* Match an ALLOCATE statement.  */
1822
1823 match
1824 gfc_match_allocate (void)
1825 {
1826   gfc_alloc *head, *tail;
1827   gfc_expr *stat;
1828   match m;
1829
1830   head = tail = NULL;
1831   stat = NULL;
1832
1833   if (gfc_match_char ('(') != MATCH_YES)
1834     goto syntax;
1835
1836   for (;;)
1837     {
1838       if (head == NULL)
1839         head = tail = gfc_get_alloc ();
1840       else
1841         {
1842           tail->next = gfc_get_alloc ();
1843           tail = tail->next;
1844         }
1845
1846       m = gfc_match_variable (&tail->expr, 0);
1847       if (m == MATCH_NO)
1848         goto syntax;
1849       if (m == MATCH_ERROR)
1850         goto cleanup;
1851
1852       if (gfc_check_do_variable (tail->expr->symtree))
1853         goto cleanup;
1854
1855       if (gfc_pure (NULL)
1856           && gfc_impure_variable (tail->expr->symtree->n.sym))
1857         {
1858           gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1859                      "PURE procedure");
1860           goto cleanup;
1861         }
1862
1863       if (tail->expr->ts.type == BT_DERIVED)
1864         tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
1865
1866       if (gfc_match_char (',') != MATCH_YES)
1867         break;
1868
1869       m = gfc_match (" stat = %v", &stat);
1870       if (m == MATCH_ERROR)
1871         goto cleanup;
1872       if (m == MATCH_YES)
1873         break;
1874     }
1875
1876   if (stat != NULL)
1877     {
1878       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
1879         {
1880           gfc_error ("STAT variable '%s' of ALLOCATE statement at %C cannot "
1881                      "be INTENT(IN)", stat->symtree->n.sym->name);
1882           goto cleanup;
1883         }
1884
1885       if (gfc_pure (NULL) && gfc_impure_variable (stat->symtree->n.sym))
1886         {
1887           gfc_error ("Illegal STAT variable in ALLOCATE statement at %C "
1888                      "for a PURE procedure");
1889           goto cleanup;
1890         }
1891
1892       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
1893         {
1894           gfc_error ("STAT expression at %C must be a variable");
1895           goto cleanup;
1896         }
1897
1898       gfc_check_do_variable(stat->symtree);
1899     }
1900
1901   if (gfc_match (" )%t") != MATCH_YES)
1902     goto syntax;
1903
1904   new_st.op = EXEC_ALLOCATE;
1905   new_st.expr = stat;
1906   new_st.ext.alloc_list = head;
1907
1908   return MATCH_YES;
1909
1910 syntax:
1911   gfc_syntax_error (ST_ALLOCATE);
1912
1913 cleanup:
1914   gfc_free_expr (stat);
1915   gfc_free_alloc_list (head);
1916   return MATCH_ERROR;
1917 }
1918
1919
1920 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1921    a set of pointer assignments to intrinsic NULL().  */
1922
1923 match
1924 gfc_match_nullify (void)
1925 {
1926   gfc_code *tail;
1927   gfc_expr *e, *p;
1928   match m;
1929
1930   tail = NULL;
1931
1932   if (gfc_match_char ('(') != MATCH_YES)
1933     goto syntax;
1934
1935   for (;;)
1936     {
1937       m = gfc_match_variable (&p, 0);
1938       if (m == MATCH_ERROR)
1939         goto cleanup;
1940       if (m == MATCH_NO)
1941         goto syntax;
1942
1943       if (gfc_check_do_variable (p->symtree))
1944         goto cleanup;
1945
1946       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
1947         {
1948           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
1949           goto cleanup;
1950         }
1951
1952       /* build ' => NULL() '.  */
1953       e = gfc_get_expr ();
1954       e->where = gfc_current_locus;
1955       e->expr_type = EXPR_NULL;
1956       e->ts.type = BT_UNKNOWN;
1957
1958       /* Chain to list.  */
1959       if (tail == NULL)
1960         tail = &new_st;
1961       else
1962         {
1963           tail->next = gfc_get_code ();
1964           tail = tail->next;
1965         }
1966
1967       tail->op = EXEC_POINTER_ASSIGN;
1968       tail->expr = p;
1969       tail->expr2 = e;
1970
1971       if (gfc_match (" )%t") == MATCH_YES)
1972         break;
1973       if (gfc_match_char (',') != MATCH_YES)
1974         goto syntax;
1975     }
1976
1977   return MATCH_YES;
1978
1979 syntax:
1980   gfc_syntax_error (ST_NULLIFY);
1981
1982 cleanup:
1983   gfc_free_statements (new_st.next);
1984   return MATCH_ERROR;
1985 }
1986
1987
1988 /* Match a DEALLOCATE statement.  */
1989
1990 match
1991 gfc_match_deallocate (void)
1992 {
1993   gfc_alloc *head, *tail;
1994   gfc_expr *stat;
1995   match m;
1996
1997   head = tail = NULL;
1998   stat = NULL;
1999
2000   if (gfc_match_char ('(') != MATCH_YES)
2001     goto syntax;
2002
2003   for (;;)
2004     {
2005       if (head == NULL)
2006         head = tail = gfc_get_alloc ();
2007       else
2008         {
2009           tail->next = gfc_get_alloc ();
2010           tail = tail->next;
2011         }
2012
2013       m = gfc_match_variable (&tail->expr, 0);
2014       if (m == MATCH_ERROR)
2015         goto cleanup;
2016       if (m == MATCH_NO)
2017         goto syntax;
2018
2019       if (gfc_check_do_variable (tail->expr->symtree))
2020         goto cleanup;
2021
2022       if (gfc_pure (NULL)
2023           && gfc_impure_variable (tail->expr->symtree->n.sym))
2024         {
2025           gfc_error ("Illegal deallocate-expression in DEALLOCATE at %C "
2026                      "for a PURE procedure");
2027           goto cleanup;
2028         }
2029
2030       if (gfc_match_char (',') != MATCH_YES)
2031         break;
2032
2033       m = gfc_match (" stat = %v", &stat);
2034       if (m == MATCH_ERROR)
2035         goto cleanup;
2036       if (m == MATCH_YES)
2037         break;
2038     }
2039
2040   if (stat != NULL)
2041     {
2042       if (stat->symtree->n.sym->attr.intent == INTENT_IN)
2043         {
2044           gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
2045                      "cannot be INTENT(IN)", stat->symtree->n.sym->name);
2046           goto cleanup;
2047         }
2048
2049       if (gfc_pure(NULL) && gfc_impure_variable (stat->symtree->n.sym))
2050         {
2051           gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
2052                      "for a PURE procedure");
2053           goto cleanup;
2054         }
2055
2056       if (stat->symtree->n.sym->attr.flavor != FL_VARIABLE)
2057         {
2058           gfc_error ("STAT expression at %C must be a variable");
2059           goto cleanup;
2060         }
2061
2062       gfc_check_do_variable(stat->symtree);
2063     }
2064
2065   if (gfc_match (" )%t") != MATCH_YES)
2066     goto syntax;
2067
2068   new_st.op = EXEC_DEALLOCATE;
2069   new_st.expr = stat;
2070   new_st.ext.alloc_list = head;
2071
2072   return MATCH_YES;
2073
2074 syntax:
2075   gfc_syntax_error (ST_DEALLOCATE);
2076
2077 cleanup:
2078   gfc_free_expr (stat);
2079   gfc_free_alloc_list (head);
2080   return MATCH_ERROR;
2081 }
2082
2083
2084 /* Match a RETURN statement.  */
2085
2086 match
2087 gfc_match_return (void)
2088 {
2089   gfc_expr *e;
2090   match m;
2091   gfc_compile_state s;
2092   int c;
2093
2094   e = NULL;
2095   if (gfc_match_eos () == MATCH_YES)
2096     goto done;
2097
2098   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2099     {
2100       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2101                  "a SUBROUTINE");
2102       goto cleanup;
2103     }
2104
2105   if (gfc_current_form == FORM_FREE)
2106     {
2107       /* The following are valid, so we can't require a blank after the
2108         RETURN keyword:
2109           return+1
2110           return(1)  */
2111       c = gfc_peek_char ();
2112       if (ISALPHA (c) || ISDIGIT (c))
2113         return MATCH_NO;
2114     }
2115
2116   m = gfc_match (" %e%t", &e);
2117   if (m == MATCH_YES)
2118     goto done;
2119   if (m == MATCH_ERROR)
2120     goto cleanup;
2121
2122   gfc_syntax_error (ST_RETURN);
2123
2124 cleanup:
2125   gfc_free_expr (e);
2126   return MATCH_ERROR;
2127
2128 done:
2129   gfc_enclosing_unit (&s);
2130   if (s == COMP_PROGRAM
2131       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2132                         "main program at %C") == FAILURE)
2133       return MATCH_ERROR;
2134
2135   new_st.op = EXEC_RETURN;
2136   new_st.expr = e;
2137
2138   return MATCH_YES;
2139 }
2140
2141
2142 /* Match a CALL statement.  The tricky part here are possible
2143    alternate return specifiers.  We handle these by having all
2144    "subroutines" actually return an integer via a register that gives
2145    the return number.  If the call specifies alternate returns, we
2146    generate code for a SELECT statement whose case clauses contain
2147    GOTOs to the various labels.  */
2148
2149 match
2150 gfc_match_call (void)
2151 {
2152   char name[GFC_MAX_SYMBOL_LEN + 1];
2153   gfc_actual_arglist *a, *arglist;
2154   gfc_case *new_case;
2155   gfc_symbol *sym;
2156   gfc_symtree *st;
2157   gfc_code *c;
2158   match m;
2159   int i;
2160
2161   arglist = NULL;
2162
2163   m = gfc_match ("% %n", name);
2164   if (m == MATCH_NO)
2165     goto syntax;
2166   if (m != MATCH_YES)
2167     return m;
2168
2169   if (gfc_get_ha_sym_tree (name, &st))
2170     return MATCH_ERROR;
2171
2172   sym = st->n.sym;
2173
2174   if (sym->ns != gfc_current_ns
2175         && !sym->attr.generic
2176         && !sym->attr.subroutine
2177         && gfc_get_sym_tree (name, NULL, &st) == 1)
2178     return MATCH_ERROR;
2179
2180   sym = st->n.sym;
2181
2182   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
2183     return MATCH_ERROR;
2184
2185   gfc_set_sym_referenced (sym);
2186
2187   if (gfc_match_eos () != MATCH_YES)
2188     {
2189       m = gfc_match_actual_arglist (1, &arglist);
2190       if (m == MATCH_NO)
2191         goto syntax;
2192       if (m == MATCH_ERROR)
2193         goto cleanup;
2194
2195       if (gfc_match_eos () != MATCH_YES)
2196         goto syntax;
2197     }
2198
2199   /* If any alternate return labels were found, construct a SELECT
2200      statement that will jump to the right place.  */
2201
2202   i = 0;
2203   for (a = arglist; a; a = a->next)
2204     if (a->expr == NULL)
2205       i = 1;
2206
2207   if (i)
2208     {
2209       gfc_symtree *select_st;
2210       gfc_symbol *select_sym;
2211       char name[GFC_MAX_SYMBOL_LEN + 1];
2212
2213       new_st.next = c = gfc_get_code ();
2214       c->op = EXEC_SELECT;
2215       sprintf (name, "_result_%s", sym->name);
2216       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
2217
2218       select_sym = select_st->n.sym;
2219       select_sym->ts.type = BT_INTEGER;
2220       select_sym->ts.kind = gfc_default_integer_kind;
2221       gfc_set_sym_referenced (select_sym);
2222       c->expr = gfc_get_expr ();
2223       c->expr->expr_type = EXPR_VARIABLE;
2224       c->expr->symtree = select_st;
2225       c->expr->ts = select_sym->ts;
2226       c->expr->where = gfc_current_locus;
2227
2228       i = 0;
2229       for (a = arglist; a; a = a->next)
2230         {
2231           if (a->expr != NULL)
2232             continue;
2233
2234           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
2235             continue;
2236
2237           i++;
2238
2239           c->block = gfc_get_code ();
2240           c = c->block;
2241           c->op = EXEC_SELECT;
2242
2243           new_case = gfc_get_case ();
2244           new_case->high = new_case->low = gfc_int_expr (i);
2245           c->ext.case_list = new_case;
2246
2247           c->next = gfc_get_code ();
2248           c->next->op = EXEC_GOTO;
2249           c->next->label = a->label;
2250         }
2251     }
2252
2253   new_st.op = EXEC_CALL;
2254   new_st.symtree = st;
2255   new_st.ext.actual = arglist;
2256
2257   return MATCH_YES;
2258
2259 syntax:
2260   gfc_syntax_error (ST_CALL);
2261
2262 cleanup:
2263   gfc_free_actual_arglist (arglist);
2264   return MATCH_ERROR;
2265 }
2266
2267
2268 /* Given a name, return a pointer to the common head structure,
2269    creating it if it does not exist. If FROM_MODULE is nonzero, we
2270    mangle the name so that it doesn't interfere with commons defined 
2271    in the using namespace.
2272    TODO: Add to global symbol tree.  */
2273
2274 gfc_common_head *
2275 gfc_get_common (const char *name, int from_module)
2276 {
2277   gfc_symtree *st;
2278   static int serial = 0;
2279   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
2280
2281   if (from_module)
2282     {
2283       /* A use associated common block is only needed to correctly layout
2284          the variables it contains.  */
2285       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
2286       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
2287     }
2288   else
2289     {
2290       st = gfc_find_symtree (gfc_current_ns->common_root, name);
2291
2292       if (st == NULL)
2293         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
2294     }
2295
2296   if (st->n.common == NULL)
2297     {
2298       st->n.common = gfc_get_common_head ();
2299       st->n.common->where = gfc_current_locus;
2300       strcpy (st->n.common->name, name);
2301     }
2302
2303   return st->n.common;
2304 }
2305
2306
2307 /* Match a common block name.  */
2308
2309 static match
2310 match_common_name (char *name)
2311 {
2312   match m;
2313
2314   if (gfc_match_char ('/') == MATCH_NO)
2315     {
2316       name[0] = '\0';
2317       return MATCH_YES;
2318     }
2319
2320   if (gfc_match_char ('/') == MATCH_YES)
2321     {
2322       name[0] = '\0';
2323       return MATCH_YES;
2324     }
2325
2326   m = gfc_match_name (name);
2327
2328   if (m == MATCH_ERROR)
2329     return MATCH_ERROR;
2330   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
2331     return MATCH_YES;
2332
2333   gfc_error ("Syntax error in common block name at %C");
2334   return MATCH_ERROR;
2335 }
2336
2337
2338 /* Match a COMMON statement.  */
2339
2340 match
2341 gfc_match_common (void)
2342 {
2343   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
2344   char name[GFC_MAX_SYMBOL_LEN + 1];
2345   gfc_common_head *t;
2346   gfc_array_spec *as;
2347   gfc_equiv *e1, *e2;
2348   match m;
2349   gfc_gsymbol *gsym;
2350
2351   old_blank_common = gfc_current_ns->blank_common.head;
2352   if (old_blank_common)
2353     {
2354       while (old_blank_common->common_next)
2355         old_blank_common = old_blank_common->common_next;
2356     }
2357
2358   as = NULL;
2359
2360   for (;;)
2361     {
2362       m = match_common_name (name);
2363       if (m == MATCH_ERROR)
2364         goto cleanup;
2365
2366       gsym = gfc_get_gsymbol (name);
2367       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
2368         {
2369           gfc_error ("Symbol '%s' at %C is already an external symbol that "
2370                      "is not COMMON", name);
2371           goto cleanup;
2372         }
2373
2374       if (gsym->type == GSYM_UNKNOWN)
2375         {
2376           gsym->type = GSYM_COMMON;
2377           gsym->where = gfc_current_locus;
2378           gsym->defined = 1;
2379         }
2380
2381       gsym->used = 1;
2382
2383       if (name[0] == '\0')
2384         {
2385           if (gfc_current_ns->is_block_data)
2386             {
2387               gfc_warning ("BLOCK DATA unit cannot contain blank COMMON "
2388                            "at %C");
2389             }
2390           t = &gfc_current_ns->blank_common;
2391           if (t->head == NULL)
2392             t->where = gfc_current_locus;
2393         }
2394       else
2395         {
2396           t = gfc_get_common (name, 0);
2397         }
2398       head = &t->head;
2399
2400       if (*head == NULL)
2401         tail = NULL;
2402       else
2403         {
2404           tail = *head;
2405           while (tail->common_next)
2406             tail = tail->common_next;
2407         }
2408
2409       /* Grab the list of symbols.  */
2410       for (;;)
2411         {
2412           m = gfc_match_symbol (&sym, 0);
2413           if (m == MATCH_ERROR)
2414             goto cleanup;
2415           if (m == MATCH_NO)
2416             goto syntax;
2417
2418           if (sym->attr.in_common)
2419             {
2420               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2421                          sym->name);
2422               goto cleanup;
2423             }
2424
2425           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE) 
2426             goto cleanup;
2427
2428           if (sym->value != NULL && sym->value->expr_type != EXPR_NULL
2429               && (name[0] == '\0' || !sym->attr.data))
2430             {
2431               if (name[0] == '\0')
2432                 gfc_error ("Previously initialized symbol '%s' in "
2433                            "blank COMMON block at %C", sym->name);
2434               else
2435                 gfc_error ("Previously initialized symbol '%s' in "
2436                            "COMMON block '%s' at %C", sym->name, name);
2437               goto cleanup;
2438             }
2439
2440           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
2441             goto cleanup;
2442
2443           /* Derived type names must have the SEQUENCE attribute.  */
2444           if (sym->ts.type == BT_DERIVED && !sym->ts.derived->attr.sequence)
2445             {
2446               gfc_error ("Derived type variable in COMMON at %C does not "
2447                          "have the SEQUENCE attribute");
2448               goto cleanup;
2449             }
2450
2451           if (tail != NULL)
2452             tail->common_next = sym;
2453           else
2454             *head = sym;
2455
2456           tail = sym;
2457
2458           /* Deal with an optional array specification after the
2459              symbol name.  */
2460           m = gfc_match_array_spec (&as);
2461           if (m == MATCH_ERROR)
2462             goto cleanup;
2463
2464           if (m == MATCH_YES)
2465             {
2466               if (as->type != AS_EXPLICIT)
2467                 {
2468                   gfc_error ("Array specification for symbol '%s' in COMMON "
2469                              "at %C must be explicit", sym->name);
2470                   goto cleanup;
2471                 }
2472
2473               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
2474                 goto cleanup;
2475
2476               if (sym->attr.pointer)
2477                 {
2478                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
2479                              "POINTER array", sym->name);
2480                   goto cleanup;
2481                 }
2482
2483               sym->as = as;
2484               as = NULL;
2485
2486             }
2487
2488           sym->common_head = t;
2489
2490           /* Check to see if the symbol is already in an equivalence group.
2491              If it is, set the other members as being in common.  */
2492           if (sym->attr.in_equivalence)
2493             {
2494               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
2495                 {
2496                   for (e2 = e1; e2; e2 = e2->eq)
2497                     if (e2->expr->symtree->n.sym == sym)
2498                       goto equiv_found;
2499
2500                   continue;
2501
2502           equiv_found:
2503
2504                   for (e2 = e1; e2; e2 = e2->eq)
2505                     {
2506                       other = e2->expr->symtree->n.sym;
2507                       if (other->common_head
2508                           && other->common_head != sym->common_head)
2509                         {
2510                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
2511                                      "%C is being indirectly equivalenced to "
2512                                      "another COMMON block '%s'",
2513                                      sym->name, sym->common_head->name,
2514                                      other->common_head->name);
2515                             goto cleanup;
2516                         }
2517                       other->attr.in_common = 1;
2518                       other->common_head = t;
2519                     }
2520                 }
2521             }
2522
2523
2524           gfc_gobble_whitespace ();
2525           if (gfc_match_eos () == MATCH_YES)
2526             goto done;
2527           if (gfc_peek_char () == '/')
2528             break;
2529           if (gfc_match_char (',') != MATCH_YES)
2530             goto syntax;
2531           gfc_gobble_whitespace ();
2532           if (gfc_peek_char () == '/')
2533             break;
2534         }
2535     }
2536
2537 done:
2538   return MATCH_YES;
2539
2540 syntax:
2541   gfc_syntax_error (ST_COMMON);
2542
2543 cleanup:
2544   if (old_blank_common)
2545     old_blank_common->common_next = NULL;
2546   else
2547     gfc_current_ns->blank_common.head = NULL;
2548   gfc_free_array_spec (as);
2549   return MATCH_ERROR;
2550 }
2551
2552
2553 /* Match a BLOCK DATA program unit.  */
2554
2555 match
2556 gfc_match_block_data (void)
2557 {
2558   char name[GFC_MAX_SYMBOL_LEN + 1];
2559   gfc_symbol *sym;
2560   match m;
2561
2562   if (gfc_match_eos () == MATCH_YES)
2563     {
2564       gfc_new_block = NULL;
2565       return MATCH_YES;
2566     }
2567
2568   m = gfc_match ("% %n%t", name);
2569   if (m != MATCH_YES)
2570     return MATCH_ERROR;
2571
2572   if (gfc_get_symbol (name, NULL, &sym))
2573     return MATCH_ERROR;
2574
2575   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
2576     return MATCH_ERROR;
2577
2578   gfc_new_block = sym;
2579
2580   return MATCH_YES;
2581 }
2582
2583
2584 /* Free a namelist structure.  */
2585
2586 void
2587 gfc_free_namelist (gfc_namelist *name)
2588 {
2589   gfc_namelist *n;
2590
2591   for (; name; name = n)
2592     {
2593       n = name->next;
2594       gfc_free (name);
2595     }
2596 }
2597
2598
2599 /* Match a NAMELIST statement.  */
2600
2601 match
2602 gfc_match_namelist (void)
2603 {
2604   gfc_symbol *group_name, *sym;
2605   gfc_namelist *nl;
2606   match m, m2;
2607
2608   m = gfc_match (" / %s /", &group_name);
2609   if (m == MATCH_NO)
2610     goto syntax;
2611   if (m == MATCH_ERROR)
2612     goto error;
2613
2614   for (;;)
2615     {
2616       if (group_name->ts.type != BT_UNKNOWN)
2617         {
2618           gfc_error ("Namelist group name '%s' at %C already has a basic "
2619                      "type of %s", group_name->name,
2620                      gfc_typename (&group_name->ts));
2621           return MATCH_ERROR;
2622         }
2623
2624       if (group_name->attr.flavor == FL_NAMELIST
2625           && group_name->attr.use_assoc
2626           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
2627                              "at %C already is USE associated and can"
2628                              "not be respecified.", group_name->name)
2629              == FAILURE)
2630         return MATCH_ERROR;
2631
2632       if (group_name->attr.flavor != FL_NAMELIST
2633           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
2634                              group_name->name, NULL) == FAILURE)
2635         return MATCH_ERROR;
2636
2637       for (;;)
2638         {
2639           m = gfc_match_symbol (&sym, 1);
2640           if (m == MATCH_NO)
2641             goto syntax;
2642           if (m == MATCH_ERROR)
2643             goto error;
2644
2645           if (sym->attr.in_namelist == 0
2646               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
2647             goto error;
2648
2649           /* Use gfc_error_check here, rather than goto error, so that
2650              these are the only errors for the next two lines.  */
2651           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
2652             {
2653               gfc_error ("Assumed size array '%s' in namelist '%s' at "
2654                          "%C is not allowed", sym->name, group_name->name);
2655               gfc_error_check ();
2656             }
2657
2658           if (sym->ts.type == BT_CHARACTER && sym->ts.cl->length == NULL)
2659             {
2660               gfc_error ("Assumed character length '%s' in namelist '%s' at "
2661                          "%C is not allowed", sym->name, group_name->name);
2662               gfc_error_check ();
2663             }
2664
2665           if (sym->as && sym->as->type == AS_ASSUMED_SHAPE
2666               && gfc_notify_std (GFC_STD_GNU, "Assumed shape array '%s' in "
2667                                  "namelist '%s' at %C is an extension.",
2668                                  sym->name, group_name->name) == FAILURE)
2669             gfc_error_check ();
2670
2671           nl = gfc_get_namelist ();
2672           nl->sym = sym;
2673           sym->refs++;
2674
2675           if (group_name->namelist == NULL)
2676             group_name->namelist = group_name->namelist_tail = nl;
2677           else
2678             {
2679               group_name->namelist_tail->next = nl;
2680               group_name->namelist_tail = nl;
2681             }
2682
2683           if (gfc_match_eos () == MATCH_YES)
2684             goto done;
2685
2686           m = gfc_match_char (',');
2687
2688           if (gfc_match_char ('/') == MATCH_YES)
2689             {
2690               m2 = gfc_match (" %s /", &group_name);
2691               if (m2 == MATCH_YES)
2692                 break;
2693               if (m2 == MATCH_ERROR)
2694                 goto error;
2695               goto syntax;
2696             }
2697
2698           if (m != MATCH_YES)
2699             goto syntax;
2700         }
2701     }
2702
2703 done:
2704   return MATCH_YES;
2705
2706 syntax:
2707   gfc_syntax_error (ST_NAMELIST);
2708
2709 error:
2710   return MATCH_ERROR;
2711 }
2712
2713
2714 /* Match a MODULE statement.  */
2715
2716 match
2717 gfc_match_module (void)
2718 {
2719   match m;
2720
2721   m = gfc_match (" %s%t", &gfc_new_block);
2722   if (m != MATCH_YES)
2723     return m;
2724
2725   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
2726                       gfc_new_block->name, NULL) == FAILURE)
2727     return MATCH_ERROR;
2728
2729   return MATCH_YES;
2730 }
2731
2732
2733 /* Free equivalence sets and lists.  Recursively is the easiest way to
2734    do this.  */
2735
2736 void
2737 gfc_free_equiv (gfc_equiv *eq)
2738 {
2739   if (eq == NULL)
2740     return;
2741
2742   gfc_free_equiv (eq->eq);
2743   gfc_free_equiv (eq->next);
2744   gfc_free_expr (eq->expr);
2745   gfc_free (eq);
2746 }
2747
2748
2749 /* Match an EQUIVALENCE statement.  */
2750
2751 match
2752 gfc_match_equivalence (void)
2753 {
2754   gfc_equiv *eq, *set, *tail;
2755   gfc_ref *ref;
2756   gfc_symbol *sym;
2757   match m;
2758   gfc_common_head *common_head = NULL;
2759   bool common_flag;
2760   int cnt;
2761
2762   tail = NULL;
2763
2764   for (;;)
2765     {
2766       eq = gfc_get_equiv ();
2767       if (tail == NULL)
2768         tail = eq;
2769
2770       eq->next = gfc_current_ns->equiv;
2771       gfc_current_ns->equiv = eq;
2772
2773       if (gfc_match_char ('(') != MATCH_YES)
2774         goto syntax;
2775
2776       set = eq;
2777       common_flag = FALSE;
2778       cnt = 0;
2779
2780       for (;;)
2781         {
2782           m = gfc_match_equiv_variable (&set->expr);
2783           if (m == MATCH_ERROR)
2784             goto cleanup;
2785           if (m == MATCH_NO)
2786             goto syntax;
2787
2788           /*  count the number of objects.  */
2789           cnt++;
2790
2791           if (gfc_match_char ('%') == MATCH_YES)
2792             {
2793               gfc_error ("Derived type component %C is not a "
2794                          "permitted EQUIVALENCE member");
2795               goto cleanup;
2796             }
2797
2798           for (ref = set->expr->ref; ref; ref = ref->next)
2799             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
2800               {
2801                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
2802                            "be an array section");
2803                 goto cleanup;
2804               }
2805
2806           sym = set->expr->symtree->n.sym;
2807
2808           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
2809             goto cleanup;
2810
2811           if (sym->attr.in_common)
2812             {
2813               common_flag = TRUE;
2814               common_head = sym->common_head;
2815             }
2816
2817           if (gfc_match_char (')') == MATCH_YES)
2818             break;
2819
2820           if (gfc_match_char (',') != MATCH_YES)
2821             goto syntax;
2822
2823           set->eq = gfc_get_equiv ();
2824           set = set->eq;
2825         }
2826
2827       if (cnt < 2)
2828         {
2829           gfc_error ("EQUIVALENCE at %C requires two or more objects");
2830           goto cleanup;
2831         }
2832
2833       /* If one of the members of an equivalence is in common, then
2834          mark them all as being in common.  Before doing this, check
2835          that members of the equivalence group are not in different
2836          common blocks.  */
2837       if (common_flag)
2838         for (set = eq; set; set = set->eq)
2839           {
2840             sym = set->expr->symtree->n.sym;
2841             if (sym->common_head && sym->common_head != common_head)
2842               {
2843                 gfc_error ("Attempt to indirectly overlap COMMON "
2844                            "blocks %s and %s by EQUIVALENCE at %C",
2845                            sym->common_head->name, common_head->name);
2846                 goto cleanup;
2847               }
2848             sym->attr.in_common = 1;
2849             sym->common_head = common_head;
2850           }
2851
2852       if (gfc_match_eos () == MATCH_YES)
2853         break;
2854       if (gfc_match_char (',') != MATCH_YES)
2855         goto syntax;
2856     }
2857
2858   return MATCH_YES;
2859
2860 syntax:
2861   gfc_syntax_error (ST_EQUIVALENCE);
2862
2863 cleanup:
2864   eq = tail->next;
2865   tail->next = NULL;
2866
2867   gfc_free_equiv (gfc_current_ns->equiv);
2868   gfc_current_ns->equiv = eq;
2869
2870   return MATCH_ERROR;
2871 }
2872
2873
2874 /* Check that a statement function is not recursive. This is done by looking
2875    for the statement function symbol(sym) by looking recursively through its
2876    expression(e).  If a reference to sym is found, true is returned.  
2877    12.5.4 requires that any variable of function that is implicitly typed
2878    shall have that type confirmed by any subsequent type declaration.  The
2879    implicit typing is conveniently done here.  */
2880
2881 static bool
2882 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
2883 {
2884   gfc_actual_arglist *arg;
2885   gfc_ref *ref;
2886   int i;
2887
2888   if (e == NULL)
2889     return false;
2890
2891   switch (e->expr_type)
2892     {
2893     case EXPR_FUNCTION:
2894       for (arg = e->value.function.actual; arg; arg = arg->next)
2895         {
2896           if (sym->name == arg->name || recursive_stmt_fcn (arg->expr, sym))
2897             return true;
2898         }
2899
2900       if (e->symtree == NULL)
2901         return false;
2902
2903       /* Check the name before testing for nested recursion!  */
2904       if (sym->name == e->symtree->n.sym->name)
2905         return true;
2906
2907       /* Catch recursion via other statement functions.  */
2908       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
2909           && e->symtree->n.sym->value
2910           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
2911         return true;
2912
2913       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2914         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2915
2916       break;
2917
2918     case EXPR_VARIABLE:
2919       if (e->symtree && sym->name == e->symtree->n.sym->name)
2920         return true;
2921
2922       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
2923         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
2924       break;
2925
2926     case EXPR_OP:
2927       if (recursive_stmt_fcn (e->value.op.op1, sym)
2928           || recursive_stmt_fcn (e->value.op.op2, sym))
2929         return true;
2930       break;
2931
2932     default:
2933       break;
2934     }
2935
2936   /* Component references do not need to be checked.  */
2937   if (e->ref)
2938     {
2939       for (ref = e->ref; ref; ref = ref->next)
2940         {
2941           switch (ref->type)
2942             {
2943             case REF_ARRAY:
2944               for (i = 0; i < ref->u.ar.dimen; i++)
2945                 {
2946                   if (recursive_stmt_fcn (ref->u.ar.start[i], sym)
2947                       || recursive_stmt_fcn (ref->u.ar.end[i], sym)
2948                       || recursive_stmt_fcn (ref->u.ar.stride[i], sym))
2949                     return true;
2950                 }
2951               break;
2952
2953             case REF_SUBSTRING:
2954               if (recursive_stmt_fcn (ref->u.ss.start, sym)
2955                   || recursive_stmt_fcn (ref->u.ss.end, sym))
2956                 return true;
2957
2958               break;
2959
2960             default:
2961               break;
2962             }
2963         }
2964     }
2965   return false;
2966 }
2967
2968
2969 /* Match a statement function declaration.  It is so easy to match
2970    non-statement function statements with a MATCH_ERROR as opposed to
2971    MATCH_NO that we suppress error message in most cases.  */
2972
2973 match
2974 gfc_match_st_function (void)
2975 {
2976   gfc_error_buf old_error;
2977   gfc_symbol *sym;
2978   gfc_expr *expr;
2979   match m;
2980
2981   m = gfc_match_symbol (&sym, 0);
2982   if (m != MATCH_YES)
2983     return m;
2984
2985   gfc_push_error (&old_error);
2986
2987   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
2988                          sym->name, NULL) == FAILURE)
2989     goto undo_error;
2990
2991   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
2992     goto undo_error;
2993
2994   m = gfc_match (" = %e%t", &expr);
2995   if (m == MATCH_NO)
2996     goto undo_error;
2997
2998   gfc_free_error (&old_error);
2999   if (m == MATCH_ERROR)
3000     return m;
3001
3002   if (recursive_stmt_fcn (expr, sym))
3003     {
3004       gfc_error ("Statement function at %L is recursive", &expr->where);
3005       return MATCH_ERROR;
3006     }
3007
3008   sym->value = expr;
3009
3010   return MATCH_YES;
3011
3012 undo_error:
3013   gfc_pop_error (&old_error);
3014   return MATCH_NO;
3015 }
3016
3017
3018 /***************** SELECT CASE subroutines ******************/
3019
3020 /* Free a single case structure.  */
3021
3022 static void
3023 free_case (gfc_case *p)
3024 {
3025   if (p->low == p->high)
3026     p->high = NULL;
3027   gfc_free_expr (p->low);
3028   gfc_free_expr (p->high);
3029   gfc_free (p);
3030 }
3031
3032
3033 /* Free a list of case structures.  */
3034
3035 void
3036 gfc_free_case_list (gfc_case *p)
3037 {
3038   gfc_case *q;
3039
3040   for (; p; p = q)
3041     {
3042       q = p->next;
3043       free_case (p);
3044     }
3045 }
3046
3047
3048 /* Match a single case selector.  */
3049
3050 static match
3051 match_case_selector (gfc_case **cp)
3052 {
3053   gfc_case *c;
3054   match m;
3055
3056   c = gfc_get_case ();
3057   c->where = gfc_current_locus;
3058
3059   if (gfc_match_char (':') == MATCH_YES)
3060     {
3061       m = gfc_match_init_expr (&c->high);
3062       if (m == MATCH_NO)
3063         goto need_expr;
3064       if (m == MATCH_ERROR)
3065         goto cleanup;
3066     }
3067   else
3068     {
3069       m = gfc_match_init_expr (&c->low);
3070       if (m == MATCH_ERROR)
3071         goto cleanup;
3072       if (m == MATCH_NO)
3073         goto need_expr;
3074
3075       /* If we're not looking at a ':' now, make a range out of a single
3076          target.  Else get the upper bound for the case range.  */
3077       if (gfc_match_char (':') != MATCH_YES)
3078         c->high = c->low;
3079       else
3080         {
3081           m = gfc_match_init_expr (&c->high);
3082           if (m == MATCH_ERROR)
3083             goto cleanup;
3084           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3085         }
3086     }
3087
3088   *cp = c;
3089   return MATCH_YES;
3090
3091 need_expr:
3092   gfc_error ("Expected initialization expression in CASE at %C");
3093
3094 cleanup:
3095   free_case (c);
3096   return MATCH_ERROR;
3097 }
3098
3099
3100 /* Match the end of a case statement.  */
3101
3102 static match
3103 match_case_eos (void)
3104 {
3105   char name[GFC_MAX_SYMBOL_LEN + 1];
3106   match m;
3107
3108   if (gfc_match_eos () == MATCH_YES)
3109     return MATCH_YES;
3110
3111   /* If the case construct doesn't have a case-construct-name, we
3112      should have matched the EOS.  */
3113   if (!gfc_current_block ())
3114     {
3115       gfc_error ("Expected the name of the SELECT CASE construct at %C");
3116       return MATCH_ERROR;
3117     }
3118
3119   gfc_gobble_whitespace ();
3120
3121   m = gfc_match_name (name);
3122   if (m != MATCH_YES)
3123     return m;
3124
3125   if (strcmp (name, gfc_current_block ()->name) != 0)
3126     {
3127       gfc_error ("Expected case name of '%s' at %C",
3128                  gfc_current_block ()->name);
3129       return MATCH_ERROR;
3130     }
3131
3132   return gfc_match_eos ();
3133 }
3134
3135
3136 /* Match a SELECT statement.  */
3137
3138 match
3139 gfc_match_select (void)
3140 {
3141   gfc_expr *expr;
3142   match m;
3143
3144   m = gfc_match_label ();
3145   if (m == MATCH_ERROR)
3146     return m;
3147
3148   m = gfc_match (" select case ( %e )%t", &expr);
3149   if (m != MATCH_YES)
3150     return m;
3151
3152   new_st.op = EXEC_SELECT;
3153   new_st.expr = expr;
3154
3155   return MATCH_YES;
3156 }
3157
3158
3159 /* Match a CASE statement.  */
3160
3161 match
3162 gfc_match_case (void)
3163 {
3164   gfc_case *c, *head, *tail;
3165   match m;
3166
3167   head = tail = NULL;
3168
3169   if (gfc_current_state () != COMP_SELECT)
3170     {
3171       gfc_error ("Unexpected CASE statement at %C");
3172       return MATCH_ERROR;
3173     }
3174
3175   if (gfc_match ("% default") == MATCH_YES)
3176     {
3177       m = match_case_eos ();
3178       if (m == MATCH_NO)
3179         goto syntax;
3180       if (m == MATCH_ERROR)
3181         goto cleanup;
3182
3183       new_st.op = EXEC_SELECT;
3184       c = gfc_get_case ();
3185       c->where = gfc_current_locus;
3186       new_st.ext.case_list = c;
3187       return MATCH_YES;
3188     }
3189
3190   if (gfc_match_char ('(') != MATCH_YES)
3191     goto syntax;
3192
3193   for (;;)
3194     {
3195       if (match_case_selector (&c) == MATCH_ERROR)
3196         goto cleanup;
3197
3198       if (head == NULL)
3199         head = c;
3200       else
3201         tail->next = c;
3202
3203       tail = c;
3204
3205       if (gfc_match_char (')') == MATCH_YES)
3206         break;
3207       if (gfc_match_char (',') != MATCH_YES)
3208         goto syntax;
3209     }
3210
3211   m = match_case_eos ();
3212   if (m == MATCH_NO)
3213     goto syntax;
3214   if (m == MATCH_ERROR)
3215     goto cleanup;
3216
3217   new_st.op = EXEC_SELECT;
3218   new_st.ext.case_list = head;
3219
3220   return MATCH_YES;
3221
3222 syntax:
3223   gfc_error ("Syntax error in CASE-specification at %C");
3224
3225 cleanup:
3226   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
3227   return MATCH_ERROR;
3228 }
3229
3230 /********************* WHERE subroutines ********************/
3231
3232 /* Match the rest of a simple WHERE statement that follows an IF statement.  
3233  */
3234
3235 static match
3236 match_simple_where (void)
3237 {
3238   gfc_expr *expr;
3239   gfc_code *c;
3240   match m;
3241
3242   m = gfc_match (" ( %e )", &expr);
3243   if (m != MATCH_YES)
3244     return m;
3245
3246   m = gfc_match_assignment ();
3247   if (m == MATCH_NO)
3248     goto syntax;
3249   if (m == MATCH_ERROR)
3250     goto cleanup;
3251
3252   if (gfc_match_eos () != MATCH_YES)
3253     goto syntax;
3254
3255   c = gfc_get_code ();
3256
3257   c->op = EXEC_WHERE;
3258   c->expr = expr;
3259   c->next = gfc_get_code ();
3260
3261   *c->next = new_st;
3262   gfc_clear_new_st ();
3263
3264   new_st.op = EXEC_WHERE;
3265   new_st.block = c;
3266
3267   return MATCH_YES;
3268
3269 syntax:
3270   gfc_syntax_error (ST_WHERE);
3271
3272 cleanup:
3273   gfc_free_expr (expr);
3274   return MATCH_ERROR;
3275 }
3276
3277
3278 /* Match a WHERE statement.  */
3279
3280 match
3281 gfc_match_where (gfc_statement *st)
3282 {
3283   gfc_expr *expr;
3284   match m0, m;
3285   gfc_code *c;
3286
3287   m0 = gfc_match_label ();
3288   if (m0 == MATCH_ERROR)
3289     return m0;
3290
3291   m = gfc_match (" where ( %e )", &expr);
3292   if (m != MATCH_YES)
3293     return m;
3294
3295   if (gfc_match_eos () == MATCH_YES)
3296     {
3297       *st = ST_WHERE_BLOCK;
3298       new_st.op = EXEC_WHERE;
3299       new_st.expr = expr;
3300       return MATCH_YES;
3301     }
3302
3303   m = gfc_match_assignment ();
3304   if (m == MATCH_NO)
3305     gfc_syntax_error (ST_WHERE);
3306
3307   if (m != MATCH_YES)
3308     {
3309       gfc_free_expr (expr);
3310       return MATCH_ERROR;
3311     }
3312
3313   /* We've got a simple WHERE statement.  */
3314   *st = ST_WHERE;
3315   c = gfc_get_code ();
3316
3317   c->op = EXEC_WHERE;
3318   c->expr = expr;
3319   c->next = gfc_get_code ();
3320
3321   *c->next = new_st;
3322   gfc_clear_new_st ();
3323
3324   new_st.op = EXEC_WHERE;
3325   new_st.block = c;
3326
3327   return MATCH_YES;
3328 }
3329
3330
3331 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
3332    new_st if successful.  */
3333
3334 match
3335 gfc_match_elsewhere (void)
3336 {
3337   char name[GFC_MAX_SYMBOL_LEN + 1];
3338   gfc_expr *expr;
3339   match m;
3340
3341   if (gfc_current_state () != COMP_WHERE)
3342     {
3343       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
3344       return MATCH_ERROR;
3345     }
3346
3347   expr = NULL;
3348
3349   if (gfc_match_char ('(') == MATCH_YES)
3350     {
3351       m = gfc_match_expr (&expr);
3352       if (m == MATCH_NO)
3353         goto syntax;
3354       if (m == MATCH_ERROR)
3355         return MATCH_ERROR;
3356
3357       if (gfc_match_char (')') != MATCH_YES)
3358         goto syntax;
3359     }
3360
3361   if (gfc_match_eos () != MATCH_YES)
3362     {
3363       /* Only makes sense if we have a where-construct-name.  */
3364       if (!gfc_current_block ())
3365         {
3366           m = MATCH_ERROR;
3367           goto cleanup;
3368         }
3369       /* Better be a name at this point.  */
3370       m = gfc_match_name (name);
3371       if (m == MATCH_NO)
3372         goto syntax;
3373       if (m == MATCH_ERROR)
3374         goto cleanup;
3375
3376       if (gfc_match_eos () != MATCH_YES)
3377         goto syntax;
3378
3379       if (strcmp (name, gfc_current_block ()->name) != 0)
3380         {
3381           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3382                      name, gfc_current_block ()->name);
3383           goto cleanup;
3384         }
3385     }
3386
3387   new_st.op = EXEC_WHERE;
3388   new_st.expr = expr;
3389   return MATCH_YES;
3390
3391 syntax:
3392   gfc_syntax_error (ST_ELSEWHERE);
3393
3394 cleanup:
3395   gfc_free_expr (expr);
3396   return MATCH_ERROR;
3397 }
3398
3399
3400 /******************** FORALL subroutines ********************/
3401
3402 /* Free a list of FORALL iterators.  */
3403
3404 void
3405 gfc_free_forall_iterator (gfc_forall_iterator *iter)
3406 {
3407   gfc_forall_iterator *next;
3408
3409   while (iter)
3410     {
3411       next = iter->next;
3412       gfc_free_expr (iter->var);
3413       gfc_free_expr (iter->start);
3414       gfc_free_expr (iter->end);
3415       gfc_free_expr (iter->stride);
3416       gfc_free (iter);
3417       iter = next;
3418     }
3419 }
3420
3421
3422 /* Match an iterator as part of a FORALL statement.  The format is:
3423
3424      <var> = <start>:<end>[:<stride>]
3425
3426    On MATCH_NO, the caller tests for the possibility that there is a
3427    scalar mask expression.  */
3428
3429 static match
3430 match_forall_iterator (gfc_forall_iterator **result)
3431 {
3432   gfc_forall_iterator *iter;
3433   locus where;
3434   match m;
3435
3436   where = gfc_current_locus;
3437   iter = gfc_getmem (sizeof (gfc_forall_iterator));
3438
3439   m = gfc_match_expr (&iter->var);
3440   if (m != MATCH_YES)
3441     goto cleanup;
3442
3443   if (gfc_match_char ('=') != MATCH_YES
3444       || iter->var->expr_type != EXPR_VARIABLE)
3445     {
3446       m = MATCH_NO;
3447       goto cleanup;
3448     }
3449
3450   m = gfc_match_expr (&iter->start);
3451   if (m != MATCH_YES)
3452     goto cleanup;
3453
3454   if (gfc_match_char (':') != MATCH_YES)
3455     goto syntax;
3456
3457   m = gfc_match_expr (&iter->end);
3458   if (m == MATCH_NO)
3459     goto syntax;
3460   if (m == MATCH_ERROR)
3461     goto cleanup;
3462
3463   if (gfc_match_char (':') == MATCH_NO)
3464     iter->stride = gfc_int_expr (1);
3465   else
3466     {
3467       m = gfc_match_expr (&iter->stride);
3468       if (m == MATCH_NO)
3469         goto syntax;
3470       if (m == MATCH_ERROR)
3471         goto cleanup;
3472     }
3473
3474   /* Mark the iteration variable's symbol as used as a FORALL index.  */
3475   iter->var->symtree->n.sym->forall_index = true;
3476
3477   *result = iter;
3478   return MATCH_YES;
3479
3480 syntax:
3481   gfc_error ("Syntax error in FORALL iterator at %C");
3482   m = MATCH_ERROR;
3483
3484 cleanup:
3485
3486   gfc_current_locus = where;
3487   gfc_free_forall_iterator (iter);
3488   return m;
3489 }
3490
3491
3492 /* Match the header of a FORALL statement.  */
3493
3494 static match
3495 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
3496 {
3497   gfc_forall_iterator *head, *tail, *new;
3498   gfc_expr *msk;
3499   match m;
3500
3501   gfc_gobble_whitespace ();
3502
3503   head = tail = NULL;
3504   msk = NULL;
3505
3506   if (gfc_match_char ('(') != MATCH_YES)
3507     return MATCH_NO;
3508
3509   m = match_forall_iterator (&new);
3510   if (m == MATCH_ERROR)
3511     goto cleanup;
3512   if (m == MATCH_NO)
3513     goto syntax;
3514
3515   head = tail = new;
3516
3517   for (;;)
3518     {
3519       if (gfc_match_char (',') != MATCH_YES)
3520         break;
3521
3522       m = match_forall_iterator (&new);
3523       if (m == MATCH_ERROR)
3524         goto cleanup;
3525
3526       if (m == MATCH_YES)
3527         {
3528           tail->next = new;
3529           tail = new;
3530           continue;
3531         }
3532
3533       /* Have to have a mask expression.  */
3534
3535       m = gfc_match_expr (&msk);
3536       if (m == MATCH_NO)
3537         goto syntax;
3538       if (m == MATCH_ERROR)
3539         goto cleanup;
3540
3541       break;
3542     }
3543
3544   if (gfc_match_char (')') == MATCH_NO)
3545     goto syntax;
3546
3547   *phead = head;
3548   *mask = msk;
3549   return MATCH_YES;
3550
3551 syntax:
3552   gfc_syntax_error (ST_FORALL);
3553
3554 cleanup:
3555   gfc_free_expr (msk);
3556   gfc_free_forall_iterator (head);
3557
3558   return MATCH_ERROR;
3559 }
3560
3561 /* Match the rest of a simple FORALL statement that follows an 
3562    IF statement.  */
3563
3564 static match
3565 match_simple_forall (void)
3566 {
3567   gfc_forall_iterator *head;
3568   gfc_expr *mask;
3569   gfc_code *c;
3570   match m;
3571
3572   mask = NULL;
3573   head = NULL;
3574   c = NULL;
3575
3576   m = match_forall_header (&head, &mask);
3577
3578   if (m == MATCH_NO)
3579     goto syntax;
3580   if (m != MATCH_YES)
3581     goto cleanup;
3582
3583   m = gfc_match_assignment ();
3584
3585   if (m == MATCH_ERROR)
3586     goto cleanup;
3587   if (m == MATCH_NO)
3588     {
3589       m = gfc_match_pointer_assignment ();
3590       if (m == MATCH_ERROR)
3591         goto cleanup;
3592       if (m == MATCH_NO)
3593         goto syntax;
3594     }
3595
3596   c = gfc_get_code ();
3597   *c = new_st;
3598   c->loc = gfc_current_locus;
3599
3600   if (gfc_match_eos () != MATCH_YES)
3601     goto syntax;
3602
3603   gfc_clear_new_st ();
3604   new_st.op = EXEC_FORALL;
3605   new_st.expr = mask;
3606   new_st.ext.forall_iterator = head;
3607   new_st.block = gfc_get_code ();
3608
3609   new_st.block->op = EXEC_FORALL;
3610   new_st.block->next = c;
3611
3612   return MATCH_YES;
3613
3614 syntax:
3615   gfc_syntax_error (ST_FORALL);
3616
3617 cleanup:
3618   gfc_free_forall_iterator (head);
3619   gfc_free_expr (mask);
3620
3621   return MATCH_ERROR;
3622 }
3623
3624
3625 /* Match a FORALL statement.  */
3626
3627 match
3628 gfc_match_forall (gfc_statement *st)
3629 {
3630   gfc_forall_iterator *head;
3631   gfc_expr *mask;
3632   gfc_code *c;
3633   match m0, m;
3634
3635   head = NULL;
3636   mask = NULL;
3637   c = NULL;
3638
3639   m0 = gfc_match_label ();
3640   if (m0 == MATCH_ERROR)
3641     return MATCH_ERROR;
3642
3643   m = gfc_match (" forall");
3644   if (m != MATCH_YES)
3645     return m;
3646
3647   m = match_forall_header (&head, &mask);
3648   if (m == MATCH_ERROR)
3649     goto cleanup;
3650   if (m == MATCH_NO)
3651     goto syntax;
3652
3653   if (gfc_match_eos () == MATCH_YES)
3654     {
3655       *st = ST_FORALL_BLOCK;
3656       new_st.op = EXEC_FORALL;
3657       new_st.expr = mask;
3658       new_st.ext.forall_iterator = head;
3659       return MATCH_YES;
3660     }
3661
3662   m = gfc_match_assignment ();
3663   if (m == MATCH_ERROR)
3664     goto cleanup;
3665   if (m == MATCH_NO)
3666     {
3667       m = gfc_match_pointer_assignment ();
3668       if (m == MATCH_ERROR)
3669         goto cleanup;
3670       if (m == MATCH_NO)
3671         goto syntax;
3672     }
3673
3674   c = gfc_get_code ();
3675   *c = new_st;
3676   c->loc = gfc_current_locus;
3677
3678   gfc_clear_new_st ();
3679   new_st.op = EXEC_FORALL;
3680   new_st.expr = mask;
3681   new_st.ext.forall_iterator = head;
3682   new_st.block = gfc_get_code ();
3683   new_st.block->op = EXEC_FORALL;
3684   new_st.block->next = c;
3685
3686   *st = ST_FORALL;
3687   return MATCH_YES;
3688
3689 syntax:
3690   gfc_syntax_error (ST_FORALL);
3691
3692 cleanup:
3693   gfc_free_forall_iterator (head);
3694   gfc_free_expr (mask);
3695   gfc_free_statements (c);
3696   return MATCH_NO;
3697 }