OSDN Git Service

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