OSDN Git Service

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