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/] [primary.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
/* Primary expression subroutines
2
   Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
3
   Free Software Foundation, Inc.
4
   Contributed by Andy Vaught
5
 
6
This file is part of GCC.
7
 
8
GCC is free software; you can redistribute it and/or modify it under
9
the terms of the GNU General Public License as published by the Free
10
Software Foundation; either version 3, or (at your option) any later
11
version.
12
 
13
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14
WARRANTY; without even the implied warranty of MERCHANTABILITY or
15
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
16
for more details.
17
 
18
You should have received a copy of the GNU General Public License
19
along with GCC; see the file COPYING3.  If not see
20
<http://www.gnu.org/licenses/>.  */
21
 
22
#include "config.h"
23
#include "system.h"
24
#include "flags.h"
25
#include "gfortran.h"
26
#include "arith.h"
27
#include "match.h"
28
#include "parse.h"
29
#include "toplev.h"
30
 
31
/* Matches a kind-parameter expression, which is either a named
32
   symbolic constant or a nonnegative integer constant.  If
33
   successful, sets the kind value to the correct integer.  */
34
 
35
static match
36
match_kind_param (int *kind)
37
{
38
  char name[GFC_MAX_SYMBOL_LEN + 1];
39
  gfc_symbol *sym;
40
  const char *p;
41
  match m;
42
 
43
  m = gfc_match_small_literal_int (kind, NULL);
44
  if (m != MATCH_NO)
45
    return m;
46
 
47
  m = gfc_match_name (name);
48
  if (m != MATCH_YES)
49
    return m;
50
 
51
  if (gfc_find_symbol (name, NULL, 1, &sym))
52
    return MATCH_ERROR;
53
 
54
  if (sym == NULL)
55
    return MATCH_NO;
56
 
57
  if (sym->attr.flavor != FL_PARAMETER)
58
    return MATCH_NO;
59
 
60
  if (sym->value == NULL)
61
    return MATCH_NO;
62
 
63
  p = gfc_extract_int (sym->value, kind);
64
  if (p != NULL)
65
    return MATCH_NO;
66
 
67
  gfc_set_sym_referenced (sym);
68
 
69
  if (*kind < 0)
70
    return MATCH_NO;
71
 
72
  return MATCH_YES;
73
}
74
 
75
 
76
/* Get a trailing kind-specification for non-character variables.
77
   Returns:
78
      the integer kind value or:
79
      -1 if an error was generated
80
      -2 if no kind was found */
81
 
82
static int
83
get_kind (void)
84
{
85
  int kind;
86
  match m;
87
 
88
  if (gfc_match_char ('_') != MATCH_YES)
89
    return -2;
90
 
91
  m = match_kind_param (&kind);
92
  if (m == MATCH_NO)
93
    gfc_error ("Missing kind-parameter at %C");
94
 
95
  return (m == MATCH_YES) ? kind : -1;
96
}
97
 
98
 
99
/* Given a character and a radix, see if the character is a valid
100
   digit in that radix.  */
101
 
102
int
103
gfc_check_digit (char c, int radix)
104
{
105
  int r;
106
 
107
  switch (radix)
108
    {
109
    case 2:
110
      r = ('0' <= c && c <= '1');
111
      break;
112
 
113
    case 8:
114
      r = ('0' <= c && c <= '7');
115
      break;
116
 
117
    case 10:
118
      r = ('0' <= c && c <= '9');
119
      break;
120
 
121
    case 16:
122
      r = ISXDIGIT (c);
123
      break;
124
 
125
    default:
126
      gfc_internal_error ("gfc_check_digit(): bad radix");
127
    }
128
 
129
  return r;
130
}
131
 
132
 
133
/* Match the digit string part of an integer if signflag is not set,
134
   the signed digit string part if signflag is set.  If the buffer
135
   is NULL, we just count characters for the resolution pass.  Returns
136
   the number of characters matched, -1 for no match.  */
137
 
138
static int
139
match_digits (int signflag, int radix, char *buffer)
140
{
141
  locus old_loc;
142
  int length;
143
  char c;
144
 
145
  length = 0;
146
  c = gfc_next_ascii_char ();
147
 
148
  if (signflag && (c == '+' || c == '-'))
149
    {
150
      if (buffer != NULL)
151
        *buffer++ = c;
152
      gfc_gobble_whitespace ();
153
      c = gfc_next_ascii_char ();
154
      length++;
155
    }
156
 
157
  if (!gfc_check_digit (c, radix))
158
    return -1;
159
 
160
  length++;
161
  if (buffer != NULL)
162
    *buffer++ = c;
163
 
164
  for (;;)
165
    {
166
      old_loc = gfc_current_locus;
167
      c = gfc_next_ascii_char ();
168
 
169
      if (!gfc_check_digit (c, radix))
170
        break;
171
 
172
      if (buffer != NULL)
173
        *buffer++ = c;
174
      length++;
175
    }
176
 
177
  gfc_current_locus = old_loc;
178
 
179
  return length;
180
}
181
 
182
 
183
/* Match an integer (digit string and optional kind).
184
   A sign will be accepted if signflag is set.  */
185
 
186
static match
187
match_integer_constant (gfc_expr **result, int signflag)
188
{
189
  int length, kind;
190
  locus old_loc;
191
  char *buffer;
192
  gfc_expr *e;
193
 
194
  old_loc = gfc_current_locus;
195
  gfc_gobble_whitespace ();
196
 
197
  length = match_digits (signflag, 10, NULL);
198
  gfc_current_locus = old_loc;
199
  if (length == -1)
200
    return MATCH_NO;
201
 
202
  buffer = (char *) alloca (length + 1);
203
  memset (buffer, '\0', length + 1);
204
 
205
  gfc_gobble_whitespace ();
206
 
207
  match_digits (signflag, 10, buffer);
208
 
209
  kind = get_kind ();
210
  if (kind == -2)
211
    kind = gfc_default_integer_kind;
212
  if (kind == -1)
213
    return MATCH_ERROR;
214
 
215
  if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
216
    {
217
      gfc_error ("Integer kind %d at %C not available", kind);
218
      return MATCH_ERROR;
219
    }
220
 
221
  e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
222
 
223
  if (gfc_range_check (e) != ARITH_OK)
224
    {
225
      gfc_error ("Integer too big for its kind at %C. This check can be "
226
                 "disabled with the option -fno-range-check");
227
 
228
      gfc_free_expr (e);
229
      return MATCH_ERROR;
230
    }
231
 
232
  *result = e;
233
  return MATCH_YES;
234
}
235
 
236
 
237
/* Match a Hollerith constant.  */
238
 
239
static match
240
match_hollerith_constant (gfc_expr **result)
241
{
242
  locus old_loc;
243
  gfc_expr *e = NULL;
244
  const char *msg;
245
  int num;
246
  int i;
247
 
248
  old_loc = gfc_current_locus;
249
  gfc_gobble_whitespace ();
250
 
251
  if (match_integer_constant (&e, 0) == MATCH_YES
252
      && gfc_match_char ('h') == MATCH_YES)
253
    {
254
      if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
255
                          "at %C") == FAILURE)
256
        goto cleanup;
257
 
258
      msg = gfc_extract_int (e, &num);
259
      if (msg != NULL)
260
        {
261
          gfc_error (msg);
262
          goto cleanup;
263
        }
264
      if (num == 0)
265
        {
266
          gfc_error ("Invalid Hollerith constant: %L must contain at least "
267
                     "one character", &old_loc);
268
          goto cleanup;
269
        }
270
      if (e->ts.kind != gfc_default_integer_kind)
271
        {
272
          gfc_error ("Invalid Hollerith constant: Integer kind at %L "
273
                     "should be default", &old_loc);
274
          goto cleanup;
275
        }
276
      else
277
        {
278
          gfc_free_expr (e);
279
          e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
280
                                   &gfc_current_locus);
281
 
282
          e->representation.string = XCNEWVEC (char, num + 1);
283
 
284
          for (i = 0; i < num; i++)
285
            {
286
              gfc_char_t c = gfc_next_char_literal (1);
287
              if (! gfc_wide_fits_in_byte (c))
288
                {
289
                  gfc_error ("Invalid Hollerith constant at %L contains a "
290
                             "wide character", &old_loc);
291
                  goto cleanup;
292
                }
293
 
294
              e->representation.string[i] = (unsigned char) c;
295
            }
296
 
297
          e->representation.string[num] = '\0';
298
          e->representation.length = num;
299
 
300
          *result = e;
301
          return MATCH_YES;
302
        }
303
    }
304
 
305
  gfc_free_expr (e);
306
  gfc_current_locus = old_loc;
307
  return MATCH_NO;
308
 
309
cleanup:
310
  gfc_free_expr (e);
311
  return MATCH_ERROR;
312
}
313
 
314
 
315
/* Match a binary, octal or hexadecimal constant that can be found in
316
   a DATA statement.  The standard permits b'010...', o'73...', and
317
   z'a1...' where b, o, and z can be capital letters.  This function
318
   also accepts postfixed forms of the constants: '01...'b, '73...'o,
319
   and 'a1...'z.  An additional extension is the use of x for z.  */
320
 
321
static match
322
match_boz_constant (gfc_expr **result)
323
{
324
  int radix, length, x_hex, kind;
325
  locus old_loc, start_loc;
326
  char *buffer, post, delim;
327
  gfc_expr *e;
328
 
329
  start_loc = old_loc = gfc_current_locus;
330
  gfc_gobble_whitespace ();
331
 
332
  x_hex = 0;
333
  switch (post = gfc_next_ascii_char ())
334
    {
335
    case 'b':
336
      radix = 2;
337
      post = 0;
338
      break;
339
    case 'o':
340
      radix = 8;
341
      post = 0;
342
      break;
343
    case 'x':
344
      x_hex = 1;
345
      /* Fall through.  */
346
    case 'z':
347
      radix = 16;
348
      post = 0;
349
      break;
350
    case '\'':
351
      /* Fall through.  */
352
    case '\"':
353
      delim = post;
354
      post = 1;
355
      radix = 16;  /* Set to accept any valid digit string.  */
356
      break;
357
    default:
358
      goto backup;
359
    }
360
 
361
  /* No whitespace allowed here.  */
362
 
363
  if (post == 0)
364
    delim = gfc_next_ascii_char ();
365
 
366
  if (delim != '\'' && delim != '\"')
367
    goto backup;
368
 
369
  if (x_hex
370
      && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
371
                          "constant at %C uses non-standard syntax")
372
          == FAILURE))
373
      return MATCH_ERROR;
374
 
375
  old_loc = gfc_current_locus;
376
 
377
  length = match_digits (0, radix, NULL);
378
  if (length == -1)
379
    {
380
      gfc_error ("Empty set of digits in BOZ constant at %C");
381
      return MATCH_ERROR;
382
    }
383
 
384
  if (gfc_next_ascii_char () != delim)
385
    {
386
      gfc_error ("Illegal character in BOZ constant at %C");
387
      return MATCH_ERROR;
388
    }
389
 
390
  if (post == 1)
391
    {
392
      switch (gfc_next_ascii_char ())
393
        {
394
        case 'b':
395
          radix = 2;
396
          break;
397
        case 'o':
398
          radix = 8;
399
          break;
400
        case 'x':
401
          /* Fall through.  */
402
        case 'z':
403
          radix = 16;
404
          break;
405
        default:
406
          goto backup;
407
        }
408
 
409
      if (gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
410
                          "at %C uses non-standard postfix syntax")
411
          == FAILURE)
412
        return MATCH_ERROR;
413
    }
414
 
415
  gfc_current_locus = old_loc;
416
 
417
  buffer = (char *) alloca (length + 1);
418
  memset (buffer, '\0', length + 1);
419
 
420
  match_digits (0, radix, buffer);
421
  gfc_next_ascii_char ();    /* Eat delimiter.  */
422
  if (post == 1)
423
    gfc_next_ascii_char ();  /* Eat postfixed b, o, z, or x.  */
424
 
425
  /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
426
     "If a data-stmt-constant is a boz-literal-constant, the corresponding
427
     variable shall be of type integer.  The boz-literal-constant is treated
428
     as if it were an int-literal-constant with a kind-param that specifies
429
     the representation method with the largest decimal exponent range
430
     supported by the processor."  */
431
 
432
  kind = gfc_max_integer_kind;
433
  e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
434
 
435
  /* Mark as boz variable.  */
436
  e->is_boz = 1;
437
 
