OSDN Git Service

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