OSDN Git Service

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