438
  if (gfc_range_check (e) != ARITH_OK)
439
    {
440
      gfc_error ("Integer too big for integer kind %i at %C", kind);
441
      gfc_free_expr (e);
442
      return MATCH_ERROR;
443
    }
444
 
445
  if (!gfc_in_match_data ()
446
      && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: BOZ used outside a DATA "
447
                          "statement at %C")
448
          == FAILURE))
449
      return MATCH_ERROR;
450
 
451
  *result = e;
452
  return MATCH_YES;
453
 
454
backup:
455
  gfc_current_locus = start_loc;
456
  return MATCH_NO;
457
}
458
 
459
 
460
/* Match a real constant of some sort.  Allow a signed constant if signflag
461
   is nonzero.  */
462
 
463
static match
464
match_real_constant (gfc_expr **result, int signflag)
465
{
466
  int kind, count, seen_dp, seen_digits;
467
  locus old_loc, temp_loc;
468
  char *p, *buffer, c, exp_char;
469
  gfc_expr *e;
470
  bool negate;
471
 
472
  old_loc = gfc_current_locus;
473
  gfc_gobble_whitespace ();
474
 
475
  e = NULL;
476
 
477
  count = 0;
478
  seen_dp = 0;
479
  seen_digits = 0;
480
  exp_char = ' ';
481
  negate = FALSE;
482
 
483
  c = gfc_next_ascii_char ();
484
  if (signflag && (c == '+' || c == '-'))
485
    {
486
      if (c == '-')
487
        negate = TRUE;
488
 
489
      gfc_gobble_whitespace ();
490
      c = gfc_next_ascii_char ();
491
    }
492
 
493
  /* Scan significand.  */
494
  for (;; c = gfc_next_ascii_char (), count++)
495
    {
496
      if (c == '.')
497
        {
498
          if (seen_dp)
499
            goto done;
500
 
501
          /* Check to see if "." goes with a following operator like
502
             ".eq.".  */
503
          temp_loc = gfc_current_locus;
504
          c = gfc_next_ascii_char ();
505
 
506
          if (c == 'e' || c == 'd' || c == 'q')
507
            {
508
              c = gfc_next_ascii_char ();
509
              if (c == '.')
510
                goto done;      /* Operator named .e. or .d.  */
511
            }
512
 
513
          if (ISALPHA (c))
514
            goto done;          /* Distinguish 1.e9 from 1.eq.2 */
515
 
516
          gfc_current_locus = temp_loc;
517
          seen_dp = 1;
518
          continue;
519
        }
520
 
521
      if (ISDIGIT (c))
522
        {
523
          seen_digits = 1;
524
          continue;
525
        }
526
 
527
      break;
528
    }
529
 
530
  if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
531
    goto done;
532
  exp_char = c;
533
 
534
  /* Scan exponent.  */
535
  c = gfc_next_ascii_char ();
536
  count++;
537
 
538
  if (c == '+' || c == '-')
539
    {                           /* optional sign */
540
      c = gfc_next_ascii_char ();
541
      count++;
542
    }
543
 
544
  if (!ISDIGIT (c))
545
    {
546
      gfc_error ("Missing exponent in real number at %C");
547
      return MATCH_ERROR;
548
    }
549
 
550
  while (ISDIGIT (c))
551
    {
552
      c = gfc_next_ascii_char ();
553
      count++;
554
    }
555
 
556
done:
557
  /* Check that we have a numeric constant.  */
558
  if (!seen_digits || (!seen_dp && exp_char == ' '))
559
    {
560
      gfc_current_locus = old_loc;
561
      return MATCH_NO;
562
    }
563
 
564
  /* Convert the number.  */
565
  gfc_current_locus = old_loc;
566
  gfc_gobble_whitespace ();
567
 
568
  buffer = (char *) alloca (count + 1);
569
  memset (buffer, '\0', count + 1);
570
 
571
  p = buffer;
572
  c = gfc_next_ascii_char ();
573
  if (c == '+' || c == '-')
574
    {
575
      gfc_gobble_whitespace ();
576
      c = gfc_next_ascii_char ();
577
    }
578
 
579
  /* Hack for mpfr_set_str().  */
580
  for (;;)
581
    {
582
      if (c == 'd' || c == 'q')
583
        *p = 'e';
584
      else
585
        *p = c;
586
      p++;
587
      if (--count == 0)
588
        break;
589
 
590
      c = gfc_next_ascii_char ();
591
    }
592
 
593
  kind = get_kind ();
594
  if (kind == -1)
595
    goto cleanup;
596
 
597
  switch (exp_char)
598
    {
599
    case 'd':
600
      if (kind != -2)
601
        {
602
          gfc_error ("Real number at %C has a 'd' exponent and an explicit "
603
                     "kind");
604
          goto cleanup;
605
        }
606
      kind = gfc_default_double_kind;
607
      break;
608
 
609
    default:
610
      if (kind == -2)
611
        kind = gfc_default_real_kind;
612
 
613
      if (gfc_validate_kind (BT_REAL, kind, true) < 0)
614
        {
615
          gfc_error ("Invalid real kind %d at %C", kind);
616
          goto cleanup;
617
        }
618
    }
619
 
620
  e = gfc_convert_real (buffer, kind, &gfc_current_locus);
621
  if (negate)
622
    mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
623
 
624
  switch (gfc_range_check (e))
625
    {
626
    case ARITH_OK:
627
      break;
628
    case ARITH_OVERFLOW:
629
      gfc_error ("Real constant overflows its kind at %C");
630
      goto cleanup;
631
 
632
    case ARITH_UNDERFLOW:
633
      if (gfc_option.warn_underflow)
634
        gfc_warning ("Real constant underflows its kind at %C");
635
      mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
636
      break;
637
 
638
    default:
639
      gfc_internal_error ("gfc_range_check() returned bad value");
640
    }
641
 
642
  *result = e;
643
  return MATCH_YES;
644
 
645
cleanup:
646
  gfc_free_expr (e);
647
  return MATCH_ERROR;
648
}
649
 
650
 
651
/* Match a substring reference.  */
652
 
653
static match
654
match_substring (gfc_charlen *cl, int init, gfc_ref **result)
655
{
656
  gfc_expr *start, *end;
657
  locus old_loc;
658
  gfc_ref *ref;
659
  match m;
660
 
661
  start = NULL;
662
  end = NULL;
663
 
664
  old_loc = gfc_current_locus;
665
 
666
  m = gfc_match_char ('(');
667
  if (m != MATCH_YES)
668
    return MATCH_NO;
669
 
670
  if (gfc_match_char (':') != MATCH_YES)
671
    {
672
      if (init)
673
        m = gfc_match_init_expr (&start);
674
      else
675
        m = gfc_match_expr (&start);
676
 
677
      if (m != MATCH_YES)
678
        {
679
          m = MATCH_NO;
680
          goto cleanup;
681
        }
682
 
683
      m = gfc_match_char (':');
684
      if (m != MATCH_YES)
685
        goto cleanup;
686
    }
687
 
688
  if (gfc_match_char (')') != MATCH_YES)
689
    {
690
      if (init)
691
        m = gfc_match_init_expr (&end);
692
      else
693
        m = gfc_match_expr (&end);
694
 
695
      if (m == MATCH_NO)
696
        goto syntax;
697
      if (m == MATCH_ERROR)
698
        goto cleanup;
699
 
700
      m = gfc_match_char (')');
701
      if (m == MATCH_NO)
702
        goto syntax;
703
    }
704
 
705
  /* Optimize away the (:) reference.  */
706
  if (start == NULL && end == NULL)
707
    ref = NULL;
708
  else
709
    {
710
      ref = gfc_get_ref ();
711
 
712
      ref->type = REF_SUBSTRING;
713
      if (start == NULL)
714
        start = gfc_int_expr (1);
715
      ref->u.ss.start = start;
716
      if (end == NULL && cl)
717
        end = gfc_copy_expr (cl->length);
718
      ref->u.ss.end = end;
719
      ref->u.ss.length = cl;
720
    }
721
 
722
  *result = ref;
723
  return MATCH_YES;
724
 
725
syntax:
726
  gfc_error ("Syntax error in SUBSTRING specification at %C");
727
  m = MATCH_ERROR;
728
 
729
cleanup:
730
  gfc_free_expr (start);
731
  gfc_free_expr (end);
732
 
733
  gfc_current_locus = old_loc;
734
  return m;
735
}
736
 
737
 
738
/* Reads the next character of a string constant, taking care to
739
   return doubled delimiters on the input as a single instance of
740
   the delimiter.
741
 
742
   Special return values for "ret" argument are:
743
     -1   End of the string, as determined by the delimiter
744
     -2   Unterminated string detected
745
 
746
   Backslash codes are also expanded at this time.  */
747
 
748
static gfc_char_t
749
next_string_char (gfc_char_t delimiter, int *ret)
750
{
751
  locus old_locus;
752
  gfc_char_t c;
753
 
754
  c = gfc_next_char_literal (1);
755
  *ret = 0;
756
 
757
  if (c == '\n')
758
    {
759
      *ret = -2;
760
      return 0;
761
    }
762
 
763
  if (gfc_option.flag_backslash && c == '\\')
764
    {
765
      old_locus = gfc_current_locus;
766
 
767
      if (gfc_match_special_char (&c) == MATCH_NO)
768
        gfc_current_locus = old_locus;
769
 
770
      if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
771
        gfc_warning ("Extension: backslash character at %C");
772
    }
773
 
774
  if (c != delimiter)
775
    return c;
776
 
777
  old_locus = gfc_current_locus;
778
  c = gfc_next_char_literal (0);
779
 
780
  if (c == delimiter)
781
    return c;
782
  gfc_current_locus = old_locus;
783
 
784
  *ret = -1;
785
  return 0;
786
}
787
 
788
 
789
/* Special case of gfc_match_name() that matches a parameter kind name
790
   before a string constant.  This takes case of the weird but legal
791
   case of:
792
 
793
     kind_____'string'
794
 
795
   where kind____ is a parameter. gfc_match_name() will happily slurp
796
   up all the underscores, which leads to problems.  If we return
797
   MATCH_YES, the parse pointer points to the final underscore, which
798
   is not part of the name.  We never return MATCH_ERROR-- errors in
799
   the name will be detected later.  */
800
 
801
static match
802
match_charkind_name (char *name)
803
{
804
  locus old_loc;
805
  char c, peek;
806
  int len;
807
 
808
  gfc_gobble_whitespace ();
809
  c = gfc_next_ascii_char ();
810
  if (!ISALPHA (c))
811
    return MATCH_NO;
812
 
813
  *name++ = c;
814
  len = 1;
815
 
816
  for (;;)
817
    {
818
      old_loc = gfc_current_locus;
819
      c = gfc_next_ascii_char ();
820
 
821
      if (c == '_')
822
        {
823
          peek = gfc_peek_ascii_char ();
824
 
825
          if (peek == '\'' || peek == '\"')
826
            {
827
              gfc_current_locus = old_loc;
828
              *name = '\0';
829
              return MATCH_YES;
830
            }
831
        }
832
 
833
      if (!ISALNUM (c)
834
          && c != '_'
835
          && (c != '$' || !gfc_option.flag_dollar_ok))
836
        break;
837
 
838
      *name++ = c;
839
      if (++len > GFC_MAX_SYMBOL_LEN)
840
        break;
841
    }
842
 
843
  return MATCH_NO;
844
}
845
 
846
 
847
/* See if the current input matches a character constant.  Lots of
848
   contortions have to be done to match the kind parameter which comes
849
   before the actual string.  The main consideration is that we don't
850
   want to error out too quickly.  For example, we don't actually do
851
   any validation of the kinds until we have actually seen a legal
852
   delimiter.  Using match_kind_param() generates errors too quickly.  */
853
 
