OSDN Git Service

2010-12-11 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / gcc / fortran / match.c
1 /* Matching subroutines in all sizes, shapes and colors.
2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
3    2009, 2010
4    2010 Free Software Foundation, Inc.
5    Contributed by Andy Vaught
6
7 This file is part of GCC.
8
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
12 version.
13
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
17 for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3.  If not see
21 <http://www.gnu.org/licenses/>.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "match.h"
28 #include "parse.h"
29
30 int gfc_matching_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_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C")
1750       == FAILURE)
1751     return MATCH_ERROR;
1752
1753   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
1754     {
1755        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
1756        return MATCH_ERROR;
1757     }
1758
1759   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
1760     {
1761       gfc_error ("Nested CRITICAL block at %C");
1762       return MATCH_ERROR;
1763     }
1764
1765   new_st.op = EXEC_CRITICAL;
1766
1767   if (label != NULL
1768       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1769     return MATCH_ERROR;
1770
1771   return MATCH_YES;
1772 }
1773
1774
1775 /* Match a BLOCK statement.  */
1776
1777 match
1778 gfc_match_block (void)
1779 {
1780   match m;
1781
1782   if (gfc_match_label () == MATCH_ERROR)
1783     return MATCH_ERROR;
1784
1785   if (gfc_match (" block") != MATCH_YES)
1786     return MATCH_NO;
1787
1788   /* For this to be a correct BLOCK statement, the line must end now.  */
1789   m = gfc_match_eos ();
1790   if (m == MATCH_ERROR)
1791     return MATCH_ERROR;
1792   if (m == MATCH_NO)
1793     return MATCH_NO;
1794
1795   return MATCH_YES;
1796 }
1797
1798
1799 /* Match an ASSOCIATE statement.  */
1800
1801 match
1802 gfc_match_associate (void)
1803 {
1804   if (gfc_match_label () == MATCH_ERROR)
1805     return MATCH_ERROR;
1806
1807   if (gfc_match (" associate") != MATCH_YES)
1808     return MATCH_NO;
1809
1810   /* Match the association list.  */
1811   if (gfc_match_char ('(') != MATCH_YES)
1812     {
1813       gfc_error ("Expected association list at %C");
1814       return MATCH_ERROR;
1815     }
1816   new_st.ext.block.assoc = NULL;
1817   while (true)
1818     {
1819       gfc_association_list* newAssoc = gfc_get_association_list ();
1820       gfc_association_list* a;
1821
1822       /* Match the next association.  */
1823       if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
1824             != MATCH_YES)
1825         {
1826           gfc_error ("Expected association at %C");
1827           goto assocListError;
1828         }
1829       newAssoc->where = gfc_current_locus;
1830
1831       /* Check that the current name is not yet in the list.  */
1832       for (a = new_st.ext.block.assoc; a; a = a->next)
1833         if (!strcmp (a->name, newAssoc->name))
1834           {
1835             gfc_error ("Duplicate name '%s' in association at %C",
1836                        newAssoc->name);
1837             goto assocListError;
1838           }
1839
1840       /* The target expression must not be coindexed.  */
1841       if (gfc_is_coindexed (newAssoc->target))
1842         {
1843           gfc_error ("Association target at %C must not be coindexed");
1844           goto assocListError;
1845         }
1846
1847       /* The `variable' field is left blank for now; because the target is not
1848          yet resolved, we can't use gfc_has_vector_subscript to determine it
1849          for now.  This is set during resolution.  */
1850
1851       /* Put it into the list.  */
1852       newAssoc->next = new_st.ext.block.assoc;
1853       new_st.ext.block.assoc = newAssoc;
1854
1855       /* Try next one or end if closing parenthesis is found.  */
1856       gfc_gobble_whitespace ();
1857       if (gfc_peek_char () == ')')
1858         break;
1859       if (gfc_match_char (',') != MATCH_YES)
1860         {
1861           gfc_error ("Expected ')' or ',' at %C");
1862           return MATCH_ERROR;
1863         }
1864
1865       continue;
1866
1867 assocListError:
1868       gfc_free (newAssoc);
1869       goto error;
1870     }
1871   if (gfc_match_char (')') != MATCH_YES)
1872     {
1873       /* This should never happen as we peek above.  */
1874       gcc_unreachable ();
1875     }
1876
1877   if (gfc_match_eos () != MATCH_YES)
1878     {
1879       gfc_error ("Junk after ASSOCIATE statement at %C");
1880       goto error;
1881     }
1882
1883   return MATCH_YES;
1884
1885 error:
1886   gfc_free_association_list (new_st.ext.block.assoc);
1887   return MATCH_ERROR;
1888 }
1889
1890
1891 /* Match a DO statement.  */
1892
1893 match
1894 gfc_match_do (void)
1895 {
1896   gfc_iterator iter, *ip;
1897   locus old_loc;
1898   gfc_st_label *label;
1899   match m;
1900
1901   old_loc = gfc_current_locus;
1902
1903   label = NULL;
1904   iter.var = iter.start = iter.end = iter.step = NULL;
1905
1906   m = gfc_match_label ();
1907   if (m == MATCH_ERROR)
1908     return m;
1909
1910   if (gfc_match (" do") != MATCH_YES)
1911     return MATCH_NO;
1912
1913   m = gfc_match_st_label (&label);
1914   if (m == MATCH_ERROR)
1915     goto cleanup;
1916
1917   /* Match an infinite DO, make it like a DO WHILE(.TRUE.).  */
1918
1919   if (gfc_match_eos () == MATCH_YES)
1920     {
1921       iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
1922       new_st.op = EXEC_DO_WHILE;
1923       goto done;
1924     }
1925
1926   /* Match an optional comma, if no comma is found, a space is obligatory.  */
1927   if (gfc_match_char (',') != MATCH_YES && gfc_match ("% ") != MATCH_YES)
1928     return MATCH_NO;
1929
1930   /* Check for balanced parens.  */
1931   
1932   if (gfc_match_parens () == MATCH_ERROR)
1933     return MATCH_ERROR;
1934
1935   /* See if we have a DO WHILE.  */
1936   if (gfc_match (" while ( %e )%t", &iter.end) == MATCH_YES)
1937     {
1938       new_st.op = EXEC_DO_WHILE;
1939       goto done;
1940     }
1941
1942   /* The abortive DO WHILE may have done something to the symbol
1943      table, so we start over.  */
1944   gfc_undo_symbols ();
1945   gfc_current_locus = old_loc;
1946
1947   gfc_match_label ();           /* This won't error.  */
1948   gfc_match (" do ");           /* This will work.  */
1949
1950   gfc_match_st_label (&label);  /* Can't error out.  */
1951   gfc_match_char (',');         /* Optional comma.  */
1952
1953   m = gfc_match_iterator (&iter, 0);
1954   if (m == MATCH_NO)
1955     return MATCH_NO;
1956   if (m == MATCH_ERROR)
1957     goto cleanup;
1958
1959   iter.var->symtree->n.sym->attr.implied_index = 0;
1960   gfc_check_do_variable (iter.var->symtree);
1961
1962   if (gfc_match_eos () != MATCH_YES)
1963     {
1964       gfc_syntax_error (ST_DO);
1965       goto cleanup;
1966     }
1967
1968   new_st.op = EXEC_DO;
1969
1970 done:
1971   if (label != NULL
1972       && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
1973     goto cleanup;
1974
1975   new_st.label1 = label;
1976
1977   if (new_st.op == EXEC_DO_WHILE)
1978     new_st.expr1 = iter.end;
1979   else
1980     {
1981       new_st.ext.iterator = ip = gfc_get_iterator ();
1982       *ip = iter;
1983     }
1984
1985   return MATCH_YES;
1986
1987 cleanup:
1988   gfc_free_iterator (&iter, 0);
1989
1990   return MATCH_ERROR;
1991 }
1992
1993
1994 /* Match an EXIT or CYCLE statement.  */
1995
1996 static match
1997 match_exit_cycle (gfc_statement st, gfc_exec_op op)
1998 {
1999   gfc_state_data *p, *o;
2000   gfc_symbol *sym;
2001   match m;
2002   int cnt;
2003
2004   if (gfc_match_eos () == MATCH_YES)
2005     sym = NULL;
2006   else
2007     {
2008       char name[GFC_MAX_SYMBOL_LEN + 1];
2009       gfc_symtree* stree;
2010
2011       m = gfc_match ("% %n%t", name);
2012       if (m == MATCH_ERROR)
2013         return MATCH_ERROR;
2014       if (m == MATCH_NO)
2015         {
2016           gfc_syntax_error (st);
2017           return MATCH_ERROR;
2018         }
2019
2020       /* Find the corresponding symbol.  If there's a BLOCK statement
2021          between here and the label, it is not in gfc_current_ns but a parent
2022          namespace!  */
2023       stree = gfc_find_symtree_in_proc (name, gfc_current_ns);
2024       if (!stree)
2025         {
2026           gfc_error ("Name '%s' in %s statement at %C is unknown",
2027                      name, gfc_ascii_statement (st));
2028           return MATCH_ERROR;
2029         }
2030
2031       sym = stree->n.sym;
2032       if (sym->attr.flavor != FL_LABEL)
2033         {
2034           gfc_error ("Name '%s' in %s statement at %C is not a construct name",
2035                      name, gfc_ascii_statement (st));
2036           return MATCH_ERROR;
2037         }
2038     }
2039
2040   /* Find the loop specified by the label (or lack of a label).  */
2041   for (o = NULL, p = gfc_state_stack; p; p = p->previous)
2042     if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK)
2043       o = p;
2044     else if (p->state == COMP_CRITICAL)
2045       {
2046         gfc_error("%s statement at %C leaves CRITICAL construct",
2047                   gfc_ascii_statement (st));
2048         return MATCH_ERROR;
2049       }
2050     else if ((sym && sym == p->sym) || (!sym && p->state == COMP_DO))
2051       break;
2052
2053   if (p == NULL)
2054     {
2055       if (sym == NULL)
2056         gfc_error ("%s statement at %C is not within a construct",
2057                    gfc_ascii_statement (st));
2058       else
2059         gfc_error ("%s statement at %C is not within construct '%s'",
2060                    gfc_ascii_statement (st), sym->name);
2061
2062       return MATCH_ERROR;
2063     }
2064
2065   /* Special checks for EXIT from non-loop constructs.  */
2066   switch (p->state)
2067     {
2068     case COMP_DO:
2069       break;
2070
2071     case COMP_CRITICAL:
2072       /* This is already handled above.  */
2073       gcc_unreachable ();
2074
2075     case COMP_ASSOCIATE:
2076     case COMP_BLOCK:
2077     case COMP_IF:
2078     case COMP_SELECT:
2079     case COMP_SELECT_TYPE:
2080       gcc_assert (sym);
2081       if (op == EXEC_CYCLE)
2082         {
2083           gfc_error ("CYCLE statement at %C is not applicable to non-loop"
2084                      " construct '%s'", sym->name);
2085           return MATCH_ERROR;
2086         }
2087       gcc_assert (op == EXEC_EXIT);
2088       if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: EXIT statement with no"
2089                           " do-construct-name at %C") == FAILURE)
2090         return MATCH_ERROR;
2091       break;
2092       
2093     default:
2094       gfc_error ("%s statement at %C is not applicable to construct '%s'",
2095                  gfc_ascii_statement (st), sym->name);
2096       return MATCH_ERROR;
2097     }
2098
2099   if (o != NULL)
2100     {
2101       gfc_error ("%s statement at %C leaving OpenMP structured block",
2102                  gfc_ascii_statement (st));
2103       return MATCH_ERROR;
2104     }
2105
2106   for (o = p, cnt = 0; o->state == COMP_DO && o->previous != NULL; cnt++)
2107     o = o->previous;
2108   if (cnt > 0
2109       && o != NULL
2110       && o->state == COMP_OMP_STRUCTURED_BLOCK
2111       && (o->head->op == EXEC_OMP_DO
2112           || o->head->op == EXEC_OMP_PARALLEL_DO))
2113     {
2114       int collapse = 1;
2115       gcc_assert (o->head->next != NULL
2116                   && (o->head->next->op == EXEC_DO
2117                       || o->head->next->op == EXEC_DO_WHILE)
2118                   && o->previous != NULL
2119                   && o->previous->tail->op == o->head->op);
2120       if (o->previous->tail->ext.omp_clauses != NULL
2121           && o->previous->tail->ext.omp_clauses->collapse > 1)
2122         collapse = o->previous->tail->ext.omp_clauses->collapse;
2123       if (st == ST_EXIT && cnt <= collapse)
2124         {
2125           gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
2126           return MATCH_ERROR;
2127         }
2128       if (st == ST_CYCLE && cnt < collapse)
2129         {
2130           gfc_error ("CYCLE statement at %C to non-innermost collapsed"
2131                      " !$OMP DO loop");
2132           return MATCH_ERROR;
2133         }
2134     }
2135
2136   /* Save the first statement in the construct - needed by the backend.  */
2137   new_st.ext.which_construct = p->construct;
2138
2139   new_st.op = op;
2140
2141   return MATCH_YES;
2142 }
2143
2144
2145 /* Match the EXIT statement.  */
2146
2147 match
2148 gfc_match_exit (void)
2149 {
2150   return match_exit_cycle (ST_EXIT, EXEC_EXIT);
2151 }
2152
2153
2154 /* Match the CYCLE statement.  */
2155
2156 match
2157 gfc_match_cycle (void)
2158 {
2159   return match_exit_cycle (ST_CYCLE, EXEC_CYCLE);
2160 }
2161
2162
2163 /* Match a number or character constant after an (ALL) STOP or PAUSE statement.  */
2164
2165 static match
2166 gfc_match_stopcode (gfc_statement st)
2167 {
2168   gfc_expr *e;
2169   match m;
2170
2171   e = NULL;
2172
2173   if (gfc_match_eos () != MATCH_YES)
2174     {
2175       m = gfc_match_init_expr (&e);
2176       if (m == MATCH_ERROR)
2177         goto cleanup;
2178       if (m == MATCH_NO)
2179         goto syntax;
2180
2181       if (gfc_match_eos () != MATCH_YES)
2182         goto syntax;
2183     }
2184
2185   if (gfc_pure (NULL))
2186     {
2187       gfc_error ("%s statement not allowed in PURE procedure at %C",
2188                  gfc_ascii_statement (st));
2189       goto cleanup;
2190     }
2191
2192   if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS)
2193     {
2194       gfc_error ("Image control statement STOP at %C in CRITICAL block");
2195       goto cleanup;
2196     }
2197
2198   if (e != NULL)
2199     {
2200       if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
2201         {
2202           gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
2203                      &e->where);
2204           goto cleanup;
2205         }
2206
2207       if (e->rank != 0)
2208         {
2209           gfc_error ("STOP code at %L must be scalar",
2210                      &e->where);
2211           goto cleanup;
2212         }
2213
2214       if (e->ts.type == BT_CHARACTER
2215           && e->ts.kind != gfc_default_character_kind)
2216         {
2217           gfc_error ("STOP code at %L must be default character KIND=%d",
2218                      &e->where, (int) gfc_default_character_kind);
2219           goto cleanup;
2220         }
2221
2222       if (e->ts.type == BT_INTEGER
2223           && e->ts.kind != gfc_default_integer_kind)
2224         {
2225           gfc_error ("STOP code at %L must be default integer KIND=%d",
2226                      &e->where, (int) gfc_default_integer_kind);
2227           goto cleanup;
2228         }
2229     }
2230
2231   switch (st)
2232     {
2233     case ST_STOP:
2234       new_st.op = EXEC_STOP;
2235       break;
2236     case ST_ERROR_STOP:
2237       new_st.op = EXEC_ERROR_STOP;
2238       break;
2239     case ST_PAUSE:
2240       new_st.op = EXEC_PAUSE;
2241       break;
2242     default:
2243       gcc_unreachable ();
2244     }
2245
2246   new_st.expr1 = e;
2247   new_st.ext.stop_code = -1;
2248
2249   return MATCH_YES;
2250
2251 syntax:
2252   gfc_syntax_error (st);
2253
2254 cleanup:
2255
2256   gfc_free_expr (e);
2257   return MATCH_ERROR;
2258 }
2259
2260
2261 /* Match the (deprecated) PAUSE statement.  */
2262
2263 match
2264 gfc_match_pause (void)
2265 {
2266   match m;
2267
2268   m = gfc_match_stopcode (ST_PAUSE);
2269   if (m == MATCH_YES)
2270     {
2271       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: PAUSE statement"
2272           " at %C")
2273           == FAILURE)
2274         m = MATCH_ERROR;
2275     }
2276   return m;
2277 }
2278
2279
2280 /* Match the STOP statement.  */
2281
2282 match
2283 gfc_match_stop (void)
2284 {
2285   return gfc_match_stopcode (ST_STOP);
2286 }
2287
2288
2289 /* Match the ERROR STOP statement.  */
2290
2291 match
2292 gfc_match_error_stop (void)
2293 {
2294   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C")
2295       == FAILURE)
2296     return MATCH_ERROR;
2297
2298   return gfc_match_stopcode (ST_ERROR_STOP);
2299 }
2300
2301
2302 /* Match SYNC ALL/IMAGES/MEMORY statement. Syntax:
2303      SYNC ALL [(sync-stat-list)]
2304      SYNC MEMORY [(sync-stat-list)]
2305      SYNC IMAGES (image-set [, sync-stat-list] )
2306    with sync-stat is int-expr or *.  */
2307
2308 static match
2309 sync_statement (gfc_statement st)
2310 {
2311   match m;
2312   gfc_expr *tmp, *imageset, *stat, *errmsg;
2313   bool saw_stat, saw_errmsg;
2314
2315   tmp = imageset = stat = errmsg = NULL;
2316   saw_stat = saw_errmsg = false;
2317
2318   if (gfc_pure (NULL))
2319     {
2320       gfc_error ("Image control statement SYNC at %C in PURE procedure");
2321       return MATCH_ERROR;
2322     }
2323
2324   if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C")
2325       == FAILURE)
2326     return MATCH_ERROR;
2327
2328   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
2329     {
2330        gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
2331        return MATCH_ERROR;
2332     }
2333
2334   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
2335     {
2336       gfc_error ("Image control statement SYNC at %C in CRITICAL block");
2337       return MATCH_ERROR;
2338     }
2339         
2340   if (gfc_match_eos () == MATCH_YES)
2341     {
2342       if (st == ST_SYNC_IMAGES)
2343         goto syntax;
2344       goto done;
2345     }
2346
2347   if (gfc_match_char ('(') != MATCH_YES)
2348     goto syntax;
2349
2350   if (st == ST_SYNC_IMAGES)
2351     {
2352       /* Denote '*' as imageset == NULL.  */
2353       m = gfc_match_char ('*');
2354       if (m == MATCH_ERROR)
2355         goto syntax;
2356       if (m == MATCH_NO)
2357         {
2358           if (gfc_match ("%e", &imageset) != MATCH_YES)
2359             goto syntax;
2360         }
2361       m = gfc_match_char (',');
2362       if (m == MATCH_ERROR)
2363         goto syntax;
2364       if (m == MATCH_NO)
2365         {
2366           m = gfc_match_char (')');
2367           if (m == MATCH_YES)
2368             goto done;
2369           goto syntax;
2370         }
2371     }
2372
2373   for (;;)
2374     {
2375       m = gfc_match (" stat = %v", &tmp);
2376       if (m == MATCH_ERROR)
2377         goto syntax;
2378       if (m == MATCH_YES)
2379         {
2380           if (saw_stat)
2381             {
2382               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2383               goto cleanup;
2384             }
2385           stat = tmp;
2386           saw_stat = true;
2387
2388           if (gfc_match_char (',') == MATCH_YES)
2389             continue;
2390         }
2391
2392       m = gfc_match (" errmsg = %v", &tmp);
2393       if (m == MATCH_ERROR)
2394         goto syntax;
2395       if (m == MATCH_YES)
2396         {
2397           if (saw_errmsg)
2398             {
2399               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
2400               goto cleanup;
2401             }
2402           errmsg = tmp;
2403           saw_errmsg = true;
2404
2405           if (gfc_match_char (',') == MATCH_YES)
2406             continue;
2407         }
2408
2409       gfc_gobble_whitespace ();
2410
2411       if (gfc_peek_char () == ')')
2412         break;
2413
2414       goto syntax;
2415     }
2416
2417   if (gfc_match (" )%t") != MATCH_YES)
2418     goto syntax;
2419
2420 done:
2421   switch (st)
2422     {
2423     case ST_SYNC_ALL:
2424       new_st.op = EXEC_SYNC_ALL;
2425       break;
2426     case ST_SYNC_IMAGES:
2427       new_st.op = EXEC_SYNC_IMAGES;
2428       break;
2429     case ST_SYNC_MEMORY:
2430       new_st.op = EXEC_SYNC_MEMORY;
2431       break;
2432     default:
2433       gcc_unreachable ();
2434     }
2435
2436   new_st.expr1 = imageset;
2437   new_st.expr2 = stat;
2438   new_st.expr3 = errmsg;
2439
2440   return MATCH_YES;
2441
2442 syntax:
2443   gfc_syntax_error (st);
2444
2445 cleanup:
2446   gfc_free_expr (tmp);
2447   gfc_free_expr (imageset);
2448   gfc_free_expr (stat);
2449   gfc_free_expr (errmsg);
2450
2451   return MATCH_ERROR;
2452 }
2453
2454
2455 /* Match SYNC ALL statement.  */
2456
2457 match
2458 gfc_match_sync_all (void)
2459 {
2460   return sync_statement (ST_SYNC_ALL);
2461 }
2462
2463
2464 /* Match SYNC IMAGES statement.  */
2465
2466 match
2467 gfc_match_sync_images (void)
2468 {
2469   return sync_statement (ST_SYNC_IMAGES);
2470 }
2471
2472
2473 /* Match SYNC MEMORY statement.  */
2474
2475 match
2476 gfc_match_sync_memory (void)
2477 {
2478   return sync_statement (ST_SYNC_MEMORY);
2479 }
2480
2481
2482 /* Match a CONTINUE statement.  */
2483
2484 match
2485 gfc_match_continue (void)
2486 {
2487   if (gfc_match_eos () != MATCH_YES)
2488     {
2489       gfc_syntax_error (ST_CONTINUE);
2490       return MATCH_ERROR;
2491     }
2492
2493   new_st.op = EXEC_CONTINUE;
2494   return MATCH_YES;
2495 }
2496
2497
2498 /* Match the (deprecated) ASSIGN statement.  */
2499
2500 match
2501 gfc_match_assign (void)
2502 {
2503   gfc_expr *expr;
2504   gfc_st_label *label;
2505
2506   if (gfc_match (" %l", &label) == MATCH_YES)
2507     {
2508       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
2509         return MATCH_ERROR;
2510       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
2511         {
2512           if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: ASSIGN "
2513                               "statement at %C")
2514               == FAILURE)
2515             return MATCH_ERROR;
2516
2517           expr->symtree->n.sym->attr.assign = 1;
2518
2519           new_st.op = EXEC_LABEL_ASSIGN;
2520           new_st.label1 = label;
2521           new_st.expr1 = expr;
2522           return MATCH_YES;
2523         }
2524     }
2525   return MATCH_NO;
2526 }
2527
2528
2529 /* Match the GO TO statement.  As a computed GOTO statement is
2530    matched, it is transformed into an equivalent SELECT block.  No
2531    tree is necessary, and the resulting jumps-to-jumps are
2532    specifically optimized away by the back end.  */
2533
2534 match
2535 gfc_match_goto (void)
2536 {
2537   gfc_code *head, *tail;
2538   gfc_expr *expr;
2539   gfc_case *cp;
2540   gfc_st_label *label;
2541   int i;
2542   match m;
2543
2544   if (gfc_match (" %l%t", &label) == MATCH_YES)
2545     {
2546       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2547         return MATCH_ERROR;
2548
2549       new_st.op = EXEC_GOTO;
2550       new_st.label1 = label;
2551       return MATCH_YES;
2552     }
2553
2554   /* The assigned GO TO statement.  */ 
2555
2556   if (gfc_match_variable (&expr, 0) == MATCH_YES)
2557     {
2558       if (gfc_notify_std (GFC_STD_F95_DEL, "Deleted feature: Assigned GOTO "
2559                           "statement at %C")
2560           == FAILURE)
2561         return MATCH_ERROR;
2562
2563       new_st.op = EXEC_GOTO;
2564       new_st.expr1 = expr;
2565
2566       if (gfc_match_eos () == MATCH_YES)
2567         return MATCH_YES;
2568
2569       /* Match label list.  */
2570       gfc_match_char (',');
2571       if (gfc_match_char ('(') != MATCH_YES)
2572         {
2573           gfc_syntax_error (ST_GOTO);
2574           return MATCH_ERROR;
2575         }
2576       head = tail = NULL;
2577
2578       do
2579         {
2580           m = gfc_match_st_label (&label);
2581           if (m != MATCH_YES)
2582             goto syntax;
2583
2584           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2585             goto cleanup;
2586
2587           if (head == NULL)
2588             head = tail = gfc_get_code ();
2589           else
2590             {
2591               tail->block = gfc_get_code ();
2592               tail = tail->block;
2593             }
2594
2595           tail->label1 = label;
2596           tail->op = EXEC_GOTO;
2597         }
2598       while (gfc_match_char (',') == MATCH_YES);
2599
2600       if (gfc_match (")%t") != MATCH_YES)
2601         goto syntax;
2602
2603       if (head == NULL)
2604         {
2605            gfc_error ("Statement label list in GOTO at %C cannot be empty");
2606            goto syntax;
2607         }
2608       new_st.block = head;
2609
2610       return MATCH_YES;
2611     }
2612
2613   /* Last chance is a computed GO TO statement.  */
2614   if (gfc_match_char ('(') != MATCH_YES)
2615     {
2616       gfc_syntax_error (ST_GOTO);
2617       return MATCH_ERROR;
2618     }
2619
2620   head = tail = NULL;
2621   i = 1;
2622
2623   do
2624     {
2625       m = gfc_match_st_label (&label);
2626       if (m != MATCH_YES)
2627         goto syntax;
2628
2629       if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
2630         goto cleanup;
2631
2632       if (head == NULL)
2633         head = tail = gfc_get_code ();
2634       else
2635         {
2636           tail->block = gfc_get_code ();
2637           tail = tail->block;
2638         }
2639
2640       cp = gfc_get_case ();
2641       cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
2642                                              NULL, i++);
2643
2644       tail->op = EXEC_SELECT;
2645       tail->ext.case_list = cp;
2646
2647       tail->next = gfc_get_code ();
2648       tail->next->op = EXEC_GOTO;
2649       tail->next->label1 = label;
2650     }
2651   while (gfc_match_char (',') == MATCH_YES);
2652
2653   if (gfc_match_char (')') != MATCH_YES)
2654     goto syntax;
2655
2656   if (head == NULL)
2657     {
2658       gfc_error ("Statement label list in GOTO at %C cannot be empty");
2659       goto syntax;
2660     }
2661
2662   /* Get the rest of the statement.  */
2663   gfc_match_char (',');
2664
2665   if (gfc_match (" %e%t", &expr) != MATCH_YES)
2666     goto syntax;
2667
2668   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Computed GOTO "
2669                       "at %C") == FAILURE)
2670     return MATCH_ERROR;
2671
2672   /* At this point, a computed GOTO has been fully matched and an
2673      equivalent SELECT statement constructed.  */
2674
2675   new_st.op = EXEC_SELECT;
2676   new_st.expr1 = NULL;
2677
2678   /* Hack: For a "real" SELECT, the expression is in expr. We put
2679      it in expr2 so we can distinguish then and produce the correct
2680      diagnostics.  */
2681   new_st.expr2 = expr;
2682   new_st.block = head;
2683   return MATCH_YES;
2684
2685 syntax:
2686   gfc_syntax_error (ST_GOTO);
2687 cleanup:
2688   gfc_free_statements (head);
2689   return MATCH_ERROR;
2690 }
2691
2692
2693 /* Frees a list of gfc_alloc structures.  */
2694
2695 void
2696 gfc_free_alloc_list (gfc_alloc *p)
2697 {
2698   gfc_alloc *q;
2699
2700   for (; p; p = q)
2701     {
2702       q = p->next;
2703       gfc_free_expr (p->expr);
2704       gfc_free (p);
2705     }
2706 }
2707
2708
2709 /* Match a Fortran 2003 derived-type-spec (F03:R455), which is just the name of
2710    an accessible derived type.  */
2711
2712 static match
2713 match_derived_type_spec (gfc_typespec *ts)
2714 {
2715   char name[GFC_MAX_SYMBOL_LEN + 1];
2716   locus old_locus; 
2717   gfc_symbol *derived;
2718
2719   old_locus = gfc_current_locus;
2720
2721   if (gfc_match ("%n", name) != MATCH_YES)
2722     {
2723        gfc_current_locus = old_locus;
2724        return MATCH_NO;
2725     }
2726
2727   gfc_find_symbol (name, NULL, 1, &derived);
2728
2729   if (derived && derived->attr.flavor == FL_DERIVED)
2730     {
2731       ts->type = BT_DERIVED;
2732       ts->u.derived = derived;
2733       return MATCH_YES;
2734     }
2735
2736   gfc_current_locus = old_locus; 
2737   return MATCH_NO;
2738 }
2739
2740
2741 /* Match a Fortran 2003 type-spec (F03:R401).  This is similar to
2742    gfc_match_decl_type_spec() from decl.c, with the following exceptions:
2743    It only includes the intrinsic types from the Fortran 2003 standard
2744    (thus, neither BYTE nor forms like REAL*4 are allowed). Additionally,
2745    the implicit_flag is not needed, so it was removed. Derived types are
2746    identified by their name alone.  */
2747
2748 static match
2749 match_type_spec (gfc_typespec *ts)
2750 {
2751   match m;
2752   locus old_locus;
2753
2754   gfc_clear_ts (ts);
2755   gfc_gobble_whitespace ();
2756   old_locus = gfc_current_locus;
2757
2758   if (match_derived_type_spec (ts) == MATCH_YES)
2759     {
2760       /* Enforce F03:C401.  */
2761       if (ts->u.derived->attr.abstract)
2762         {
2763           gfc_error ("Derived type '%s' at %L may not be ABSTRACT",
2764                      ts->u.derived->name, &old_locus);
2765           return MATCH_ERROR;
2766         }
2767       return MATCH_YES;
2768     }
2769
2770   if (gfc_match ("integer") == MATCH_YES)
2771     {
2772       ts->type = BT_INTEGER;
2773       ts->kind = gfc_default_integer_kind;
2774       goto kind_selector;
2775     }
2776
2777   if (gfc_match ("real") == MATCH_YES)
2778     {
2779       ts->type = BT_REAL;
2780       ts->kind = gfc_default_real_kind;
2781       goto kind_selector;
2782     }
2783
2784   if (gfc_match ("double precision") == MATCH_YES)
2785     {
2786       ts->type = BT_REAL;
2787       ts->kind = gfc_default_double_kind;
2788       return MATCH_YES;
2789     }
2790
2791   if (gfc_match ("complex") == MATCH_YES)
2792     {
2793       ts->type = BT_COMPLEX;
2794       ts->kind = gfc_default_complex_kind;
2795       goto kind_selector;
2796     }
2797
2798   if (gfc_match ("character") == MATCH_YES)
2799     {
2800       ts->type = BT_CHARACTER;
2801
2802       m = gfc_match_char_spec (ts);
2803
2804       if (m == MATCH_NO)
2805         m = MATCH_YES;
2806
2807       return m;
2808     }
2809
2810   if (gfc_match ("logical") == MATCH_YES)
2811     {
2812       ts->type = BT_LOGICAL;
2813       ts->kind = gfc_default_logical_kind;
2814       goto kind_selector;
2815     }
2816
2817   /* If a type is not matched, simply return MATCH_NO.  */
2818   gfc_current_locus = old_locus;
2819   return MATCH_NO;
2820
2821 kind_selector:
2822
2823   gfc_gobble_whitespace ();
2824   if (gfc_peek_ascii_char () == '*')
2825     {
2826       gfc_error ("Invalid type-spec at %C");
2827       return MATCH_ERROR;
2828     }
2829
2830   m = gfc_match_kind_spec (ts, false);
2831
2832   if (m == MATCH_NO)
2833     m = MATCH_YES;              /* No kind specifier found.  */
2834
2835   return m;
2836 }
2837
2838
2839 /* Match an ALLOCATE statement.  */
2840
2841 match
2842 gfc_match_allocate (void)
2843 {
2844   gfc_alloc *head, *tail;
2845   gfc_expr *stat, *errmsg, *tmp, *source, *mold;
2846   gfc_typespec ts;
2847   gfc_symbol *sym;
2848   match m;
2849   locus old_locus, deferred_locus;
2850   bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
2851
2852   head = tail = NULL;
2853   stat = errmsg = source = mold = tmp = NULL;
2854   saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
2855
2856   if (gfc_match_char ('(') != MATCH_YES)
2857     goto syntax;
2858
2859   /* Match an optional type-spec.  */
2860   old_locus = gfc_current_locus;
2861   m = match_type_spec (&ts);
2862   if (m == MATCH_ERROR)
2863     goto cleanup;
2864   else if (m == MATCH_NO)
2865     {
2866       char name[GFC_MAX_SYMBOL_LEN + 3];
2867
2868       if (gfc_match ("%n :: ", name) == MATCH_YES)
2869         {
2870           gfc_error ("Error in type-spec at %L", &old_locus);
2871           goto cleanup;
2872         }
2873
2874       ts.type = BT_UNKNOWN;
2875     }
2876   else
2877     {
2878       if (gfc_match (" :: ") == MATCH_YES)
2879         {
2880           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: typespec in "
2881                               "ALLOCATE at %L", &old_locus) == FAILURE)
2882             goto cleanup;
2883
2884           if (ts.deferred)
2885             {
2886               gfc_error ("Type-spec at %L cannot contain a deferred "
2887                          "type parameter", &old_locus);
2888               goto cleanup;
2889             }
2890         }
2891       else
2892         {
2893           ts.type = BT_UNKNOWN;
2894           gfc_current_locus = old_locus;
2895         }
2896     }
2897
2898   for (;;)
2899     {
2900       if (head == NULL)
2901         head = tail = gfc_get_alloc ();
2902       else
2903         {
2904           tail->next = gfc_get_alloc ();
2905           tail = tail->next;
2906         }
2907
2908       m = gfc_match_variable (&tail->expr, 0);
2909       if (m == MATCH_NO)
2910         goto syntax;
2911       if (m == MATCH_ERROR)
2912         goto cleanup;
2913
2914       if (gfc_check_do_variable (tail->expr->symtree))
2915         goto cleanup;
2916
2917       if (gfc_pure (NULL) && gfc_impure_variable (tail->expr->symtree->n.sym))
2918         {
2919           gfc_error ("Bad allocate-object at %C for a PURE procedure");
2920           goto cleanup;
2921         }
2922
2923       if (tail->expr->ts.deferred)
2924         {
2925           saw_deferred = true;
2926           deferred_locus = tail->expr->where;
2927         }
2928
2929       /* The ALLOCATE statement had an optional typespec.  Check the
2930          constraints.  */
2931       if (ts.type != BT_UNKNOWN)
2932         {
2933           /* Enforce F03:C624.  */
2934           if (!gfc_type_compatible (&tail->expr->ts, &ts))
2935             {
2936               gfc_error ("Type of entity at %L is type incompatible with "
2937                          "typespec", &tail->expr->where);
2938               goto cleanup;
2939             }
2940
2941           /* Enforce F03:C627.  */
2942           if (ts.kind != tail->expr->ts.kind)
2943             {
2944               gfc_error ("Kind type parameter for entity at %L differs from "
2945                          "the kind type parameter of the typespec",
2946                          &tail->expr->where);
2947               goto cleanup;
2948             }
2949         }
2950
2951       if (tail->expr->ts.type == BT_DERIVED)
2952         tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
2953
2954       /* FIXME: disable the checking on derived types and arrays.  */
2955       sym = tail->expr->symtree->n.sym;
2956       b1 = !(tail->expr->ref
2957            && (tail->expr->ref->type == REF_COMPONENT
2958                 || tail->expr->ref->type == REF_ARRAY));
2959       if (sym && sym->ts.type == BT_CLASS)
2960         b2 = !(CLASS_DATA (sym)->attr.allocatable
2961                || CLASS_DATA (sym)->attr.class_pointer);
2962       else
2963         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
2964                       || sym->attr.proc_pointer);
2965       b3 = sym && sym->ns && sym->ns->proc_name
2966            && (sym->ns->proc_name->attr.allocatable
2967                 || sym->ns->proc_name->attr.pointer
2968                 || sym->ns->proc_name->attr.proc_pointer);
2969       if (b1 && b2 && !b3)
2970         {
2971           gfc_error ("Allocate-object at %L is not a nonprocedure pointer "
2972                      "or an allocatable variable", &tail->expr->where);
2973           goto cleanup;
2974         }
2975
2976       if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
2977         {
2978           gfc_error ("Shape specification for allocatable scalar at %C");
2979           goto cleanup;
2980         }
2981
2982       if (gfc_match_char (',') != MATCH_YES)
2983         break;
2984
2985 alloc_opt_list:
2986
2987       m = gfc_match (" stat = %v", &tmp);
2988       if (m == MATCH_ERROR)
2989         goto cleanup;
2990       if (m == MATCH_YES)
2991         {
2992           /* Enforce C630.  */
2993           if (saw_stat)
2994             {
2995               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
2996               goto cleanup;
2997             }
2998
2999           stat = tmp;
3000           tmp = NULL;
3001           saw_stat = true;
3002
3003           if (gfc_check_do_variable (stat->symtree))
3004             goto cleanup;
3005
3006           if (gfc_match_char (',') == MATCH_YES)
3007             goto alloc_opt_list;
3008         }
3009
3010       m = gfc_match (" errmsg = %v", &tmp);
3011       if (m == MATCH_ERROR)
3012         goto cleanup;
3013       if (m == MATCH_YES)
3014         {
3015           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG tag at %L",
3016                               &tmp->where) == FAILURE)
3017             goto cleanup;
3018
3019           /* Enforce C630.  */
3020           if (saw_errmsg)
3021             {
3022               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3023               goto cleanup;
3024             }
3025
3026           errmsg = tmp;
3027           tmp = NULL;
3028           saw_errmsg = true;
3029
3030           if (gfc_match_char (',') == MATCH_YES)
3031             goto alloc_opt_list;
3032         }
3033
3034       m = gfc_match (" source = %e", &tmp);
3035       if (m == MATCH_ERROR)
3036         goto cleanup;
3037       if (m == MATCH_YES)
3038         {
3039           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: SOURCE tag at %L",
3040                               &tmp->where) == FAILURE)
3041             goto cleanup;
3042
3043           /* Enforce C630.  */
3044           if (saw_source)
3045             {
3046               gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
3047               goto cleanup;
3048             }
3049
3050           /* The next 2 conditionals check C631.  */
3051           if (ts.type != BT_UNKNOWN)
3052             {
3053               gfc_error ("SOURCE tag at %L conflicts with the typespec at %L",
3054                          &tmp->where, &old_locus);
3055               goto cleanup;
3056             }
3057
3058           if (head->next)
3059             {
3060               gfc_error ("SOURCE tag at %L requires only a single entity in "
3061                          "the allocation-list", &tmp->where);
3062               goto cleanup;
3063             }
3064
3065           source = tmp;
3066           tmp = NULL;
3067           saw_source = true;
3068
3069           if (gfc_match_char (',') == MATCH_YES)
3070             goto alloc_opt_list;
3071         }
3072
3073       m = gfc_match (" mold = %e", &tmp);
3074       if (m == MATCH_ERROR)
3075         goto cleanup;
3076       if (m == MATCH_YES)
3077         {
3078           if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: MOLD tag at %L",
3079                               &tmp->where) == FAILURE)
3080             goto cleanup;
3081
3082           /* Check F08:C636.  */
3083           if (saw_mold)
3084             {
3085               gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
3086               goto cleanup;
3087             }
3088   
3089           /* Check F08:C637.  */
3090           if (ts.type != BT_UNKNOWN)
3091             {
3092               gfc_error ("MOLD tag at %L conflicts with the typespec at %L",
3093                          &tmp->where, &old_locus);
3094               goto cleanup;
3095             }
3096
3097           mold = tmp;
3098           tmp = NULL;
3099           saw_mold = true;
3100           mold->mold = 1;
3101
3102           if (gfc_match_char (',') == MATCH_YES)
3103             goto alloc_opt_list;
3104         }
3105
3106         gfc_gobble_whitespace ();
3107
3108         if (gfc_peek_char () == ')')
3109           break;
3110     }
3111
3112   if (gfc_match (" )%t") != MATCH_YES)
3113     goto syntax;
3114
3115   /* Check F08:C637.  */
3116   if (source && mold)
3117     {
3118       gfc_error ("MOLD tag at %L conflicts with SOURCE tag at %L",
3119                   &mold->where, &source->where);
3120       goto cleanup;
3121     }
3122
3123   /* Check F03:C623,  */
3124   if (saw_deferred && ts.type == BT_UNKNOWN && !source)
3125     {
3126       gfc_error ("Allocate-object at %L with a deferred type parameter "
3127                  "requires either a type-spec or SOURCE tag", &deferred_locus);
3128       goto cleanup;
3129     }
3130   
3131   new_st.op = EXEC_ALLOCATE;
3132   new_st.expr1 = stat;
3133   new_st.expr2 = errmsg;
3134   if (source)
3135     new_st.expr3 = source;
3136   else
3137     new_st.expr3 = mold;
3138   new_st.ext.alloc.list = head;
3139   new_st.ext.alloc.ts = ts;
3140
3141   return MATCH_YES;
3142
3143 syntax:
3144   gfc_syntax_error (ST_ALLOCATE);
3145
3146 cleanup:
3147   gfc_free_expr (errmsg);
3148   gfc_free_expr (source);
3149   gfc_free_expr (stat);
3150   gfc_free_expr (mold);
3151   if (tmp && tmp->expr_type) gfc_free_expr (tmp);
3152   gfc_free_alloc_list (head);
3153   return MATCH_ERROR;
3154 }
3155
3156
3157 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
3158    a set of pointer assignments to intrinsic NULL().  */
3159
3160 match
3161 gfc_match_nullify (void)
3162 {
3163   gfc_code *tail;
3164   gfc_expr *e, *p;
3165   match m;
3166
3167   tail = NULL;
3168
3169   if (gfc_match_char ('(') != MATCH_YES)
3170     goto syntax;
3171
3172   for (;;)
3173     {
3174       m = gfc_match_variable (&p, 0);
3175       if (m == MATCH_ERROR)
3176         goto cleanup;
3177       if (m == MATCH_NO)
3178         goto syntax;
3179
3180       if (gfc_check_do_variable (p->symtree))
3181         goto cleanup;
3182
3183       /* build ' => NULL() '.  */
3184       e = gfc_get_null_expr (&gfc_current_locus);
3185
3186       /* Chain to list.  */
3187       if (tail == NULL)
3188         tail = &new_st;
3189       else
3190         {
3191           tail->next = gfc_get_code ();
3192           tail = tail->next;
3193         }
3194
3195       tail->op = EXEC_POINTER_ASSIGN;
3196       tail->expr1 = p;
3197       tail->expr2 = e;
3198
3199       if (gfc_match (" )%t") == MATCH_YES)
3200         break;
3201       if (gfc_match_char (',') != MATCH_YES)
3202         goto syntax;
3203     }
3204
3205   return MATCH_YES;
3206
3207 syntax:
3208   gfc_syntax_error (ST_NULLIFY);
3209
3210 cleanup:
3211   gfc_free_statements (new_st.next);
3212   new_st.next = NULL;
3213   gfc_free_expr (new_st.expr1);
3214   new_st.expr1 = NULL;
3215   gfc_free_expr (new_st.expr2);
3216   new_st.expr2 = NULL;
3217   return MATCH_ERROR;
3218 }
3219
3220
3221 /* Match a DEALLOCATE statement.  */
3222
3223 match
3224 gfc_match_deallocate (void)
3225 {
3226   gfc_alloc *head, *tail;
3227   gfc_expr *stat, *errmsg, *tmp;
3228   gfc_symbol *sym;
3229   match m;
3230   bool saw_stat, saw_errmsg, b1, b2;
3231
3232   head = tail = NULL;
3233   stat = errmsg = tmp = NULL;
3234   saw_stat = saw_errmsg = false;
3235
3236   if (gfc_match_char ('(') != MATCH_YES)
3237     goto syntax;
3238
3239   for (;;)
3240     {
3241       if (head == NULL)
3242         head = tail = gfc_get_alloc ();
3243       else
3244         {
3245           tail->next = gfc_get_alloc ();
3246           tail = tail->next;
3247         }
3248
3249       m = gfc_match_variable (&tail->expr, 0);
3250       if (m == MATCH_ERROR)
3251         goto cleanup;
3252       if (m == MATCH_NO)
3253         goto syntax;
3254
3255       if (gfc_check_do_variable (tail->expr->symtree))
3256         goto cleanup;
3257
3258       sym = tail->expr->symtree->n.sym;
3259
3260       if (gfc_pure (NULL) && gfc_impure_variable (sym))
3261         {
3262           gfc_error ("Illegal allocate-object at %C for a PURE procedure");
3263           goto cleanup;
3264         }
3265
3266       /* FIXME: disable the checking on derived types.  */
3267       b1 = !(tail->expr->ref
3268            && (tail->expr->ref->type == REF_COMPONENT
3269                || tail->expr->ref->type == REF_ARRAY));
3270       if (sym && sym->ts.type == BT_CLASS)
3271         b2 = !(CLASS_DATA (sym)->attr.allocatable
3272                || CLASS_DATA (sym)->attr.class_pointer);
3273       else
3274         b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
3275                       || sym->attr.proc_pointer);
3276       if (b1 && b2)
3277         {
3278           gfc_error ("Allocate-object at %C is not a nonprocedure pointer "
3279                      "or an allocatable variable");
3280           goto cleanup;
3281         }
3282
3283       if (gfc_match_char (',') != MATCH_YES)
3284         break;
3285
3286 dealloc_opt_list:
3287
3288       m = gfc_match (" stat = %v", &tmp);
3289       if (m == MATCH_ERROR)
3290         goto cleanup;
3291       if (m == MATCH_YES)
3292         {
3293           if (saw_stat)
3294             {
3295               gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
3296               gfc_free_expr (tmp);
3297               goto cleanup;
3298             }
3299
3300           stat = tmp;
3301           saw_stat = true;
3302
3303           if (gfc_check_do_variable (stat->symtree))
3304             goto cleanup;
3305
3306           if (gfc_match_char (',') == MATCH_YES)
3307             goto dealloc_opt_list;
3308         }
3309
3310       m = gfc_match (" errmsg = %v", &tmp);
3311       if (m == MATCH_ERROR)
3312         goto cleanup;
3313       if (m == MATCH_YES)
3314         {
3315           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ERRMSG at %L",
3316                               &tmp->where) == FAILURE)
3317             goto cleanup;
3318
3319           if (saw_errmsg)
3320             {
3321               gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
3322               gfc_free_expr (tmp);
3323               goto cleanup;
3324             }
3325
3326           errmsg = tmp;
3327           saw_errmsg = true;
3328
3329           if (gfc_match_char (',') == MATCH_YES)
3330             goto dealloc_opt_list;
3331         }
3332
3333         gfc_gobble_whitespace ();
3334
3335         if (gfc_peek_char () == ')')
3336           break;
3337     }
3338
3339   if (gfc_match (" )%t") != MATCH_YES)
3340     goto syntax;
3341
3342   new_st.op = EXEC_DEALLOCATE;
3343   new_st.expr1 = stat;
3344   new_st.expr2 = errmsg;
3345   new_st.ext.alloc.list = head;
3346
3347   return MATCH_YES;
3348
3349 syntax:
3350   gfc_syntax_error (ST_DEALLOCATE);
3351
3352 cleanup:
3353   gfc_free_expr (errmsg);
3354   gfc_free_expr (stat);
3355   gfc_free_alloc_list (head);
3356   return MATCH_ERROR;
3357 }
3358
3359
3360 /* Match a RETURN statement.  */
3361
3362 match
3363 gfc_match_return (void)
3364 {
3365   gfc_expr *e;
3366   match m;
3367   gfc_compile_state s;
3368
3369   e = NULL;
3370
3371   if (gfc_find_state (COMP_CRITICAL) == SUCCESS)
3372     {
3373       gfc_error ("Image control statement RETURN at %C in CRITICAL block");
3374       return MATCH_ERROR;
3375     }
3376
3377   if (gfc_match_eos () == MATCH_YES)
3378     goto done;
3379
3380   if (gfc_find_state (COMP_SUBROUTINE) == FAILURE)
3381     {
3382       gfc_error ("Alternate RETURN statement at %C is only allowed within "
3383                  "a SUBROUTINE");
3384       goto cleanup;
3385     }
3386
3387   if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: Alternate RETURN "
3388                       "at %C") == FAILURE)
3389     return MATCH_ERROR;
3390
3391   if (gfc_current_form == FORM_FREE)
3392     {
3393       /* The following are valid, so we can't require a blank after the
3394         RETURN keyword:
3395           return+1
3396           return(1)  */
3397       char c = gfc_peek_ascii_char ();
3398       if (ISALPHA (c) || ISDIGIT (c))
3399         return MATCH_NO;
3400     }
3401
3402   m = gfc_match (" %e%t", &e);
3403   if (m == MATCH_YES)
3404     goto done;
3405   if (m == MATCH_ERROR)
3406     goto cleanup;
3407
3408   gfc_syntax_error (ST_RETURN);
3409
3410 cleanup:
3411   gfc_free_expr (e);
3412   return MATCH_ERROR;
3413
3414 done:
3415   gfc_enclosing_unit (&s);
3416   if (s == COMP_PROGRAM
3417       && gfc_notify_std (GFC_STD_GNU, "Extension: RETURN statement in "
3418                         "main program at %C") == FAILURE)
3419       return MATCH_ERROR;
3420
3421   new_st.op = EXEC_RETURN;
3422   new_st.expr1 = e;
3423
3424   return MATCH_YES;
3425 }
3426
3427
3428 /* Match the call of a type-bound procedure, if CALL%var has already been 
3429    matched and var found to be a derived-type variable.  */
3430
3431 static match
3432 match_typebound_call (gfc_symtree* varst)
3433 {
3434   gfc_expr* base;
3435   match m;
3436
3437   base = gfc_get_expr ();
3438   base->expr_type = EXPR_VARIABLE;
3439   base->symtree = varst;
3440   base->where = gfc_current_locus;
3441   gfc_set_sym_referenced (varst->n.sym);
3442   
3443   m = gfc_match_varspec (base, 0, true, true);
3444   if (m == MATCH_NO)
3445     gfc_error ("Expected component reference at %C");
3446   if (m != MATCH_YES)
3447     return MATCH_ERROR;
3448
3449   if (gfc_match_eos () != MATCH_YES)
3450     {
3451       gfc_error ("Junk after CALL at %C");
3452       return MATCH_ERROR;
3453     }
3454
3455   if (base->expr_type == EXPR_COMPCALL)
3456     new_st.op = EXEC_COMPCALL;
3457   else if (base->expr_type == EXPR_PPC)
3458     new_st.op = EXEC_CALL_PPC;
3459   else
3460     {
3461       gfc_error ("Expected type-bound procedure or procedure pointer component "
3462                  "at %C");
3463       return MATCH_ERROR;
3464     }
3465   new_st.expr1 = base;
3466
3467   return MATCH_YES;
3468 }
3469
3470
3471 /* Match a CALL statement.  The tricky part here are possible
3472    alternate return specifiers.  We handle these by having all
3473    "subroutines" actually return an integer via a register that gives
3474    the return number.  If the call specifies alternate returns, we
3475    generate code for a SELECT statement whose case clauses contain
3476    GOTOs to the various labels.  */
3477
3478 match
3479 gfc_match_call (void)
3480 {
3481   char name[GFC_MAX_SYMBOL_LEN + 1];
3482   gfc_actual_arglist *a, *arglist;
3483   gfc_case *new_case;
3484   gfc_symbol *sym;
3485   gfc_symtree *st;
3486   gfc_code *c;
3487   match m;
3488   int i;
3489
3490   arglist = NULL;
3491
3492   m = gfc_match ("% %n", name);
3493   if (m == MATCH_NO)
3494     goto syntax;
3495   if (m != MATCH_YES)
3496     return m;
3497
3498   if (gfc_get_ha_sym_tree (name, &st))
3499     return MATCH_ERROR;
3500
3501   sym = st->n.sym;
3502
3503   /* If this is a variable of derived-type, it probably starts a type-bound
3504      procedure call.  */
3505   if ((sym->attr.flavor != FL_PROCEDURE
3506        || gfc_is_function_return_value (sym, gfc_current_ns))
3507       && (sym->ts.type == BT_DERIVED || sym->ts.type == BT_CLASS))
3508     return match_typebound_call (st);
3509
3510   /* If it does not seem to be callable (include functions so that the
3511      right association is made.  They are thrown out in resolution.)
3512      ...  */
3513   if (!sym->attr.generic
3514         && !sym->attr.subroutine
3515         && !sym->attr.function)
3516     {
3517       if (!(sym->attr.external && !sym->attr.referenced))
3518         {
3519           /* ...create a symbol in this scope...  */
3520           if (sym->ns != gfc_current_ns
3521                 && gfc_get_sym_tree (name, NULL, &st, false) == 1)
3522             return MATCH_ERROR;
3523
3524           if (sym != st->n.sym)
3525             sym = st->n.sym;
3526         }
3527
3528       /* ...and then to try to make the symbol into a subroutine.  */
3529       if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3530         return MATCH_ERROR;
3531     }
3532
3533   gfc_set_sym_referenced (sym);
3534
3535   if (gfc_match_eos () != MATCH_YES)
3536     {
3537       m = gfc_match_actual_arglist (1, &arglist);
3538       if (m == MATCH_NO)
3539         goto syntax;
3540       if (m == MATCH_ERROR)
3541         goto cleanup;
3542
3543       if (gfc_match_eos () != MATCH_YES)
3544         goto syntax;
3545     }
3546
3547   /* If any alternate return labels were found, construct a SELECT
3548      statement that will jump to the right place.  */
3549
3550   i = 0;
3551   for (a = arglist; a; a = a->next)
3552     if (a->expr == NULL)
3553       i = 1;
3554
3555   if (i)
3556     {
3557       gfc_symtree *select_st;
3558       gfc_symbol *select_sym;
3559       char name[GFC_MAX_SYMBOL_LEN + 1];
3560
3561       new_st.next = c = gfc_get_code ();
3562       c->op = EXEC_SELECT;
3563       sprintf (name, "_result_%s", sym->name);
3564       gfc_get_ha_sym_tree (name, &select_st);   /* Can't fail.  */
3565
3566       select_sym = select_st->n.sym;
3567       select_sym->ts.type = BT_INTEGER;
3568       select_sym->ts.kind = gfc_default_integer_kind;
3569       gfc_set_sym_referenced (select_sym);
3570       c->expr1 = gfc_get_expr ();
3571       c->expr1->expr_type = EXPR_VARIABLE;
3572       c->expr1->symtree = select_st;
3573       c->expr1->ts = select_sym->ts;
3574       c->expr1->where = gfc_current_locus;
3575
3576       i = 0;
3577       for (a = arglist; a; a = a->next)
3578         {
3579           if (a->expr != NULL)
3580             continue;
3581
3582           if (gfc_reference_st_label (a->label, ST_LABEL_TARGET) == FAILURE)
3583             continue;
3584
3585           i++;
3586
3587           c->block = gfc_get_code ();
3588           c = c->block;
3589           c->op = EXEC_SELECT;
3590
3591           new_case = gfc_get_case ();
3592           new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
3593           new_case->low = new_case->high;
3594           c->ext.case_list = new_case;
3595
3596           c->next = gfc_get_code ();
3597           c->next->op = EXEC_GOTO;
3598           c->next->label1 = a->label;
3599         }
3600     }
3601
3602   new_st.op = EXEC_CALL;
3603   new_st.symtree = st;
3604   new_st.ext.actual = arglist;
3605
3606   return MATCH_YES;
3607
3608 syntax:
3609   gfc_syntax_error (ST_CALL);
3610
3611 cleanup:
3612   gfc_free_actual_arglist (arglist);
3613   return MATCH_ERROR;
3614 }
3615
3616
3617 /* Given a name, return a pointer to the common head structure,
3618    creating it if it does not exist. If FROM_MODULE is nonzero, we
3619    mangle the name so that it doesn't interfere with commons defined 
3620    in the using namespace.
3621    TODO: Add to global symbol tree.  */
3622
3623 gfc_common_head *
3624 gfc_get_common (const char *name, int from_module)
3625 {
3626   gfc_symtree *st;
3627   static int serial = 0;
3628   char mangled_name[GFC_MAX_SYMBOL_LEN + 1];
3629
3630   if (from_module)
3631     {
3632       /* A use associated common block is only needed to correctly layout
3633          the variables it contains.  */
3634       snprintf (mangled_name, GFC_MAX_SYMBOL_LEN, "_%d_%s", serial++, name);
3635       st = gfc_new_symtree (&gfc_current_ns->common_root, mangled_name);
3636     }
3637   else
3638     {
3639       st = gfc_find_symtree (gfc_current_ns->common_root, name);
3640
3641       if (st == NULL)
3642         st = gfc_new_symtree (&gfc_current_ns->common_root, name);
3643     }
3644
3645   if (st->n.common == NULL)
3646     {
3647       st->n.common = gfc_get_common_head ();
3648       st->n.common->where = gfc_current_locus;
3649       strcpy (st->n.common->name, name);
3650     }
3651
3652   return st->n.common;
3653 }
3654
3655
3656 /* Match a common block name.  */
3657
3658 match match_common_name (char *name)
3659 {
3660   match m;
3661
3662   if (gfc_match_char ('/') == MATCH_NO)
3663     {
3664       name[0] = '\0';
3665       return MATCH_YES;
3666     }
3667
3668   if (gfc_match_char ('/') == MATCH_YES)
3669     {
3670       name[0] = '\0';
3671       return MATCH_YES;
3672     }
3673
3674   m = gfc_match_name (name);
3675
3676   if (m == MATCH_ERROR)
3677     return MATCH_ERROR;
3678   if (m == MATCH_YES && gfc_match_char ('/') == MATCH_YES)
3679     return MATCH_YES;
3680
3681   gfc_error ("Syntax error in common block name at %C");
3682   return MATCH_ERROR;
3683 }
3684
3685
3686 /* Match a COMMON statement.  */
3687
3688 match
3689 gfc_match_common (void)
3690 {
3691   gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
3692   char name[GFC_MAX_SYMBOL_LEN + 1];
3693   gfc_common_head *t;
3694   gfc_array_spec *as;
3695   gfc_equiv *e1, *e2;
3696   match m;
3697   gfc_gsymbol *gsym;
3698
3699   old_blank_common = gfc_current_ns->blank_common.head;
3700   if (old_blank_common)
3701     {
3702       while (old_blank_common->common_next)
3703         old_blank_common = old_blank_common->common_next;
3704     }
3705
3706   as = NULL;
3707
3708   for (;;)
3709     {
3710       m = match_common_name (name);
3711       if (m == MATCH_ERROR)
3712         goto cleanup;
3713
3714       gsym = gfc_get_gsymbol (name);
3715       if (gsym->type != GSYM_UNKNOWN && gsym->type != GSYM_COMMON)
3716         {
3717           gfc_error ("Symbol '%s' at %C is already an external symbol that "