OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [fortran/] [match.c] - Blame information for rev 304

Go to most recent revision | Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.