854
static match
855
match_string_constant (gfc_expr **result)
856
{
857
  char name[GFC_MAX_SYMBOL_LEN + 1], peek;
858
  int i, kind, length, warn_ampersand, ret;
859
  locus old_locus, start_locus;
860
  gfc_symbol *sym;
861
  gfc_expr *e;
862
  const char *q;
863
  match m;
864
  gfc_char_t c, delimiter, *p;
865
 
866
  old_locus = gfc_current_locus;
867
 
868
  gfc_gobble_whitespace ();
869
 
870
  start_locus = gfc_current_locus;
871
 
872
  c = gfc_next_char ();
873
  if (c == '\'' || c == '"')
874
    {
875
      kind = gfc_default_character_kind;
876
      goto got_delim;
877
    }
878
 
879
  if (gfc_wide_is_digit (c))
880
    {
881
      kind = 0;
882
 
883
      while (gfc_wide_is_digit (c))
884
        {
885
          kind = kind * 10 + c - '0';
886
          if (kind > 9999999)
887
            goto no_match;
888
          c = gfc_next_char ();
889
        }
890
 
891
    }
892
  else
893
    {
894
      gfc_current_locus = old_locus;
895
 
896
      m = match_charkind_name (name);
897
      if (m != MATCH_YES)
898
        goto no_match;
899
 
900
      if (gfc_find_symbol (name, NULL, 1, &sym)
901
          || sym == NULL
902
          || sym->attr.flavor != FL_PARAMETER)
903
        goto no_match;
904
 
905
      kind = -1;
906
      c = gfc_next_char ();
907
    }
908
 
909
  if (c == ' ')
910
    {
911
      gfc_gobble_whitespace ();
912
      c = gfc_next_char ();
913
    }
914
 
915
  if (c != '_')
916
    goto no_match;
917
 
918
  gfc_gobble_whitespace ();
919
  start_locus = gfc_current_locus;
920
 
921
  c = gfc_next_char ();
922
  if (c != '\'' && c != '"')
923
    goto no_match;
924
 
925
  if (kind == -1)
926
    {
927
      q = gfc_extract_int (sym->value, &kind);
928
      if (q != NULL)
929
        {
930
          gfc_error (q);
931
          return MATCH_ERROR;
932
        }
933
      gfc_set_sym_referenced (sym);
934
    }
935
 
936
  if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
937
    {
938
      gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
939
      return MATCH_ERROR;
940
    }
941
 
942
got_delim:
943
  /* Scan the string into a block of memory by first figuring out how
944
     long it is, allocating the structure, then re-reading it.  This
945
     isn't particularly efficient, but string constants aren't that
946
     common in most code.  TODO: Use obstacks?  */
947
 
948
  delimiter = c;
949
  length = 0;
950
 
951
  for (;;)
952
    {
953
      c = next_string_char (delimiter, &ret);
954
      if (ret == -1)
955
        break;
956
      if (ret == -2)
957
        {
958
          gfc_current_locus = start_locus;
959
          gfc_error ("Unterminated character constant beginning at %C");
960
          return MATCH_ERROR;
961
        }
962
 
963
      length++;
964
    }
965
 
966
  /* Peek at the next character to see if it is a b, o, z, or x for the
967
     postfixed BOZ literal constants.  */
968
  peek = gfc_peek_ascii_char ();
969
  if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
970
    goto no_match;
971
 
972
 
973
  e = gfc_get_expr ();
974
 
975
  e->expr_type = EXPR_CONSTANT;
976
  e->ref = NULL;
977
  e->ts.type = BT_CHARACTER;
978
  e->ts.kind = kind;
979
  e->ts.is_c_interop = 0;
980
  e->ts.is_iso_c = 0;
981
  e->where = start_locus;
982
 
983
  e->value.character.string = p = gfc_get_wide_string (length + 1);
984
  e->value.character.length = length;
985
 
986
  gfc_current_locus = start_locus;
987
  gfc_next_char ();             /* Skip delimiter */
988
 
989
  /* We disable the warning for the following loop as the warning has already
990
     been printed in the loop above.  */
991
  warn_ampersand = gfc_option.warn_ampersand;
992
  gfc_option.warn_ampersand = 0;
993
 
994
  for (i = 0; i < length; i++)
995
    {
996
      c = next_string_char (delimiter, &ret);
997
 
998
      if (!gfc_check_character_range (c, kind))
999
        {
1000
          gfc_error ("Character '%s' in string at %C is not representable "
1001
                     "in character kind %d", gfc_print_wide_char (c), kind);
1002
          return MATCH_ERROR;
1003
        }
1004
 
1005
      *p++ = c;
1006
    }
1007
 
1008
  *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
1009
  gfc_option.warn_ampersand = warn_ampersand;
1010
 
1011
  next_string_char (delimiter, &ret);
1012
  if (ret != -1)
1013
    gfc_internal_error ("match_string_constant(): Delimiter not found");
1014
 
1015
  if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
1016
    e->expr_type = EXPR_SUBSTRING;
1017
 
1018
  *result = e;
1019
 
1020
  return MATCH_YES;
1021
 
1022
no_match:
1023
  gfc_current_locus = old_locus;
1024
  return MATCH_NO;
1025
}
1026
 
1027
 
1028
/* Match a .true. or .false.  Returns 1 if a .true. was found,
1029
 
1030
static int
1031
match_logical_constant_string (void)
1032
{
1033
  locus orig_loc = gfc_current_locus;
1034
 
1035
  gfc_gobble_whitespace ();
1036
  if (gfc_next_ascii_char () == '.')
1037
    {
1038
      char ch = gfc_next_ascii_char ();
1039
      if (ch == 'f')
1040
        {
1041
          if (gfc_next_ascii_char () == 'a'
1042
              && gfc_next_ascii_char () == 'l'
1043
              && gfc_next_ascii_char () == 's'
1044
              && gfc_next_ascii_char () == 'e'
1045
              && gfc_next_ascii_char () == '.')
1046
            /* Matched ".false.".  */
1047
            return 0;
1048
        }
1049
      else if (ch == 't')
1050
        {
1051
          if (gfc_next_ascii_char () == 'r'
1052
              && gfc_next_ascii_char () == 'u'
1053
              && gfc_next_ascii_char () == 'e'
1054
              && gfc_next_ascii_char () == '.')
1055
            /* Matched ".true.".  */
1056
            return 1;
1057
        }
1058
    }
1059
  gfc_current_locus = orig_loc;
1060
  return -1;
1061
}
1062
 
1063
/* Match a .true. or .false.  */
1064
 
1065
static match
1066
match_logical_constant (gfc_expr **result)
1067
{
1068
  gfc_expr *e;
1069
  int i, kind;
1070
 
1071
  i = match_logical_constant_string ();
1072
  if (i == -1)
1073
    return MATCH_NO;
1074
 
1075
  kind = get_kind ();
1076
  if (kind == -1)
1077
    return MATCH_ERROR;
1078
  if (kind == -2)
1079
    kind = gfc_default_logical_kind;
1080
 
1081
  if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1082
    {
1083
      gfc_error ("Bad kind for logical constant at %C");
1084
      return MATCH_ERROR;
1085
    }
1086
 
1087
  e = gfc_get_expr ();
1088
 
1089
  e->expr_type = EXPR_CONSTANT;
1090
  e->value.logical = i;
1091
  e->ts.type = BT_LOGICAL;
1092
  e->ts.kind = kind;
1093
  e->ts.is_c_interop = 0;
1094
  e->ts.is_iso_c = 0;
1095
  e->where = gfc_current_locus;
1096
 
1097
  *result = e;
1098
  return MATCH_YES;
1099
}
1100
 
1101
 
1102
/* Match a real or imaginary part of a complex constant that is a
1103
   symbolic constant.  */
1104
 
1105
static match
1106
match_sym_complex_part (gfc_expr **result)
1107
{
1108
  char name[GFC_MAX_SYMBOL_LEN + 1];
1109
  gfc_symbol *sym;
1110
  gfc_expr *e;
1111
  match m;
1112
 
1113
  m = gfc_match_name (name);
1114
  if (m != MATCH_YES)
1115
    return m;
1116
 
1117
  if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1118
    return MATCH_NO;
1119
 
1120
  if (sym->attr.flavor != FL_PARAMETER)
1121
    {
1122
      gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1123
      return MATCH_ERROR;
1124
    }
1125
 
1126
  if (!gfc_numeric_ts (&sym->value->ts))
1127
    {
1128
      gfc_error ("Numeric PARAMETER required in complex constant at %C");
1129
      return MATCH_ERROR;
1130
    }
1131
 
1132
  if (sym->value->rank != 0)
1133
    {
1134
      gfc_error ("Scalar PARAMETER required in complex constant at %C");
1135
      return MATCH_ERROR;
1136
    }
1137
 
1138
  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1139
                      "complex constant at %C") == FAILURE)
1140
    return MATCH_ERROR;
1141
 
1142
  switch (sym->value->ts.type)
1143
    {
1144
    case BT_REAL:
1145
      e = gfc_copy_expr (sym->value);
1146
      break;
1147
 
1148
    case BT_COMPLEX:
1149
      e = gfc_complex2real (sym->value, sym->value->ts.kind);
1150
      if (e == NULL)
1151
        goto error;
1152
      break;
1153
 
1154
    case BT_INTEGER:
1155
      e = gfc_int2real (sym->value, gfc_default_real_kind);
1156
      if (e == NULL)
1157
        goto error;
1158
      break;
1159
 
1160
    default:
1161
      gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1162
    }
1163
 
1164
  *result = e;          /* e is a scalar, real, constant expression.  */
1165
  return MATCH_YES;
1166
 
1167
error:
1168
  gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1169
  return MATCH_ERROR;
1170
}
1171
 
1172
 
1173
/* Match a real or imaginary part of a complex number.  */
1174
 
1175
static match
1176
match_complex_part (gfc_expr **result)
1177
{
1178
  match m;
1179
 
1180
  m = match_sym_complex_part (result);
1181
  if (m != MATCH_NO)
1182
    return m;
1183
 
1184
  m = match_real_constant (result, 1);
1185
  if (m != MATCH_NO)
1186
    return m;
1187
 
1188
  return match_integer_constant (result, 1);
1189
}
1190
 
1191
 
1192
/* Try to match a complex constant.  */
1193
 
1194
static match
1195
match_complex_constant (gfc_expr **result)
1196
{
1197
  gfc_expr *e, *real, *imag;
1198
  gfc_error_buf old_error;
1199
  gfc_typespec target;
1200
  locus old_loc;
1201
  int kind;
1202
  match m;
1203
 
1204
  old_loc = gfc_current_locus;
1205
  real = imag = e = NULL;
1206
 
1207
  m = gfc_match_char ('(');
1208
  if (m != MATCH_YES)
1209
    return m;
1210
 
1211
  gfc_push_error (&old_error);
1212
 
1213
  m = match_complex_part (&real);
1214
  if (m == MATCH_NO)
1215
    {
1216
      gfc_free_error (&old_error);
1217
      goto cleanup;
1218
    }
1219
 
1220
  if (gfc_match_char (',') == MATCH_NO)
1221
    {
1222
      gfc_pop_error (&old_error);
1223
      m = MATCH_NO;
1224
      goto cleanup;
1225
    }
1226
 
1227
  /* If m is error, then something was wrong with the real part and we
1228
     assume we have a complex constant because we've seen the ','.  An
1229
     ambiguous case here is the start of an iterator list of some
1230
     sort. These sort of lists are matched prior to coming here.  */
1231
 
1232
  if (m == MATCH_ERROR)
1233
    {
1234
      gfc_free_error (&old_error);
1235
      goto cleanup;
1236
    }
1237
  gfc_pop_error (&old_error);
1238
 
1239
  m = match_complex_part (&imag);
1240
  if (m == MATCH_NO)
1241
    goto syntax;
1242
  if (m == MATCH_ERROR)
1243
    goto cleanup;
1244
 
1245
  m = gfc_match_char (')');
1246
  if (m == MATCH_NO)
1247
    {
1248
      /* Give the matcher for implied do-loops a chance to run.  This
1249
         yields a much saner error message for (/ (i, 4=i, 6) /).  */
1250
      if (gfc_peek_ascii_char () == '=')
1251
        {
1252
          m = MATCH_ERROR;
1253
          goto cleanup;
1254
        }
1255
      else
1256
    goto syntax;
1257
    }
1258
 
1259
  if (m == MATCH_ERROR)
1260
    goto cleanup;
1261
 
1262
  /* Decide on the kind of this complex number.  */
1263
  if (real->ts.type == BT_REAL)
1264
    {
1265
      if (imag->ts.type == BT_REAL)
1266
        kind = gfc_kind_max (real, imag);
1267
      else
1268
        kind = real->ts.kind;
1269
    }
1270
  else
1271
    {
1272
      if (imag->ts.type == BT_REAL)
1273
        kind = imag->ts.kind;
1274
      else
1275
        kind = gfc_default_real_kind;
1276
    }
1277
  target.type = BT_REAL;
1278
  target.kind = kind;
1279
  target.is_c_interop = 0;
1280
  target.is_iso_c = 0;
1281
 
1282
  if (real->ts.type != BT_REAL || kind != real->ts.kind)
1283
    gfc_convert_type (real, &target, 2);
1284
  if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1285
    gfc_convert_type (imag, &target, 2);
1286
 
1287
  e = gfc_convert_complex (real, imag, kind);
1288
  e->where = gfc_current_locus;
1289
 
1290
  gfc_free_expr (real);
1291
  gfc_free_expr (imag);
1292
 
1293
  *result = e;
1294
  return MATCH_YES;
1295
 
1296
syntax:
1297
  gfc_error ("Syntax error in COMPLEX constant at %C");
1298
  m = MATCH_ERROR;
1299
 
1300
cleanup:
1301
  gfc_free_expr (e);
1302
  gfc_free_expr (real);
1303
  gfc_free_expr (imag);
1304
  gfc_current_locus = old_loc;
1305
 
1306
  return m;
1307
}
1308
 
