OSDN Git Service

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