OSDN Git Service

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