1309
 
1310
/* Match constants in any of several forms.  Returns nonzero for a
1311
   match, zero for no match.  */
1312
 
1313
match
1314
gfc_match_literal_constant (gfc_expr **result, int signflag)
1315
{
1316
  match m;
1317
 
1318
  m = match_complex_constant (result);
1319
  if (m != MATCH_NO)
1320
    return m;
1321
 
1322
  m = match_string_constant (result);
1323
  if (m != MATCH_NO)
1324
    return m;
1325
 
1326
  m = match_boz_constant (result);
1327
  if (m != MATCH_NO)
1328
    return m;
1329
 
1330
  m = match_real_constant (result, signflag);
1331
  if (m != MATCH_NO)
1332
    return m;
1333
 
1334
  m = match_hollerith_constant (result);
1335
  if (m != MATCH_NO)
1336
    return m;
1337
 
1338
  m = match_integer_constant (result, signflag);
1339
  if (m != MATCH_NO)
1340
    return m;
1341
 
1342
  m = match_logical_constant (result);
1343
  if (m != MATCH_NO)
1344
    return m;
1345
 
1346
  return MATCH_NO;
1347
}
1348
 
1349
 
1350
/* This checks if a symbol is the return value of an encompassing function.
1351
   Function nesting can be maximally two levels deep, but we may have
1352
   additional local namespaces like BLOCK etc.  */
1353
 
1354
bool
1355
gfc_is_function_return_value (gfc_symbol *sym, gfc_namespace *ns)
1356
{
1357
  if (!sym->attr.function || (sym->result != sym))
1358
    return false;
1359
  while (ns)
1360
    {
1361
      if (ns->proc_name == sym)
1362
        return true;
1363
      ns = ns->parent;
1364
    }
1365
  return false;
1366
}
1367
 
1368
 
1369
/* Match a single actual argument value.  An actual argument is
1370
   usually an expression, but can also be a procedure name.  If the
1371
   argument is a single name, it is not always possible to tell
1372
   whether the name is a dummy procedure or not.  We treat these cases
1373
   by creating an argument that looks like a dummy procedure and
1374
   fixing things later during resolution.  */
1375
 
1376
static match
1377
match_actual_arg (gfc_expr **result)
1378
{
1379
  char name[GFC_MAX_SYMBOL_LEN + 1];
1380
  gfc_symtree *symtree;
1381
  locus where, w;
1382
  gfc_expr *e;
1383
  char c;
1384
 
1385
  gfc_gobble_whitespace ();
1386
  where = gfc_current_locus;
1387
 
1388
  switch (gfc_match_name (name))
1389
    {
1390
    case MATCH_ERROR:
1391
      return MATCH_ERROR;
1392
 
1393
    case MATCH_NO:
1394
      break;
1395
 
1396
    case MATCH_YES:
1397
      w = gfc_current_locus;
1398
      gfc_gobble_whitespace ();
1399
      c = gfc_next_ascii_char ();
1400
      gfc_current_locus = w;
1401
 
1402
      if (c != ',' && c != ')')
1403
        break;
1404
 
1405
      if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1406
        break;
1407
      /* Handle error elsewhere.  */
1408
 
1409
      /* Eliminate a couple of common cases where we know we don't
1410
         have a function argument.  */
1411
      if (symtree == NULL)
1412
        {
1413
          gfc_get_sym_tree (name, NULL, &symtree, false);
1414
          gfc_set_sym_referenced (symtree->n.sym);
1415
        }
1416
      else
1417
        {
1418
          gfc_symbol *sym;
1419
 
1420
          sym = symtree->n.sym;
1421
          gfc_set_sym_referenced (sym);
1422
          if (sym->attr.flavor != FL_PROCEDURE
1423
              && sym->attr.flavor != FL_UNKNOWN)
1424
            break;
1425
 
1426
          if (sym->attr.in_common && !sym->attr.proc_pointer)
1427
            {
1428
              gfc_add_flavor (&sym->attr, FL_VARIABLE, sym->name,
1429
                              &sym->declared_at);
1430
              break;
1431
            }
1432
 
1433
          /* If the symbol is a function with itself as the result and
1434
             is being defined, then we have a variable.  */
1435
          if (sym->attr.function && sym->result == sym)
1436
            {
1437
              if (gfc_is_function_return_value (sym, gfc_current_ns))
1438
                break;
1439
 
1440
              if (sym->attr.entry
1441
                  && (sym->ns == gfc_current_ns
1442
                      || sym->ns == gfc_current_ns->parent))
1443
                {
1444
                  gfc_entry_list *el = NULL;
1445
 
1446
                  for (el = sym->ns->entries; el; el = el->next)
1447
                    if (sym == el->sym)
1448
                      break;
1449
 
1450
                  if (el)
1451
                    break;
1452
                }
1453
            }
1454
        }
1455
 
1456
      e = gfc_get_expr ();      /* Leave it unknown for now */
1457
      e->symtree = symtree;
1458
      e->expr_type = EXPR_VARIABLE;
1459
      e->ts.type = BT_PROCEDURE;
1460
      e->where = where;
1461
 
1462
      *result = e;
1463
      return MATCH_YES;
1464
    }
1465
 
1466
  gfc_current_locus = where;
1467
  return gfc_match_expr (result);
1468
}
1469
 
1470
 
1471
/* Match a keyword argument.  */
1472
 
1473
static match
1474
match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1475
{
1476
  char name[GFC_MAX_SYMBOL_LEN + 1];
1477
  gfc_actual_arglist *a;
1478
  locus name_locus;
1479
  match m;
1480
 
1481
  name_locus = gfc_current_locus;
1482
  m = gfc_match_name (name);
1483
 
1484
  if (m != MATCH_YES)
1485
    goto cleanup;
1486
  if (gfc_match_char ('=') != MATCH_YES)
1487
    {
1488
      m = MATCH_NO;
1489
      goto cleanup;
1490
    }
1491
 
1492
  m = match_actual_arg (&actual->expr);
1493
  if (m != MATCH_YES)
1494
    goto cleanup;
1495
 
1496
  /* Make sure this name has not appeared yet.  */
1497
 
1498
  if (name[0] != '\0')
1499
    {
1500
      for (a = base; a; a = a->next)
1501
        if (a->name != NULL && strcmp (a->name, name) == 0)
1502
          {
1503
            gfc_error ("Keyword '%s' at %C has already appeared in the "
1504
                       "current argument list", name);
1505
            return MATCH_ERROR;
1506
          }
1507
    }
1508
 
1509
  actual->name = gfc_get_string (name);
1510
  return MATCH_YES;
1511
 
1512
cleanup:
1513
  gfc_current_locus = name_locus;
1514
  return m;
1515
}
1516
 
1517
 
1518
/* Match an argument list function, such as %VAL.  */
1519
 
1520
static match
1521
match_arg_list_function (gfc_actual_arglist *result)
1522
{
1523
  char name[GFC_MAX_SYMBOL_LEN + 1];
1524
  locus old_locus;
1525
  match m;
1526
 
1527
  old_locus = gfc_current_locus;
1528
 
1529
  if (gfc_match_char ('%') != MATCH_YES)
1530
    {
1531
      m = MATCH_NO;
1532
      goto cleanup;
1533
    }
1534
 
1535
  m = gfc_match ("%n (", name);
1536
  if (m != MATCH_YES)
1537
    goto cleanup;
1538
 
1539
  if (name[0] != '\0')
1540
    {
1541
      switch (name[0])
1542
        {
1543
        case 'l':
1544
          if (strncmp (name, "loc", 3) == 0)
1545
            {
1546
              result->name = "%LOC";
1547
              break;
1548
            }
1549
        case 'r':
1550
          if (strncmp (name, "ref", 3) == 0)
1551
            {
1552
              result->name = "%REF";
1553
              break;
1554
            }
1555
        case 'v':
1556
          if (strncmp (name, "val", 3) == 0)
1557
            {
1558
              result->name = "%VAL";
1559
              break;
1560
            }
1561
        default:
1562
          m = MATCH_ERROR;
1563
          goto cleanup;
1564
        }
1565
    }
1566
 
1567
  if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1568
                      "function at %C") == FAILURE)
1569
    {
1570
      m = MATCH_ERROR;
1571
      goto cleanup;
1572
    }
1573
 
1574
  m = match_actual_arg (&result->expr);
1575
  if (m != MATCH_YES)
1576
    goto cleanup;
1577
 
1578
  if (gfc_match_char (')') != MATCH_YES)
1579
    {
1580
      m = MATCH_NO;
1581
      goto cleanup;
1582
    }
1583
 
1584
  return MATCH_YES;
1585
 
1586
cleanup:
1587
  gfc_current_locus = old_locus;
1588
  return m;
1589
}
1590
 
1591
 
1592
/* Matches an actual argument list of a function or subroutine, from
1593
   the opening parenthesis to the closing parenthesis.  The argument
1594
   list is assumed to allow keyword arguments because we don't know if
1595
   the symbol associated with the procedure has an implicit interface
1596
   or not.  We make sure keywords are unique. If sub_flag is set,
1597
   we're matching the argument list of a subroutine.  */
1598
 
1599
match
1600
gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1601
{
1602
  gfc_actual_arglist *head, *tail;
1603
  int seen_keyword;
1604
  gfc_st_label *label;
1605
  locus old_loc;
1606
  match m;
1607
 
1608
  *argp = tail = NULL;
1609
  old_loc = gfc_current_locus;
1610
 
1611
  seen_keyword = 0;
1612
 
1613
  if (gfc_match_char ('(') == MATCH_NO)
1614
    return (sub_flag) ? MATCH_YES : MATCH_NO;
1615
 
1616
  if (gfc_match_char (')') == MATCH_YES)
1617
    return MATCH_YES;
1618
  head = NULL;
1619
 
1620
  for (;;)
1621
    {
1622
      if (head == NULL)
1623
        head = tail = gfc_get_actual_arglist ();
1624
      else
1625
        {
1626
          tail->next = gfc_get_actual_arglist ();
1627
          tail = tail->next;
1628
        }
1629
 
1630
      if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1631
        {
1632
          m = gfc_match_st_label (&label);
1633
          if (m == MATCH_NO)
1634
            gfc_error ("Expected alternate return label at %C");
1635
          if (m != MATCH_YES)
1636
            goto cleanup;
1637
 
1638
          tail->label = label;
1639
          goto next;
1640
        }
1641
 
1642
      /* After the first keyword argument is seen, the following
1643
         arguments must also have keywords.  */
1644
      if (seen_keyword)
1645
        {
1646
          m = match_keyword_arg (tail, head);
1647
 
1648
          if (m == MATCH_ERROR)
1649
            goto cleanup;
1650
          if (m == MATCH_NO)
1651
            {
1652
              gfc_error ("Missing keyword name in actual argument list at %C");
1653
              goto cleanup;
1654
            }
1655
 
1656
        }
1657
      else
1658
        {
1659
          /* Try an argument list function, like %VAL.  */
1660
          m = match_arg_list_function (tail);
1661
          if (m == MATCH_ERROR)
1662
            goto cleanup;
1663
 
1664
          /* See if we have the first keyword argument.  */
1665
          if (m == MATCH_NO)
1666
            {
1667
              m = match_keyword_arg (tail, head);
1668
              if (m == MATCH_YES)
1669
                seen_keyword = 1;
1670
              if (m == MATCH_ERROR)
1671
                goto cleanup;
1672
            }
1673
 
1674
          if (m == MATCH_NO)
1675
            {
1676
              /* Try for a non-keyword argument.  */
1677
              m = match_actual_arg (&tail->expr);
1678
              if (m == MATCH_ERROR)
1679
                goto cleanup;
1680
              if (m == MATCH_NO)
1681
                goto syntax;
1682
            }
1683
        }
1684
 
1685
 
1686
    next:
1687
      if (gfc_match_char (')') == MATCH_YES)
1688
        break;
1689
      if (gfc_match_char (',') != MATCH_YES)
1690
        goto syntax;
1691
    }
1692
 
1693
  *argp = head;
1694
  return MATCH_YES;
1695
 
1696
syntax:
1697
  gfc_error ("Syntax error in argument list at %C");
1698
 
1699
cleanup:
1700
  gfc_free_actual_arglist (head);
1701
  gfc_current_locus = old_loc;
1702
 
1703
  return MATCH_ERROR;
1704
}
1705
 
