OSDN Git Service

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