OSDN Git Service

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