1706
 
1707
/* Used by gfc_match_varspec() to extend the reference list by one
1708
   element.  */
1709
 
1710
static gfc_ref *
1711
extend_ref (gfc_expr *primary, gfc_ref *tail)
1712
{
1713
  if (primary->ref == NULL)
1714
    primary->ref = tail = gfc_get_ref ();
1715
  else
1716
    {
1717
      if (tail == NULL)
1718
        gfc_internal_error ("extend_ref(): Bad tail");
1719
      tail->next = gfc_get_ref ();
1720
      tail = tail->next;
1721
    }
1722
 
1723
  return tail;
1724
}
1725
 
1726
 
1727
/* Match any additional specifications associated with the current
1728
   variable like member references or substrings.  If equiv_flag is
1729
   set we only match stuff that is allowed inside an EQUIVALENCE
1730
   statement.  sub_flag tells whether we expect a type-bound procedure found
1731
   to be a subroutine as part of CALL or a FUNCTION. For procedure pointer
1732
   components, 'ppc_arg' determines whether the PPC may be called (with an
1733
   argument list), or whether it may just be referred to as a pointer.  */
1734
 
1735
match
1736
gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
1737
                   bool ppc_arg)
1738
{
1739
  char name[GFC_MAX_SYMBOL_LEN + 1];
1740
  gfc_ref *substring, *tail;
1741
  gfc_component *component;
1742
  gfc_symbol *sym = primary->symtree->n.sym;
1743
  match m;
1744
  bool unknown;
1745
 
1746
  tail = NULL;
1747
 
1748
  gfc_gobble_whitespace ();
1749
  if ((equiv_flag && gfc_peek_ascii_char () == '(')
1750
      || (sym->attr.dimension && !sym->attr.proc_pointer
1751
          && !gfc_is_proc_ptr_comp (primary, NULL)
1752
          && !(gfc_matching_procptr_assignment
1753
               && sym->attr.flavor == FL_PROCEDURE))
1754
      || (sym->ts.type == BT_CLASS
1755
          && sym->ts.u.derived->components->attr.dimension))
1756
    {
1757
      /* In EQUIVALENCE, we don't know yet whether we are seeing
1758
         an array, character variable or array of character
1759
         variables.  We'll leave the decision till resolve time.  */
1760
      tail = extend_ref (primary, tail);
1761
      tail->type = REF_ARRAY;
1762
 
1763
      m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1764
                               equiv_flag);
1765
      if (m != MATCH_YES)
1766
        return m;
1767
 
1768
      gfc_gobble_whitespace ();
1769
      if (equiv_flag && gfc_peek_ascii_char () == '(')
1770
        {
1771
          tail = extend_ref (primary, tail);
1772
          tail->type = REF_ARRAY;
1773
 
1774
          m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1775
          if (m != MATCH_YES)
1776
            return m;
1777
        }
1778
    }
1779
 
1780
  primary->ts = sym->ts;
1781
 
1782
  if (equiv_flag)
1783
    return MATCH_YES;
1784
 
1785
  if (sym->ts.type == BT_UNKNOWN && gfc_peek_ascii_char () == '%'
1786
      && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
1787
    gfc_set_default_type (sym, 0, sym->ns);
1788
 
1789
  if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
1790
      || gfc_match_char ('%') != MATCH_YES)
1791
    goto check_substring;
1792
 
1793
  sym = sym->ts.u.derived;
1794
 
1795
  for (;;)
1796
    {
1797
      gfc_try t;
1798
      gfc_symtree *tbp;
1799
 
1800
      m = gfc_match_name (name);
1801
      if (m == MATCH_NO)
1802
        gfc_error ("Expected structure component name at %C");
1803
      if (m != MATCH_YES)
1804
        return MATCH_ERROR;
1805
 
1806
      if (sym->f2k_derived)
1807
        tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus);
1808
      else
1809
        tbp = NULL;
1810
 
1811
      if (tbp)
1812
        {
1813
          gfc_symbol* tbp_sym;
1814
 
1815
          if (t == FAILURE)
1816
            return MATCH_ERROR;
1817
 
1818
          gcc_assert (!tail || !tail->next);
1819
          gcc_assert (primary->expr_type == EXPR_VARIABLE);
1820
 
1821
          if (tbp->n.tb->is_generic)
1822
            tbp_sym = NULL;
1823
          else
1824
            tbp_sym = tbp->n.tb->u.specific->n.sym;
1825
 
1826
          primary->expr_type = EXPR_COMPCALL;
1827
          primary->value.compcall.tbp = tbp->n.tb;
1828
          primary->value.compcall.name = tbp->name;
1829
          primary->value.compcall.ignore_pass = 0;
1830
          primary->value.compcall.assign = 0;
1831
          primary->value.compcall.base_object = NULL;
1832
          gcc_assert (primary->symtree->n.sym->attr.referenced);
1833
          if (tbp_sym)
1834
            primary->ts = tbp_sym->ts;
1835
 
1836
          m = gfc_match_actual_arglist (tbp->n.tb->subroutine,
1837
                                        &primary->value.compcall.actual);
1838
          if (m == MATCH_ERROR)
1839
            return MATCH_ERROR;
1840
          if (m == MATCH_NO)
1841
            {
1842
              if (sub_flag)
1843
                primary->value.compcall.actual = NULL;
1844
              else
1845
                {
1846
                  gfc_error ("Expected argument list at %C");
1847
                  return MATCH_ERROR;
1848
                }
1849
            }
1850
 
1851
          break;
1852
        }
1853
 
1854
      component = gfc_find_component (sym, name, false, false);
1855
      if (component == NULL)
1856
        return MATCH_ERROR;
1857
 
1858
      tail = extend_ref (primary, tail);
1859
      tail->type = REF_COMPONENT;
1860
 
1861
      tail->u.c.component = component;
1862
      tail->u.c.sym = sym;
1863
 
1864
      primary->ts = component->ts;
1865
 
1866
      if (component->attr.proc_pointer && ppc_arg
1867
          && !gfc_matching_procptr_assignment)
1868
        {
1869
          m = gfc_match_actual_arglist (sub_flag,
1870
                                        &primary->value.compcall.actual);
1871
          if (m == MATCH_ERROR)
1872
            return MATCH_ERROR;
1873
          if (m == MATCH_YES)
1874
            primary->expr_type = EXPR_PPC;
1875
 
1876
          break;
1877
        }
1878
 
1879
      if (component->as != NULL && !component->attr.proc_pointer)
1880
        {
1881
          tail = extend_ref (primary, tail);
1882
          tail->type = REF_ARRAY;
1883
 
1884
          m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1885
          if (m != MATCH_YES)
1886
            return m;
1887
        }
1888
      else if (component->ts.type == BT_CLASS
1889
               && component->ts.u.derived->components->as != NULL
1890
               && !component->attr.proc_pointer)
1891
        {
1892
          tail = extend_ref (primary, tail);
1893
          tail->type = REF_ARRAY;
1894
 
1895
          m = gfc_match_array_ref (&tail->u.ar,
1896
                                   component->ts.u.derived->components->as,
1897
                                   equiv_flag);
1898
          if (m != MATCH_YES)
1899
            return m;
1900
        }
1901
 
1902
      if ((component->ts.type != BT_DERIVED && component->ts.type != BT_CLASS)
1903
          || gfc_match_char ('%') != MATCH_YES)
1904
        break;
1905
 
1906
      sym = component->ts.u.derived;
1907
    }
1908
 
1909
check_substring:
1910
  unknown = false;
1911
  if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED)
1912
    {
1913
      if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER)
1914
       {
1915
         gfc_set_default_type (sym, 0, sym->ns);
1916
         primary->ts = sym->ts;
1917
         unknown = true;
1918
       }
1919
    }
1920
 
1921
  if (primary->ts.type == BT_CHARACTER)
1922
    {
1923
      switch (match_substring (primary->ts.u.cl, equiv_flag, &substring))
1924
        {
1925
        case MATCH_YES:
1926
          if (tail == NULL)
1927
            primary->ref = substring;
1928
          else
1929
            tail->next = substring;
1930
 
1931
          if (primary->expr_type == EXPR_CONSTANT)
1932
            primary->expr_type = EXPR_SUBSTRING;
1933
 
1934
          if (substring)
1935
            primary->ts.u.cl = NULL;
1936
 
1937
          break;
1938
 
1939
        case MATCH_NO:
1940
          if (unknown)
1941
            {
1942
              gfc_clear_ts (&primary->ts);
1943
              gfc_clear_ts (&sym->ts);
1944
            }
1945
          break;
1946
 
1947
        case MATCH_ERROR:
1948
          return MATCH_ERROR;
1949
        }
1950
    }
1951
 
1952
  return MATCH_YES;
1953
}
1954
 
1955
 
1956
/* Given an expression that is a variable, figure out what the
1957
   ultimate variable's type and attribute is, traversing the reference
1958
   structures if necessary.
1959
 
1960
   This subroutine is trickier than it looks.  We start at the base
1961
   symbol and store the attribute.  Component references load a
1962
   completely new attribute.
1963
 
1964
   A couple of rules come into play.  Subobjects of targets are always
1965
   targets themselves.  If we see a component that goes through a
1966
   pointer, then the expression must also be a target, since the
1967
   pointer is associated with something (if it isn't core will soon be
1968
   dumped).  If we see a full part or section of an array, the
1969
   expression is also an array.
1970
 
1971
   We can have at most one full array reference.  */
1972
 
1973
symbol_attribute
1974
gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1975
{
1976
  int dimension, pointer, allocatable, target;
1977
  symbol_attribute attr;
1978
  gfc_ref *ref;
1979
  gfc_symbol *sym;
1980
  gfc_component *comp;
1981
 
1982
  if (expr->expr_type != EXPR_VARIABLE && expr->expr_type != EXPR_FUNCTION)
1983
    gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1984
 
1985
  ref = expr->ref;
1986
  sym = expr->symtree->n.sym;
1987
  attr = sym->attr;
1988
 
1989
  if (sym->ts.type == BT_CLASS)
1990
    {
1991
      dimension = sym->ts.u.derived->components->attr.dimension;
1992
      pointer = sym->ts.u.derived->components->attr.pointer;
1993
      allocatable = sym->ts.u.derived->components->attr.allocatable;
1994
    }
1995
  else
1996
    {
1997
      dimension = attr.dimension;
1998
      pointer = attr.pointer;
1999
      allocatable = attr.allocatable;
2000
    }
2001
 
2002
  target = attr.target;
2003
  if (pointer || attr.proc_pointer)
2004
    target = 1;
2005
 
2006
  if (ts != NULL && expr->ts.type == BT_UNKNOWN)
2007
    *ts = sym->ts;
2008
 
2009
  for (; ref; ref = ref->next)
2010
    switch (ref->type)
2011
      {
2012
      case REF_ARRAY:
2013
 
2014
        switch (ref->u.ar.type)
2015
          {
2016
          case AR_FULL:
2017
            dimension = 1;
2018
            break;
2019
 
2020
          case AR_SECTION:
2021
            allocatable = pointer = 0;
2022
            dimension = 1;
2023
            break;
2024
 
2025
          case AR_ELEMENT:
2026
            allocatable = pointer = 0;
2027
            break;
2028
 
2029
          case AR_UNKNOWN:
2030
            gfc_internal_error ("gfc_variable_attr(): Bad array reference");
2031
          }
2032
 
2033
        break;
2034
 
2035
      case REF_COMPONENT:
2036
        comp = ref->u.c.component;
2037
        attr = comp->attr;
2038
        if (ts != NULL)
2039
          {
2040
            *ts = comp->ts;
2041
            /* Don't set the string length if a substring reference
2042
               follows.  */
2043
            if (ts->type == BT_CHARACTER
2044
                && ref->next && ref->next->type == REF_SUBSTRING)
2045
                ts->u.cl = NULL;
2046
          }
2047
 
2048
        if (comp->ts.type == BT_CLASS)
2049
          {
2050
            pointer = comp->ts.u.derived->components->attr.pointer;
2051
            allocatable = comp->ts.u.derived->components->attr.allocatable;
2052
          }
2053
        else
2054
          {
2055
            pointer = comp->attr.pointer;
2056
            allocatable = comp->attr.allocatable;
2057
          }
2058
        if (pointer || attr.proc_pointer)
2059
          target = 1;
2060
 
2061
        break;
2062
 
2063
      case REF_SUBSTRING:
2064
        allocatable = pointer = 0;
2065
        break;
2066
      }
2067
 
2068
  attr.dimension = dimension;
2069
  attr.pointer = pointer;
2070
  attr.allocatable = allocatable;
2071
  attr.target = target;
2072
 
2073
  return attr;
2074
}
2075
 
