OSDN Git Service

a2f70a07f93ded077e8440507ccdc993b8aa0045
[pf3gnuchains/gcc-fork.git] / gcc / fortran / primary.c
1 /* Primary expression subroutines
2    Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007
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 2, 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 COPYING.  If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
21 02110-1301, USA.  */
22
23 #include "config.h"
24 #include "system.h"
25 #include "flags.h"
26 #include "gfortran.h"
27 #include "arith.h"
28 #include "match.h"
29 #include "parse.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   p = gfc_extract_int (sym->value, kind);
61   if (p != NULL)
62     return MATCH_NO;
63
64   if (*kind < 0)
65     return MATCH_NO;
66
67   return MATCH_YES;
68 }
69
70
71 /* Get a trailing kind-specification for non-character variables.
72    Returns:
73       the integer kind value or:
74       -1 if an error was generated
75       -2 if no kind was found */
76
77 static int
78 get_kind (void)
79 {
80   int kind;
81   match m;
82
83   if (gfc_match_char ('_') != MATCH_YES)
84     return -2;
85
86   m = match_kind_param (&kind);
87   if (m == MATCH_NO)
88     gfc_error ("Missing kind-parameter at %C");
89
90   return (m == MATCH_YES) ? kind : -1;
91 }
92
93
94 /* Given a character and a radix, see if the character is a valid
95    digit in that radix.  */
96
97 static int
98 check_digit (int c, int radix)
99 {
100   int r;
101
102   switch (radix)
103     {
104     case 2:
105       r = ('0' <= c && c <= '1');
106       break;
107
108     case 8:
109       r = ('0' <= c && c <= '7');
110       break;
111
112     case 10:
113       r = ('0' <= c && c <= '9');
114       break;
115
116     case 16:
117       r = ISXDIGIT (c);
118       break;
119
120     default:
121       gfc_internal_error ("check_digit(): bad radix");
122     }
123
124   return r;
125 }
126
127
128 /* Match the digit string part of an integer if signflag is not set,
129    the signed digit string part if signflag is set.  If the buffer 
130    is NULL, we just count characters for the resolution pass.  Returns 
131    the number of characters matched, -1 for no match.  */
132
133 static int
134 match_digits (int signflag, int radix, char *buffer)
135 {
136   locus old_loc;
137   int length, c;
138
139   length = 0;
140   c = gfc_next_char ();
141
142   if (signflag && (c == '+' || c == '-'))
143     {
144       if (buffer != NULL)
145         *buffer++ = c;
146       gfc_gobble_whitespace ();
147       c = gfc_next_char ();
148       length++;
149     }
150
151   if (!check_digit (c, radix))
152     return -1;
153
154   length++;
155   if (buffer != NULL)
156     *buffer++ = c;
157
158   for (;;)
159     {
160       old_loc = gfc_current_locus;
161       c = gfc_next_char ();
162
163       if (!check_digit (c, radix))
164         break;
165
166       if (buffer != NULL)
167         *buffer++ = c;
168       length++;
169     }
170
171   gfc_current_locus = old_loc;
172
173   return length;
174 }
175
176
177 /* Match an integer (digit string and optional kind).  
178    A sign will be accepted if signflag is set.  */
179
180 static match
181 match_integer_constant (gfc_expr **result, int signflag)
182 {
183   int length, kind;
184   locus old_loc;
185   char *buffer;
186   gfc_expr *e;
187
188   old_loc = gfc_current_locus;
189   gfc_gobble_whitespace ();
190
191   length = match_digits (signflag, 10, NULL);
192   gfc_current_locus = old_loc;
193   if (length == -1)
194     return MATCH_NO;
195
196   buffer = alloca (length + 1);
197   memset (buffer, '\0', length + 1);
198
199   gfc_gobble_whitespace ();
200
201   match_digits (signflag, 10, buffer);
202
203   kind = get_kind ();
204   if (kind == -2)
205     kind = gfc_default_integer_kind;
206   if (kind == -1)
207     return MATCH_ERROR;
208
209   if (gfc_validate_kind (BT_INTEGER, kind, true) < 0)
210     {
211       gfc_error ("Integer kind %d at %C not available", kind);
212       return MATCH_ERROR;
213     }
214
215   e = gfc_convert_integer (buffer, kind, 10, &gfc_current_locus);
216
217   if (gfc_range_check (e) != ARITH_OK)
218     {
219       gfc_error ("Integer too big for its kind at %C");
220
221       gfc_free_expr (e);
222       return MATCH_ERROR;
223     }
224
225   *result = e;
226   return MATCH_YES;
227 }
228
229
230 /* Match a Hollerith constant.  */
231
232 static match
233 match_hollerith_constant (gfc_expr **result)
234 {
235   locus old_loc;
236   gfc_expr *e = NULL;
237   const char *msg;
238   char *buffer;
239   int num;
240   int i;  
241
242   old_loc = gfc_current_locus;
243   gfc_gobble_whitespace ();
244
245   if (match_integer_constant (&e, 0) == MATCH_YES
246       && gfc_match_char ('h') == MATCH_YES)
247     {
248       if (gfc_notify_std (GFC_STD_LEGACY, "Extension: Hollerith constant "
249                           "at %C") == FAILURE)
250         goto cleanup;
251
252       msg = gfc_extract_int (e, &num);
253       if (msg != NULL)
254         {
255           gfc_error (msg);
256           goto cleanup;
257         }
258       if (num == 0)
259         {
260           gfc_error ("Invalid Hollerith constant: %L must contain at least "
261                      "one character", &old_loc);
262           goto cleanup;
263         }
264       if (e->ts.kind != gfc_default_integer_kind)
265         {
266           gfc_error ("Invalid Hollerith constant: Integer kind at %L "
267                      "should be default", &old_loc);
268           goto cleanup;
269         }
270       else
271         {
272           buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
273           for (i = 0; i < num; i++)
274             {
275               buffer[i] = gfc_next_char_literal (1);
276             }
277           gfc_free_expr (e);
278           e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
279                                    &gfc_current_locus);
280           e->value.character.string = gfc_getmem (num + 1);
281           memcpy (e->value.character.string, buffer, num);
282           e->value.character.string[num] = '\0';
283           e->value.character.length = num;
284           *result = e;
285           return MATCH_YES;
286         }
287     }
288
289   gfc_free_expr (e);
290   gfc_current_locus = old_loc;
291   return MATCH_NO;
292
293 cleanup:
294   gfc_free_expr (e);
295   return MATCH_ERROR;
296 }
297
298
299 /* Match a binary, octal or hexadecimal constant that can be found in
300    a DATA statement.  The standard permits b'010...', o'73...', and
301    z'a1...' where b, o, and z can be capital letters.  This function
302    also accepts postfixed forms of the constants: '01...'b, '73...'o,
303    and 'a1...'z.  An additional extension is the use of x for z.  */
304
305 static match
306 match_boz_constant (gfc_expr **result)
307 {
308   int post, radix, delim, length, x_hex, kind;
309   locus old_loc, start_loc;
310   char *buffer;
311   gfc_expr *e;
312
313   start_loc = old_loc = gfc_current_locus;
314   gfc_gobble_whitespace ();
315
316   x_hex = 0;
317   switch (post = gfc_next_char ())
318     {
319     case 'b':
320       radix = 2;
321       post = 0;
322       break;
323     case 'o':
324       radix = 8;
325       post = 0;
326       break;
327     case 'x':
328       x_hex = 1;
329       /* Fall through.  */
330     case 'z':
331       radix = 16;
332       post = 0;
333       break;
334     case '\'':
335       /* Fall through.  */
336     case '\"':
337       delim = post;
338       post = 1;
339       radix = 16;  /* Set to accept any valid digit string.  */
340       break;
341     default:
342       goto backup;
343     }
344
345   /* No whitespace allowed here.  */
346
347   if (post == 0)
348     delim = gfc_next_char ();
349
350   if (delim != '\'' && delim != '\"')
351     goto backup;
352
353   if (x_hex && pedantic
354       && (gfc_notify_std (GFC_STD_GNU, "Extension: Hexadecimal "
355                           "constant at %C uses non-standard syntax.")
356           == FAILURE))
357       return MATCH_ERROR;
358
359   old_loc = gfc_current_locus;
360
361   length = match_digits (0, radix, NULL);
362   if (length == -1)
363     {
364       gfc_error ("Empty set of digits in BOZ constant at %C");
365       return MATCH_ERROR;
366     }
367
368   if (gfc_next_char () != delim)
369     {
370       gfc_error ("Illegal character in BOZ constant at %C");
371       return MATCH_ERROR;
372     }
373
374   if (post == 1)
375     {
376       switch (gfc_next_char ())
377         {
378         case 'b':
379           radix = 2;
380           break;
381         case 'o':
382           radix = 8;
383           break;
384         case 'x':
385           /* Fall through.  */
386         case 'z':
387           radix = 16;
388           break;
389         default:
390           goto backup;
391         }
392         gfc_notify_std (GFC_STD_GNU, "Extension: BOZ constant "
393                         "at %C uses non-standard postfix syntax.");
394     }
395
396   gfc_current_locus = old_loc;
397
398   buffer = alloca (length + 1);
399   memset (buffer, '\0', length + 1);
400
401   match_digits (0, radix, buffer);
402   gfc_next_char ();    /* Eat delimiter.  */
403   if (post == 1)
404     gfc_next_char ();  /* Eat postfixed b, o, z, or x.  */
405
406   /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
407      "If a data-stmt-constant is a boz-literal-constant, the corresponding
408      variable shall be of type integer.  The boz-literal-constant is treated
409      as if it were an int-literal-constant with a kind-param that specifies
410      the representation method with the largest decimal exponent range
411      supported by the processor."  */
412
413   kind = gfc_max_integer_kind;
414   e = gfc_convert_integer (buffer, kind, radix, &gfc_current_locus);
415
416   if (gfc_range_check (e) != ARITH_OK)
417     {
418       gfc_error ("Integer too big for integer kind %i at %C", kind);
419       gfc_free_expr (e);
420       return MATCH_ERROR;
421     }
422
423   *result = e;
424   return MATCH_YES;
425
426 backup:
427   gfc_current_locus = start_loc;
428   return MATCH_NO;
429 }
430
431
432 /* Match a real constant of some sort.  Allow a signed constant if signflag
433    is nonzero.  Allow integer constants if allow_int is true.  */
434
435 static match
436 match_real_constant (gfc_expr **result, int signflag)
437 {
438   int kind, c, count, seen_dp, seen_digits, exp_char;
439   locus old_loc, temp_loc;
440   char *p, *buffer;
441   gfc_expr *e;
442   bool negate;
443
444   old_loc = gfc_current_locus;
445   gfc_gobble_whitespace ();
446
447   e = NULL;
448
449   count = 0;
450   seen_dp = 0;
451   seen_digits = 0;
452   exp_char = ' ';
453   negate = FALSE;
454
455   c = gfc_next_char ();
456   if (signflag && (c == '+' || c == '-'))
457     {
458       if (c == '-')
459         negate = TRUE;
460
461       gfc_gobble_whitespace ();
462       c = gfc_next_char ();
463     }
464
465   /* Scan significand.  */
466   for (;; c = gfc_next_char (), count++)
467     {
468       if (c == '.')
469         {
470           if (seen_dp)
471             goto done;
472
473           /* Check to see if "." goes with a following operator like 
474              ".eq.".  */
475           temp_loc = gfc_current_locus;
476           c = gfc_next_char ();
477
478           if (c == 'e' || c == 'd' || c == 'q')
479             {
480               c = gfc_next_char ();
481               if (c == '.')
482                 goto done;      /* Operator named .e. or .d.  */
483             }
484
485           if (ISALPHA (c))
486             goto done;          /* Distinguish 1.e9 from 1.eq.2 */
487
488           gfc_current_locus = temp_loc;
489           seen_dp = 1;
490           continue;
491         }
492
493       if (ISDIGIT (c))
494         {
495           seen_digits = 1;
496           continue;
497         }
498
499       break;
500     }
501
502   if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
503     goto done;
504   exp_char = c;
505
506   /* Scan exponent.  */
507   c = gfc_next_char ();
508   count++;
509
510   if (c == '+' || c == '-')
511     {                           /* optional sign */
512       c = gfc_next_char ();
513       count++;
514     }
515
516   if (!ISDIGIT (c))
517     {
518       gfc_error ("Missing exponent in real number at %C");
519       return MATCH_ERROR;
520     }
521
522   while (ISDIGIT (c))
523     {
524       c = gfc_next_char ();
525       count++;
526     }
527
528 done:
529   /* Check that we have a numeric constant.  */
530   if (!seen_digits || (!seen_dp && exp_char == ' '))
531     {
532       gfc_current_locus = old_loc;
533       return MATCH_NO;
534     }
535
536   /* Convert the number.  */
537   gfc_current_locus = old_loc;
538   gfc_gobble_whitespace ();
539
540   buffer = alloca (count + 1);
541   memset (buffer, '\0', count + 1);
542
543   p = buffer;
544   c = gfc_next_char ();
545   if (c == '+' || c == '-')
546     {
547       gfc_gobble_whitespace ();
548       c = gfc_next_char ();
549     }
550
551   /* Hack for mpfr_set_str().  */
552   for (;;)
553     {
554       if (c == 'd' || c == 'q')
555         *p = 'e';
556       else
557         *p = c;
558       p++;
559       if (--count == 0)
560         break;
561
562       c = gfc_next_char ();
563     }
564
565   kind = get_kind ();
566   if (kind == -1)
567     goto cleanup;
568
569   switch (exp_char)
570     {
571     case 'd':
572       if (kind != -2)
573         {
574           gfc_error ("Real number at %C has a 'd' exponent and an explicit "
575                      "kind");
576           goto cleanup;
577         }
578       kind = gfc_default_double_kind;
579       break;
580
581     default:
582       if (kind == -2)
583         kind = gfc_default_real_kind;
584
585       if (gfc_validate_kind (BT_REAL, kind, true) < 0)
586         {
587           gfc_error ("Invalid real kind %d at %C", kind);
588           goto cleanup;
589         }
590     }
591
592   e = gfc_convert_real (buffer, kind, &gfc_current_locus);
593   if (negate)
594     mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
595
596   switch (gfc_range_check (e))
597     {
598     case ARITH_OK:
599       break;
600     case ARITH_OVERFLOW:
601       gfc_error ("Real constant overflows its kind at %C");
602       goto cleanup;
603
604     case ARITH_UNDERFLOW:
605       if (gfc_option.warn_underflow)
606         gfc_warning ("Real constant underflows its kind at %C");
607       mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
608       break;
609
610     default:
611       gfc_internal_error ("gfc_range_check() returned bad value");
612     }
613
614   *result = e;
615   return MATCH_YES;
616
617 cleanup:
618   gfc_free_expr (e);
619   return MATCH_ERROR;
620 }
621
622
623 /* Match a substring reference.  */
624
625 static match
626 match_substring (gfc_charlen *cl, int init, gfc_ref **result)
627 {
628   gfc_expr *start, *end;
629   locus old_loc;
630   gfc_ref *ref;
631   match m;
632
633   start = NULL;
634   end = NULL;
635
636   old_loc = gfc_current_locus;
637
638   m = gfc_match_char ('(');
639   if (m != MATCH_YES)
640     return MATCH_NO;
641
642   if (gfc_match_char (':') != MATCH_YES)
643     {
644       if (init)
645         m = gfc_match_init_expr (&start);
646       else
647         m = gfc_match_expr (&start);
648
649       if (m != MATCH_YES)
650         {
651           m = MATCH_NO;
652           goto cleanup;
653         }
654
655       m = gfc_match_char (':');
656       if (m != MATCH_YES)
657         goto cleanup;
658     }
659
660   if (gfc_match_char (')') != MATCH_YES)
661     {
662       if (init)
663         m = gfc_match_init_expr (&end);
664       else
665         m = gfc_match_expr (&end);
666
667       if (m == MATCH_NO)
668         goto syntax;
669       if (m == MATCH_ERROR)
670         goto cleanup;
671
672       m = gfc_match_char (')');
673       if (m == MATCH_NO)
674         goto syntax;
675     }
676
677   /* Optimize away the (:) reference.  */
678   if (start == NULL && end == NULL)
679     ref = NULL;
680   else
681     {
682       ref = gfc_get_ref ();
683
684       ref->type = REF_SUBSTRING;
685       if (start == NULL)
686         start = gfc_int_expr (1);
687       ref->u.ss.start = start;
688       if (end == NULL && cl)
689         end = gfc_copy_expr (cl->length);
690       ref->u.ss.end = end;
691       ref->u.ss.length = cl;
692     }
693
694   *result = ref;
695   return MATCH_YES;
696
697 syntax:
698   gfc_error ("Syntax error in SUBSTRING specification at %C");
699   m = MATCH_ERROR;
700
701 cleanup:
702   gfc_free_expr (start);
703   gfc_free_expr (end);
704
705   gfc_current_locus = old_loc;
706   return m;
707 }
708
709
710 /* Reads the next character of a string constant, taking care to
711    return doubled delimiters on the input as a single instance of
712    the delimiter.
713
714    Special return values are:
715      -1   End of the string, as determined by the delimiter
716      -2   Unterminated string detected
717
718    Backslash codes are also expanded at this time.  */
719
720 static int
721 next_string_char (char delimiter)
722 {
723   locus old_locus;
724   int c;
725
726   c = gfc_next_char_literal (1);
727
728   if (c == '\n')
729     return -2;
730
731   if (gfc_option.flag_backslash && c == '\\')
732     {
733       old_locus = gfc_current_locus;
734
735       switch (gfc_next_char_literal (1))
736         {
737         case 'a':
738           c = '\a';
739           break;
740         case 'b':
741           c = '\b';
742           break;
743         case 't':
744           c = '\t';
745           break;
746         case 'f':
747           c = '\f';
748           break;
749         case 'n':
750           c = '\n';
751           break;
752         case 'r':
753           c = '\r';
754           break;
755         case 'v':
756           c = '\v';
757           break;
758         case '\\':
759           c = '\\';
760           break;
761
762         default:
763           /* Unknown backslash codes are simply not expanded */
764           gfc_current_locus = old_locus;
765           break;
766         }
767     }
768
769   if (c != delimiter)
770     return c;
771
772   old_locus = gfc_current_locus;
773   c = gfc_next_char_literal (1);
774
775   if (c == delimiter)
776     return c;
777   gfc_current_locus = old_locus;
778
779   return -1;
780 }
781
782
783 /* Special case of gfc_match_name() that matches a parameter kind name
784    before a string constant.  This takes case of the weird but legal
785    case of:
786
787      kind_____'string'
788
789    where kind____ is a parameter. gfc_match_name() will happily slurp
790    up all the underscores, which leads to problems.  If we return
791    MATCH_YES, the parse pointer points to the final underscore, which
792    is not part of the name.  We never return MATCH_ERROR-- errors in
793    the name will be detected later.  */
794
795 static match
796 match_charkind_name (char *name)
797 {
798   locus old_loc;
799   char c, peek;
800   int len;
801
802   gfc_gobble_whitespace ();
803   c = gfc_next_char ();
804   if (!ISALPHA (c))
805     return MATCH_NO;
806
807   *name++ = c;
808   len = 1;
809
810   for (;;)
811     {
812       old_loc = gfc_current_locus;
813       c = gfc_next_char ();
814
815       if (c == '_')
816         {
817           peek = gfc_peek_char ();
818
819           if (peek == '\'' || peek == '\"')
820             {
821               gfc_current_locus = old_loc;
822               *name = '\0';
823               return MATCH_YES;
824             }
825         }
826
827       if (!ISALNUM (c)
828           && c != '_'
829           && (gfc_option.flag_dollar_ok && c != '$'))
830         break;
831
832       *name++ = c;
833       if (++len > GFC_MAX_SYMBOL_LEN)
834         break;
835     }
836
837   return MATCH_NO;
838 }
839
840
841 /* See if the current input matches a character constant.  Lots of
842    contortions have to be done to match the kind parameter which comes
843    before the actual string.  The main consideration is that we don't
844    want to error out too quickly.  For example, we don't actually do
845    any validation of the kinds until we have actually seen a legal
846    delimiter.  Using match_kind_param() generates errors too quickly.  */
847
848 static match
849 match_string_constant (gfc_expr **result)
850 {
851   char *p, name[GFC_MAX_SYMBOL_LEN + 1];
852   int i, c, kind, length, delimiter;
853   locus old_locus, start_locus;
854   gfc_symbol *sym;
855   gfc_expr *e;
856   const char *q;
857   match m;
858
859   old_locus = gfc_current_locus;
860
861   gfc_gobble_whitespace ();
862
863   start_locus = gfc_current_locus;
864
865   c = gfc_next_char ();
866   if (c == '\'' || c == '"')
867     {
868       kind = gfc_default_character_kind;
869       goto got_delim;
870     }
871
872   if (ISDIGIT (c))
873     {
874       kind = 0;
875
876       while (ISDIGIT (c))
877         {
878           kind = kind * 10 + c - '0';
879           if (kind > 9999999)
880             goto no_match;
881           c = gfc_next_char ();
882         }
883
884     }
885   else
886     {
887       gfc_current_locus = old_locus;
888
889       m = match_charkind_name (name);
890       if (m != MATCH_YES)
891         goto no_match;
892
893       if (gfc_find_symbol (name, NULL, 1, &sym)
894           || sym == NULL
895           || sym->attr.flavor != FL_PARAMETER)
896         goto no_match;
897
898       kind = -1;
899       c = gfc_next_char ();
900     }
901
902   if (c == ' ')
903     {
904       gfc_gobble_whitespace ();
905       c = gfc_next_char ();
906     }
907
908   if (c != '_')
909     goto no_match;
910
911   gfc_gobble_whitespace ();
912   start_locus = gfc_current_locus;
913
914   c = gfc_next_char ();
915   if (c != '\'' && c != '"')
916     goto no_match;
917
918   if (kind == -1)
919     {
920       q = gfc_extract_int (sym->value, &kind);
921       if (q != NULL)
922         {
923           gfc_error (q);
924           return MATCH_ERROR;
925         }
926     }
927
928   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
929     {
930       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
931       return MATCH_ERROR;
932     }
933
934 got_delim:
935   /* Scan the string into a block of memory by first figuring out how
936      long it is, allocating the structure, then re-reading it.  This
937      isn't particularly efficient, but string constants aren't that
938      common in most code.  TODO: Use obstacks?  */
939
940   delimiter = c;
941   length = 0;
942
943   for (;;)
944     {
945       c = next_string_char (delimiter);
946       if (c == -1)
947         break;
948       if (c == -2)
949         {
950           gfc_current_locus = start_locus;
951           gfc_error ("Unterminated character constant beginning at %C");
952           return MATCH_ERROR;
953         }
954
955       length++;
956     }
957
958   /* Peek at the next character to see if it is a b, o, z, or x for the
959      postfixed BOZ literal constants.  */
960   c = gfc_peek_char ();
961   if (c == 'b' || c == 'o' || c =='z' || c == 'x')
962     goto no_match;
963
964
965   e = gfc_get_expr ();
966
967   e->expr_type = EXPR_CONSTANT;
968   e->ref = NULL;
969   e->ts.type = BT_CHARACTER;
970   e->ts.kind = kind;
971   e->where = start_locus;
972
973   e->value.character.string = p = gfc_getmem (length + 1);
974   e->value.character.length = length;
975
976   gfc_current_locus = start_locus;
977   gfc_next_char ();             /* Skip delimiter */
978
979   for (i = 0; i < length; i++)
980     *p++ = next_string_char (delimiter);
981
982   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
983
984   if (next_string_char (delimiter) != -1)
985     gfc_internal_error ("match_string_constant(): Delimiter not found");
986
987   if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
988     e->expr_type = EXPR_SUBSTRING;
989
990   *result = e;
991
992   return MATCH_YES;
993
994 no_match:
995   gfc_current_locus = old_locus;
996   return MATCH_NO;
997 }
998
999
1000 /* Match a .true. or .false.  */
1001
1002 static match
1003 match_logical_constant (gfc_expr **result)
1004 {
1005   static mstring logical_ops[] = {
1006     minit (".false.", 0),
1007     minit (".true.", 1),
1008     minit (NULL, -1)
1009   };
1010
1011   gfc_expr *e;
1012   int i, kind;
1013
1014   i = gfc_match_strings (logical_ops);
1015   if (i == -1)
1016     return MATCH_NO;
1017
1018   kind = get_kind ();
1019   if (kind == -1)
1020     return MATCH_ERROR;
1021   if (kind == -2)
1022     kind = gfc_default_logical_kind;
1023
1024   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1025     gfc_error ("Bad kind for logical constant at %C");
1026
1027   e = gfc_get_expr ();
1028
1029   e->expr_type = EXPR_CONSTANT;
1030   e->value.logical = i;
1031   e->ts.type = BT_LOGICAL;
1032   e->ts.kind = kind;
1033   e->where = gfc_current_locus;
1034
1035   *result = e;
1036   return MATCH_YES;
1037 }
1038
1039
1040 /* Match a real or imaginary part of a complex constant that is a
1041    symbolic constant.  */
1042
1043 static match
1044 match_sym_complex_part (gfc_expr **result)
1045 {
1046   char name[GFC_MAX_SYMBOL_LEN + 1];
1047   gfc_symbol *sym;
1048   gfc_expr *e;
1049   match m;
1050
1051   m = gfc_match_name (name);
1052   if (m != MATCH_YES)
1053     return m;
1054
1055   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1056     return MATCH_NO;
1057
1058   if (sym->attr.flavor != FL_PARAMETER)
1059     {
1060       gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1061       return MATCH_ERROR;
1062     }
1063
1064   if (!gfc_numeric_ts (&sym->value->ts))
1065     {
1066       gfc_error ("Numeric PARAMETER required in complex constant at %C");
1067       return MATCH_ERROR;
1068     }
1069
1070   if (sym->value->rank != 0)
1071     {
1072       gfc_error ("Scalar PARAMETER required in complex constant at %C");
1073       return MATCH_ERROR;
1074     }
1075
1076   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1077                       "complex constant at %C") == FAILURE)
1078     return MATCH_ERROR;
1079
1080   switch (sym->value->ts.type)
1081     {
1082     case BT_REAL:
1083       e = gfc_copy_expr (sym->value);
1084       break;
1085
1086     case BT_COMPLEX:
1087       e = gfc_complex2real (sym->value, sym->value->ts.kind);
1088       if (e == NULL)
1089         goto error;
1090       break;
1091
1092     case BT_INTEGER:
1093       e = gfc_int2real (sym->value, gfc_default_real_kind);
1094       if (e == NULL)
1095         goto error;
1096       break;
1097
1098     default:
1099       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1100     }
1101
1102   *result = e;          /* e is a scalar, real, constant expression.  */
1103   return MATCH_YES;
1104
1105 error:
1106   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1107   return MATCH_ERROR;
1108 }
1109
1110
1111 /* Match a real or imaginary part of a complex number.  */
1112
1113 static match
1114 match_complex_part (gfc_expr **result)
1115 {
1116   match m;
1117
1118   m = match_sym_complex_part (result);
1119   if (m != MATCH_NO)
1120     return m;
1121
1122   m = match_real_constant (result, 1);
1123   if (m != MATCH_NO)
1124     return m;
1125
1126   return match_integer_constant (result, 1);
1127 }
1128
1129
1130 /* Try to match a complex constant.  */
1131
1132 static match
1133 match_complex_constant (gfc_expr **result)
1134 {
1135   gfc_expr *e, *real, *imag;
1136   gfc_error_buf old_error;
1137   gfc_typespec target;
1138   locus old_loc;
1139   int kind;
1140   match m;
1141
1142   old_loc = gfc_current_locus;
1143   real = imag = e = NULL;
1144
1145   m = gfc_match_char ('(');
1146   if (m != MATCH_YES)
1147     return m;
1148
1149   gfc_push_error (&old_error);
1150
1151   m = match_complex_part (&real);
1152   if (m == MATCH_NO)
1153     {
1154       gfc_free_error (&old_error);
1155       goto cleanup;
1156     }
1157
1158   if (gfc_match_char (',') == MATCH_NO)
1159     {
1160       gfc_pop_error (&old_error);
1161       m = MATCH_NO;
1162       goto cleanup;
1163     }
1164
1165   /* If m is error, then something was wrong with the real part and we
1166      assume we have a complex constant because we've seen the ','.  An
1167      ambiguous case here is the start of an iterator list of some
1168      sort. These sort of lists are matched prior to coming here.  */
1169
1170   if (m == MATCH_ERROR)
1171     {
1172       gfc_free_error (&old_error);
1173       goto cleanup;
1174     }
1175   gfc_pop_error (&old_error);
1176
1177   m = match_complex_part (&imag);
1178   if (m == MATCH_NO)
1179     goto syntax;
1180   if (m == MATCH_ERROR)
1181     goto cleanup;
1182
1183   m = gfc_match_char (')');
1184   if (m == MATCH_NO)
1185     {
1186       /* Give the matcher for implied do-loops a chance to run.  This
1187          yields a much saner error message for (/ (i, 4=i, 6) /).  */
1188       if (gfc_peek_char () == '=')
1189         {
1190           m = MATCH_ERROR;
1191           goto cleanup;
1192         }
1193       else
1194     goto syntax;
1195     }
1196
1197   if (m == MATCH_ERROR)
1198     goto cleanup;
1199
1200   /* Decide on the kind of this complex number.  */
1201   if (real->ts.type == BT_REAL)
1202     {
1203       if (imag->ts.type == BT_REAL)
1204         kind = gfc_kind_max (real, imag);
1205       else
1206         kind = real->ts.kind;
1207     }
1208   else
1209     {
1210       if (imag->ts.type == BT_REAL)
1211         kind = imag->ts.kind;
1212       else
1213         kind = gfc_default_real_kind;
1214     }
1215   target.type = BT_REAL;
1216   target.kind = kind;
1217
1218   if (real->ts.type != BT_REAL || kind != real->ts.kind)
1219     gfc_convert_type (real, &target, 2);
1220   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1221     gfc_convert_type (imag, &target, 2);
1222
1223   e = gfc_convert_complex (real, imag, kind);
1224   e->where = gfc_current_locus;
1225
1226   gfc_free_expr (real);
1227   gfc_free_expr (imag);
1228
1229   *result = e;
1230   return MATCH_YES;
1231
1232 syntax:
1233   gfc_error ("Syntax error in COMPLEX constant at %C");
1234   m = MATCH_ERROR;
1235
1236 cleanup:
1237   gfc_free_expr (e);
1238   gfc_free_expr (real);
1239   gfc_free_expr (imag);
1240   gfc_current_locus = old_loc;
1241
1242   return m;
1243 }
1244
1245
1246 /* Match constants in any of several forms.  Returns nonzero for a
1247    match, zero for no match.  */
1248
1249 match
1250 gfc_match_literal_constant (gfc_expr **result, int signflag)
1251 {
1252   match m;
1253
1254   m = match_complex_constant (result);
1255   if (m != MATCH_NO)
1256     return m;
1257
1258   m = match_string_constant (result);
1259   if (m != MATCH_NO)
1260     return m;
1261
1262   m = match_boz_constant (result);
1263   if (m != MATCH_NO)
1264     return m;
1265
1266   m = match_real_constant (result, signflag);
1267   if (m != MATCH_NO)
1268     return m;
1269
1270   m = match_hollerith_constant (result);
1271   if (m != MATCH_NO)
1272     return m;
1273
1274   m = match_integer_constant (result, signflag);
1275   if (m != MATCH_NO)
1276     return m;
1277
1278   m = match_logical_constant (result);
1279   if (m != MATCH_NO)
1280     return m;
1281
1282   return MATCH_NO;
1283 }
1284
1285
1286 /* Match a single actual argument value.  An actual argument is
1287    usually an expression, but can also be a procedure name.  If the
1288    argument is a single name, it is not always possible to tell
1289    whether the name is a dummy procedure or not.  We treat these cases
1290    by creating an argument that looks like a dummy procedure and
1291    fixing things later during resolution.  */
1292
1293 static match
1294 match_actual_arg (gfc_expr **result)
1295 {
1296   char name[GFC_MAX_SYMBOL_LEN + 1];
1297   gfc_symtree *symtree;
1298   locus where, w;
1299   gfc_expr *e;
1300   int c;
1301
1302   where = gfc_current_locus;
1303
1304   switch (gfc_match_name (name))
1305     {
1306     case MATCH_ERROR:
1307       return MATCH_ERROR;
1308
1309     case MATCH_NO:
1310       break;
1311
1312     case MATCH_YES:
1313       w = gfc_current_locus;
1314       gfc_gobble_whitespace ();
1315       c = gfc_next_char ();
1316       gfc_current_locus = w;
1317
1318       if (c != ',' && c != ')')
1319         break;
1320
1321       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1322         break;
1323       /* Handle error elsewhere.  */
1324
1325       /* Eliminate a couple of common cases where we know we don't
1326          have a function argument.  */
1327       if (symtree == NULL)
1328         {
1329           gfc_get_sym_tree (name, NULL, &symtree);
1330           gfc_set_sym_referenced (symtree->n.sym);
1331         }
1332       else
1333         {
1334           gfc_symbol *sym;
1335
1336           sym = symtree->n.sym;
1337           gfc_set_sym_referenced (sym);
1338           if (sym->attr.flavor != FL_PROCEDURE
1339               && sym->attr.flavor != FL_UNKNOWN)
1340             break;
1341
1342           /* If the symbol is a function with itself as the result and
1343              is being defined, then we have a variable.  */
1344           if (sym->attr.function && sym->result == sym)
1345             {
1346               if (gfc_current_ns->proc_name == sym
1347                   || (gfc_current_ns->parent != NULL
1348                       && gfc_current_ns->parent->proc_name == sym))
1349                 break;
1350
1351               if (sym->attr.entry
1352                   && (sym->ns == gfc_current_ns
1353                       || sym->ns == gfc_current_ns->parent))
1354                 {
1355                   gfc_entry_list *el = NULL;
1356
1357                   for (el = sym->ns->entries; el; el = el->next)
1358                     if (sym == el->sym)
1359                       break;
1360
1361                   if (el)
1362                     break;
1363                 }
1364             }
1365         }
1366
1367       e = gfc_get_expr ();      /* Leave it unknown for now */
1368       e->symtree = symtree;
1369       e->expr_type = EXPR_VARIABLE;
1370       e->ts.type = BT_PROCEDURE;
1371       e->where = where;
1372
1373       *result = e;
1374       return MATCH_YES;
1375     }
1376
1377   gfc_current_locus = where;
1378   return gfc_match_expr (result);
1379 }
1380
1381
1382 /* Match a keyword argument.  */
1383
1384 static match
1385 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1386 {
1387   char name[GFC_MAX_SYMBOL_LEN + 1];
1388   gfc_actual_arglist *a;
1389   locus name_locus;
1390   match m;
1391
1392   name_locus = gfc_current_locus;
1393   m = gfc_match_name (name);
1394
1395   if (m != MATCH_YES)
1396     goto cleanup;
1397   if (gfc_match_char ('=') != MATCH_YES)
1398     {
1399       m = MATCH_NO;
1400       goto cleanup;
1401     }
1402
1403   m = match_actual_arg (&actual->expr);
1404   if (m != MATCH_YES)
1405     goto cleanup;
1406
1407   /* Make sure this name has not appeared yet.  */
1408
1409   if (name[0] != '\0')
1410     {
1411       for (a = base; a; a = a->next)
1412         if (a->name != NULL && strcmp (a->name, name) == 0)
1413           {
1414             gfc_error ("Keyword '%s' at %C has already appeared in the "
1415                        "current argument list", name);
1416             return MATCH_ERROR;
1417           }
1418     }
1419
1420   actual->name = gfc_get_string (name);
1421   return MATCH_YES;
1422
1423 cleanup:
1424   gfc_current_locus = name_locus;
1425   return m;
1426 }
1427
1428
1429 /* Match an argument list function, such as %VAL.  */
1430
1431 static match
1432 match_arg_list_function (gfc_actual_arglist *result)
1433 {
1434   char name[GFC_MAX_SYMBOL_LEN + 1];
1435   locus old_locus;
1436   match m;
1437
1438   old_locus = gfc_current_locus;
1439
1440   if (gfc_match_char ('%') != MATCH_YES)
1441     {
1442       m = MATCH_NO;
1443       goto cleanup;
1444     }
1445
1446   m = gfc_match ("%n (", name);
1447   if (m != MATCH_YES)
1448     goto cleanup;
1449
1450   if (name[0] != '\0')
1451     {
1452       switch (name[0])
1453         {
1454         case 'l':
1455           if (strncmp (name, "loc", 3) == 0)
1456             {
1457               result->name = "%LOC";
1458               break;
1459             }
1460         case 'r':
1461           if (strncmp (name, "ref", 3) == 0)
1462             {
1463               result->name = "%REF";
1464               break;
1465             }
1466         case 'v':
1467           if (strncmp (name, "val", 3) == 0)
1468             {
1469               result->name = "%VAL";
1470               break;
1471             }
1472         default:
1473           m = MATCH_ERROR;
1474           goto cleanup;
1475         }
1476     }
1477
1478   if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1479                       "function at %C") == FAILURE)
1480     {
1481       m = MATCH_ERROR;
1482       goto cleanup;
1483     }
1484
1485   m = match_actual_arg (&result->expr);
1486   if (m != MATCH_YES)
1487     goto cleanup;
1488
1489   if (gfc_match_char (')') != MATCH_YES)
1490     {
1491       m = MATCH_NO;
1492       goto cleanup;
1493     }
1494
1495   return MATCH_YES;
1496
1497 cleanup:
1498   gfc_current_locus = old_locus;
1499   return m;
1500 }
1501
1502
1503 /* Matches an actual argument list of a function or subroutine, from
1504    the opening parenthesis to the closing parenthesis.  The argument
1505    list is assumed to allow keyword arguments because we don't know if
1506    the symbol associated with the procedure has an implicit interface
1507    or not.  We make sure keywords are unique. If SUB_FLAG is set,
1508    we're matching the argument list of a subroutine.  */
1509
1510 match
1511 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1512 {
1513   gfc_actual_arglist *head, *tail;
1514   int seen_keyword;
1515   gfc_st_label *label;
1516   locus old_loc;
1517   match m;
1518
1519   *argp = tail = NULL;
1520   old_loc = gfc_current_locus;
1521
1522   seen_keyword = 0;
1523
1524   if (gfc_match_char ('(') == MATCH_NO)
1525     return (sub_flag) ? MATCH_YES : MATCH_NO;
1526
1527   if (gfc_match_char (')') == MATCH_YES)
1528     return MATCH_YES;
1529   head = NULL;
1530
1531   for (;;)
1532     {
1533       if (head == NULL)
1534         head = tail = gfc_get_actual_arglist ();
1535       else
1536         {
1537           tail->next = gfc_get_actual_arglist ();
1538           tail = tail->next;
1539         }
1540
1541       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1542         {
1543           m = gfc_match_st_label (&label);
1544           if (m == MATCH_NO)
1545             gfc_error ("Expected alternate return label at %C");
1546           if (m != MATCH_YES)
1547             goto cleanup;
1548
1549           tail->label = label;
1550           goto next;
1551         }
1552
1553       /* After the first keyword argument is seen, the following
1554          arguments must also have keywords.  */
1555       if (seen_keyword)
1556         {
1557           m = match_keyword_arg (tail, head);
1558
1559           if (m == MATCH_ERROR)
1560             goto cleanup;
1561           if (m == MATCH_NO)
1562             {
1563               gfc_error ("Missing keyword name in actual argument list at %C");
1564               goto cleanup;
1565             }
1566
1567         }
1568       else
1569         {
1570           /* Try an argument list function, like %VAL.  */
1571           m = match_arg_list_function (tail);
1572           if (m == MATCH_ERROR)
1573             goto cleanup;
1574
1575           /* See if we have the first keyword argument.  */
1576           if (m == MATCH_NO)
1577             {
1578               m = match_keyword_arg (tail, head);
1579               if (m == MATCH_YES)
1580                 seen_keyword = 1;
1581               if (m == MATCH_ERROR)
1582                 goto cleanup;
1583             }
1584
1585           if (m == MATCH_NO)
1586             {
1587               /* Try for a non-keyword argument.  */
1588               m = match_actual_arg (&tail->expr);
1589               if (m == MATCH_ERROR)
1590                 goto cleanup;
1591               if (m == MATCH_NO)
1592                 goto syntax;
1593             }
1594         }
1595
1596
1597     next:
1598       if (gfc_match_char (')') == MATCH_YES)
1599         break;
1600       if (gfc_match_char (',') != MATCH_YES)
1601         goto syntax;
1602     }
1603
1604   *argp = head;
1605   return MATCH_YES;
1606
1607 syntax:
1608   gfc_error ("Syntax error in argument list at %C");
1609
1610 cleanup:
1611   gfc_free_actual_arglist (head);
1612   gfc_current_locus = old_loc;
1613
1614   return MATCH_ERROR;
1615 }
1616
1617
1618 /* Used by match_varspec() to extend the reference list by one
1619    element.  */
1620
1621 static gfc_ref *
1622 extend_ref (gfc_expr *primary, gfc_ref *tail)
1623 {
1624   if (primary->ref == NULL)
1625     primary->ref = tail = gfc_get_ref ();
1626   else
1627     {
1628       if (tail == NULL)
1629         gfc_internal_error ("extend_ref(): Bad tail");
1630       tail->next = gfc_get_ref ();
1631       tail = tail->next;
1632     }
1633
1634   return tail;
1635 }
1636
1637
1638 /* Match any additional specifications associated with the current
1639    variable like member references or substrings.  If equiv_flag is
1640    set we only match stuff that is allowed inside an EQUIVALENCE
1641    statement.  */
1642
1643 static match
1644 match_varspec (gfc_expr *primary, int equiv_flag)
1645 {
1646   char name[GFC_MAX_SYMBOL_LEN + 1];
1647   gfc_ref *substring, *tail;
1648   gfc_component *component;
1649   gfc_symbol *sym = primary->symtree->n.sym;
1650   match m;
1651
1652   tail = NULL;
1653
1654   if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1655     {
1656       /* In EQUIVALENCE, we don't know yet whether we are seeing
1657          an array, character variable or array of character
1658          variables.  We'll leave the decision till resolve time.  */
1659       tail = extend_ref (primary, tail);
1660       tail->type = REF_ARRAY;
1661
1662       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1663                                equiv_flag);
1664       if (m != MATCH_YES)
1665         return m;
1666
1667       if (equiv_flag && gfc_peek_char () == '(')
1668         {
1669           tail = extend_ref (primary, tail);
1670           tail->type = REF_ARRAY;
1671
1672           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1673           if (m != MATCH_YES)
1674             return m;
1675         }
1676     }
1677
1678   primary->ts = sym->ts;
1679
1680   if (equiv_flag)
1681     return MATCH_YES;
1682
1683   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1684     goto check_substring;
1685
1686   sym = sym->ts.derived;
1687
1688   for (;;)
1689     {
1690       m = gfc_match_name (name);
1691       if (m == MATCH_NO)
1692         gfc_error ("Expected structure component name at %C");
1693       if (m != MATCH_YES)
1694         return MATCH_ERROR;
1695
1696       component = gfc_find_component (sym, name);
1697       if (component == NULL)
1698         return MATCH_ERROR;
1699
1700       tail = extend_ref (primary, tail);
1701       tail->type = REF_COMPONENT;
1702
1703       tail->u.c.component = component;
1704       tail->u.c.sym = sym;
1705
1706       primary->ts = component->ts;
1707
1708       if (component->as != NULL)
1709         {
1710           tail = extend_ref (primary, tail);
1711           tail->type = REF_ARRAY;
1712
1713           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1714           if (m != MATCH_YES)
1715             return m;
1716         }
1717
1718       if (component->ts.type != BT_DERIVED
1719           || gfc_match_char ('%') != MATCH_YES)
1720         break;
1721
1722       sym = component->ts.derived;
1723     }
1724
1725 check_substring:
1726   if (primary->ts.type == BT_UNKNOWN)
1727     {
1728       if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1729        {
1730          gfc_set_default_type (sym, 0, sym->ns);
1731          primary->ts = sym->ts;
1732        }
1733     }
1734
1735   if (primary->ts.type == BT_CHARACTER)
1736     {
1737       switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1738         {
1739         case MATCH_YES:
1740           if (tail == NULL)
1741             primary->ref = substring;
1742           else
1743             tail->next = substring;
1744
1745           if (primary->expr_type == EXPR_CONSTANT)
1746             primary->expr_type = EXPR_SUBSTRING;
1747
1748           if (substring)
1749             primary->ts.cl = NULL;
1750
1751           break;
1752
1753         case MATCH_NO:
1754           break;
1755
1756         case MATCH_ERROR:
1757           return MATCH_ERROR;
1758         }
1759     }
1760
1761   return MATCH_YES;
1762 }
1763
1764
1765 /* Given an expression that is a variable, figure out what the
1766    ultimate variable's type and attribute is, traversing the reference
1767    structures if necessary.
1768
1769    This subroutine is trickier than it looks.  We start at the base
1770    symbol and store the attribute.  Component references load a
1771    completely new attribute.
1772
1773    A couple of rules come into play.  Subobjects of targets are always
1774    targets themselves.  If we see a component that goes through a
1775    pointer, then the expression must also be a target, since the
1776    pointer is associated with something (if it isn't core will soon be
1777    dumped).  If we see a full part or section of an array, the
1778    expression is also an array.
1779
1780    We can have at most one full array reference.  */
1781
1782 symbol_attribute
1783 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1784 {
1785   int dimension, pointer, allocatable, target;
1786   symbol_attribute attr;
1787   gfc_ref *ref;
1788
1789   if (expr->expr_type != EXPR_VARIABLE)
1790     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1791
1792   ref = expr->ref;
1793   attr = expr->symtree->n.sym->attr;
1794
1795   dimension = attr.dimension;
1796   pointer = attr.pointer;
1797   allocatable = attr.allocatable;
1798
1799   target = attr.target;
1800   if (pointer)
1801     target = 1;
1802
1803   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1804     *ts = expr->symtree->n.sym->ts;
1805
1806   for (; ref; ref = ref->next)
1807     switch (ref->type)
1808       {
1809       case REF_ARRAY:
1810
1811         switch (ref->u.ar.type)
1812           {
1813           case AR_FULL:
1814             dimension = 1;
1815             break;
1816
1817           case AR_SECTION:
1818             allocatable = pointer = 0;
1819             dimension = 1;
1820             break;
1821
1822           case AR_ELEMENT:
1823             allocatable = pointer = 0;
1824             break;
1825
1826           case AR_UNKNOWN:
1827             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1828           }
1829
1830         break;
1831
1832       case REF_COMPONENT:
1833         gfc_get_component_attr (&attr, ref->u.c.component);
1834         if (ts != NULL)
1835           *ts = ref->u.c.component->ts;
1836
1837         pointer = ref->u.c.component->pointer;
1838         allocatable = ref->u.c.component->allocatable;
1839         if (pointer)
1840           target = 1;
1841
1842         break;
1843
1844       case REF_SUBSTRING:
1845         allocatable = pointer = 0;
1846         break;
1847       }
1848
1849   attr.dimension = dimension;
1850   attr.pointer = pointer;
1851   attr.allocatable = allocatable;
1852   attr.target = target;
1853
1854   return attr;
1855 }
1856
1857
1858 /* Return the attribute from a general expression.  */
1859
1860 symbol_attribute
1861 gfc_expr_attr (gfc_expr *e)
1862 {
1863   symbol_attribute attr;
1864
1865   switch (e->expr_type)
1866     {
1867     case EXPR_VARIABLE:
1868       attr = gfc_variable_attr (e, NULL);
1869       break;
1870
1871     case EXPR_FUNCTION:
1872       gfc_clear_attr (&attr);
1873
1874       if (e->value.function.esym != NULL)
1875         attr = e->value.function.esym->result->attr;
1876
1877       /* TODO: NULL() returns pointers.  May have to take care of this
1878          here.  */
1879
1880       break;
1881
1882     default:
1883       gfc_clear_attr (&attr);
1884       break;
1885     }
1886
1887   return attr;
1888 }
1889
1890
1891 /* Match a structure constructor.  The initial symbol has already been
1892    seen.  */
1893
1894 match
1895 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1896 {
1897   gfc_constructor *head, *tail;
1898   gfc_component *comp;
1899   gfc_expr *e;
1900   locus where;
1901   match m;
1902
1903   head = tail = NULL;
1904
1905   if (gfc_match_char ('(') != MATCH_YES)
1906     goto syntax;
1907
1908   where = gfc_current_locus;
1909
1910   gfc_find_component (sym, NULL);
1911
1912   for (comp = sym->components; comp; comp = comp->next)
1913     {
1914       if (head == NULL)
1915         tail = head = gfc_get_constructor ();
1916       else
1917         {
1918           tail->next = gfc_get_constructor ();
1919           tail = tail->next;
1920         }
1921
1922       m = gfc_match_expr (&tail->expr);
1923       if (m == MATCH_NO)
1924         goto syntax;
1925       if (m == MATCH_ERROR)
1926         goto cleanup;
1927
1928       if (gfc_match_char (',') == MATCH_YES)
1929         {
1930           if (comp->next == NULL)
1931             {
1932               gfc_error ("Too many components in structure constructor at %C");
1933               goto cleanup;
1934             }
1935
1936           continue;
1937         }
1938
1939       break;
1940     }
1941
1942   if (gfc_match_char (')') != MATCH_YES)
1943     goto syntax;
1944
1945   if (comp->next != NULL)
1946     {
1947       gfc_error ("Too few components in structure constructor at %C");
1948       goto cleanup;
1949     }
1950
1951   e = gfc_get_expr ();
1952
1953   e->expr_type = EXPR_STRUCTURE;
1954
1955   e->ts.type = BT_DERIVED;
1956   e->ts.derived = sym;
1957   e->where = where;
1958
1959   e->value.constructor = head;
1960
1961   *result = e;
1962   return MATCH_YES;
1963
1964 syntax:
1965   gfc_error ("Syntax error in structure constructor at %C");
1966
1967 cleanup:
1968   gfc_free_constructor (head);
1969   return MATCH_ERROR;
1970 }
1971
1972
1973 /* Matches a variable name followed by anything that might follow it--
1974    array reference, argument list of a function, etc.  */
1975
1976 match
1977 gfc_match_rvalue (gfc_expr **result)
1978 {
1979   gfc_actual_arglist *actual_arglist;
1980   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
1981   gfc_state_data *st;
1982   gfc_symbol *sym;
1983   gfc_symtree *symtree;
1984   locus where, old_loc;
1985   gfc_expr *e;
1986   match m, m2;
1987   int i;
1988   gfc_typespec *ts;
1989   bool implicit_char;
1990
1991   m = gfc_match_name (name);
1992   if (m != MATCH_YES)
1993     return m;
1994
1995   if (gfc_find_state (COMP_INTERFACE) == SUCCESS
1996       && !gfc_current_ns->has_import_set)
1997     i = gfc_get_sym_tree (name, NULL, &symtree);
1998   else
1999     i = gfc_get_ha_sym_tree (name, &symtree);
2000
2001   if (i)
2002     return MATCH_ERROR;
2003
2004   sym = symtree->n.sym;
2005   e = NULL;
2006   where = gfc_current_locus;
2007
2008   gfc_set_sym_referenced (sym);
2009
2010   if (sym->attr.function && sym->result == sym)
2011     {
2012       /* See if this is a directly recursive function call.  */
2013       gfc_gobble_whitespace ();
2014       if (sym->attr.recursive
2015           && gfc_peek_char () == '('
2016           && gfc_current_ns->proc_name == sym)
2017         {
2018           if (!sym->attr.dimension)
2019             goto function0;
2020
2021           gfc_error ("'%s' is array valued and directly recursive "
2022                      "at %C , so the keyword RESULT must be specified "
2023                      "in the FUNCTION statement", sym->name);
2024           return MATCH_ERROR;
2025         }
2026         
2027       if (gfc_current_ns->proc_name == sym
2028           || (gfc_current_ns->parent != NULL
2029               && gfc_current_ns->parent->proc_name == sym))
2030         goto variable;
2031
2032       if (sym->attr.entry
2033           && (sym->ns == gfc_current_ns
2034               || sym->ns == gfc_current_ns->parent))
2035         {
2036           gfc_entry_list *el = NULL;
2037           
2038           for (el = sym->ns->entries; el; el = el->next)
2039             if (sym == el->sym)
2040               goto variable;
2041         }
2042     }
2043
2044   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2045     goto function0;
2046
2047   if (sym->attr.generic)
2048     goto generic_function;
2049
2050   switch (sym->attr.flavor)
2051     {
2052     case FL_VARIABLE:
2053     variable:
2054       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2055           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2056         gfc_set_default_type (sym, 0, sym->ns);
2057
2058       e = gfc_get_expr ();
2059
2060       e->expr_type = EXPR_VARIABLE;
2061       e->symtree = symtree;
2062
2063       m = match_varspec (e, 0);
2064       break;
2065
2066     case FL_PARAMETER:
2067       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2068          end up here.  Unfortunately, sym->value->expr_type is set to 
2069          EXPR_CONSTANT, and so the if () branch would be followed without
2070          the !sym->as check.  */
2071       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2072         e = gfc_copy_expr (sym->value);
2073       else
2074         {
2075           e = gfc_get_expr ();
2076           e->expr_type = EXPR_VARIABLE;
2077         }
2078
2079       e->symtree = symtree;
2080       m = match_varspec (e, 0);
2081       break;
2082
2083     case FL_DERIVED:
2084       sym = gfc_use_derived (sym);
2085       if (sym == NULL)
2086         m = MATCH_ERROR;
2087       else
2088         m = gfc_match_structure_constructor (sym, &e);
2089       break;
2090
2091     /* If we're here, then the name is known to be the name of a
2092        procedure, yet it is not sure to be the name of a function.  */
2093     case FL_PROCEDURE:
2094       if (sym->attr.subroutine)
2095         {
2096           gfc_error ("Unexpected use of subroutine name '%s' at %C",
2097                      sym->name);
2098           m = MATCH_ERROR;
2099           break;
2100         }
2101
2102       /* At this point, the name has to be a non-statement function.
2103          If the name is the same as the current function being
2104          compiled, then we have a variable reference (to the function
2105          result) if the name is non-recursive.  */
2106
2107       st = gfc_enclosing_unit (NULL);
2108
2109       if (st != NULL && st->state == COMP_FUNCTION
2110           && st->sym == sym
2111           && !sym->attr.recursive)
2112         {
2113           e = gfc_get_expr ();
2114           e->symtree = symtree;
2115           e->expr_type = EXPR_VARIABLE;
2116
2117           m = match_varspec (e, 0);
2118           break;
2119         }
2120
2121     /* Match a function reference.  */
2122     function0:
2123       m = gfc_match_actual_arglist (0, &actual_arglist);
2124       if (m == MATCH_NO)
2125         {
2126           if (sym->attr.proc == PROC_ST_FUNCTION)
2127             gfc_error ("Statement function '%s' requires argument list at %C",
2128                        sym->name);
2129           else
2130             gfc_error ("Function '%s' requires an argument list at %C",
2131                        sym->name);
2132
2133           m = MATCH_ERROR;
2134           break;
2135         }
2136
2137       if (m != MATCH_YES)
2138         {
2139           m = MATCH_ERROR;
2140           break;
2141         }
2142
2143       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2144       sym = symtree->n.sym;
2145
2146       e = gfc_get_expr ();
2147       e->symtree = symtree;
2148       e->expr_type = EXPR_FUNCTION;
2149       e->value.function.actual = actual_arglist;
2150       e->where = gfc_current_locus;
2151
2152       if (sym->as != NULL)
2153         e->rank = sym->as->rank;
2154
2155       if (!sym->attr.function
2156           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2157         {
2158           m = MATCH_ERROR;
2159           break;
2160         }
2161
2162       if (sym->result == NULL)
2163         sym->result = sym;
2164
2165       m = MATCH_YES;
2166       break;
2167
2168     case FL_UNKNOWN:
2169
2170       /* Special case for derived type variables that get their types
2171          via an IMPLICIT statement.  This can't wait for the
2172          resolution phase.  */
2173
2174       if (gfc_peek_char () == '%'
2175           && sym->ts.type == BT_UNKNOWN
2176           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2177         gfc_set_default_type (sym, 0, sym->ns);
2178
2179       /* If the symbol has a dimension attribute, the expression is a
2180          variable.  */
2181
2182       if (sym->attr.dimension)
2183         {
2184           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2185                               sym->name, NULL) == FAILURE)
2186             {
2187               m = MATCH_ERROR;
2188               break;
2189             }
2190
2191           e = gfc_get_expr ();
2192           e->symtree = symtree;
2193           e->expr_type = EXPR_VARIABLE;
2194           m = match_varspec (e, 0);
2195           break;
2196         }
2197
2198       /* Name is not an array, so we peek to see if a '(' implies a
2199          function call or a substring reference.  Otherwise the
2200          variable is just a scalar.  */
2201
2202       gfc_gobble_whitespace ();
2203       if (gfc_peek_char () != '(')
2204         {
2205           /* Assume a scalar variable */
2206           e = gfc_get_expr ();
2207           e->symtree = symtree;
2208           e->expr_type = EXPR_VARIABLE;
2209
2210           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2211                               sym->name, NULL) == FAILURE)
2212             {
2213               m = MATCH_ERROR;
2214               break;
2215             }
2216
2217           e->ts = sym->ts;
2218           m = match_varspec (e, 0);
2219           break;
2220         }
2221
2222       /* See if this is a function reference with a keyword argument
2223          as first argument. We do this because otherwise a spurious
2224          symbol would end up in the symbol table.  */
2225
2226       old_loc = gfc_current_locus;
2227       m2 = gfc_match (" ( %n =", argname);
2228       gfc_current_locus = old_loc;
2229
2230       e = gfc_get_expr ();
2231       e->symtree = symtree;
2232
2233       if (m2 != MATCH_YES)
2234         {
2235           /* Try to figure out whether we're dealing with a character type.
2236              We're peeking ahead here, because we don't want to call 
2237              match_substring if we're dealing with an implicitly typed
2238              non-character variable.  */
2239           implicit_char = false;
2240           if (sym->ts.type == BT_UNKNOWN)
2241             {
2242               ts = gfc_get_default_type (sym,NULL);
2243               if (ts->type == BT_CHARACTER)
2244                 implicit_char = true;
2245             }
2246
2247           /* See if this could possibly be a substring reference of a name
2248              that we're not sure is a variable yet.  */
2249
2250           if ((implicit_char || sym->ts.type == BT_CHARACTER)
2251               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2252             {
2253
2254               e->expr_type = EXPR_VARIABLE;
2255
2256               if (sym->attr.flavor != FL_VARIABLE
2257                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2258                                      sym->name, NULL) == FAILURE)
2259                 {
2260                   m = MATCH_ERROR;
2261                   break;
2262                 }
2263
2264               if (sym->ts.type == BT_UNKNOWN
2265                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2266                 {
2267                   m = MATCH_ERROR;
2268                   break;
2269                 }
2270
2271               e->ts = sym->ts;
2272               if (e->ref)
2273                 e->ts.cl = NULL;
2274               m = MATCH_YES;
2275               break;
2276             }
2277         }
2278
2279       /* Give up, assume we have a function.  */
2280
2281       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2282       sym = symtree->n.sym;
2283       e->expr_type = EXPR_FUNCTION;
2284
2285       if (!sym->attr.function
2286           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2287         {
2288           m = MATCH_ERROR;
2289           break;
2290         }
2291
2292       sym->result = sym;
2293
2294       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2295       if (m == MATCH_NO)
2296         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2297
2298       if (m != MATCH_YES)
2299         {
2300           m = MATCH_ERROR;
2301           break;
2302         }
2303
2304       /* If our new function returns a character, array or structure
2305          type, it might have subsequent references.  */
2306
2307       m = match_varspec (e, 0);
2308       if (m == MATCH_NO)
2309         m = MATCH_YES;
2310
2311       break;
2312
2313     generic_function:
2314       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2315
2316       e = gfc_get_expr ();
2317       e->symtree = symtree;
2318       e->expr_type = EXPR_FUNCTION;
2319
2320       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2321       break;
2322
2323     default:
2324       gfc_error ("Symbol at %C is not appropriate for an expression");
2325       return MATCH_ERROR;
2326     }
2327
2328   if (m == MATCH_YES)
2329     {
2330       e->where = where;
2331       *result = e;
2332     }
2333   else
2334     gfc_free_expr (e);
2335
2336   return m;
2337 }
2338
2339
2340 /* Match a variable, ie something that can be assigned to.  This
2341    starts as a symbol, can be a structure component or an array
2342    reference.  It can be a function if the function doesn't have a
2343    separate RESULT variable.  If the symbol has not been previously
2344    seen, we assume it is a variable.
2345
2346    This function is called by two interface functions:
2347    gfc_match_variable, which has host_flag = 1, and
2348    gfc_match_equiv_variable, with host_flag = 0, to restrict the
2349    match of the symbol to the local scope.  */
2350
2351 static match
2352 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2353 {
2354   gfc_symbol *sym;
2355   gfc_symtree *st;
2356   gfc_expr *expr;
2357   locus where;
2358   match m;
2359
2360   /* Since nothing has any business being an lvalue in a module
2361      specification block, an interface block or a contains section,
2362      we force the changed_symbols mechanism to work by setting
2363      host_flag to 0. This prevents valid symbols that have the name
2364      of keywords, such as 'end', being turned into variables by
2365      failed matching to assignments for, eg., END INTERFACE.  */
2366   if (gfc_current_state () == COMP_MODULE
2367       || gfc_current_state () == COMP_INTERFACE
2368       || gfc_current_state () == COMP_CONTAINS)
2369     host_flag = 0;
2370
2371   m = gfc_match_sym_tree (&st, host_flag);
2372   if (m != MATCH_YES)
2373     return m;
2374   where = gfc_current_locus;
2375
2376   sym = st->n.sym;
2377   gfc_set_sym_referenced (sym);
2378   switch (sym->attr.flavor)
2379     {
2380     case FL_VARIABLE:
2381       if (sym->attr.protected && sym->attr.use_assoc)
2382         {
2383           gfc_error ("Assigning to PROTECTED variable at %C");
2384           return MATCH_ERROR;
2385         }
2386       break;
2387
2388     case FL_UNKNOWN:
2389       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2390                           sym->name, NULL) == FAILURE)
2391         return MATCH_ERROR;
2392       break;
2393
2394     case FL_PARAMETER:
2395       if (equiv_flag)
2396         gfc_error ("Named constant at %C in an EQUIVALENCE");
2397       else
2398         gfc_error ("Cannot assign to a named constant at %C");
2399       return MATCH_ERROR;
2400       break;
2401
2402     case FL_PROCEDURE:
2403       /* Check for a nonrecursive function result */
2404       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2405         {
2406           /* If a function result is a derived type, then the derived
2407              type may still have to be resolved.  */
2408
2409           if (sym->ts.type == BT_DERIVED
2410               && gfc_use_derived (sym->ts.derived) == NULL)
2411             return MATCH_ERROR;
2412           break;
2413         }
2414
2415       /* Fall through to error */
2416
2417     default:
2418       gfc_error ("Expected VARIABLE at %C");
2419       return MATCH_ERROR;
2420     }
2421
2422   /* Special case for derived type variables that get their types
2423      via an IMPLICIT statement.  This can't wait for the
2424      resolution phase.  */
2425
2426     {
2427       gfc_namespace * implicit_ns;
2428
2429       if (gfc_current_ns->proc_name == sym)
2430         implicit_ns = gfc_current_ns;
2431       else
2432         implicit_ns = sym->ns;
2433         
2434       if (gfc_peek_char () == '%'
2435           && sym->ts.type == BT_UNKNOWN
2436           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2437         gfc_set_default_type (sym, 0, implicit_ns);
2438     }
2439
2440   expr = gfc_get_expr ();
2441
2442   expr->expr_type = EXPR_VARIABLE;
2443   expr->symtree = st;
2444   expr->ts = sym->ts;
2445   expr->where = where;
2446
2447   /* Now see if we have to do more.  */
2448   m = match_varspec (expr, equiv_flag);
2449   if (m != MATCH_YES)
2450     {
2451       gfc_free_expr (expr);
2452       return m;
2453     }
2454
2455   *result = expr;
2456   return MATCH_YES;
2457 }
2458
2459
2460 match
2461 gfc_match_variable (gfc_expr **result, int equiv_flag)
2462 {
2463   return match_variable (result, equiv_flag, 1);
2464 }
2465
2466
2467 match
2468 gfc_match_equiv_variable (gfc_expr **result)
2469 {
2470   return match_variable (result, 1, 0);
2471 }
2472