OSDN Git Service

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