2076
 
2077
/* Return the attribute from a general expression.  */
2078
 
2079
symbol_attribute
2080
gfc_expr_attr (gfc_expr *e)
2081
{
2082
  symbol_attribute attr;
2083
 
2084
  switch (e->expr_type)
2085
    {
2086
    case EXPR_VARIABLE:
2087
      attr = gfc_variable_attr (e, NULL);
2088
      break;
2089
 
2090
    case EXPR_FUNCTION:
2091
      gfc_clear_attr (&attr);
2092
 
2093
      if (e->value.function.esym != NULL)
2094
        {
2095
          gfc_symbol *sym = e->value.function.esym->result;
2096
          attr = sym->attr;
2097
          if (sym->ts.type == BT_CLASS)
2098
            {
2099
              attr.dimension = sym->ts.u.derived->components->attr.dimension;
2100
              attr.pointer = sym->ts.u.derived->components->attr.pointer;
2101
              attr.allocatable = sym->ts.u.derived->components->attr.allocatable;
2102
            }
2103
        }
2104
      else
2105
        attr = gfc_variable_attr (e, NULL);
2106
 
2107
      /* TODO: NULL() returns pointers.  May have to take care of this
2108
         here.  */
2109
 
2110
      break;
2111
 
2112
    default:
2113
      gfc_clear_attr (&attr);
2114
      break;
2115
    }
2116
 
2117
  return attr;
2118
}
2119
 
2120
 
2121
/* Match a structure constructor.  The initial symbol has already been
2122
   seen.  */
2123
 
2124
typedef struct gfc_structure_ctor_component
2125
{
2126
  char* name;
2127
  gfc_expr* val;
2128
  locus where;
2129
  struct gfc_structure_ctor_component* next;
2130
}
2131
gfc_structure_ctor_component;
2132
 
2133
#define gfc_get_structure_ctor_component() XCNEW (gfc_structure_ctor_component)
2134
 
2135
static void
2136
gfc_free_structure_ctor_component (gfc_structure_ctor_component *comp)
2137
{
2138
  gfc_free (comp->name);
2139
  gfc_free_expr (comp->val);
2140
}
2141
 
2142
 
2143
/* Translate the component list into the actual constructor by sorting it in
2144
   the order required; this also checks along the way that each and every
2145
   component actually has an initializer and handles default initializers
2146
   for components without explicit value given.  */
2147
static gfc_try
2148
build_actual_constructor (gfc_structure_ctor_component **comp_head,
2149
                          gfc_constructor **ctor_head, gfc_symbol *sym)
2150
{
2151
  gfc_structure_ctor_component *comp_iter;
2152
  gfc_constructor *ctor_tail = NULL;
2153
  gfc_component *comp;
2154
 
2155
  for (comp = sym->components; comp; comp = comp->next)
2156
    {
2157
      gfc_structure_ctor_component **next_ptr;
2158
      gfc_expr *value = NULL;
2159
 
2160
      /* Try to find the initializer for the current component by name.  */
2161
      next_ptr = comp_head;
2162
      for (comp_iter = *comp_head; comp_iter; comp_iter = comp_iter->next)
2163
        {
2164
          if (!strcmp (comp_iter->name, comp->name))
2165
            break;
2166
          next_ptr = &comp_iter->next;
2167
        }
2168
 
2169
      /* If an extension, try building the parent derived type by building
2170
         a value expression for the parent derived type and calling self.  */
2171
      if (!comp_iter && comp == sym->components && sym->attr.extension)
2172
        {
2173
          value = gfc_get_expr ();
2174
          value->expr_type = EXPR_STRUCTURE;
2175
          value->value.constructor = NULL;
2176
          value->ts = comp->ts;
2177
          value->where = gfc_current_locus;
2178
 
2179
          if (build_actual_constructor (comp_head, &value->value.constructor,
2180
                                        comp->ts.u.derived) == FAILURE)
2181
            {
2182
              gfc_free_expr (value);
2183
              return FAILURE;
2184
            }
2185
          *ctor_head = ctor_tail = gfc_get_constructor ();
2186
          ctor_tail->expr = value;
2187
          continue;
2188
        }
2189
 
2190
      /* If it was not found, try the default initializer if there's any;
2191
         otherwise, it's an error.  */
2192
      if (!comp_iter)
2193
        {
2194
          if (comp->initializer)
2195
            {
2196
              if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2197
                                  " constructor with missing optional arguments"
2198
                                  " at %C") == FAILURE)
2199
                return FAILURE;
2200
              value = gfc_copy_expr (comp->initializer);
2201
            }
2202
          else
2203
            {
2204
              gfc_error ("No initializer for component '%s' given in the"
2205
                         " structure constructor at %C!", comp->name);
2206
              return FAILURE;
2207
            }
2208
        }
2209
      else
2210
        value = comp_iter->val;
2211
 
2212
      /* Add the value to the constructor chain built.  */
2213
      if (ctor_tail)
2214
        {
2215
          ctor_tail->next = gfc_get_constructor ();
2216
          ctor_tail = ctor_tail->next;
2217
        }
2218
      else
2219
        *ctor_head = ctor_tail = gfc_get_constructor ();
2220
      gcc_assert (value);
2221
      ctor_tail->expr = value;
2222
 
2223
      /* Remove the entry from the component list.  We don't want the expression
2224
         value to be free'd, so set it to NULL.  */
2225
      if (comp_iter)
2226
        {
2227
          *next_ptr = comp_iter->next;
2228
          comp_iter->val = NULL;
2229
          gfc_free_structure_ctor_component (comp_iter);
2230
        }
2231
    }
2232
  return SUCCESS;
2233
}
2234
 
2235
match
2236
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
2237
                                 bool parent)
2238
{
2239
  gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
2240
  gfc_constructor *ctor_head, *ctor_tail;
2241
  gfc_component *comp; /* Is set NULL when named component is first seen */
2242
  gfc_expr *e;
2243
  locus where;
2244
  match m;
2245
  const char* last_name = NULL;
2246
 
2247
  comp_tail = comp_head = NULL;
2248
  ctor_head = ctor_tail = NULL;
2249
 
2250
  if (!parent && gfc_match_char ('(') != MATCH_YES)
2251
    goto syntax;
2252
 
2253
  where = gfc_current_locus;
2254
 
2255
  gfc_find_component (sym, NULL, false, true);
2256
 
2257
  /* Check that we're not about to construct an ABSTRACT type.  */
2258
  if (!parent && sym->attr.abstract)
2259
    {
2260
      gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
2261
      return MATCH_ERROR;
2262
    }
2263
 
2264
  /* Match the component list and store it in a list together with the
2265
     corresponding component names.  Check for empty argument list first.  */
2266
  if (gfc_match_char (')') != MATCH_YES)
2267
    {
2268
      comp = sym->components;
2269
      do
2270
        {
2271
          gfc_component *this_comp = NULL;
2272
 
2273
          if (!comp_head)
2274
            comp_tail = comp_head = gfc_get_structure_ctor_component ();
2275
          else
2276
            {
2277
              comp_tail->next = gfc_get_structure_ctor_component ();
2278
              comp_tail = comp_tail->next;
2279
            }
2280
          comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
2281
          comp_tail->val = NULL;
2282
          comp_tail->where = gfc_current_locus;
2283
 
2284
          /* Try matching a component name.  */
2285
          if (gfc_match_name (comp_tail->name) == MATCH_YES
2286
              && gfc_match_char ('=') == MATCH_YES)
2287
            {
2288
              if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
2289
                                  " constructor with named arguments at %C")
2290
                  == FAILURE)
2291
                goto cleanup;
2292
 
2293
              last_name = comp_tail->name;
2294
              comp = NULL;
2295
            }
2296
          else
2297
            {
2298
              /* Components without name are not allowed after the first named
2299
                 component initializer!  */
2300
              if (!comp)
2301
                {
2302
                  if (last_name)
2303
                    gfc_error ("Component initializer without name after"
2304
                               " component named %s at %C!", last_name);
2305
                  else if (!parent)
2306
                    gfc_error ("Too many components in structure constructor at"
2307
                               " %C!");
2308
                  goto cleanup;
2309
                }
2310
 
2311
              gfc_current_locus = comp_tail->where;
2312
              strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
2313
            }
2314
 
2315
          /* Find the current component in the structure definition and check
2316
             its access is not private.  */
2317
          if (comp)
2318
            this_comp = gfc_find_component (sym, comp->name, false, false);
2319
          else
2320
            {
2321
              this_comp = gfc_find_component (sym,
2322
                                              (const char *)comp_tail->name,
2323
                                              false, false);
2324
              comp = NULL; /* Reset needed!  */
2325
            }
2326
 
2327
          /* Here we can check if a component name is given which does not
2328
             correspond to any component of the defined structure.  */
2329
          if (!this_comp)
2330
            goto cleanup;
2331
 
2332
          /* Check if this component is already given a value.  */
2333
          for (comp_iter = comp_head; comp_iter != comp_tail;
2334
               comp_iter = comp_iter->next)
2335
            {
2336
              gcc_assert (comp_iter);
2337
              if (!strcmp (comp_iter->name, comp_tail->name))
2338
                {
2339
                  gfc_error ("Component '%s' is initialized twice in the"
2340
                             " structure constructor at %C!", comp_tail->name);
2341
                  goto cleanup;
2342
                }
2343
            }
2344
 
2345
          /* Match the current initializer expression.  */
2346
          m = gfc_match_expr (&comp_tail->val);
2347
          if (m == MATCH_NO)
2348
            goto syntax;
2349
          if (m == MATCH_ERROR)
2350
            goto cleanup;
2351
 
2352
          /* If not explicitly a parent constructor, gather up the components
2353
             and build one.  */
2354
          if (comp && comp == sym->components
2355
                && sym->attr.extension
2356
                && (comp_tail->val->ts.type != BT_DERIVED
2357
                      ||
2358
                    comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
2359
            {
2360
              gfc_current_locus = where;
2361
              gfc_free_expr (comp_tail->val);
2362
              comp_tail->val = NULL;
2363
 
2364
              m = gfc_match_structure_constructor (comp->ts.u.derived,
2365
                                                   &comp_tail->val, true);
2366
              if (m == MATCH_NO)
2367
                goto syntax;
2368
              if (m == MATCH_ERROR)
2369
                goto cleanup;
2370
            }
2371
 
2372
          if (comp)
2373
            comp = comp->next;
2374
 
2375
          if (parent && !comp)
2376
            break;
2377
        }
2378
 
2379
      while (gfc_match_char (',') == MATCH_YES);
2380
 
2381
      if (!parent && gfc_match_char (')') != MATCH_YES)
2382
        goto syntax;
2383
    }
2384
 
2385
  if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
2386
    goto cleanup;
2387
 
2388
  /* No component should be left, as this should have caused an error in the
2389
     loop constructing the component-list (name that does not correspond to any
2390
     component in the structure definition).  */
2391
  if (comp_head && sym->attr.extension)
2392
    {
2393
      for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
2394
        {
2395
          gfc_error ("component '%s' at %L has already been set by a "
2396
                     "parent derived type constructor", comp_iter->name,
2397
                     &comp_iter->where);
2398
        }
2399
      goto cleanup;
2400
    }
2401
  else
2402
    gcc_assert (!comp_head);
2403
 
2404
  e = gfc_get_expr ();
2405
 
2406
  e->expr_type = EXPR_STRUCTURE;
2407
 
2408
  e->ts.type = BT_DERIVED;
2409
  e->ts.u.derived = sym;
2410
  e->where = where;
2411
 
2412
  e->value.constructor = ctor_head;
2413
 
2414
  *result = e;
2415
  return MATCH_YES;
2416
 
2417
syntax:
2418
  gfc_error ("Syntax error in structure constructor at %C");
2419
 
2420
cleanup:
2421
  for (comp_iter = comp_head; comp_iter; )
2422
    {
2423
      gfc_structure_ctor_component *next = comp_iter->next;
2424
      gfc_free_structure_ctor_component (comp_iter);
2425
      comp_iter = next;
2426
    }
2427
  gfc_free_constructor (ctor_head);
2428
  return MATCH_ERROR;
2429
}
2430
 
