OSDN Git Service

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