OSDN Git Service

2009-10-21 Janus Weil <janus@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / match.c
1 /* Matching subroutines in all sizes, shapes and colors.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
3    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   /* Match the start of an iterator without affecting the symbol table.  */
953
954   start = gfc_current_locus;
955   m = gfc_match (" %n =", name);
956   gfc_current_locus = start;
957
958   if (m != MATCH_YES)
959     return MATCH_NO;
960
961   m = gfc_match_variable (&var, 0);
962   if (m != MATCH_YES)
963     return MATCH_NO;
964
965   gfc_match_char ('=');
966
967   e1 = e2 = e3 = NULL;
968
969   if (var->ref != NULL)
970     {
971       gfc_error ("Loop variable at %C cannot be a sub-component");
972       goto cleanup;
973     }
974
975   if (var->symtree->n.sym->attr.intent == INTENT_IN)
976     {
977       gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
978                  var->symtree->n.sym->name);
979       goto cleanup;
980     }
981
982   var->symtree->n.sym->attr.implied_index = 1;
983
984   m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1);
985   if (m == MATCH_NO)
986     goto syntax;
987   if (m == MATCH_ERROR)
988     goto cleanup;
989
990   if (gfc_match_char (',') != MATCH_YES)
991     goto syntax;
992
993   m = init_flag ? gfc_match_init_expr (&e2) : gfc_match_expr (&e2);
994   if (m == MATCH_NO)
995     goto syntax;
996   if (m == MATCH_ERROR)
997     goto cleanup;
998
999   if (gfc_match_char (',') != MATCH_YES)
1000     {
1001       e3 = gfc_int_expr (1);
1002       goto done;
1003     }
1004
1005   m = init_flag ? gfc_match_init_expr (&e3) : gfc_match_expr (&e3);
1006   if (m == MATCH_ERROR)
1007     goto cleanup;
1008   if (m == MATCH_NO)
1009     {
1010       gfc_error ("Expected a step value in iterator at %C");
1011       goto cleanup;
1012     }
1013
1014 done:
1015   iter->var = var;
1016   iter->start = e1;
1017   iter->end = e2;
1018   iter->step = e3;
1019   return MATCH_YES;
1020
1021 syntax:
1022   gfc_error ("Syntax error in iterator at %C");
1023
1024 cleanup:
1025   gfc_free_expr (e1);
1026   gfc_free_expr (e2);
1027   gfc_free_expr (e3);
1028
1029   return MATCH_ERROR;
1030 }
1031
1032
1033 /* Tries to match the next non-whitespace character on the input.
1034    This subroutine does not return MATCH_ERROR.  */
1035
1036 match
1037 gfc_match_char (char c)
1038 {
1039   locus where;
1040
1041   where = gfc_current_locus;
1042   gfc_gobble_whitespace ();
1043
1044   if (gfc_next_ascii_char () == c)
1045     return MATCH_YES;
1046
1047   gfc_current_locus = where;
1048   return MATCH_NO;
1049 }
1050
1051
1052 /* General purpose matching subroutine.  The target string is a
1053    scanf-like format string in which spaces correspond to arbitrary
1054    whitespace (including no whitespace), characters correspond to
1055    themselves.  The %-codes are:
1056
1057    %%  Literal percent sign
1058    %e  Expression, pointer to a pointer is set
1059    %s  Symbol, pointer to the symbol is set
1060    %n  Name, character buffer is set to name
1061    %t  Matches end of statement.
1062    %o  Matches an intrinsic operator, returned as an INTRINSIC enum.
1063    %l  Matches a statement label
1064    %v  Matches a variable expression (an lvalue)
1065    %   Matches a required space (in free form) and optional spaces.  */
1066
1067 match
1068 gfc_match (const char *target, ...)
1069 {
1070   gfc_st_label **label;
1071   int matches, *ip;
1072   locus old_loc;
1073   va_list argp;
1074   char c, *np;
1075   match m, n;
1076   void **vp;
1077   const char *p;
1078
1079   old_loc = gfc_current_locus;
1080   va_start (argp, target);
1081   m = MATCH_NO;
1082   matches = 0;
1083   p = target;
1084
1085 loop:
1086   c = *p++;
1087   switch (c)
1088     {
1089     case ' ':
1090       gfc_gobble_whitespace ();
1091       goto loop;
1092     case '\0':
1093       m = MATCH_YES;
1094       break;
1095
1096     case '%':
1097       c = *p++;
1098       switch (c)
1099         {
1100         case 'e':
1101           vp = va_arg (argp, void **);
1102           n = gfc_match_expr ((gfc_expr **) vp);
1103           if (n != MATCH_YES)
1104             {
1105               m = n;
1106               goto not_yes;
1107             }
1108
1109           matches++;
1110           goto loop;
1111
1112         case 'v':
1113           vp = va_arg (argp, void **);
1114           n = gfc_match_variable ((gfc_expr **) vp, 0);
1115           if (n != MATCH_YES)
1116             {
1117               m = n;
1118               goto not_yes;
1119             }
1120
1121           matches++;
1122           goto loop;
1123
1124         case 's':
1125           vp = va_arg (argp, void **);
1126           n = gfc_match_symbol ((gfc_symbol **) vp, 0);
1127           if (n != MATCH_YES)
1128             {
1129               m = n;
1130               goto not_yes;
1131             }
1132
1133           matches++;
1134           goto loop;
1135
1136         case 'n':
1137           np = va_arg (argp, char *);
1138           n = gfc_match_name (np);
1139           if (n != MATCH_YES)
1140             {
1141               m = n;
1142               goto not_yes;
1143             }
1144
1145           matches++;
1146           goto loop;
1147
1148         case 'l':
1149           label = va_arg (argp, gfc_st_label **);
1150           n = gfc_match_st_label (label);
1151           if (n != MATCH_YES)
1152             {
1153               m = n;
1154               goto not_yes;
1155             }
1156
1157           matches++;
1158           goto loop;
1159
1160         case 'o':
1161           ip = va_arg (argp, int *);
1162           n = gfc_match_intrinsic_op ((gfc_intrinsic_op *) ip);
1163           if (n != MATCH_YES)
1164             {
1165               m = n;
1166               goto not_yes;
1167             }
1168
1169           matches++;
1170           goto loop;
1171
1172         case 't':
1173           if (gfc_match_eos () != MATCH_YES)
1174             {
1175               m = MATCH_NO;
1176               goto not_yes;
1177             }
1178           goto loop;
1179
1180         case ' ':
1181           if (gfc_match_space () == MATCH_YES)
1182             goto loop;
1183           m = MATCH_NO;
1184           goto not_yes;
1185
1186         case '%':
1187           break;        /* Fall through to character matcher.  */
1188
1189         default:
1190           gfc_internal_error ("gfc_match(): Bad match code %c", c);
1191         }
1192
1193     default:
1194
1195       /* gfc_next_ascii_char converts characters to lower-case, so we shouldn't
1196          expect an upper case character here!  */
1197       gcc_assert (TOLOWER (c) == c);
1198
1199       if (c == gfc_next_ascii_char ())
1200         goto loop;
1201       break;
1202     }
1203
1204 not_yes:
1205   va_end (argp);
1206
1207   if (m != MATCH_YES)
1208     {
1209       /* Clean up after a failed match.  */
1210       gfc_current_locus = old_loc;
1211       va_start (argp, target);
1212
1213       p = target;
1214       for (; matches > 0; matches--)
1215         {
1216           while (*p++ != '%');
1217
1218           switch (*p++)
1219             {
1220             case '%':
1221               matches++;
1222               break;            /* Skip.  */
1223
1224             /* Matches that don't have to be undone */
1225             case 'o':
1226             case 'l':
1227             case 'n':
1228             case 's':
1229               (void) va_arg (argp, void **);
1230               break;
1231
1232             case 'e':
1233             case 'v':
1234               vp = va_arg (argp, void **);
1235               gfc_free_expr ((struct gfc_expr *)*vp);
1236               *vp = NULL;
1237               break;
1238             }
1239         }
1240
1241       va_end (argp);
1242     }
1243
1244   return m;
1245 }
1246
1247
1248 /*********************** Statement level matching **********************/
1249
1250 /* Matches the start of a program unit, which is the program keyword
1251    followed by an obligatory symbol.  */
1252
1253 match
1254 gfc_match_program (void)
1255 {
1256   gfc_symbol *sym;
1257   match m;
1258
1259   m = gfc_match ("% %s%t", &sym);
1260
1261   if (m == MATCH_NO)
1262     {
1263       gfc_error ("Invalid form of PROGRAM statement at %C");
1264       m = MATCH_ERROR;
1265     }
1266
1267   if (m == MATCH_ERROR)
1268     return m;
1269
1270   if (gfc_add_flavor (&sym->attr, FL_PROGRAM, sym->name, NULL) == FAILURE)
1271     return MATCH_ERROR;
1272
1273   gfc_new_block = sym;
1274
1275   return MATCH_YES;
1276 }
1277
1278
1279 /* Match a simple assignment statement.  */
1280
1281 match
1282 gfc_match_assignment (void)
1283 {
1284   gfc_expr *lvalue, *rvalue;
1285   locus old_loc;
1286   match m;
1287
1288   old_loc = gfc_current_locus;
1289
1290   lvalue = NULL;
1291   m = gfc_match (" %v =", &lvalue);
1292   if (m != MATCH_YES)
1293     {
1294       gfc_current_locus = old_loc;
1295       gfc_free_expr (lvalue);
1296       return MATCH_NO;
1297     }
1298
1299   rvalue = NULL;
1300   m = gfc_match (" %e%t", &rvalue);
1301   if (m != MATCH_YES)
1302     {
1303       gfc_current_locus = old_loc;
1304       gfc_free_expr (lvalue);
1305       gfc_free_expr (rvalue);
1306       return m;
1307     }
1308
1309   gfc_set_sym_referenced (lvalue->symtree->n.sym);
1310
1311   new_st.op = EXEC_ASSIGN;
1312   new_st.expr1 = lvalue;
1313   new_st.expr2 = rvalue;
1314
1315   gfc_check_do_variable (lvalue->symtree);
1316
1317   return MATCH_YES;
1318 }
1319
1320
1321 /* Match a pointer assignment statement.  */
1322
1323 match
1324 gfc_match_pointer_assignment (void)
1325 {
1326   gfc_expr *lvalue, *rvalue;
1327   locus old_loc;
1328   match m;
1329
1330   old_loc = gfc_current_locus;
1331
1332   lvalue = rvalue = NULL;
1333   gfc_matching_procptr_assignment = 0;
1334
1335   m = gfc_match (" %v =>", &lvalue);
1336   if (m != MATCH_YES)
1337     {
1338       m = MATCH_NO;
1339       goto cleanup;
1340     }
1341
1342   if (lvalue->symtree->n.sym->attr.proc_pointer
1343       || gfc_is_proc_ptr_comp (lvalue, NULL))
1344     gfc_matching_procptr_assignment = 1;
1345
1346   m = gfc_match (" %e%t", &rvalue);
1347   gfc_matching_procptr_assignment = 0;
1348   if (m != MATCH_YES)
1349     goto cleanup;
1350
1351   new_st.op = EXEC_POINTER_ASSIGN;
1352   new_st.expr1 = lvalue;
1353   new_st.expr2 = rvalue;
1354
1355   return MATCH_YES;
1356
1357 cleanup:
1358   gfc_current_locus = old_loc;
1359   gfc_free_expr (lvalue);
1360   gfc_free_expr (rvalue);
1361   return m;
1362 }
1363
1364
1365 /* We try to match an easy arithmetic IF statement. This only happens
1366    when just after having encountered a simple IF statement. This code
1367    is really duplicate with parts of the gfc_match_if code, but this is
1368    *much* easier.  */
1369
1370 static match
1371 match_arithmetic_if (void)
1372 {
1373   gfc_st_label *l1, *l2, *l3;
1374   gfc_expr *expr;
1375   match m;
1376
1377   m = gfc_match (" ( %e ) %l , %l , %l%t", &expr, &l1, &l2, &l3);
1378   if (m != MATCH_YES)
1379     return m;
1380
1381   if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1382       || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1383       || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1384     {
1385       gfc_free_expr (expr);
1386       return MATCH_ERROR;
1387     }
1388
1389   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1390                       "statement at %C") == FAILURE)
1391     return MATCH_ERROR;
1392
1393   new_st.op = EXEC_ARITHMETIC_IF;
1394   new_st.expr1 = expr;
1395   new_st.label1 = l1;
1396   new_st.label2 = l2;
1397   new_st.label3 = l3;
1398
1399   return MATCH_YES;
1400 }
1401
1402
1403 /* The IF statement is a bit of a pain.  First of all, there are three
1404    forms of it, the simple IF, the IF that starts a block and the
1405    arithmetic IF.
1406
1407    There is a problem with the simple IF and that is the fact that we
1408    only have a single level of undo information on symbols.  What this
1409    means is for a simple IF, we must re-match the whole IF statement
1410    multiple times in order to guarantee that the symbol table ends up
1411    in the proper state.  */
1412
1413 static match match_simple_forall (void);
1414 static match match_simple_where (void);
1415
1416 match
1417 gfc_match_if (gfc_statement *if_type)
1418 {
1419   gfc_expr *expr;
1420   gfc_st_label *l1, *l2, *l3;
1421   locus old_loc, old_loc2;
1422   gfc_code *p;
1423   match m, n;
1424
1425   n = gfc_match_label ();
1426   if (n == MATCH_ERROR)
1427     return n;
1428
1429   old_loc = gfc_current_locus;
1430
1431   m = gfc_match (" if ( %e", &expr);
1432   if (m != MATCH_YES)
1433     return m;
1434
1435   old_loc2 = gfc_current_locus;
1436   gfc_current_locus = old_loc;
1437   
1438   if (gfc_match_parens () == MATCH_ERROR)
1439     return MATCH_ERROR;
1440
1441   gfc_current_locus = old_loc2;
1442
1443   if (gfc_match_char (')') != MATCH_YES)
1444     {
1445       gfc_error ("Syntax error in IF-expression at %C");
1446       gfc_free_expr (expr);
1447       return MATCH_ERROR;
1448     }
1449
1450   m = gfc_match (" %l , %l , %l%t", &l1, &l2, &l3);
1451
1452   if (m == MATCH_YES)
1453     {
1454       if (n == MATCH_YES)
1455         {
1456           gfc_error ("Block label not appropriate for arithmetic IF "
1457                      "statement at %C");
1458           gfc_free_expr (expr);
1459           return MATCH_ERROR;
1460         }
1461
1462       if (gfc_reference_st_label (l1, ST_LABEL_TARGET) == FAILURE
1463           || gfc_reference_st_label (l2, ST_LABEL_TARGET) == FAILURE
1464           || gfc_reference_st_label (l3, ST_LABEL_TARGET) == FAILURE)
1465         {
1466           gfc_free_expr (expr);
1467           return MATCH_ERROR;
1468         }
1469       
1470       if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Arithmetic IF "
1471                           "statement at %C") == FAILURE)
1472         return MATCH_ERROR;
1473
1474       new_st.op = EXEC_ARITHMETIC_IF;
1475       new_st.expr1 = expr;
1476       new_st.label1 = l1;
1477       new_st.label2 = l2;
1478       new_st.label3 = l3;
1479
1480       *if_type = ST_ARITHMETIC_IF;
1481       return MATCH_YES;
1482     }
1483
1484   if (gfc_match (" then%t") == MATCH_YES)
1485     {
1486       new_st.op = EXEC_IF;
1487       new_st.expr1 = expr;
1488       *if_type = ST_IF_BLOCK;
1489       return MATCH_YES;
1490     }
1491
1492   if (n == MATCH_YES)
1493     {
1494       gfc_error ("Block label is not appropriate for IF statement at %C");
1495       gfc_free_expr (expr);
1496       return MATCH_ERROR;
1497     }
1498
1499   /* At this point the only thing left is a simple IF statement.  At
1500      this point, n has to be MATCH_NO, so we don't have to worry about
1501      re-matching a block label.  From what we've got so far, try
1502      matching an assignment.  */
1503
1504   *if_type = ST_SIMPLE_IF;
1505
1506   m = gfc_match_assignment ();
1507   if (m == MATCH_YES)
1508     goto got_match;
1509
1510   gfc_free_expr (expr);
1511   gfc_undo_symbols ();
1512   gfc_current_locus = old_loc;
1513
1514   /* m can be MATCH_NO or MATCH_ERROR, here.  For MATCH_ERROR, a mangled
1515      assignment was found.  For MATCH_NO, continue to call the various
1516      matchers.  */
1517   if (m == MATCH_ERROR)
1518     return MATCH_ERROR;
1519
1520   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1521
1522   m = gfc_match_pointer_assignment ();
1523   if (m == MATCH_YES)
1524     goto got_match;
1525
1526   gfc_free_expr (expr);
1527   gfc_undo_symbols ();
1528   gfc_current_locus = old_loc;
1529
1530   gfc_match (" if ( %e ) ", &expr);     /* Guaranteed to match.  */
1531
1532   /* Look at the next keyword to see which matcher to call.  Matching
1533      the keyword doesn't affect the symbol table, so we don't have to
1534      restore between tries.  */
1535
1536 #define match(string, subr, statement) \
1537   if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1538
1539   gfc_clear_error ();
1540
1541   match ("allocate", gfc_match_allocate, ST_ALLOCATE)
1542   match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
1543   match ("backspace", gfc_match_backspace, ST_BACKSPACE)
1544   match ("call", gfc_match_call, ST_CALL)
1545   match ("close", gfc_match_close, ST_CLOSE)
1546   match ("continue", gfc_match_continue, ST_CONTINUE)
1547   match ("cycle", gfc_match_cycle, ST_CYCLE)
1548   match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
1549   match ("end file", gfc_match_endfile, ST_END_FILE)
1550   match ("exit", gfc_match_exit, ST_EXIT)
1551   match ("flush", gfc_match_flush, ST_FLUSH)
1552   match ("forall", match_simple_forall, ST_FORALL)
1553   match ("go to", gfc_match_goto, ST_GOTO)
1554   match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
1555   match ("inquire", gfc_match_inquire, ST_INQUIRE)
1556   match ("nullify", gfc_match_nullify, ST_NULLIFY)
1557   match ("open", gfc_match_open, ST_OPEN)
1558   match ("pause", gfc_match_pause, ST_NONE)
1559   match ("print", gfc_match_print, ST_WRITE)
1560   match ("read", gfc_match_read, ST_READ)
1561   match ("return", gfc_match_return, ST_RETURN)
1562   match ("rewind", gfc_match_rewind, ST_REWIND)
1563   match ("stop", gfc_match_stop, ST_STOP)
1564   match ("wait", gfc_match_wait, ST_WAIT)
1565   match ("where", match_simple_where, ST_WHERE)
1566   match ("write", gfc_match_write, ST_WRITE)
1567
1568   /* The gfc_match_assignment() above may have returned a MATCH_NO
1569      where the assignment was to a named constant.  Check that 
1570      special case here.  */
1571   m = gfc_match_assignment ();
1572   if (m == MATCH_NO)
1573    {
1574       gfc_error ("Cannot assign to a named constant at %C");
1575       gfc_free_expr (expr);
1576       gfc_undo_symbols ();
1577       gfc_current_locus = old_loc;
1578       return MATCH_ERROR;
1579    }
1580
1581   /* All else has failed, so give up.  See if any of the matchers has
1582      stored an error message of some sort.  */
1583   if (gfc_error_check () == 0)
1584     gfc_error ("Unclassifiable statement in IF-clause at %C");
1585
1586   gfc_free_expr (expr);
1587   return MATCH_ERROR;
1588
1589 got_match:
1590   if (m == MATCH_NO)
1591     gfc_error ("Syntax error in IF-clause at %C");
1592   if (m != MATCH_YES)
1593     {
1594       gfc_free_expr (expr);
1595       return MATCH_ERROR;
1596     }
1597
1598   /* At this point, we've matched the single IF and the action clause
1599      is in new_st.  Rearrange things so that the IF statement appears
1600      in new_st.  */
1601
1602   p = gfc_get_code ();
1603   p->next = gfc_get_code ();
1604   *p->next = new_st;
1605   p->next->loc = gfc_current_locus;
1606
1607   p->expr1 = expr;
1608   p->op = EXEC_IF;
1609
1610   gfc_clear_new_st ();
1611
1612   new_st.op = EXEC_IF;
1613   new_st.block = p;
1614
1615   return MATCH_YES;
1616 }
1617
1618 #undef match
1619
1620
1621 /* Match an ELSE statement.  */
1622
1623 match
1624 gfc_match_else (void)
1625 {
1626   char name[GFC_MAX_SYMBOL_LEN + 1];
1627
1628   if (gfc_match_eos () == MATCH_YES)
1629     return MATCH_YES;
1630
1631   if (gfc_match_name (name) != MATCH_YES
1632       || gfc_current_block () == NULL
1633       || gfc_match_eos () != MATCH_YES)
1634     {
1635       gfc_error ("Unexpected junk after ELSE statement at %C");
1636       return MATCH_ERROR;
1637     }
1638
1639   if (strcmp (name, gfc_current_block ()->name) != 0)
1640     {
1641       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1642                  name, gfc_current_block ()->name);
1643       return MATCH_ERROR;
1644     }
1645
1646   return MATCH_YES;
1647 }
1648
1649
1650 /* Match an ELSE IF statement.  */
1651
1652 match
1653 gfc_match_elseif (void)
1654 {
1655   char name[GFC_MAX_SYMBOL_LEN + 1];
1656   gfc_expr *expr;
1657   match m;
1658
1659   m = gfc_match (" ( %e ) then", &expr);
1660   if (m != MATCH_YES)
1661     return m;
1662
1663   if (gfc_match_eos () == MATCH_YES)
1664     goto done;
1665
1666   if (gfc_match_name (name) != MATCH_YES
1667       || gfc_current_block () == NULL
1668       || gfc_match_eos () != MATCH_YES)
1669     {
1670       gfc_error ("Unexpected junk after ELSE IF statement at %C");
1671       goto cleanup;
1672     }
1673
1674   if (strcmp (name, gfc_current_block ()->name) != 0)
1675     {
1676       gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1677                  name, gfc_current_block ()->name);
1678       goto cleanup;
1679     }
1680
1681 done:
1682   new_st.op = EXEC_IF;
1683   new_st.expr1 = expr;
1684   return MATCH_YES;
1685
1686 cleanup:
1687   gfc_free_expr (expr);
1688   return MATCH_ERROR;
1689 }
1690
1691
1692 /* Free a gfc_iterator structure.  */
1693
1694 void
1695 gfc_free_iterator (gfc_iterator *iter, int flag)
1696 {
1697
1698   if (iter == NULL)
1699     return;
1700
1701   gfc_free_expr (iter->var);
1702   gfc_free_expr (iter->start);
1703   gfc_free_expr (iter->end);
1704   gfc_free_expr (iter->step);
1705
1706   if (flag)
1707     gfc_free (iter);
1708 }
1709
1710
1711 /* Match a BLOCK statement.  */
1712
1713 match
1714 gfc_match_block (void)
1715 {
1716   match m;
1717
1718   if (gfc_match_label () == MATCH_ERROR)
1719     return MATCH_ERROR;
1720
1721   if (gfc_match (" block") != MATCH_YES)
1722     return MATCH_NO;
1723
1724   /* For this to be a correct BLOCK statement, the line must end now.  */
1725   m = gfc_match_eos ();
1726   if (m == MATCH_ERROR)
1727     return MATCH_ERROR;
1728   if (m == MATCH_NO)
1729     return MATCH_NO;
1730
1731   return MATCH_YES;
1732 }
1733
1734
1735 /* Match a DO statement.  */
1736
1737 match
1738 gfc_match_do (void)
1739 {
1740   gfc_iterator iter, *ip;
1741   locus old_loc;
1742   gfc_st_label *label;
1743   match m;
1744
1745   old_loc = gfc_current_locus;
1746
1747   label = NULL;
1748   iter.var = iter.start = iter.end = iter.step = NULL;
1749
1750   m = gfc_match_label ();
1751   if (m == MATCH_ERROR)
1752     return m;
1753
1754   if (gfc_match (" do") != MATCH_YES)
1755     return MATCH_NO;
1756
1757   m = gfc_match_st_label (&label);
1758   if (m == MATCH_ERROR)
1759     goto cleanup;
1760
1761   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1762
1763   if (gfc_match_eos () == MATCH_YES)
1764     {
1765       iter.end = gfc_logical_expr (1, NULL);
1766       new_st.op = EXEC_DO_WHILE;
1767       goto done;
1768     }
1769
1770   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1771   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1772     return MATCH_NO;
1773
1774   /* Check for balanced parens.  */
1775   
1776   if (gfc_match_parens () == MATCH_ERROR)
1777     return MATCH_ERROR;
1778
1779   /* See if we have a DO WHILE.  */
1780   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1781     {
1782       new_st.op = EXEC_DO_WHILE;
1783       goto done;
1784     }
1785
1786   /* The abortive DO WHILE may have done something to the symbol
1787      table, so we start over.  */
1788   gfc_undo_symbols ();
1789   gfc_current_locus = old_loc;
1790
1791   gfc_match_label ();           /* This won't error.  */
1792   gfc_match (" do ");           /* This will work.  */
1793
1794   gfc_match_st_label (&label);  /* Can't error out.  */
1795   gfc_match_char (',');         /* Optional comma.  */
1796
1797   m = gfc_match_iterator (&iter, 0);
1798   if (m == MATCH_NO)
1799     return MATCH_NO;
1800   if (m == MATCH_ERROR)
1801     goto cleanup;
1802
1803   iter.var->symtree->n.sym->attr.implied_index = 0;
1804   gfc_check_do_variable (iter.var->symtree);
1805
1806   if (gfc_match_eos () != MATCH_YES)
1807     {
1808       gfc_syntax_error (ST_DO);
1809       goto cleanup;
1810     }
1811
1812   new_st.op = EXEC_DO;
1813
1814 done:
1815   if (label != NULL
1816       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1817     goto cleanup;
1818
1819   new_st.label1 = label;
1820
1821   if (new_st.op == EXEC_DO_WHILE)
1822     new_st.expr1 = iter.end;
1823   else
1824     {
1825       new_st.ext.iterator = ip = gfc_get_iterator ();
1826       *ip = iter;
1827     }
1828
1829   return MATCH_YES;
1830
1831 cleanup:
1832   gfc_free_iterator (&iter, 0);
1833
1834   return MATCH_ERROR;
1835 }
1836
1837
1838 /* Match an EXIT or CYCLE statement.  */
1839
1840 static match
1841 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1842 {
1843   gfc_state_data *p, *o;
1844   gfc_symbol *sym;
1845   match m;
1846
1847   if (gfc_match_eos () == MATCH_YES)
1848     sym = NULL;
1849   else
1850     {
1851       m = gfc_match ("% %s%t", &sym);
1852       if (m == MATCH_ERROR)
1853         return MATCH_ERROR;
1854       if (m == MATCH_NO)
1855         {
1856           gfc_syntax_error (st);
1857           return MATCH_ERROR;
1858         }
1859
1860       if (sym->attr.flavor != FL_LABEL)
1861         {
1862           gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1863                      sym->name, gfc_ascii_statement (st));
1864           return MATCH_ERROR;
1865         }
1866     }
1867
1868   /* Find the loop mentioned specified by the label (or lack of a label).  */
1869   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
1870     if (p->state == COMP_DO && (sym == NULL || sym == p->sym))
1871       break;
1872     else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
1873       o = p;
1874
1875   if (p == NULL)
1876     {
1877       if (sym == NULL)
1878         gfc_error ("%s statement at %C is not within a loop",
1879                    gfc_ascii_statement (st));
1880       else
1881         gfc_error ("%s statement at %C is not within loop '%s'",
1882                    gfc_ascii_statement (st), sym->name);
1883
1884       return MATCH_ERROR;
1885     }
1886
1887   if (o != NULL)
1888     {
1889       gfc_error ("%s statement at %C leaving OpenMP structured block",
1890                  gfc_ascii_statement (st));
1891       return MATCH_ERROR;
1892     }
1893   else if (st == ST_EXIT
1894            && p->previous != NULL
1895            && p->previous->state == COMP_OMP_STRUCTURED_BLOCK
1896            && (p->previous->head->op == EXEC_OMP_DO
1897                || p->previous->head->op == EXEC_OMP_PARALLEL_DO))
1898     {
1899       gcc_assert (p->previous->head->next != NULL);
1900       gcc_assert (p->previous->head->next->op == EXEC_DO
1901                   || p->previous->head->next->op == EXEC_DO_WHILE);
1902       gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
1903       return MATCH_ERROR;
1904     }
1905
1906   /* Save the first statement in the loop - needed by the backend.  */
1907   new_st.ext.whichloop = p->head;
1908
1909   new_st.op = op;
1910
1911   return MATCH_YES;
1912 }
1913
1914
1915 /* Match the EXIT statement.  */
1916
1917 match
1918 gfc_match_exit (void)
1919 {
1920   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
1921 }
1922
1923
1924 /* Match the CYCLE statement.  */
1925
1926 match
1927 gfc_match_cycle (void)
1928 {
1929   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
1930 }
1931
1932
1933 /* Match a number or character constant after a STOP or PAUSE statement.  */
1934
1935 static match
1936 gfc_match_stopcode (gfc_statement st)
1937 {
1938   int stop_code;
1939   gfc_expr *e;
1940   match m;
1941   int cnt;
1942
1943   stop_code = -1;
1944   e = NULL;
1945
1946   if (gfc_match_eos () != MATCH_YES)
1947     {
1948       m = gfc_match_small_literal_int (&stop_code, &cnt);
1949       if (m == MATCH_ERROR)
1950         goto cleanup;
1951
1952       if (m == MATCH_YES && cnt > 5)
1953         {
1954           gfc_error ("Too many digits in STOP code at %C");
1955           goto cleanup;
1956         }
1957
1958       if (m == MATCH_NO)
1959         {
1960           /* Try a character constant.  */
1961           m = gfc_match_expr (&e);
1962           if (m == MATCH_ERROR)
1963             goto cleanup;
1964           if (m == MATCH_NO)
1965             goto syntax;
1966           if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
1967             goto syntax;
1968         }
1969
1970       if (gfc_match_eos () != MATCH_YES)
1971         goto syntax;
1972     }
1973
1974   if (gfc_pure (NULL))
1975     {
1976       gfc_error ("%s statement not allowed in PURE procedure at %C",
1977                  gfc_ascii_statement (st));
1978       goto cleanup;
1979     }
1980
1981   new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE;
1982   new_st.expr1 = e;
1983   new_st.ext.stop_code = stop_code;
1984
1985   return MATCH_YES;
1986
1987 syntax:
1988   gfc_syntax_error (st);
1989
1990 cleanup:
1991
1992   gfc_free_expr (e);
1993   return MATCH_ERROR;
1994 }
1995
1996
1997 /* Match the (deprecated) PAUSE statement.  */
1998
1999 match
2000 gfc_match_pause (void)
2001 {
2002   match m;
2003
2004   m = gfc_match_stopcode (ST_PAUSE);
2005   if (m == MATCH_YES)
2006     {
2007       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2008           " at %C")
2009           == FAILURE)
2010         m = MATCH_ERROR;
2011     }
2012   return m;
2013 }
2014
2015
2016 /* Match the STOP statement.  */
2017
2018 match
2019 gfc_match_stop (void)
2020 {
2021   return gfc_match_stopcode (ST_STOP);
2022 }
2023
2024
2025 /* Match a CONTINUE statement.  */
2026
2027 match
2028 gfc_match_continue (void)
2029 {
2030   if (gfc_match_eos () != MATCH_YES)
2031     {
2032       gfc_syntax_error (ST_CONTINUE);
2033       return MATCH_ERROR;
2034     }
2035
2036   new_st.op = EXEC_CONTINUE;
2037   return MATCH_YES;
2038 }
2039
2040
2041 /* Match the (deprecated) ASSIGN statement.  */
2042
2043 match
2044 gfc_match_assign (void)
2045 {
2046   gfc_expr *expr;
2047   gfc_st_label *label;
2048
2049   if (gfc_match (" %l", &label) == MATCH_YES)
2050     {
2051       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2052         return MATCH_ERROR;
2053       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2054         {
2055           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2056                               "statement at %C")
2057               == FAILURE)
2058             return MATCH_ERROR;
2059
2060           expr->symtree->n.sym->attr.assign = 1;
2061
2062           new_st.op = EXEC_LABEL_ASSIGN;
2063           new_st.label1 = label;
2064           new_st.expr1 = expr;
2065           return MATCH_YES;
2066         }
2067     }
2068   return MATCH_NO;
2069 }
2070
2071
2072 /* Match the GO TO statement.  As a computed GOTO statement is
2073    matched, it is transformed into an equivalent SELECT block.  No
2074    tree is necessary, and the resulting jumps-to-jumps are
2075    specifically optimized away by the back end.  */
2076
2077 match
2078 gfc_match_goto (void)
2079 {
2080   gfc_code *head, *tail;
2081   gfc_expr *expr;
2082   gfc_case *cp;
2083   gfc_st_label *label;
2084   int i;
2085   match m;
2086
2087   if (gfc_match (" %l%t", &label) == MATCH_YES)
2088     {
2089       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2090         return MATCH_ERROR;
2091
2092       new_st.op = EXEC_GOTO;
2093       new_st.label1 = label;
2094       return MATCH_YES;
2095     }
2096
2097   /* The assigned GO TO statement.  */ 
2098
2099   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2100     {
2101       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2102                           "statement at %C")
2103           == FAILURE)
2104         return MATCH_ERROR;
2105
2106       new_st.op = EXEC_GOTO;
2107       new_st.expr1 = expr;
2108
2109       if (gfc_match_eos () == MATCH_YES)
2110         return MATCH_YES;
2111
2112       /* Match label list.  */
2113       gfc_match_char (',');
2114       if (gfc_match_char ('(') != MATCH_YES)
2115         {
2116           gfc_syntax_error (ST_GOTO);
2117           return MATCH_ERROR;
2118         }
2119       head = tail = NULL;
2120
2121       do
2122         {
2123           m = gfc_match_st_label (&label);
2124           if (m != MATCH_YES)
2125             goto syntax;
2126
2127           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2128             goto cleanup;
2129
2130           if (head == NULL)
2131             head = tail = gfc_get_code ();
2132           else
2133             {
2134               tail->block = gfc_get_code ();
2135               tail = tail->block;
2136             }
2137
2138           tail->label1 = label;
2139           tail->op = EXEC_GOTO;
2140         }
2141       while (gfc_match_char (',') == MATCH_YES);
2142
2143       if (gfc_match (")%t") != MATCH_YES)
2144         goto syntax;
2145
2146       if (head == NULL)
2147         {
2148            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2149            goto syntax;
2150         }
2151       new_st.block = head;
2152
2153       return MATCH_YES;
2154     }
2155
2156   /* Last chance is a computed GO TO statement.  */
2157   if (gfc_match_char ('(') != MATCH_YES)
2158     {
2159       gfc_syntax_error (ST_GOTO);
2160       return MATCH_ERROR;
2161     }
2162
2163   head = tail = NULL;
2164   i = 1;
2165
2166   do
2167     {
2168       m = gfc_match_st_label (&label);
2169       if (m != MATCH_YES)
2170         goto syntax;
2171
2172       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2173         goto cleanup;
2174
2175       if (head == NULL)
2176         head = tail = gfc_get_code ();
2177       else
2178         {
2179           tail->block = gfc_get_code ();
2180           tail = tail->block;
2181         }
2182
2183       cp = gfc_get_case ();
2184       cp->low = cp->high = gfc_int_expr (i++);
2185
2186       tail->op = EXEC_SELECT;
2187       tail->ext.case_list = cp;
2188
2189       tail->next = gfc_get_code ();
2190       tail->next->op = EXEC_GOTO;
2191       tail->next->label1 = label;
2192     }
2193   while (gfc_match_char (',') == MATCH_YES);
2194
2195   if (gfc_match_char (')') != MATCH_YES)
2196     goto syntax;
2197
2198   if (head == NULL)
2199     {
2200       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2201       goto syntax;
2202     }
2203
2204   /* Get the rest of the statement.  */
2205   gfc_match_char (',');
2206
2207   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2208     goto syntax;
2209
2210   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2211                       "at %C") == FAILURE)
2212     return MATCH_ERROR;
2213
2214   /* At this point, a computed GOTO has been fully matched and an
2215      equivalent SELECT statement constructed.  */
2216
2217   new_st.op = EXEC_SELECT;
2218   new_st.expr1 = NULL;
2219
2220   /* Hack: For a "real" SELECT, the expression is in expr. We put
2221      it in expr2 so we can distinguish then and produce the correct
2222      diagnostics.  */
2223   new_st.expr2 = expr;
2224   new_st.block = head;
2225   return MATCH_YES;
2226
2227 syntax:
2228   gfc_syntax_error (ST_GOTO);
2229 cleanup:
2230   gfc_free_statements (head);
2231   return MATCH_ERROR;
2232 }
2233
2234
2235 /* Frees a list of gfc_alloc structures.  */
2236
2237 void
2238 gfc_free_alloc_list (gfc_alloc *p)
2239 {
2240   gfc_alloc *q;
2241
2242   for (; p; p = q)
2243     {
2244       q = p->next;
2245       gfc_free_expr (p->expr);
2246       gfc_free (p);
2247     }
2248 }
2249
2250
2251 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2252    an accessible derived type.  */
2253
2254 static match
2255 match_derived_type_spec (gfc_typespec *ts)
2256 {
2257   locus old_locus; 
2258   gfc_symbol *derived;
2259
2260   old_locus = gfc_current_locus; 
2261
2262   if (gfc_match_symbol (&derived, 1) == MATCH_YES)
2263     {
2264       if (derived->attr.flavor == FL_DERIVED)
2265         {
2266           ts->type = BT_DERIVED;
2267           ts->u.derived = derived;
2268           return MATCH_YES;
2269         }
2270       else
2271         {
2272           /* Enforce F03:C476.  */
2273           gfc_error ("'%s' at %L is not an accessible derived type",
2274                      derived->name, &gfc_current_locus);
2275           return MATCH_ERROR;
2276         }
2277     }
2278
2279   gfc_current_locus = old_locus; 
2280   return MATCH_NO;
2281 }
2282
2283
2284 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
2285    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2286    It only includes the intrinsic types from the Fortran 2003 standard
2287    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2288    the implicit_flag is not needed, so it was removed.  Derived types are
2289    identified by their name alone.  */
2290
2291 static match
2292 match_type_spec (gfc_typespec *ts)
2293 {
2294   match m;
2295   locus old_locus;
2296
2297   gfc_clear_ts (ts);
2298   old_locus = gfc_current_locus;
2299
2300   if (gfc_match ("integer") == MATCH_YES)
2301     {
2302       ts->type = BT_INTEGER;
2303       ts->kind = gfc_default_integer_kind;
2304       goto kind_selector;
2305     }
2306
2307   if (gfc_match ("real") == MATCH_YES)
2308     {
2309       ts->type = BT_REAL;
2310       ts->kind = gfc_default_real_kind;
2311       goto kind_selector;
2312     }
2313
2314   if (gfc_match ("double precision") == MATCH_YES)
2315     {
2316       ts->type = BT_REAL;
2317       ts->kind = gfc_default_double_kind;
2318       return MATCH_YES;
2319     }
2320
2321   if (gfc_match ("complex") == MATCH_YES)
2322     {
2323       ts->type = BT_COMPLEX;
2324       ts->kind = gfc_default_complex_kind;
2325       goto kind_selector;
2326     }
2327
2328   if (gfc_match ("character") == MATCH_YES)
2329     {
2330       ts->type = BT_CHARACTER;
2331       goto char_selector;
2332     }
2333
2334   if (gfc_match ("logical") == MATCH_YES)
2335     {
2336       ts->type = BT_LOGICAL;
2337       ts->kind = gfc_default_logical_kind;
2338       goto kind_selector;
2339     }
2340
2341   m = match_derived_type_spec (ts);
2342   if (m == MATCH_YES)
2343     {
2344       old_locus = gfc_current_locus;
2345       if (gfc_match (" :: ") != MATCH_YES)
2346         return MATCH_ERROR;
2347       gfc_current_locus = old_locus;
2348       /* Enfore F03:C401.  */
2349       if (ts->u.derived->attr.abstract)
2350         {
2351           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2352                      ts->u.derived->name, &old_locus);
2353           return MATCH_ERROR;
2354         }
2355       return MATCH_YES;
2356     }
2357   else if (m == MATCH_ERROR && gfc_match (" :: ") == MATCH_YES)
2358     return MATCH_ERROR;
2359
2360   /* If a type is not matched, simply return MATCH_NO.  */
2361   gfc_current_locus = old_locus;
2362   return MATCH_NO;
2363
2364 kind_selector:
2365
2366   gfc_gobble_whitespace ();
2367   if (gfc_peek_ascii_char () == '*')
2368     {
2369       gfc_error ("Invalid type-spec at %C");
2370       return MATCH_ERROR;
2371     }
2372
2373   m = gfc_match_kind_spec (ts, false);
2374
2375   if (m == MATCH_NO)
2376     m = MATCH_YES;              /* No kind specifier found.  */
2377
2378   return m;
2379
2380 char_selector:
2381
2382   m = gfc_match_char_spec (ts);
2383
2384   if (m == MATCH_NO)
2385     m = MATCH_YES;              /* No kind specifier found.  */
2386
2387   return m;
2388 }
2389
2390
2391 /* Used in gfc_match_allocate to check that a allocation-object and
2392    a source-expr are conformable.  This does not catch all possible 
2393    cases; in particular a runtime checking is needed.  */
2394
2395 static gfc_try
2396 conformable_arrays (gfc_expr *e1, gfc_expr *e2)
2397 {
2398   /* First compare rank.  */
2399   if (e2->ref && e1->rank != e2->ref->u.ar.as->rank)
2400     {
2401       gfc_error ("Source-expr at %L must be scalar or have the "
2402                  "same rank as the allocate-object at %L",
2403                  &e1->where, &e2->where);
2404       return FAILURE;
2405     }
2406
2407   if (e1->shape)
2408     {
2409       int i;
2410       mpz_t s;
2411
2412       mpz_init (s);
2413
2414       for (i = 0; i < e1->rank; i++)
2415         {
2416           if (e2->ref->u.ar.end[i])
2417             {
2418               mpz_set (s, e2->ref->u.ar.end[i]->value.integer);
2419               mpz_sub (s, s, e2->ref->u.ar.start[i]->value.integer);
2420               mpz_add_ui (s, s, 1);
2421             }
2422           else
2423             {
2424               mpz_set (s, e2->ref->u.ar.start[i]->value.integer);
2425             }
2426
2427           if (mpz_cmp (e1->shape[i], s) != 0)
2428             {
2429               gfc_error ("Source-expr at %L and allocate-object at %L must "
2430                          "have the same shape", &e1->where, &e2->where);
2431               mpz_clear (s);
2432               return FAILURE;
2433             }
2434         }
2435
2436       mpz_clear (s);
2437     }
2438
2439   return SUCCESS;
2440 }
2441
2442
2443 /* Match an ALLOCATE statement.  */
2444
2445 match
2446 gfc_match_allocate (void)
2447 {
2448   gfc_alloc *head, *tail;
2449   gfc_expr *stat, *errmsg, *tmp, *source;
2450   gfc_typespec ts;
2451   gfc_symbol *sym;
2452   match m;
2453   locus old_locus;
2454   bool saw_stat, saw_errmsg, saw_source, b1, b2, b3;
2455
2456   head = tail = NULL;
2457   stat = errmsg = source = tmp = NULL;
2458   saw_stat = saw_errmsg = saw_source = false;
2459
2460   if (gfc_match_char ('(') != MATCH_YES)
2461     goto syntax;
2462
2463   /* Match an optional type-spec.  */
2464   old_locus = gfc_current_locus;
2465   m = match_type_spec (&ts);
2466   if (m == MATCH_ERROR)
2467     goto cleanup;
2468   else if (m == MATCH_NO)
2469     ts.type = BT_UNKNOWN;
2470   else
2471     {
2472       if (gfc_match (" :: ") == MATCH_YES)
2473         {
2474           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2475                               "ALLOCATE at %L", &old_locus) == FAILURE)
2476             goto cleanup;
2477         }
2478       else
2479         {
2480           ts.type = BT_UNKNOWN;
2481           gfc_current_locus = old_locus;
2482         }
2483     }
2484
2485   for (;;)
2486     {
2487       if (head == NULL)
2488         head = tail = gfc_get_alloc ();
2489       else
2490         {
2491           tail->next = gfc_get_alloc ();
2492           tail = tail->next;
2493         }
2494
2495       m = gfc_match_variable (&tail->expr, 0);
2496       if (m == MATCH_NO)
2497         goto syntax;
2498       if (m == MATCH_ERROR)
2499         goto cleanup;
2500
2501       if (gfc_check_do_variable (tail->expr->symtree))
2502         goto cleanup;
2503
2504       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2505         {
2506           gfc_error ("Bad allocate-object at %C for a PURE procedure");
2507           goto cleanup;
2508         }
2509
2510       /* The ALLOCATE statement had an optional typespec.  Check the
2511          constraints.  */
2512       if (ts.type != BT_UNKNOWN)
2513         {
2514           /* Enforce F03:C624.  */
2515           if (!gfc_type_compatible (&tail->expr->ts, &ts))
2516             {
2517               gfc_error ("Type of entity at %L is type incompatible with "
2518                          "typespec", &tail->expr->where);
2519               goto cleanup;
2520             }
2521
2522           /* Enforce F03:C627.  */
2523           if (ts.kind != tail->expr->ts.kind)
2524             {
2525               gfc_error ("Kind type parameter for entity at %L differs from "
2526                          "the kind type parameter of the typespec",
2527                          &tail->expr->where);
2528               goto cleanup;
2529             }
2530         }
2531
2532       if (tail->expr->ts.type == BT_DERIVED)
2533         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2534
2535       /* FIXME: disable the checking on derived types and arrays.  */
2536       sym = tail->expr->symtree->n.sym;
2537       b1 = !(tail->expr->ref
2538            && (tail->expr->ref->type == REF_COMPONENT
2539                 || tail->expr->ref->type == REF_ARRAY));
2540       if (sym && sym->ts.type == BT_CLASS)
2541         b2 = !(sym->ts.u.derived->components->attr.allocatable
2542                || sym->ts.u.derived->components->attr.pointer);
2543       else
2544         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2545                       || sym->attr.proc_pointer);
2546       b3 = sym && sym->ns && sym->ns->proc_name
2547            && (sym->ns->proc_name->attr.allocatable
2548                 || sym->ns->proc_name->attr.pointer
2549                 || sym->ns->proc_name->attr.proc_pointer);
2550       if (b1 && b2 && !b3)
2551         {
2552           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2553                      "or an allocatable variable");
2554           goto cleanup;
2555         }
2556
2557       if (gfc_match_char (',') != MATCH_YES)
2558         break;
2559
2560 alloc_opt_list:
2561
2562       m = gfc_match (" stat = %v", &tmp);
2563       if (m == MATCH_ERROR)
2564         goto cleanup;
2565       if (m == MATCH_YES)
2566         {
2567           /* Enforce C630.  */
2568           if (saw_stat)
2569             {
2570               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2571               goto cleanup;
2572             }
2573
2574           stat = tmp;
2575           saw_stat = true;
2576
2577           if (gfc_check_do_variable (stat->symtree))
2578             goto cleanup;
2579
2580           if (gfc_match_char (',') == MATCH_YES)
2581             goto alloc_opt_list;
2582         }
2583
2584       m = gfc_match (" errmsg = %v", &tmp);
2585       if (m == MATCH_ERROR)
2586         goto cleanup;
2587       if (m == MATCH_YES)
2588         {
2589           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
2590                               &tmp->where) == FAILURE)
2591             goto cleanup;
2592
2593           /* Enforce C630.  */
2594           if (saw_errmsg)
2595             {
2596               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2597               goto cleanup;
2598             }
2599
2600           errmsg = tmp;
2601           saw_errmsg = true;
2602
2603           if (gfc_match_char (',') == MATCH_YES)
2604             goto alloc_opt_list;
2605         }
2606
2607       m = gfc_match (" source = %e", &tmp);
2608       if (m == MATCH_ERROR)
2609         goto cleanup;
2610       if (m == MATCH_YES)
2611         {
2612           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
2613                               &tmp->where) == FAILURE)
2614             goto cleanup;
2615
2616           /* Enforce C630.  */
2617           if (saw_source)
2618             {
2619               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
2620               goto cleanup;
2621             }
2622
2623           /* The next 3 conditionals check C631.  */
2624           if (ts.type != BT_UNKNOWN)
2625             {
2626               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
2627                          &tmp->where, &old_locus);
2628               goto cleanup;
2629             }
2630
2631           if (head->next)
2632             {
2633               gfc_error ("SOURCE tag at %L requires only a single entity in "
2634                          "the allocation-list", &tmp->where);
2635               goto cleanup;
2636             }
2637
2638           gfc_resolve_expr (tmp);
2639
2640           if (!gfc_type_compatible (&head->expr->ts, &tmp->ts))
2641             {
2642               gfc_error ("Type of entity at %L is type incompatible with "
2643                          "source-expr at %L", &head->expr->where, &tmp->where);
2644               goto cleanup;
2645             }
2646
2647           /* Check C633.  */
2648           if (tmp->ts.kind != head->expr->ts.kind)
2649             {
2650               gfc_error ("The allocate-object at %L and the source-expr at %L "
2651                          "shall have the same kind type parameter",
2652                          &head->expr->where, &tmp->where);
2653               goto cleanup;
2654             }
2655
2656           /* Check C632 and restriction following Note 6.18.  */
2657           if (tmp->rank > 0 && conformable_arrays (tmp, head->expr) == FAILURE)
2658             goto cleanup;
2659
2660           source = tmp;
2661           saw_source = true;
2662
2663           if (gfc_match_char (',') == MATCH_YES)
2664             goto alloc_opt_list;
2665         }
2666
2667         gfc_gobble_whitespace ();
2668
2669         if (gfc_peek_char () == ')')
2670           break;
2671     }
2672
2673
2674   if (gfc_match (" )%t") != MATCH_YES)
2675     goto syntax;
2676
2677   new_st.op = EXEC_ALLOCATE;
2678   new_st.expr1 = stat;
2679   new_st.expr2 = errmsg;
2680   new_st.expr3 = source;
2681   new_st.ext.alloc.list = head;
2682   new_st.ext.alloc.ts = ts;
2683
2684   return MATCH_YES;
2685
2686 syntax:
2687   gfc_syntax_error (ST_ALLOCATE);
2688
2689 cleanup:
2690   gfc_free_expr (errmsg);
2691   gfc_free_expr (source);
2692   gfc_free_expr (stat);
2693   gfc_free_expr (tmp);
2694   gfc_free_alloc_list (head);
2695   return MATCH_ERROR;
2696 }
2697
2698
2699 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
2700    a set of pointer assignments to intrinsic NULL().  */
2701
2702 match
2703 gfc_match_nullify (void)
2704 {
2705   gfc_code *tail;
2706   gfc_expr *e, *p;
2707   match m;
2708
2709   tail = NULL;
2710
2711   if (gfc_match_char ('(') != MATCH_YES)
2712     goto syntax;
2713
2714   for (;;)
2715     {
2716       m = gfc_match_variable (&p, 0);
2717       if (m == MATCH_ERROR)
2718         goto cleanup;
2719       if (m == MATCH_NO)
2720         goto syntax;
2721
2722       if (gfc_check_do_variable (p->symtree))
2723         goto cleanup;
2724
2725       if (gfc_pure (NULL) && gfc_impure_variable (p->symtree->n.sym))
2726         {
2727           gfc_error ("Illegal variable in NULLIFY at %C for a PURE procedure");
2728           goto cleanup;
2729         }
2730
2731       /* build ' => NULL() '.  */
2732       e = gfc_get_expr ();
2733       e->where = gfc_current_locus;
2734       e->expr_type = EXPR_NULL;
2735       e->ts.type = BT_UNKNOWN;
2736
2737       /* Chain to list.  */
2738       if (tail == NULL)
2739         tail = &new_st;
2740       else
2741         {
2742           tail->next = gfc_get_code ();
2743           tail = tail->next;
2744         }
2745
2746       tail->op = EXEC_POINTER_ASSIGN;
2747       tail->expr1 = p;
2748       tail->expr2 = e;
2749
2750       if (gfc_match (" )%t") == MATCH_YES)
2751         break;
2752       if (gfc_match_char (',') != MATCH_YES)
2753         goto syntax;
2754     }
2755
2756   return MATCH_YES;
2757
2758 syntax:
2759   gfc_syntax_error (ST_NULLIFY);
2760
2761 cleanup:
2762   gfc_free_statements (new_st.next);
2763   new_st.next = NULL;
2764   gfc_free_expr (new_st.expr1);
2765   new_st.expr1 = NULL;
2766   gfc_free_expr (new_st.expr2);
2767   new_st.expr2 = NULL;
2768   return MATCH_ERROR;
2769 }
2770
2771
2772 /* Match a DEALLOCATE statement.  */
2773
2774 match
2775 gfc_match_deallocate (void)
2776 {
2777   gfc_alloc *head, *tail;
2778   gfc_expr *stat, *errmsg, *tmp;
2779   gfc_symbol *sym;
2780   match m;
2781   bool saw_stat, saw_errmsg, b1, b2;
2782
2783   head = tail = NULL;
2784   stat = errmsg = tmp = NULL;
2785   saw_stat = saw_errmsg = false;
2786
2787   if (gfc_match_char ('(') != MATCH_YES)
2788     goto syntax;
2789
2790   for (;;)
2791     {
2792       if (head == NULL)
2793         head = tail = gfc_get_alloc ();
2794       else
2795         {
2796           tail->next = gfc_get_alloc ();
2797           tail = tail->next;
2798         }
2799
2800       m = gfc_match_variable (&tail->expr, 0);
2801       if (m == MATCH_ERROR)
2802         goto cleanup;
2803       if (m == MATCH_NO)
2804         goto syntax;
2805
2806       if (gfc_check_do_variable (tail->expr->symtree))
2807         goto cleanup;
2808
2809       sym = tail->expr->symtree->n.sym;
2810
2811       if (gfc_pure (NULL) && gfc_impure_variable (sym))
2812         {
2813           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
2814           goto cleanup;
2815         }
2816
2817       /* FIXME: disable the checking on derived types.  */
2818       b1 = !(tail->expr->ref
2819            && (tail->expr->ref->type == REF_COMPONENT
2820                || tail->expr->ref->type == REF_ARRAY));
2821       if (sym && sym->ts.type == BT_CLASS)
2822         b2 = !(sym->ts.u.derived->components->attr.allocatable
2823                || sym->ts.u.derived->components->attr.pointer);
2824       else
2825         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2826                       || sym->attr.proc_pointer);
2827       if (b1 && b2)
2828         {
2829           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
2830                      "or an allocatable variable");
2831           goto cleanup;
2832         }
2833
2834       if (gfc_match_char (',') != MATCH_YES)
2835         break;
2836
2837 dealloc_opt_list:
2838
2839       m = gfc_match (" stat = %v", &tmp);
2840       if (m == MATCH_ERROR)
2841         goto cleanup;
2842       if (m == MATCH_YES)
2843         {
2844           if (saw_stat)
2845             {
2846               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2847               gfc_free_expr (tmp);
2848               goto cleanup;
2849             }
2850
2851           stat = tmp;
2852           saw_stat = true;
2853
2854           if (gfc_check_do_variable (stat->symtree))
2855             goto cleanup;
2856
2857           if (gfc_match_char (',') == MATCH_YES)
2858             goto dealloc_opt_list;
2859         }
2860
2861       m = gfc_match (" errmsg = %v", &tmp);
2862       if (m == MATCH_ERROR)
2863         goto cleanup;
2864       if (m == MATCH_YES)
2865         {
2866           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
2867                               &tmp->where) == FAILURE)
2868             goto cleanup;
2869
2870           if (saw_errmsg)
2871             {
2872               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2873               gfc_free_expr (tmp);
2874               goto cleanup;
2875             }
2876
2877           errmsg = tmp;
2878           saw_errmsg = true;
2879
2880           if (gfc_match_char (',') == MATCH_YES)
2881             goto dealloc_opt_list;
2882         }
2883
2884         gfc_gobble_whitespace ();
2885
2886         if (gfc_peek_char () == ')')
2887           break;
2888     }
2889
2890   if (gfc_match (" )%t") != MATCH_YES)
2891     goto syntax;
2892
2893   new_st.op = EXEC_DEALLOCATE;
2894   new_st.expr1 = stat;
2895   new_st.expr2 = errmsg;
2896   new_st.ext.alloc.list = head;
2897
2898   return MATCH_YES;
2899
2900 syntax:
2901   gfc_syntax_error (ST_DEALLOCATE);
2902
2903 cleanup:
2904   gfc_free_expr (errmsg);
2905   gfc_free_expr (stat);
2906   gfc_free_alloc_list (head);
2907   return MATCH_ERROR;
2908 }
2909
2910
2911 /* Match a RETURN statement.  */
2912
2913 match
2914 gfc_match_return (void)
2915 {
2916   gfc_expr *e;
2917   match m;
2918   gfc_compile_state s;
2919
2920   e = NULL;
2921   if (gfc_match_eos () == MATCH_YES)
2922     goto done;
2923
2924   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
2925     {
2926       gfc_error ("Alternate RETURN statement at %C is only allowed within "
2927                  "a SUBROUTINE");
2928       goto cleanup;
2929     }
2930
2931   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
2932                       "at %C") == FAILURE)
2933     return MATCH_ERROR;
2934
2935   if (gfc_current_form == FORM_FREE)
2936     {
2937       /* The following are valid, so we can't require a blank after the
2938         RETURN keyword:
2939           return+1
2940           return(1)  */
2941       char c = gfc_peek_ascii_char ();
2942       if (ISALPHA (c) || ISDIGIT (c))
2943         return MATCH_NO;
2944     }
2945
2946   m = gfc_match (" %e%t", &e);
2947   if (m == MATCH_YES)
2948     goto done;
2949   if (m == MATCH_ERROR)
2950     goto cleanup;
2951
2952   gfc_syntax_error (ST_RETURN);
2953
2954 cleanup:
2955   gfc_free_expr (e);
2956   return MATCH_ERROR;
2957
2958 done:
2959   gfc_enclosing_unit (&s);
2960   if (s == COMP_PROGRAM
2961       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
2962                         "main program at %C") == FAILURE)
2963       return MATCH_ERROR;
2964
2965   new_st.op = EXEC_RETURN;
2966   new_st.expr1 = e;
2967
2968   return MATCH_YES;
2969 }
2970
2971
2972 /* Match the call of a type-bound procedure, if CALL%var has already been 
2973    matched and var found to be a derived-type variable.  */
2974
2975 static match
2976 match_typebound_call (gfc_symtree* varst)
2977 {
2978   gfc_symbol* var;
2979   gfc_expr* base;
2980   match m;
2981
2982   var = varst->n.sym;
2983
2984   base = gfc_get_expr ();
2985   base->expr_type = EXPR_VARIABLE;
2986   base->symtree = varst;
2987   base->where = gfc_current_locus;
2988   gfc_set_sym_referenced (varst->n.sym);
2989   
2990   m = gfc_match_varspec (base, 0, true, true);
2991   if (m == MATCH_NO)
2992     gfc_error ("Expected component reference at %C");
2993   if (m != MATCH_YES)
2994     return MATCH_ERROR;
2995
2996   if (gfc_match_eos () != MATCH_YES)
2997     {
2998       gfc_error ("Junk after CALL at %C");
2999       return MATCH_ERROR;
3000     }
3001
3002   if (base->expr_type == EXPR_COMPCALL)
3003     new_st.op = EXEC_COMPCALL;
3004   else if (base->expr_type == EXPR_PPC)
3005     new_st.op = EXEC_CALL_PPC;
3006   else
3007     {
3008       gfc_error ("Expected type-bound procedure or procedure pointer component "
3009                  "at %C");
3010       return MATCH_ERROR;
3011     }
3012   new_st.expr1 = base;
3013
3014   return MATCH_YES;
3015 }
3016
3017
3018 /* Match a CALL statement.  The tricky part here are possible
3019    alternate return specifiers.  We handle these by having all
3020    "subroutines" actually return an integer via a register that gives
3021    the return number.  If the call specifies alternate returns, we
3022    generate code for a SELECT statement whose case clauses contain
3023    GOTOs to the various labels.  */
3024
3025 match
3026 gfc_match_call (void)
3027 {
3028   char name[GFC_MAX_SYMBOL_LEN + 1];
3029   gfc_actual_arglist *a, *arglist;
3030   gfc_case *new_case;
3031   gfc_symbol *sym;
3032   gfc_symtree *st;
3033   gfc_code *c;
3034   match m;
3035   int i;
3036
3037   arglist = NULL;
3038
3039   m = gfc_match ("% %n", name);
3040   if (m == MATCH_NO)
3041     goto syntax;
3042   if (m != MATCH_YES)
3043     return m;
3044
3045   if (gfc_get_ha_sym_tree (name, &st))
3046     return MATCH_ERROR;
3047
3048   sym = st->n.sym;
3049
3050   /* If this is a variable of derived-type, it probably starts a type-bound
3051      procedure call.  */
3052   if (sym->attr.flavor != FL_PROCEDURE
3053       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3054     return match_typebound_call (st);
3055
3056   /* If it does not seem to be callable (include functions so that the
3057      right association is made.  They are thrown out in resolution.)
3058      ...  */
3059   if (!sym->attr.generic
3060         && !sym->attr.subroutine
3061         && !sym->attr.function)
3062     {
3063       if (!(sym->attr.external && !sym->attr.referenced))
3064         {
3065           /* ...create a symbol in this scope...  */
3066           if (sym->ns != gfc_current_ns
3067                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3068             return MATCH_ERROR;
3069
3070           if (sym != st->n.sym)
3071             sym = st->n.sym;
3072         }
3073
3074       /* ...and then to try to make the symbol into a subroutine.  */
3075       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3076         return MATCH_ERROR;
3077     }
3078
3079   gfc_set_sym_referenced (sym);
3080
3081   if (gfc_match_eos () != MATCH_YES)
3082     {
3083       m = gfc_match_actual_arglist (1, &arglist);
3084       if (m == MATCH_NO)
3085         goto syntax;
3086       if (m == MATCH_ERROR)
3087         goto cleanup;
3088
3089       if (gfc_match_eos () != MATCH_YES)
3090         goto syntax;
3091     }
3092
3093   /* If any alternate return labels were found, construct a SELECT
3094      statement that will jump to the right place.  */
3095
3096   i = 0;
3097   for (a = arglist; a; a = a->next)
3098     if (a->expr == NULL)
3099       i = 1;
3100
3101   if (i)
3102     {
3103       gfc_symtree *select_st;
3104       gfc_symbol *select_sym;
3105       char name[GFC_MAX_SYMBOL_LEN + 1];
3106
3107       new_st.next = c = gfc_get_code ();
3108       c->op = EXEC_SELECT;
3109       sprintf (name, "_result_%s", sym->name);
3110       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3111
3112       select_sym = select_st->n.sym;
3113       select_sym->ts.type = BT_INTEGER;
3114       select_sym->ts.kind = gfc_default_integer_kind;
3115       gfc_set_sym_referenced (select_sym);
3116       c->expr1 = gfc_get_expr ();
3117       c->expr1->expr_type = EXPR_VARIABLE;
3118       c->expr1->symtree = select_st;
3119       c->expr1->ts = select_sym->ts;
3120       c->expr1->where = gfc_current_locus;
3121
3122       i = 0;
3123       for (a = arglist; a; a = a->next)
3124         {
3125           if (a->expr != NULL)
3126             continue;
3127
3128           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3129             continue;
3130
3131           i++;
3132
3133           c->block = gfc_get_code ();
3134           c = c->block;
3135           c->op = EXEC_SELECT;
3136
3137           new_case = gfc_get_case ();
3138           new_case->high = new_case->low = gfc_int_expr (i);
3139           c->ext.case_list = new_case;
3140
3141           c->next = gfc_get_code ();
3142           c->next->op = EXEC_GOTO;
3143           c->next->label1 = a->label;
3144         }
3145     }
3146
3147   new_st.op = EXEC_CALL;
3148   new_st.symtree = st;
3149   new_st.ext.actual = arglist;
3150
3151   return MATCH_YES;
3152
3153 syntax:
3154   gfc_syntax_error (ST_CALL);
3155
3156 cleanup:
3157   gfc_free_actual_arglist (arglist);
3158   return MATCH_ERROR;
3159 }
3160
3161
3162 /* Given a name, return a pointer to the common head structure,
3163    creating it if it does not exist. If FROM_MODULE is nonzero, we
3164    mangle the name so that it doesn't interfere with commons defined 
3165    in the using namespace.
3166    TODO: Add to global symbol tree.  */
3167
3168 gfc_common_head *
3169 gfc_get_common (const char *name, int from_module)
3170 {
3171   gfc_symtree *st;
3172   static int serial = 0;
3173   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3174
3175   if (from_module)
3176     {
3177       /* A use associated common block is only needed to correctly layout
3178          the variables it contains.  */
3179       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3180       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3181     }
3182   else
3183     {
3184       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3185
3186       if (st == NULL)
3187         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3188     }
3189
3190   if (st->n.common == NULL)
3191     {
3192       st->n.common = gfc_get_common_head ();
3193       st->n.common->where = gfc_current_locus;
3194       strcpy (st->n.common->name, name);
3195     }
3196
3197   return st->n.common;
3198 }
3199
3200
3201 /* Match a common block name.  */
3202
3203 match match_common_name (char *name)
3204 {
3205   match m;
3206
3207   if (gfc_match_char ('/') == MATCH_NO)
3208     {
3209       name[0] = '\0';
3210       return MATCH_YES;
3211     }
3212
3213   if (gfc_match_char ('/') == MATCH_YES)
3214     {
3215       name[0] = '\0';
3216       return MATCH_YES;
3217     }
3218
3219   m = gfc_match_name (name);
3220
3221   if (m == MATCH_ERROR)
3222     return MATCH_ERROR;
3223   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3224     return MATCH_YES;
3225
3226   gfc_error ("Syntax error in common block name at %C");
3227   return MATCH_ERROR;
3228 }
3229
3230
3231 /* Match a COMMON statement.  */
3232
3233 match
3234 gfc_match_common (void)
3235 {
3236   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3237   char name[GFC_MAX_SYMBOL_LEN + 1];
3238   gfc_common_head *t;
3239   gfc_array_spec *as;
3240   gfc_equiv *e1, *e2;
3241   match m;
3242   gfc_gsymbol *gsym;
3243
3244   old_blank_common = gfc_current_ns->blank_common.head;
3245   if (old_blank_common)
3246     {
3247       while (old_blank_common->common_next)
3248         old_blank_common = old_blank_common->common_next;
3249     }
3250
3251   as = NULL;
3252
3253   for (;;)
3254     {
3255       m = match_common_name (name);
3256       if (m == MATCH_ERROR)
3257         goto cleanup;
3258
3259       gsym = gfc_get_gsymbol (name);
3260       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3261         {
3262           gfc_error ("Symbol '%s' at %C is already an external symbol that "
3263                      "is not COMMON", name);
3264           goto cleanup;
3265         }
3266
3267       if (gsym->type == GSYM_UNKNOWN)
3268         {
3269           gsym->type = GSYM_COMMON;
3270           gsym->where = gfc_current_locus;
3271           gsym->defined = 1;
3272         }
3273
3274       gsym->used = 1;
3275
3276       if (name[0] == '\0')
3277         {
3278           t = &gfc_current_ns->blank_common;
3279           if (t->head == NULL)
3280             t->where = gfc_current_locus;
3281         }
3282       else
3283         {
3284           t = gfc_get_common (name, 0);
3285         }
3286       head = &t->head;
3287
3288       if (*head == NULL)
3289         tail = NULL;
3290       else
3291         {
3292           tail = *head;
3293           while (tail->common_next)
3294             tail = tail->common_next;
3295         }
3296
3297       /* Grab the list of symbols.  */
3298       for (;;)
3299         {
3300           m = gfc_match_symbol (&sym, 0);
3301           if (m == MATCH_ERROR)
3302             goto cleanup;
3303           if (m == MATCH_NO)
3304             goto syntax;
3305
3306           /* Store a ref to the common block for error checking.  */
3307           sym->common_block = t;
3308           
3309           /* See if we know the current common block is bind(c), and if
3310              so, then see if we can check if the symbol is (which it'll
3311              need to be).  This can happen if the bind(c) attr stmt was
3312              applied to the common block, and the variable(s) already
3313              defined, before declaring the common block.  */
3314           if (t->is_bind_c == 1)
3315             {
3316               if (sym->ts.type != BT_UNKNOWN && sym->ts.is_c_interop != 1)
3317                 {
3318                   /* If we find an error, just print it and continue,
3319                      cause it's just semantic, and we can see if there
3320                      are more errors.  */
3321                   gfc_error_now ("Variable '%s' at %L in common block '%s' "
3322                                  "at %C must be declared with a C "
3323                                  "interoperable kind since common block "
3324                                  "'%s' is bind(c)",
3325                                  sym->name, &(sym->declared_at), t->name,
3326                                  t->name);
3327                 }
3328               
3329               if (sym->attr.is_bind_c == 1)
3330                 gfc_error_now ("Variable '%s' in common block "
3331                                "'%s' at %C can not be bind(c) since "
3332                                "it is not global", sym->name, t->name);
3333             }
3334           
3335           if (sym->attr.in_common)
3336             {
3337               gfc_error ("Symbol '%s' at %C is already in a COMMON block",
3338                          sym->name);
3339               goto cleanup;
3340             }
3341
3342           if (((sym->value != NULL && sym->value->expr_type != EXPR_NULL)
3343                || sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
3344             {
3345               if (gfc_notify_std (GFC_STD_GNU, "Initialized symbol '%s' at %C "
3346                                                "can only be COMMON in "
3347                                                "BLOCK DATA", sym->name)
3348                   == FAILURE)
3349                 goto cleanup;
3350             }
3351
3352           if (gfc_add_in_common (&sym->attr, sym->name, NULL) == FAILURE)
3353             goto cleanup;
3354
3355           if (tail != NULL)
3356             tail->common_next = sym;
3357           else
3358             *head = sym;
3359
3360           tail = sym;
3361
3362           /* Deal with an optional array specification after the
3363              symbol name.  */
3364           m = gfc_match_array_spec (&as);
3365           if (m == MATCH_ERROR)
3366             goto cleanup;
3367
3368           if (m == MATCH_YES)
3369             {
3370               if (as->type != AS_EXPLICIT)
3371                 {
3372                   gfc_error ("Array specification for symbol '%s' in COMMON "
3373                              "at %C must be explicit", sym->name);
3374                   goto cleanup;
3375                 }
3376
3377               if (gfc_add_dimension (&sym->attr, sym->name, NULL) == FAILURE)
3378                 goto cleanup;
3379
3380               if (sym->attr.pointer)
3381                 {
3382                   gfc_error ("Symbol '%s' in COMMON at %C cannot be a "
3383                              "POINTER array", sym->name);
3384                   goto cleanup;
3385                 }
3386
3387               sym->as = as;
3388               as = NULL;
3389
3390             }
3391
3392           sym->common_head = t;
3393
3394           /* Check to see if the symbol is already in an equivalence group.
3395              If it is, set the other members as being in common.  */
3396           if (sym->attr.in_equivalence)
3397             {
3398               for (e1 = gfc_current_ns->equiv; e1; e1 = e1->next)
3399                 {
3400                   for (e2 = e1; e2; e2 = e2->eq)
3401                     if (e2->expr->symtree->n.sym == sym)
3402                       goto equiv_found;
3403
3404                   continue;
3405
3406           equiv_found:
3407
3408                   for (e2 = e1; e2; e2 = e2->eq)
3409                     {
3410                       other = e2->expr->symtree->n.sym;
3411                       if (other->common_head
3412                           && other->common_head != sym->common_head)
3413                         {
3414                           gfc_error ("Symbol '%s', in COMMON block '%s' at "
3415                                      "%C is being indirectly equivalenced to "
3416                                      "another COMMON block '%s'",
3417                                      sym->name, sym->common_head->name,
3418                                      other->common_head->name);
3419                             goto cleanup;
3420                         }
3421                       other->attr.in_common = 1;
3422                       other->common_head = t;
3423                     }
3424                 }
3425             }
3426
3427
3428           gfc_gobble_whitespace ();
3429           if (gfc_match_eos () == MATCH_YES)
3430             goto done;
3431           if (gfc_peek_ascii_char () == '/')
3432             break;
3433           if (gfc_match_char (',') != MATCH_YES)
3434             goto syntax;
3435           gfc_gobble_whitespace ();
3436           if (gfc_peek_ascii_char () == '/')
3437             break;
3438         }
3439     }
3440
3441 done:
3442   return MATCH_YES;
3443
3444 syntax:
3445   gfc_syntax_error (ST_COMMON);
3446
3447 cleanup:
3448   if (old_blank_common)
3449     old_blank_common->common_next = NULL;
3450   else
3451     gfc_current_ns->blank_common.head = NULL;
3452   gfc_free_array_spec (as);
3453   return MATCH_ERROR;
3454 }
3455
3456
3457 /* Match a BLOCK DATA program unit.  */
3458
3459 match
3460 gfc_match_block_data (void)
3461 {
3462   char name[GFC_MAX_SYMBOL_LEN + 1];
3463   gfc_symbol *sym;
3464   match m;
3465
3466   if (gfc_match_eos () == MATCH_YES)
3467     {
3468       gfc_new_block = NULL;
3469       return MATCH_YES;
3470     }
3471
3472   m = gfc_match ("% %n%t", name);
3473   if (m != MATCH_YES)
3474     return MATCH_ERROR;
3475
3476   if (gfc_get_symbol (name, NULL, &sym))
3477     return MATCH_ERROR;
3478
3479   if (gfc_add_flavor (&sym->attr, FL_BLOCK_DATA, sym->name, NULL) == FAILURE)
3480     return MATCH_ERROR;
3481
3482   gfc_new_block = sym;
3483
3484   return MATCH_YES;
3485 }
3486
3487
3488 /* Free a namelist structure.  */
3489
3490 void
3491 gfc_free_namelist (gfc_namelist *name)
3492 {
3493   gfc_namelist *n;
3494
3495   for (; name; name = n)
3496     {
3497       n = name->next;
3498       gfc_free (name);
3499     }
3500 }
3501
3502
3503 /* Match a NAMELIST statement.  */
3504
3505 match
3506 gfc_match_namelist (void)
3507 {
3508   gfc_symbol *group_name, *sym;
3509   gfc_namelist *nl;
3510   match m, m2;
3511
3512   m = gfc_match (" / %s /", &group_name);
3513   if (m == MATCH_NO)
3514     goto syntax;
3515   if (m == MATCH_ERROR)
3516     goto error;
3517
3518   for (;;)
3519     {
3520       if (group_name->ts.type != BT_UNKNOWN)
3521         {
3522           gfc_error ("Namelist group name '%s' at %C already has a basic "
3523                      "type of %s", group_name->name,
3524                      gfc_typename (&group_name->ts));
3525           return MATCH_ERROR;
3526         }
3527
3528       if (group_name->attr.flavor == FL_NAMELIST
3529           && group_name->attr.use_assoc
3530           && gfc_notify_std (GFC_STD_GNU, "Namelist group name '%s' "
3531                              "at %C already is USE associated and can"
3532                              "not be respecified.", group_name->name)
3533              == FAILURE)
3534         return MATCH_ERROR;
3535
3536       if (group_name->attr.flavor != FL_NAMELIST
3537           && gfc_add_flavor (&group_name->attr, FL_NAMELIST,
3538                              group_name->name, NULL) == FAILURE)
3539         return MATCH_ERROR;
3540
3541       for (;;)
3542         {
3543           m = gfc_match_symbol (&sym, 1);
3544           if (m == MATCH_NO)
3545             goto syntax;
3546           if (m == MATCH_ERROR)
3547             goto error;
3548
3549           if (sym->attr.in_namelist == 0
3550               && gfc_add_in_namelist (&sym->attr, sym->name, NULL) == FAILURE)
3551             goto error;
3552
3553           /* Use gfc_error_check here, rather than goto error, so that
3554              these are the only errors for the next two lines.  */
3555           if (sym->as && sym->as->type == AS_ASSUMED_SIZE)
3556             {
3557               gfc_error ("Assumed size array '%s' in namelist '%s' at "
3558                          "%C is not allowed", sym->name, group_name->name);
3559               gfc_error_check ();
3560             }
3561
3562           if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl->length == NULL)
3563             {
3564               gfc_error ("Assumed character length '%s' in namelist '%s' at "
3565                          "%C is not allowed", sym->name, group_name->name);
3566               gfc_error_check ();
3567             }
3568
3569           nl = gfc_get_namelist ();
3570           nl->sym = sym;
3571           sym->refs++;
3572
3573           if (group_name->namelist == NULL)
3574             group_name->namelist = group_name->namelist_tail = nl;
3575           else
3576             {
3577               group_name->namelist_tail->next = nl;
3578               group_name->namelist_tail = nl;
3579             }
3580
3581           if (gfc_match_eos () == MATCH_YES)
3582             goto done;
3583
3584           m = gfc_match_char (',');
3585
3586           if (gfc_match_char ('/') == MATCH_YES)
3587             {
3588               m2 = gfc_match (" %s /", &group_name);
3589               if (m2 == MATCH_YES)
3590                 break;
3591               if (m2 == MATCH_ERROR)
3592                 goto error;
3593               goto syntax;
3594             }
3595
3596           if (m != MATCH_YES)
3597             goto syntax;
3598         }
3599     }
3600
3601 done:
3602   return MATCH_YES;
3603
3604 syntax:
3605   gfc_syntax_error (ST_NAMELIST);
3606
3607 error:
3608   return MATCH_ERROR;
3609 }
3610
3611
3612 /* Match a MODULE statement.  */
3613
3614 match
3615 gfc_match_module (void)
3616 {
3617   match m;
3618
3619   m = gfc_match (" %s%t", &gfc_new_block);
3620   if (m != MATCH_YES)
3621     return m;
3622
3623   if (gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
3624                       gfc_new_block->name, NULL) == FAILURE)
3625     return MATCH_ERROR;
3626
3627   return MATCH_YES;
3628 }
3629
3630
3631 /* Free equivalence sets and lists.  Recursively is the easiest way to
3632    do this.  */
3633
3634 void
3635 gfc_free_equiv (gfc_equiv *eq)
3636 {
3637   if (eq == NULL)
3638     return;
3639
3640   gfc_free_equiv (eq->eq);
3641   gfc_free_equiv (eq->next);
3642   gfc_free_expr (eq->expr);
3643   gfc_free (eq);
3644 }
3645
3646
3647 /* Match an EQUIVALENCE statement.  */
3648
3649 match
3650 gfc_match_equivalence (void)
3651 {
3652   gfc_equiv *eq, *set, *tail;
3653   gfc_ref *ref;
3654   gfc_symbol *sym;
3655   match m;
3656   gfc_common_head *common_head = NULL;
3657   bool common_flag;
3658   int cnt;
3659
3660   tail = NULL;
3661
3662   for (;;)
3663     {
3664       eq = gfc_get_equiv ();
3665       if (tail == NULL)
3666         tail = eq;
3667
3668       eq->next = gfc_current_ns->equiv;
3669       gfc_current_ns->equiv = eq;
3670
3671       if (gfc_match_char ('(') != MATCH_YES)
3672         goto syntax;
3673
3674       set = eq;
3675       common_flag = FALSE;
3676       cnt = 0;
3677
3678       for (;;)
3679         {
3680           m = gfc_match_equiv_variable (&set->expr);
3681           if (m == MATCH_ERROR)
3682             goto cleanup;
3683           if (m == MATCH_NO)
3684             goto syntax;
3685
3686           /*  count the number of objects.  */
3687           cnt++;
3688
3689           if (gfc_match_char ('%') == MATCH_YES)
3690             {
3691               gfc_error ("Derived type component %C is not a "
3692                          "permitted EQUIVALENCE member");
3693               goto cleanup;
3694             }
3695
3696           for (ref = set->expr->ref; ref; ref = ref->next)
3697             if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION)
3698               {
3699                 gfc_error ("Array reference in EQUIVALENCE at %C cannot "
3700                            "be an array section");
3701                 goto cleanup;
3702               }
3703
3704           sym = set->expr->symtree->n.sym;
3705
3706           if (gfc_add_in_equivalence (&sym->attr, sym->name, NULL) == FAILURE)
3707             goto cleanup;
3708
3709           if (sym->attr.in_common)
3710             {
3711               common_flag = TRUE;
3712               common_head = sym->common_head;
3713             }
3714
3715           if (gfc_match_char (')') == MATCH_YES)
3716             break;
3717
3718           if (gfc_match_char (',') != MATCH_YES)
3719             goto syntax;
3720
3721           set->eq = gfc_get_equiv ();
3722           set = set->eq;
3723         }
3724
3725       if (cnt < 2)
3726         {
3727           gfc_error ("EQUIVALENCE at %C requires two or more objects");
3728           goto cleanup;
3729         }
3730
3731       /* If one of the members of an equivalence is in common, then
3732          mark them all as being in common.  Before doing this, check
3733          that members of the equivalence group are not in different
3734          common blocks.  */
3735       if (common_flag)
3736         for (set = eq; set; set = set->eq)
3737           {
3738             sym = set->expr->symtree->n.sym;
3739             if (sym->common_head && sym->common_head != common_head)
3740               {
3741                 gfc_error ("Attempt to indirectly overlap COMMON "
3742                            "blocks %s and %s by EQUIVALENCE at %C",
3743                            sym->common_head->name, common_head->name);
3744                 goto cleanup;
3745               }
3746             sym->attr.in_common = 1;
3747             sym->common_head = common_head;
3748           }
3749
3750       if (gfc_match_eos () == MATCH_YES)
3751         break;
3752       if (gfc_match_char (',') != MATCH_YES)
3753         {
3754           gfc_error ("Expecting a comma in EQUIVALENCE at %C");
3755           goto cleanup;
3756         }
3757     }
3758
3759   return MATCH_YES;
3760
3761 syntax:
3762   gfc_syntax_error (ST_EQUIVALENCE);
3763
3764 cleanup:
3765   eq = tail->next;
3766   tail->next = NULL;
3767
3768   gfc_free_equiv (gfc_current_ns->equiv);
3769   gfc_current_ns->equiv = eq;
3770
3771   return MATCH_ERROR;
3772 }
3773
3774
3775 /* Check that a statement function is not recursive. This is done by looking
3776    for the statement function symbol(sym) by looking recursively through its
3777    expression(e).  If a reference to sym is found, true is returned.  
3778    12.5.4 requires that any variable of function that is implicitly typed
3779    shall have that type confirmed by any subsequent type declaration.  The
3780    implicit typing is conveniently done here.  */
3781 static bool
3782 recursive_stmt_fcn (gfc_expr *, gfc_symbol *);
3783
3784 static bool
3785 check_stmt_fcn (gfc_expr *e, gfc_symbol *sym, int *f ATTRIBUTE_UNUSED)
3786 {
3787
3788   if (e == NULL)
3789     return false;
3790
3791   switch (e->expr_type)
3792     {
3793     case EXPR_FUNCTION:
3794       if (e->symtree == NULL)
3795         return false;
3796
3797       /* Check the name before testing for nested recursion!  */
3798       if (sym->name == e->symtree->n.sym->name)
3799         return true;
3800
3801       /* Catch recursion via other statement functions.  */
3802       if (e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION
3803           && e->symtree->n.sym->value
3804           && recursive_stmt_fcn (e->symtree->n.sym->value, sym))
3805         return true;
3806
3807       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3808         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3809
3810       break;
3811
3812     case EXPR_VARIABLE:
3813       if (e->symtree && sym->name == e->symtree->n.sym->name)
3814         return true;
3815
3816       if (e->symtree->n.sym->ts.type == BT_UNKNOWN)
3817         gfc_set_default_type (e->symtree->n.sym, 0, NULL);
3818       break;
3819
3820     default:
3821       break;
3822     }
3823
3824   return false;
3825 }
3826
3827
3828 static bool
3829 recursive_stmt_fcn (gfc_expr *e, gfc_symbol *sym)
3830 {
3831   return gfc_traverse_expr (e, sym, check_stmt_fcn, 0);
3832 }
3833
3834
3835 /* Match a statement function declaration.  It is so easy to match
3836    non-statement function statements with a MATCH_ERROR as opposed to
3837    MATCH_NO that we suppress error message in most cases.  */
3838
3839 match
3840 gfc_match_st_function (void)
3841 {
3842   gfc_error_buf old_error;
3843   gfc_symbol *sym;
3844   gfc_expr *expr;
3845   match m;
3846
3847   m = gfc_match_symbol (&sym, 0);
3848   if (m != MATCH_YES)
3849     return m;
3850
3851   gfc_push_error (&old_error);
3852
3853   if (gfc_add_procedure (&sym->attr, PROC_ST_FUNCTION,
3854                          sym->name, NULL) == FAILURE)
3855     goto undo_error;
3856
3857   if (gfc_match_formal_arglist (sym, 1, 0) != MATCH_YES)
3858     goto undo_error;
3859
3860   m = gfc_match (" = %e%t", &expr);
3861   if (m == MATCH_NO)
3862     goto undo_error;
3863
3864   gfc_free_error (&old_error);
3865   if (m == MATCH_ERROR)
3866     return m;
3867
3868   if (recursive_stmt_fcn (expr, sym))
3869     {
3870       gfc_error ("Statement function at %L is recursive", &expr->where);
3871       return MATCH_ERROR;
3872     }
3873
3874   sym->value = expr;
3875
3876   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
3877                       "Statement function at %C") == FAILURE)
3878     return MATCH_ERROR;
3879
3880   return MATCH_YES;
3881
3882 undo_error:
3883   gfc_pop_error (&old_error);
3884   return MATCH_NO;
3885 }
3886
3887
3888 /***************** SELECT CASE subroutines ******************/
3889
3890 /* Free a single case structure.  */
3891
3892 static void
3893 free_case (gfc_case *p)
3894 {
3895   if (p->low == p->high)
3896     p->high = NULL;
3897   gfc_free_expr (p->low);
3898   gfc_free_expr (p->high);
3899   gfc_free (p);
3900 }
3901
3902
3903 /* Free a list of case structures.  */
3904
3905 void
3906 gfc_free_case_list (gfc_case *p)
3907 {
3908   gfc_case *q;
3909
3910   for (; p; p = q)
3911     {
3912       q = p->next;
3913       free_case (p);
3914     }
3915 }
3916
3917
3918 /* Match a single case selector.  */
3919
3920 static match
3921 match_case_selector (gfc_case **cp)
3922 {
3923   gfc_case *c;
3924   match m;
3925
3926   c = gfc_get_case ();
3927   c->where = gfc_current_locus;
3928
3929   if (gfc_match_char (':') == MATCH_YES)
3930     {
3931       m = gfc_match_init_expr (&c->high);
3932       if (m == MATCH_NO)
3933         goto need_expr;
3934       if (m == MATCH_ERROR)
3935         goto cleanup;
3936     }
3937   else
3938     {
3939       m = gfc_match_init_expr (&c->low);
3940       if (m == MATCH_ERROR)
3941         goto cleanup;
3942       if (m == MATCH_NO)
3943         goto need_expr;
3944
3945       /* If we're not looking at a ':' now, make a range out of a single
3946          target.  Else get the upper bound for the case range.  */
3947       if (gfc_match_char (':') != MATCH_YES)
3948         c->high = c->low;
3949       else
3950         {
3951           m = gfc_match_init_expr (&c->high);
3952           if (m == MATCH_ERROR)
3953             goto cleanup;
3954           /* MATCH_NO is fine.  It's OK if nothing is there!  */
3955         }
3956     }
3957
3958   *cp = c;
3959   return MATCH_YES;
3960
3961 need_expr:
3962   gfc_error ("Expected initialization expression in CASE at %C");
3963
3964 cleanup:
3965   free_case (c);
3966   return MATCH_ERROR;
3967 }
3968
3969
3970 /* Match the end of a case statement.  */
3971
3972 static match
3973 match_case_eos (void)
3974 {
3975   char name[GFC_MAX_SYMBOL_LEN + 1];
3976   match m;
3977
3978   if (gfc_match_eos () == MATCH_YES)
3979     return MATCH_YES;
3980
3981   /* If the case construct doesn't have a case-construct-name, we
3982      should have matched the EOS.  */
3983   if (!gfc_current_block ())
3984     return MATCH_NO;
3985
3986   gfc_gobble_whitespace ();
3987
3988   m = gfc_match_name (name);
3989   if (m != MATCH_YES)
3990     return m;
3991
3992   if (strcmp (name, gfc_current_block ()->name) != 0)
3993     {
3994       gfc_error ("Expected block name '%s' of SELECT construct at %C",
3995                  gfc_current_block ()->name);
3996       return MATCH_ERROR;
3997     }
3998
3999   return gfc_match_eos ();
4000 }
4001
4002
4003 /* Match a SELECT statement.  */
4004
4005 match
4006 gfc_match_select (void)
4007 {
4008   gfc_expr *expr;
4009   match m;
4010
4011   m = gfc_match_label ();
4012   if (m == MATCH_ERROR)
4013     return m;
4014
4015   m = gfc_match (" select case ( %e )%t", &expr);
4016   if (m != MATCH_YES)
4017     return m;
4018
4019   new_st.op = EXEC_SELECT;
4020   new_st.expr1 = expr;
4021
4022   return MATCH_YES;
4023 }
4024
4025
4026 /* Push the current selector onto the SELECT TYPE stack.  */
4027
4028 static void
4029 select_type_push (gfc_symbol *sel)
4030 {
4031   gfc_select_type_stack *top = gfc_get_select_type_stack ();
4032   top->selector = sel;
4033   top->tmp = NULL;
4034   top->prev = select_type_stack;
4035
4036   select_type_stack = top;
4037 }
4038
4039
4040 /* Set the temporary for the current SELECT TYPE selector.  */
4041
4042 static void
4043 select_type_set_tmp (gfc_typespec *ts)
4044 {
4045   char name[GFC_MAX_SYMBOL_LEN];
4046   gfc_symtree *tmp;
4047
4048   sprintf (name, "tmp$%s", ts->u.derived->name);
4049   gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
4050   gfc_add_type (tmp->n.sym, ts, NULL);
4051   gfc_set_sym_referenced (tmp->n.sym);
4052   gfc_add_pointer (&tmp->n.sym->attr, NULL);
4053   gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
4054
4055   select_type_stack->tmp = tmp;
4056 }
4057
4058
4059 /* Match a SELECT TYPE statement.  */
4060
4061 match
4062 gfc_match_select_type (void)
4063 {
4064   gfc_expr *expr1, *expr2 = NULL;
4065   match m;
4066   char name[GFC_MAX_SYMBOL_LEN];
4067
4068   m = gfc_match_label ();
4069   if (m == MATCH_ERROR)
4070     return m;
4071
4072   m = gfc_match (" select type ( ");
4073   if (m != MATCH_YES)
4074     return m;
4075
4076   gfc_current_ns = gfc_build_block_ns (gfc_current_ns);
4077
4078   m = gfc_match (" %n => %e", name, &expr2);
4079   if (m == MATCH_YES)
4080     {
4081       expr1 = gfc_get_expr();
4082       expr1->expr_type = EXPR_VARIABLE;
4083       if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
4084         return MATCH_ERROR;
4085       expr1->symtree->n.sym->ts = expr2->ts;
4086       expr1->symtree->n.sym->attr.referenced = 1;
4087       expr1->symtree->n.sym->attr.class_ok = 1;
4088     }
4089   else
4090     {
4091       m = gfc_match (" %e ", &expr1);
4092       if (m != MATCH_YES)
4093         return m;
4094     }
4095
4096   m = gfc_match (" )%t");
4097   if (m != MATCH_YES)
4098     return m;
4099
4100   /* Check for F03:C811.  */
4101   if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL))
4102     {
4103       gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
4104                  "use associate-name=>");
4105       return MATCH_ERROR;
4106     }
4107
4108   /* Check for F03:C813.  */
4109   if (expr1->ts.type != BT_CLASS && !(expr2 && expr2->ts.type == BT_CLASS))
4110     {
4111       gfc_error ("Selector shall be polymorphic in SELECT TYPE statement "
4112                  "at %C");
4113       return MATCH_ERROR;
4114     }
4115
4116   new_st.op = EXEC_SELECT_TYPE;
4117   new_st.expr1 = expr1;
4118   new_st.expr2 = expr2;
4119   new_st.ext.ns = gfc_current_ns;
4120
4121   select_type_push (expr1->symtree->n.sym);
4122
4123   return MATCH_YES;
4124 }
4125
4126
4127 /* Match a CASE statement.  */
4128
4129 match
4130 gfc_match_case (void)
4131 {
4132   gfc_case *c, *head, *tail;
4133   match m;
4134
4135   head = tail = NULL;
4136
4137   if (gfc_current_state () != COMP_SELECT)
4138     {
4139       gfc_error ("Unexpected CASE statement at %C");
4140       return MATCH_ERROR;
4141     }
4142
4143   if (gfc_match ("% default") == MATCH_YES)
4144     {
4145       m = match_case_eos ();
4146       if (m == MATCH_NO)
4147         goto syntax;
4148       if (m == MATCH_ERROR)
4149         goto cleanup;
4150
4151       new_st.op = EXEC_SELECT;
4152       c = gfc_get_case ();
4153       c->where = gfc_current_locus;
4154       new_st.ext.case_list = c;
4155       return MATCH_YES;
4156     }
4157
4158   if (gfc_match_char ('(') != MATCH_YES)
4159     goto syntax;
4160
4161   for (;;)
4162     {
4163       if (match_case_selector (&c) == MATCH_ERROR)
4164         goto cleanup;
4165
4166       if (head == NULL)
4167         head = c;
4168       else
4169         tail->next = c;
4170
4171       tail = c;
4172
4173       if (gfc_match_char (')') == MATCH_YES)
4174         break;
4175       if (gfc_match_char (',') != MATCH_YES)
4176         goto syntax;
4177     }
4178
4179   m = match_case_eos ();
4180   if (m == MATCH_NO)
4181     goto syntax;
4182   if (m == MATCH_ERROR)
4183     goto cleanup;
4184
4185   new_st.op = EXEC_SELECT;
4186   new_st.ext.case_list = head;
4187
4188   return MATCH_YES;
4189
4190 syntax:
4191   gfc_error ("Syntax error in CASE specification at %C");
4192
4193 cleanup:
4194   gfc_free_case_list (head);  /* new_st is cleaned up in parse.c.  */
4195   return MATCH_ERROR;
4196 }
4197
4198
4199 /* Match a TYPE IS statement.  */
4200
4201 match
4202 gfc_match_type_is (void)
4203 {
4204   gfc_case *c = NULL;
4205   match m;
4206
4207   if (gfc_current_state () != COMP_SELECT_TYPE)
4208     {
4209       gfc_error ("Unexpected TYPE IS statement at %C");
4210       return MATCH_ERROR;
4211     }
4212
4213   if (gfc_match_char ('(') != MATCH_YES)
4214     goto syntax;
4215
4216   c = gfc_get_case ();
4217   c->where = gfc_current_locus;
4218
4219   /* TODO: Once unlimited polymorphism is implemented, we will need to call
4220      match_type_spec here.  */
4221   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4222     goto cleanup;
4223
4224   if (gfc_match_char (')') != MATCH_YES)
4225     goto syntax;
4226
4227   m = match_case_eos ();
4228   if (m == MATCH_NO)
4229     goto syntax;
4230   if (m == MATCH_ERROR)
4231     goto cleanup;
4232
4233   new_st.op = EXEC_SELECT_TYPE;
4234   new_st.ext.case_list = c;
4235
4236   /* Create temporary variable.  */
4237   select_type_set_tmp (&c->ts);
4238
4239   return MATCH_YES;
4240
4241 syntax:
4242   gfc_error ("Syntax error in TYPE IS specification at %C");
4243
4244 cleanup:
4245   if (c != NULL)
4246     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4247   return MATCH_ERROR;
4248 }
4249
4250
4251 /* Match a CLASS IS or CLASS DEFAULT statement.  */
4252
4253 match
4254 gfc_match_class_is (void)
4255 {
4256   gfc_case *c = NULL;
4257   match m;
4258
4259   if (gfc_current_state () != COMP_SELECT_TYPE)
4260     return MATCH_NO;
4261
4262   if (gfc_match ("% default") == MATCH_YES)
4263     {
4264       m = match_case_eos ();
4265       if (m == MATCH_NO)
4266         goto syntax;
4267       if (m == MATCH_ERROR)
4268         goto cleanup;
4269
4270       new_st.op = EXEC_SELECT_TYPE;
4271       c = gfc_get_case ();
4272       c->where = gfc_current_locus;
4273       c->ts.type = BT_UNKNOWN;
4274       new_st.ext.case_list = c;
4275       return MATCH_YES;
4276     }
4277
4278   m = gfc_match ("% is");
4279   if (m == MATCH_NO)
4280     goto syntax;
4281   if (m == MATCH_ERROR)
4282     goto cleanup;
4283
4284   if (gfc_match_char ('(') != MATCH_YES)
4285     goto syntax;
4286
4287   c = gfc_get_case ();
4288   c->where = gfc_current_locus;
4289
4290   if (match_derived_type_spec (&c->ts) == MATCH_ERROR)
4291     goto cleanup;
4292
4293   if (c->ts.type == BT_DERIVED)
4294     c->ts.type = BT_CLASS;
4295
4296   if (gfc_match_char (')') != MATCH_YES)
4297     goto syntax;
4298
4299   m = match_case_eos ();
4300   if (m == MATCH_NO)
4301     goto syntax;
4302   if (m == MATCH_ERROR)
4303     goto cleanup;
4304
4305   new_st.op = EXEC_SELECT_TYPE;
4306   new_st.ext.case_list = c;
4307
4308   gfc_error_now ("CLASS IS specification at %C is not yet supported");
4309
4310   return MATCH_YES;
4311
4312 syntax:
4313   gfc_error ("Syntax error in CLASS IS specification at %C");
4314
4315 cleanup:
4316   if (c != NULL)
4317     gfc_free_case_list (c);  /* new_st is cleaned up in parse.c.  */
4318   return MATCH_ERROR;
4319 }
4320
4321
4322 /********************* WHERE subroutines ********************/
4323
4324 /* Match the rest of a simple WHERE statement that follows an IF statement.  
4325  */
4326
4327 static match
4328 match_simple_where (void)
4329 {
4330   gfc_expr *expr;
4331   gfc_code *c;
4332   match m;
4333
4334   m = gfc_match (" ( %e )", &expr);
4335   if (m != MATCH_YES)
4336     return m;
4337
4338   m = gfc_match_assignment ();
4339   if (m == MATCH_NO)
4340     goto syntax;
4341   if (m == MATCH_ERROR)
4342     goto cleanup;
4343
4344   if (gfc_match_eos () != MATCH_YES)
4345     goto syntax;
4346
4347   c = gfc_get_code ();
4348
4349   c->op = EXEC_WHERE;
4350   c->expr1 = expr;
4351   c->next = gfc_get_code ();
4352
4353   *c->next = new_st;
4354   gfc_clear_new_st ();
4355
4356   new_st.op = EXEC_WHERE;
4357   new_st.block = c;
4358
4359   return MATCH_YES;
4360
4361 syntax:
4362   gfc_syntax_error (ST_WHERE);
4363
4364 cleanup:
4365   gfc_free_expr (expr);
4366   return MATCH_ERROR;
4367 }
4368
4369
4370 /* Match a WHERE statement.  */
4371
4372 match
4373 gfc_match_where (gfc_statement *st)
4374 {
4375   gfc_expr *expr;
4376   match m0, m;
4377   gfc_code *c;
4378
4379   m0 = gfc_match_label ();
4380   if (m0 == MATCH_ERROR)
4381     return m0;
4382
4383   m = gfc_match (" where ( %e )", &expr);
4384   if (m != MATCH_YES)
4385     return m;
4386
4387   if (gfc_match_eos () == MATCH_YES)
4388     {
4389       *st = ST_WHERE_BLOCK;
4390       new_st.op = EXEC_WHERE;
4391       new_st.expr1 = expr;
4392       return MATCH_YES;
4393     }
4394
4395   m = gfc_match_assignment ();
4396   if (m == MATCH_NO)
4397     gfc_syntax_error (ST_WHERE);
4398
4399   if (m != MATCH_YES)
4400     {
4401       gfc_free_expr (expr);
4402       return MATCH_ERROR;
4403     }
4404
4405   /* We've got a simple WHERE statement.  */
4406   *st = ST_WHERE;
4407   c = gfc_get_code ();
4408
4409   c->op = EXEC_WHERE;
4410   c->expr1 = expr;
4411   c->next = gfc_get_code ();
4412
4413   *c->next = new_st;
4414   gfc_clear_new_st ();
4415
4416   new_st.op = EXEC_WHERE;
4417   new_st.block = c;
4418
4419   return MATCH_YES;
4420 }
4421
4422
4423 /* Match an ELSEWHERE statement.  We leave behind a WHERE node in
4424    new_st if successful.  */
4425
4426 match
4427 gfc_match_elsewhere (void)
4428 {
4429   char name[GFC_MAX_SYMBOL_LEN + 1];
4430   gfc_expr *expr;
4431   match m;
4432
4433   if (gfc_current_state () != COMP_WHERE)
4434     {
4435       gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
4436       return MATCH_ERROR;
4437     }
4438
4439   expr = NULL;
4440
4441   if (gfc_match_char ('(') == MATCH_YES)
4442     {
4443       m = gfc_match_expr (&expr);
4444       if (m == MATCH_NO)
4445         goto syntax;
4446       if (m == MATCH_ERROR)
4447         return MATCH_ERROR;
4448
4449       if (gfc_match_char (')') != MATCH_YES)
4450         goto syntax;
4451     }
4452
4453   if (gfc_match_eos () != MATCH_YES)
4454     {
4455       /* Only makes sense if we have a where-construct-name.  */
4456       if (!gfc_current_block ())
4457         {
4458           m = MATCH_ERROR;
4459           goto cleanup;
4460         }
4461       /* Better be a name at this point.  */
4462       m = gfc_match_name (name);
4463       if (m == MATCH_NO)
4464         goto syntax;
4465       if (m == MATCH_ERROR)
4466         goto cleanup;
4467
4468       if (gfc_match_eos () != MATCH_YES)
4469         goto syntax;
4470
4471       if (strcmp (name, gfc_current_block ()->name) != 0)
4472         {
4473           gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
4474                      name, gfc_current_block ()->name);
4475           goto cleanup;
4476         }
4477     }
4478
4479   new_st.op = EXEC_WHERE;
4480   new_st.expr1 = expr;
4481   return MATCH_YES;
4482
4483 syntax:
4484   gfc_syntax_error (ST_ELSEWHERE);
4485
4486 cleanup:
4487   gfc_free_expr (expr);
4488   return MATCH_ERROR;
4489 }
4490
4491
4492 /******************** FORALL subroutines ********************/
4493
4494 /* Free a list of FORALL iterators.  */
4495
4496 void
4497 gfc_free_forall_iterator (gfc_forall_iterator *iter)
4498 {
4499   gfc_forall_iterator *next;
4500
4501   while (iter)
4502     {
4503       next = iter->next;
4504       gfc_free_expr (iter->var);
4505       gfc_free_expr (iter->start);
4506       gfc_free_expr (iter->end);
4507       gfc_free_expr (iter->stride);
4508       gfc_free (iter);
4509       iter = next;
4510     }
4511 }
4512
4513
4514 /* Match an iterator as part of a FORALL statement.  The format is:
4515
4516      <var> = <start>:<end>[:<stride>]
4517
4518    On MATCH_NO, the caller tests for the possibility that there is a
4519    scalar mask expression.  */
4520
4521 static match
4522 match_forall_iterator (gfc_forall_iterator **result)
4523 {
4524   gfc_forall_iterator *iter;
4525   locus where;
4526   match m;
4527
4528   where = gfc_current_locus;
4529   iter = XCNEW (gfc_forall_iterator);
4530
4531   m = gfc_match_expr (&iter->var);
4532   if (m != MATCH_YES)
4533     goto cleanup;
4534
4535   if (gfc_match_char ('=') != MATCH_YES
4536       || iter->var->expr_type != EXPR_VARIABLE)
4537     {
4538       m = MATCH_NO;
4539       goto cleanup;
4540     }
4541
4542   m = gfc_match_expr (&iter->start);
4543   if (m != MATCH_YES)
4544     goto cleanup;
4545
4546   if (gfc_match_char (':') != MATCH_YES)
4547     goto syntax;
4548
4549   m = gfc_match_expr (&iter->end);
4550   if (m == MATCH_NO)
4551     goto syntax;
4552   if (m == MATCH_ERROR)
4553     goto cleanup;
4554
4555   if (gfc_match_char (':') == MATCH_NO)
4556     iter->stride = gfc_int_expr (1);
4557   else
4558     {
4559       m = gfc_match_expr (&iter->stride);
4560       if (m == MATCH_NO)
4561         goto syntax;
4562       if (m == MATCH_ERROR)
4563         goto cleanup;
4564     }
4565
4566   /* Mark the iteration variable's symbol as used as a FORALL index.  */
4567   iter->var->symtree->n.sym->forall_index = true;
4568
4569   *result = iter;
4570   return MATCH_YES;
4571
4572 syntax:
4573   gfc_error ("Syntax error in FORALL iterator at %C");
4574   m = MATCH_ERROR;
4575
4576 cleanup:
4577
4578   gfc_current_locus = where;
4579   gfc_free_forall_iterator (iter);
4580   return m;
4581 }
4582
4583
4584 /* Match the header of a FORALL statement.  */
4585
4586 static match
4587 match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask)
4588 {
4589   gfc_forall_iterator *head, *tail, *new_iter;
4590   gfc_expr *msk;
4591   match m;
4592
4593   gfc_gobble_whitespace ();
4594
4595   head = tail = NULL;
4596   msk = NULL;
4597
4598   if (gfc_match_char ('(') != MATCH_YES)
4599     return MATCH_NO;
4600
4601   m = match_forall_iterator (&new_iter);
4602   if (m == MATCH_ERROR)
4603     goto cleanup;
4604   if (m == MATCH_NO)
4605     goto syntax;
4606
4607   head = tail = new_iter;
4608
4609   for (;;)
4610     {
4611       if (gfc_match_char (',') != MATCH_YES)
4612         break;
4613
4614       m = match_forall_iterator (&new_iter);
4615       if (m == MATCH_ERROR)
4616         goto cleanup;
4617
4618       if (m == MATCH_YES)
4619         {
4620           tail->next = new_iter;
4621           tail = new_iter;
4622           continue;
4623         }
4624
4625       /* Have to have a mask expression.  */
4626
4627       m = gfc_match_expr (&msk);
4628       if (m == MATCH_NO)
4629         goto syntax;
4630       if (m == MATCH_ERROR)
4631         goto cleanup;
4632
4633       break;
4634     }
4635
4636   if (gfc_match_char (')') == MATCH_NO)
4637     goto syntax;
4638
4639   *phead = head;
4640   *mask = msk;
4641   return MATCH_YES;
4642
4643 syntax:
4644   gfc_syntax_error (ST_FORALL);
4645
4646 cleanup:
4647   gfc_free_expr (msk);
4648   gfc_free_forall_iterator (head);
4649
4650   return MATCH_ERROR;
4651 }
4652
4653 /* Match the rest of a simple FORALL statement that follows an 
4654    IF statement.  */
4655
4656 static match
4657 match_simple_forall (void)
4658 {
4659   gfc_forall_iterator *head;
4660   gfc_expr *mask;
4661   gfc_code *c;
4662   match m;
4663
4664   mask = NULL;
4665   head = NULL;
4666   c = NULL;
4667
4668   m = match_forall_header (&head, &mask);
4669
4670   if (m == MATCH_NO)
4671     goto syntax;
4672   if (m != MATCH_YES)
4673     goto cleanup;
4674
4675   m = gfc_match_assignment ();
4676
4677   if (m == MATCH_ERROR)
4678     goto cleanup;
4679   if (m == MATCH_NO)
4680     {
4681       m = gfc_match_pointer_assignment ();
4682       if (m == MATCH_ERROR)
4683         goto cleanup;
4684       if (m == MATCH_NO)
4685         goto syntax;
4686     }
4687
4688   c = gfc_get_code ();
4689   *c = new_st;
4690   c->loc = gfc_current_locus;
4691
4692   if (gfc_match_eos () != MATCH_YES)
4693     goto syntax;
4694
4695   gfc_clear_new_st ();
4696   new_st.op = EXEC_FORALL;
4697   new_st.expr1 = mask;
4698   new_st.ext.forall_iterator = head;
4699   new_st.block = gfc_get_code ();
4700
4701   new_st.block->op = EXEC_FORALL;
4702   new_st.block->next = c;
4703
4704   return MATCH_YES;
4705
4706 syntax:
4707   gfc_syntax_error (ST_FORALL);
4708
4709 cleanup:
4710   gfc_free_forall_iterator (head);
4711   gfc_free_expr (mask);
4712
4713   return MATCH_ERROR;
4714 }
4715
4716
4717 /* Match a FORALL statement.  */
4718
4719 match
4720 gfc_match_forall (gfc_statement *st)
4721 {
4722   gfc_forall_iterator *head;
4723   gfc_expr *mask;
4724   gfc_code *c;
4725   match m0, m;
4726
4727   head = NULL;
4728   mask = NULL;
4729   c = NULL;
4730
4731   m0 = gfc_match_label ();
4732   if (m0 == MATCH_ERROR)
4733     return MATCH_ERROR;
4734
4735   m = gfc_match (" forall");
4736   if (m != MATCH_YES)
4737     return m;
4738
4739   m = match_forall_header (&head, &mask);
4740   if (m == MATCH_ERROR)
4741     goto cleanup;
4742   if (m == MATCH_NO)
4743     goto syntax;
4744
4745   if (gfc_match_eos () == MATCH_YES)
4746     {
4747       *st = ST_FORALL_BLOCK;
4748       new_st.op = EXEC_FORALL;
4749       new_st.expr1 = mask;
4750       new_st.ext.forall_iterator = head;
4751       return MATCH_YES;
4752     }
4753
4754   m = gfc_match_assignment ();
4755   if (m == MATCH_ERROR)
4756     goto cleanup;
4757   if (m == MATCH_NO)
4758     {
4759       m = gfc_match_pointer_assignment ();
4760       if (m == MATCH_ERROR)
4761         goto cleanup;
4762       if (m == MATCH_NO)
4763         goto syntax;
4764     }
4765
4766   c = gfc_get_code ();
4767   *c = new_st;
4768   c->loc = gfc_current_locus;
4769
4770   gfc_clear_new_st ();
4771   new_st.op = EXEC_FORALL;
4772   new_st.expr1 = mask;
4773   new_st.ext.forall_iterator = head;
4774   new_st.block = gfc_get_code ();
4775   new_st.block->op = EXEC_FORALL;
4776   new_st.block->next = c;
4777
4778   *st = ST_FORALL;
4779   return MATCH_YES;
4780
4781 syntax:
4782   gfc_syntax_error (ST_FORALL);
4783
4784 cleanup:
4785   gfc_free_forall_iterator (head);
4786   gfc_free_expr (mask);
4787   gfc_free_statements (c);
4788   return MATCH_NO;
4789 }