2431
 
2432
/* If the symbol is an implicit do loop index and implicitly typed,
2433
   it should not be host associated.  Provide a symtree from the
2434
   current namespace.  */
2435
static match
2436
check_for_implicit_index (gfc_symtree **st, gfc_symbol **sym)
2437
{
2438
  if ((*sym)->attr.flavor == FL_VARIABLE
2439
      && (*sym)->ns != gfc_current_ns
2440
      && (*sym)->attr.implied_index
2441
      && (*sym)->attr.implicit_type
2442
      && !(*sym)->attr.use_assoc)
2443
    {
2444
      int i;
2445
      i = gfc_get_sym_tree ((*sym)->name, NULL, st, false);
2446
      if (i)
2447
        return MATCH_ERROR;
2448
      *sym = (*st)->n.sym;
2449
    }
2450
  return MATCH_YES;
2451
}
2452
 
2453
 
2454
/* Procedure pointer as function result: Replace the function symbol by the
2455
   auto-generated hidden result variable named "ppr@".  */
2456
 
2457
static gfc_try
2458
replace_hidden_procptr_result (gfc_symbol **sym, gfc_symtree **st)
2459
{
2460
  /* Check for procedure pointer result variable.  */
2461
  if ((*sym)->attr.function && !(*sym)->attr.external
2462
      && (*sym)->result && (*sym)->result != *sym
2463
      && (*sym)->result->attr.proc_pointer
2464
      && (*sym) == gfc_current_ns->proc_name
2465
      && (*sym) == (*sym)->result->ns->proc_name
2466
      && strcmp ("ppr@", (*sym)->result->name) == 0)
2467
    {
2468
      /* Automatic replacement with "hidden" result variable.  */
2469
      (*sym)->result->attr.referenced = (*sym)->attr.referenced;
2470
      *sym = (*sym)->result;
2471
      *st = gfc_find_symtree ((*sym)->ns->sym_root, (*sym)->name);
2472
      return SUCCESS;
2473
    }
2474
  return FAILURE;
2475
}
2476
 
2477
 
2478
/* Matches a variable name followed by anything that might follow it--
2479
   array reference, argument list of a function, etc.  */
2480
 
2481
match
2482
gfc_match_rvalue (gfc_expr **result)
2483
{
2484
  gfc_actual_arglist *actual_arglist;
2485
  char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2486
  gfc_state_data *st;
2487
  gfc_symbol *sym;
2488
  gfc_symtree *symtree;
2489
  locus where, old_loc;
2490
  gfc_expr *e;
2491
  match m, m2;
2492
  int i;
2493
  gfc_typespec *ts;
2494
  bool implicit_char;
2495
  gfc_ref *ref;
2496
 
2497
  m = gfc_match_name (name);
2498
  if (m != MATCH_YES)
2499
    return m;
2500
 
2501
  if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2502
      && !gfc_current_ns->has_import_set)
2503
    i = gfc_get_sym_tree (name, NULL, &symtree, false);
2504
  else
2505
    i = gfc_get_ha_sym_tree (name, &symtree);
2506
 
2507
  if (i)
2508
    return MATCH_ERROR;
2509
 
2510
  sym = symtree->n.sym;
2511
  e = NULL;
2512
  where = gfc_current_locus;
2513
 
2514
  replace_hidden_procptr_result (&sym, &symtree);
2515
 
2516
  /* If this is an implicit do loop index and implicitly typed,
2517
     it should not be host associated.  */
2518
  m = check_for_implicit_index (&symtree, &sym);
2519
  if (m != MATCH_YES)
2520
    return m;
2521
 
2522
  gfc_set_sym_referenced (sym);
2523
  sym->attr.implied_index = 0;
2524
 
2525
  if (sym->attr.function && sym->result == sym)
2526
    {
2527
      /* See if this is a directly recursive function call.  */
2528
      gfc_gobble_whitespace ();
2529
      if (sym->attr.recursive
2530
          && gfc_peek_ascii_char () == '('
2531
          && gfc_current_ns->proc_name == sym
2532
          && !sym->attr.dimension)
2533
        {
2534
          gfc_error ("'%s' at %C is the name of a recursive function "
2535
                     "and so refers to the result variable. Use an "
2536
                     "explicit RESULT variable for direct recursion "
2537
                     "(12.5.2.1)", sym->name);
2538
          return MATCH_ERROR;
2539
        }
2540
 
2541
      if (gfc_is_function_return_value (sym, gfc_current_ns))
2542
        goto variable;
2543
 
2544
      if (sym->attr.entry
2545
          && (sym->ns == gfc_current_ns
2546
              || sym->ns == gfc_current_ns->parent))
2547
        {
2548
          gfc_entry_list *el = NULL;
2549
 
2550
          for (el = sym->ns->entries; el; el = el->next)
2551
            if (sym == el->sym)
2552
              goto variable;
2553
        }
2554
    }
2555
 
2556
  if (gfc_matching_procptr_assignment)
2557
    goto procptr0;
2558
 
2559
  if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2560
    goto function0;
2561
 
2562
  if (sym->attr.generic)
2563
    goto generic_function;
2564
 
2565
  switch (sym->attr.flavor)
2566
    {
2567
    case FL_VARIABLE:
2568
    variable:
2569
      e = gfc_get_expr ();
2570
 
2571
      e->expr_type = EXPR_VARIABLE;
2572
      e->symtree = symtree;
2573
 
2574
      m = gfc_match_varspec (e, 0, false, true);
2575
      break;
2576
 
2577
    case FL_PARAMETER:
2578
      /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2579
         end up here.  Unfortunately, sym->value->expr_type is set to
2580
         EXPR_CONSTANT, and so the if () branch would be followed without
2581
         the !sym->as check.  */
2582
      if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2583
        e = gfc_copy_expr (sym->value);
2584
      else
2585
        {
2586
          e = gfc_get_expr ();
2587
          e->expr_type = EXPR_VARIABLE;
2588
        }
2589
 
2590
      e->symtree = symtree;
2591
      m = gfc_match_varspec (e, 0, false, true);
2592
 
2593
      if (sym->ts.is_c_interop || sym->ts.is_iso_c)
2594
        break;
2595
 
2596
      /* Variable array references to derived type parameters cause
2597
         all sorts of headaches in simplification. Treating such
2598
         expressions as variable works just fine for all array
2599
         references.  */
2600
      if (sym->value && sym->ts.type == BT_DERIVED && e->ref)
2601
        {
2602
          for (ref = e->ref; ref; ref = ref->next)
2603
            if (ref->type == REF_ARRAY)
2604
              break;
2605
 
2606
          if (ref == NULL || ref->u.ar.type == AR_FULL)
2607
            break;
2608
 
2609
          ref = e->ref;
2610
          e->ref = NULL;
2611
          gfc_free_expr (e);
2612
          e = gfc_get_expr ();
2613
          e->expr_type = EXPR_VARIABLE;
2614
          e->symtree = symtree;
2615
          e->ref = ref;
2616
        }
2617
 
2618
      break;
2619
 
2620
    case FL_DERIVED:
2621
      sym = gfc_use_derived (sym);
2622
      if (sym == NULL)
2623
        m = MATCH_ERROR;
2624
      else
2625
        m = gfc_match_structure_constructor (sym, &e, false);
2626
      break;
2627
 
2628
    /* If we're here, then the name is known to be the name of a
2629
       procedure, yet it is not sure to be the name of a function.  */
2630
    case FL_PROCEDURE:
2631
 
2632
    /* Procedure Pointer Assignments. */
2633
    procptr0:
2634
      if (gfc_matching_procptr_assignment)
2635
        {
2636
          gfc_gobble_whitespace ();
2637
          if (!sym->attr.dimension && gfc_peek_ascii_char () == '(')
2638
            /* Parse functions returning a procptr.  */
2639
            goto function0;
2640
 
2641
          if (gfc_is_intrinsic (sym, 0, gfc_current_locus)
2642
              || gfc_is_intrinsic (sym, 1, gfc_current_locus))
2643
            sym->attr.intrinsic = 1;
2644
          e = gfc_get_expr ();
2645
          e->expr_type = EXPR_VARIABLE;
2646
          e->symtree = symtree;
2647
          m = gfc_match_varspec (e, 0, false, true);
2648
          break;
2649
        }
2650
 
2651
      if (sym->attr.subroutine)
2652
        {
2653
          gfc_error ("Unexpected use of subroutine name '%s' at %C",
2654
                     sym->name);
2655
          m = MATCH_ERROR;
2656
          break;
2657
        }
2658
 
2659
      /* At this point, the name has to be a non-statement function.
2660
         If the name is the same as the current function being
2661
         compiled, then we have a variable reference (to the function
2662
         result) if the name is non-recursive.  */
2663
 
2664
      st = gfc_enclosing_unit (NULL);
2665
 
2666
      if (st != NULL && st->state == COMP_FUNCTION
2667
          && st->sym == sym
2668
          && !sym->attr.recursive)
2669
        {
2670
          e = gfc_get_expr ();
2671
          e->symtree = symtree;
2672
          e->expr_type = EXPR_VARIABLE;
2673
 
2674
          m = gfc_match_varspec (e, 0, false, true);
2675
          break;
2676
        }
2677
 
2678
    /* Match a function reference.  */
2679
    function0:
2680
      m = gfc_match_actual_arglist (0, &actual_arglist);
2681
      if (m == MATCH_NO)
2682
        {
2683
          if (sym->attr.proc == PROC_ST_FUNCTION)
2684
            gfc_error ("Statement function '%s' requires argument list at %C",
2685
                       sym->name);
2686
          else
2687
            gfc_error ("Function '%s' requires an argument list at %C",
2688
                       sym->name);
2689
 
2690
          m = MATCH_ERROR;
2691
          break;
2692
        }
2693
 
2694
      if (m != MATCH_YES)
2695
        {
2696
          m = MATCH_ERROR;
2697
          break;
2698
        }
2699
 
2700
      gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2701
      sym = symtree->n.sym;
2702
 
2703
      replace_hidden_procptr_result (&sym, &symtree);
2704
 
2705
      e = gfc_get_expr ();
2706
      e->symtree = symtree;
2707
      e->expr_type = EXPR_FUNCTION;
2708
      e->value.function.actual = actual_arglist;
2709
      e->where = gfc_current_locus;
2710
 
2711
      if (sym->as != NULL)
2712
        e->rank = sym->as->rank;
2713
 
2714
      if (!sym->attr.function
2715
          && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2716
        {
2717
          m = MATCH_ERROR;
2718
          break;
2719
        }
2720
 
2721
      /* Check here for the existence of at least one argument for the
2722
         iso_c_binding functions C_LOC, C_FUNLOC, and C_ASSOCIATED.  The
2723
         argument(s) given will be checked in gfc_iso_c_func_interface,
2724
         during resolution of the function call.  */
2725
      if (sym->attr.is_iso_c == 1
2726
          && (sym->from_intmod == INTMOD_ISO_C_BINDING
2727
              && (sym->intmod_sym_id == ISOCBINDING_LOC
2728
                  || sym->intmod_sym_id == ISOCBINDING_FUNLOC
2729
                  || sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
2730
        {
2731
          /* make sure we were given a param */
2732
          if (actual_arglist == NULL)
2733
            {
2734
              gfc_error ("Missing argument to '%s' at %C", sym->name);
2735
              m = MATCH_ERROR;
2736
              break;
2737
            }
2738
        }
2739
 
2740
      if (sym->result == NULL)
2741
        sym->result = sym;
2742
 
2743
      m = MATCH_YES;
2744
      break;
2745
 
2746
    case FL_UNKNOWN:
2747
 
2748
      /* Special case for derived type variables that get their types
2749
         via an IMPLICIT statement.  This can't wait for the
2750
         resolution phase.  */
2751
 
2752
      if (gfc_peek_ascii_char () == '%'
2753
          && sym->ts.type == BT_UNKNOWN
2754
          && gfc_get_default_type (sym->name, sym->ns)->type == BT_DERIVED)
2755
        gfc_set_default_type (sym, 0, sym->ns);
2756
 
2757
      /* If the symbol has a dimension attribute, the expression is a
2758
         variable.  */
2759
 
2760
      if (sym->attr.dimension)
2761
        {
2762
          if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2763
                              sym->name, NULL) == FAILURE)
2764
            {
2765
              m = MATCH_ERROR;
2766
              break;
2767
            }
2768
 
2769
          e = gfc_get_expr ();
2770
          e->symtree = symtree;
2771
          e->expr_type = EXPR_VARIABLE;
2772
          m = gfc_match_varspec (e, 0, false, true);
2773
          break;
2774
        }
2775
 
2776
      /* Name is not an array, so we peek to see if a '(' implies a
2777
         function call or a substring reference.  Otherwise the
2778
         variable is just a scalar.  */
2779
 
2780
      gfc_gobble_whitespace ();
2781
      if (gfc_peek_ascii_char () != '(')
2782
        {
2783
          /* Assume a scalar variable */
2784
          e = gfc_get_expr ();
2785
          e->symtree = symtree;
2786
          e->expr_type = EXPR_VARIABLE;
2787
 
2788
          if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2789
                              sym->name, NULL) == FAILURE)
2790
            {
2791
              m = MATCH_ERROR;
2792
              break;
2793
            }
2794
 
2795
          /*FIXME:??? gfc_match_varspec does set this for us: */
2796
          e->ts = sym->ts;
2797
          m = gfc_match_varspec (e, 0, false, true);
2798
          break;
2799
        }
2800
 
2801
      /* See if this is a function reference with a keyword argument
2802
         as first argument. We do this because otherwise a spurious
2803
         symbol would end up in the symbol table.  */
2804
 
2805
      old_loc = gfc_current_locus;
2806
      m2 = gfc_match (" ( %n =", argname);
2807
      gfc_current_locus = old_loc;
2808
 
2809
      e = gfc_get_expr ();
2810
      e->symtree = symtree;
2811
 
2812
      if (m2 != MATCH_YES)
2813
        {
2814
          /* Try to figure out whether we're dealing with a character type.
2815
             We're peeking ahead here, because we don't want to call
2816
             match_substring if we're dealing with an implicitly typed
2817
             non-character variable.  */
2818
          implicit_char = false;
2819
          if (sym->ts.type == BT_UNKNOWN)
2820
            {
2821
              ts = gfc_get_default_type (sym->name, NULL);
2822
              if (ts->type == BT_CHARACTER)
2823
                implicit_char = true;
2824
            }
2825
 
2826
          /* See if this could possibly be a substring reference of a name
2827
             that we're not sure is a variable yet.  */
2828
 
2829
          if ((implicit_char || sym->ts.type == BT_CHARACTER)
2830
              && match_substring (sym->ts.u.cl, 0, &e->ref) == MATCH_YES)
2831
            {
2832
 
2833
              e->expr_type = EXPR_VARIABLE;
2834
 
2835
              if (sym->attr.flavor != FL_VARIABLE
2836
                  && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2837
                                     sym->name, NULL) == FAILURE)
2838
                {
2839
                  m = MATCH_ERROR;
2840
                  break;
2841
                }
2842
 
2843
              if (sym->ts.type == BT_UNKNOWN
2844
                  && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2845
                {
2846
                  m = MATCH_ERROR;
2847
                  break;
2848
                }
2849
 
2850
              e->ts = sym->ts;
2851
              if (e->ref)
2852
                e->ts.u.cl = NULL;
2853
              m = MATCH_YES;
2854
              break;
2855
            }
2856
        }
2857
 
2858
      /* Give up, assume we have a function.  */
2859
 
2860
      gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2861
      sym = symtree->n.sym;
2862
      e->expr_type = EXPR_FUNCTION;
2863
 
2864
      if (!sym->attr.function
2865
          && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2866
        {
2867
          m = MATCH_ERROR;
2868
          break;
2869
        }
2870
 
2871
      sym->result = sym;
2872
 
2873
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2874
      if (m == MATCH_NO)
2875
        gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2876
 
2877
      if (m != MATCH_YES)
2878
        {
2879
          m = MATCH_ERROR;
2880
          break;
2881
        }
2882
 
2883
      /* If our new function returns a character, array or structure
2884
         type, it might have subsequent references.  */
2885
 
2886
      m = gfc_match_varspec (e, 0, false, true);
2887
      if (m == MATCH_NO)
2888
        m = MATCH_YES;
2889
 
2890
      break;
2891
 
2892
    generic_function:
2893
      gfc_get_sym_tree (name, NULL, &symtree, false);   /* Can't fail */
2894
 
2895
      e = gfc_get_expr ();
2896
      e->symtree = symtree;
2897
      e->expr_type = EXPR_FUNCTION;
2898
 
2899
      m = gfc_match_actual_arglist (0, &e->value.function.actual);
2900
      break;
2901
 
2902
    default:
2903
      gfc_error ("Symbol at %C is not appropriate for an expression");
2904
      return MATCH_ERROR;
2905
    }
2906
 
2907
  if (m == MATCH_YES)
2908
    {
2909
      e->where = where;
2910
      *result = e;
2911
    }
2912
  else
2913
    gfc_free_expr (e);
2914
 
2915
  return m;
2916
}
2917
 
