OSDN Git Service

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