2918
 
2919
/* Match a variable, i.e. something that can be assigned to.  This
2920
   starts as a symbol, can be a structure component or an array
2921
   reference.  It can be a function if the function doesn't have a
2922
   separate RESULT variable.  If the symbol has not been previously
2923
   seen, we assume it is a variable.
2924
 
2925
   This function is called by two interface functions:
2926
   gfc_match_variable, which has host_flag = 1, and
2927
   gfc_match_equiv_variable, with host_flag = 0, to restrict the
2928
   match of the symbol to the local scope.  */
2929
 
2930
static match
2931
match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2932
{
2933
  gfc_symbol *sym;
2934
  gfc_symtree *st;
2935
  gfc_expr *expr;
2936
  locus where;
2937
  match m;
2938
 
2939
  /* Since nothing has any business being an lvalue in a module
2940
     specification block, an interface block or a contains section,
2941
     we force the changed_symbols mechanism to work by setting
2942
     host_flag to 0. This prevents valid symbols that have the name
2943
     of keywords, such as 'end', being turned into variables by
2944
     failed matching to assignments for, e.g., END INTERFACE.  */
2945
  if (gfc_current_state () == COMP_MODULE
2946
      || gfc_current_state () == COMP_INTERFACE
2947
      || gfc_current_state () == COMP_CONTAINS)
2948
    host_flag = 0;
2949
 
2950
  where = gfc_current_locus;
2951
  m = gfc_match_sym_tree (&st, host_flag);
2952
  if (m != MATCH_YES)
2953
    return m;
2954
 
2955
  sym = st->n.sym;
2956
 
2957
  /* If this is an implicit do loop index and implicitly typed,
2958
     it should not be host associated.  */
2959
  m = check_for_implicit_index (&st, &sym);
2960
  if (m != MATCH_YES)
2961
    return m;
2962
 
2963
  sym->attr.implied_index = 0;
2964
 
2965
  gfc_set_sym_referenced (sym);
2966
  switch (sym->attr.flavor)
2967
    {
2968
    case FL_VARIABLE:
2969
      if (sym->attr.is_protected && sym->attr.use_assoc)
2970
        {
2971
          gfc_error ("Assigning to PROTECTED variable at %C");
2972
          return MATCH_ERROR;
2973
        }
2974
      break;
2975
 
2976
    case FL_UNKNOWN:
2977
      {
2978
        sym_flavor flavor = FL_UNKNOWN;
2979
 
2980
        gfc_gobble_whitespace ();
2981
 
2982
        if (sym->attr.external || sym->attr.procedure
2983
            || sym->attr.function || sym->attr.subroutine)
2984
          flavor = FL_PROCEDURE;
2985
 
2986
        /* If it is not a procedure, is not typed and is host associated,
2987
           we cannot give it a flavor yet.  */
2988
        else if (sym->ns == gfc_current_ns->parent
2989
                   && sym->ts.type == BT_UNKNOWN)
2990
          break;
2991
 
2992
        /* These are definitive indicators that this is a variable.  */
2993
        else if (gfc_peek_ascii_char () != '(' || sym->ts.type != BT_UNKNOWN
2994
                 || sym->attr.pointer || sym->as != NULL)
2995
          flavor = FL_VARIABLE;
2996
 
2997
        if (flavor != FL_UNKNOWN
2998
            && gfc_add_flavor (&sym->attr, flavor, sym->name, NULL) == FAILURE)
2999
          return MATCH_ERROR;
3000
      }
3001
      break;
3002
 
3003
    case FL_PARAMETER:
3004
      if (equiv_flag)
3005
        gfc_error ("Named constant at %C in an EQUIVALENCE");
3006
      else
3007
        gfc_error ("Cannot assign to a named constant at %C");
3008
      return MATCH_ERROR;
3009
      break;
3010
 
3011
    case FL_PROCEDURE:
3012
      /* Check for a nonrecursive function result variable.  */
3013
      if (sym->attr.function
3014
          && !sym->attr.external
3015
          && sym->result == sym
3016
          && (gfc_is_function_return_value (sym, gfc_current_ns)
3017
              || (sym->attr.entry
3018
                  && sym->ns == gfc_current_ns)
3019
              || (sym->attr.entry
3020
                  && sym->ns == gfc_current_ns->parent)))
3021
        {
3022
          /* If a function result is a derived type, then the derived
3023
             type may still have to be resolved.  */
3024
 
3025
          if (sym->ts.type == BT_DERIVED
3026
              && gfc_use_derived (sym->ts.u.derived) == NULL)
3027
            return MATCH_ERROR;
3028
          break;
3029
        }
3030
 
3031
      if (sym->attr.proc_pointer
3032
          || replace_hidden_procptr_result (&sym, &st) == SUCCESS)
3033
        break;
3034
 
3035
      /* Fall through to error */
3036
 
3037
    default:
3038
      gfc_error ("'%s' at %C is not a variable", sym->name);
3039
      return MATCH_ERROR;
3040
    }
3041
 
3042
  /* Special case for derived type variables that get their types
3043
     via an IMPLICIT statement.  This can't wait for the
3044
     resolution phase.  */
3045
 
3046
    {
3047
      gfc_namespace * implicit_ns;
3048
 
3049
      if (gfc_current_ns->proc_name == sym)
3050
        implicit_ns = gfc_current_ns;
3051
      else
3052
        implicit_ns = sym->ns;
3053
 
3054
      if (gfc_peek_ascii_char () == '%'
3055
          && sym->ts.type == BT_UNKNOWN
3056
          && gfc_get_default_type (sym->name, implicit_ns)->type == BT_DERIVED)
3057
        gfc_set_default_type (sym, 0, implicit_ns);
3058
    }
3059
 
3060
  expr = gfc_get_expr ();
3061
 
3062
  expr->expr_type = EXPR_VARIABLE;
3063
  expr->symtree = st;
3064
  expr->ts = sym->ts;
3065
  expr->where = where;
3066
 
3067
  /* Now see if we have to do more.  */
3068
  m = gfc_match_varspec (expr, equiv_flag, false, false);
3069
  if (m != MATCH_YES)
3070
    {
3071
      gfc_free_expr (expr);
3072
      return m;
3073
    }
3074
 
3075
  *result = expr;
3076
  return MATCH_YES;
3077
}
3078
 
3079
 
3080
match
3081
gfc_match_variable (gfc_expr **result, int equiv_flag)
3082
{
3083
  return match_variable (result, equiv_flag, 1);
3084
}
3085
 
3086
 
3087
match
3088
gfc_match_equiv_variable (gfc_expr **result)
3089
{
3090
  return match_variable (result, 1, 0);
3091
}
3092
 

powered by: WebSVN 2.1.0

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