OSDN Git Service

1ef37a695512bb17c4909a2b673bbf7afe8cef51
[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       if (!(gfc_option.allow_std & GFC_STD_GNU) && !inhibit_warnings)
769         gfc_warning ("Extension: backslash character at %C");
770     }
771
772   if (c != delimiter)
773     return c;
774
775   old_locus = gfc_current_locus;
776   c = gfc_next_char_literal (0);
777
778   if (c == delimiter)
779     return c;
780   gfc_current_locus = old_locus;
781
782   return -1;
783 }
784
785
786 /* Special case of gfc_match_name() that matches a parameter kind name
787    before a string constant.  This takes case of the weird but legal
788    case of:
789
790      kind_____'string'
791
792    where kind____ is a parameter. gfc_match_name() will happily slurp
793    up all the underscores, which leads to problems.  If we return
794    MATCH_YES, the parse pointer points to the final underscore, which
795    is not part of the name.  We never return MATCH_ERROR-- errors in
796    the name will be detected later.  */
797
798 static match
799 match_charkind_name (char *name)
800 {
801   locus old_loc;
802   char c, peek;
803   int len;
804
805   gfc_gobble_whitespace ();
806   c = gfc_next_char ();
807   if (!ISALPHA (c))
808     return MATCH_NO;
809
810   *name++ = c;
811   len = 1;
812
813   for (;;)
814     {
815       old_loc = gfc_current_locus;
816       c = gfc_next_char ();
817
818       if (c == '_')
819         {
820           peek = gfc_peek_char ();
821
822           if (peek == '\'' || peek == '\"')
823             {
824               gfc_current_locus = old_loc;
825               *name = '\0';
826               return MATCH_YES;
827             }
828         }
829
830       if (!ISALNUM (c)
831           && c != '_'
832           && (gfc_option.flag_dollar_ok && c != '$'))
833         break;
834
835       *name++ = c;
836       if (++len > GFC_MAX_SYMBOL_LEN)
837         break;
838     }
839
840   return MATCH_NO;
841 }
842
843
844 /* See if the current input matches a character constant.  Lots of
845    contortions have to be done to match the kind parameter which comes
846    before the actual string.  The main consideration is that we don't
847    want to error out too quickly.  For example, we don't actually do
848    any validation of the kinds until we have actually seen a legal
849    delimiter.  Using match_kind_param() generates errors too quickly.  */
850
851 static match
852 match_string_constant (gfc_expr **result)
853 {
854   char *p, name[GFC_MAX_SYMBOL_LEN + 1];
855   int i, c, kind, length, delimiter, warn_ampersand;
856   locus old_locus, start_locus;
857   gfc_symbol *sym;
858   gfc_expr *e;
859   const char *q;
860   match m;
861
862   old_locus = gfc_current_locus;
863
864   gfc_gobble_whitespace ();
865
866   start_locus = gfc_current_locus;
867
868   c = gfc_next_char ();
869   if (c == '\'' || c == '"')
870     {
871       kind = gfc_default_character_kind;
872       goto got_delim;
873     }
874
875   if (ISDIGIT (c))
876     {
877       kind = 0;
878
879       while (ISDIGIT (c))
880         {
881           kind = kind * 10 + c - '0';
882           if (kind > 9999999)
883             goto no_match;
884           c = gfc_next_char ();
885         }
886
887     }
888   else
889     {
890       gfc_current_locus = old_locus;
891
892       m = match_charkind_name (name);
893       if (m != MATCH_YES)
894         goto no_match;
895
896       if (gfc_find_symbol (name, NULL, 1, &sym)
897           || sym == NULL
898           || sym->attr.flavor != FL_PARAMETER)
899         goto no_match;
900
901       kind = -1;
902       c = gfc_next_char ();
903     }
904
905   if (c == ' ')
906     {
907       gfc_gobble_whitespace ();
908       c = gfc_next_char ();
909     }
910
911   if (c != '_')
912     goto no_match;
913
914   gfc_gobble_whitespace ();
915   start_locus = gfc_current_locus;
916
917   c = gfc_next_char ();
918   if (c != '\'' && c != '"')
919     goto no_match;
920
921   if (kind == -1)
922     {
923       q = gfc_extract_int (sym->value, &kind);
924       if (q != NULL)
925         {
926           gfc_error (q);
927           return MATCH_ERROR;
928         }
929     }
930
931   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
932     {
933       gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
934       return MATCH_ERROR;
935     }
936
937 got_delim:
938   /* Scan the string into a block of memory by first figuring out how
939      long it is, allocating the structure, then re-reading it.  This
940      isn't particularly efficient, but string constants aren't that
941      common in most code.  TODO: Use obstacks?  */
942
943   delimiter = c;
944   length = 0;
945
946   for (;;)
947     {
948       c = next_string_char (delimiter);
949       if (c == -1)
950         break;
951       if (c == -2)
952         {
953           gfc_current_locus = start_locus;
954           gfc_error ("Unterminated character constant beginning at %C");
955           return MATCH_ERROR;
956         }
957
958       length++;
959     }
960
961   /* Peek at the next character to see if it is a b, o, z, or x for the
962      postfixed BOZ literal constants.  */
963   c = gfc_peek_char ();
964   if (c == 'b' || c == 'o' || c =='z' || c == 'x')
965     goto no_match;
966
967
968   e = gfc_get_expr ();
969
970   e->expr_type = EXPR_CONSTANT;
971   e->ref = NULL;
972   e->ts.type = BT_CHARACTER;
973   e->ts.kind = kind;
974   e->where = start_locus;
975
976   e->value.character.string = p = gfc_getmem (length + 1);
977   e->value.character.length = length;
978
979   gfc_current_locus = start_locus;
980   gfc_next_char ();             /* Skip delimiter */
981
982   /* We disable the warning for the following loop as the warning has already
983      been printed in the loop above.  */
984   warn_ampersand = gfc_option.warn_ampersand;
985   gfc_option.warn_ampersand = 0;
986
987   for (i = 0; i < length; i++)
988     *p++ = next_string_char (delimiter);
989
990   *p = '\0';    /* TODO: C-style string is for development/debug purposes.  */
991   gfc_option.warn_ampersand = warn_ampersand;
992
993   if (next_string_char (delimiter) != -1)
994     gfc_internal_error ("match_string_constant(): Delimiter not found");
995
996   if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
997     e->expr_type = EXPR_SUBSTRING;
998
999   *result = e;
1000
1001   return MATCH_YES;
1002
1003 no_match:
1004   gfc_current_locus = old_locus;
1005   return MATCH_NO;
1006 }
1007
1008
1009 /* Match a .true. or .false.  */
1010
1011 static match
1012 match_logical_constant (gfc_expr **result)
1013 {
1014   static mstring logical_ops[] = {
1015     minit (".false.", 0),
1016     minit (".true.", 1),
1017     minit (NULL, -1)
1018   };
1019
1020   gfc_expr *e;
1021   int i, kind;
1022
1023   i = gfc_match_strings (logical_ops);
1024   if (i == -1)
1025     return MATCH_NO;
1026
1027   kind = get_kind ();
1028   if (kind == -1)
1029     return MATCH_ERROR;
1030   if (kind == -2)
1031     kind = gfc_default_logical_kind;
1032
1033   if (gfc_validate_kind (BT_LOGICAL, kind, true) < 0)
1034     {
1035       gfc_error ("Bad kind for logical constant at %C");
1036       return MATCH_ERROR;
1037     }
1038
1039   e = gfc_get_expr ();
1040
1041   e->expr_type = EXPR_CONSTANT;
1042   e->value.logical = i;
1043   e->ts.type = BT_LOGICAL;
1044   e->ts.kind = kind;
1045   e->where = gfc_current_locus;
1046
1047   *result = e;
1048   return MATCH_YES;
1049 }
1050
1051
1052 /* Match a real or imaginary part of a complex constant that is a
1053    symbolic constant.  */
1054
1055 static match
1056 match_sym_complex_part (gfc_expr **result)
1057 {
1058   char name[GFC_MAX_SYMBOL_LEN + 1];
1059   gfc_symbol *sym;
1060   gfc_expr *e;
1061   match m;
1062
1063   m = gfc_match_name (name);
1064   if (m != MATCH_YES)
1065     return m;
1066
1067   if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
1068     return MATCH_NO;
1069
1070   if (sym->attr.flavor != FL_PARAMETER)
1071     {
1072       gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1073       return MATCH_ERROR;
1074     }
1075
1076   if (!gfc_numeric_ts (&sym->value->ts))
1077     {
1078       gfc_error ("Numeric PARAMETER required in complex constant at %C");
1079       return MATCH_ERROR;
1080     }
1081
1082   if (sym->value->rank != 0)
1083     {
1084       gfc_error ("Scalar PARAMETER required in complex constant at %C");
1085       return MATCH_ERROR;
1086     }
1087
1088   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PARAMETER symbol in "
1089                       "complex constant at %C") == FAILURE)
1090     return MATCH_ERROR;
1091
1092   switch (sym->value->ts.type)
1093     {
1094     case BT_REAL:
1095       e = gfc_copy_expr (sym->value);
1096       break;
1097
1098     case BT_COMPLEX:
1099       e = gfc_complex2real (sym->value, sym->value->ts.kind);
1100       if (e == NULL)
1101         goto error;
1102       break;
1103
1104     case BT_INTEGER:
1105       e = gfc_int2real (sym->value, gfc_default_real_kind);
1106       if (e == NULL)
1107         goto error;
1108       break;
1109
1110     default:
1111       gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1112     }
1113
1114   *result = e;          /* e is a scalar, real, constant expression.  */
1115   return MATCH_YES;
1116
1117 error:
1118   gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1119   return MATCH_ERROR;
1120 }
1121
1122
1123 /* Match a real or imaginary part of a complex number.  */
1124
1125 static match
1126 match_complex_part (gfc_expr **result)
1127 {
1128   match m;
1129
1130   m = match_sym_complex_part (result);
1131   if (m != MATCH_NO)
1132     return m;
1133
1134   m = match_real_constant (result, 1);
1135   if (m != MATCH_NO)
1136     return m;
1137
1138   return match_integer_constant (result, 1);
1139 }
1140
1141
1142 /* Try to match a complex constant.  */
1143
1144 static match
1145 match_complex_constant (gfc_expr **result)
1146 {
1147   gfc_expr *e, *real, *imag;
1148   gfc_error_buf old_error;
1149   gfc_typespec target;
1150   locus old_loc;
1151   int kind;
1152   match m;
1153
1154   old_loc = gfc_current_locus;
1155   real = imag = e = NULL;
1156
1157   m = gfc_match_char ('(');
1158   if (m != MATCH_YES)
1159     return m;
1160
1161   gfc_push_error (&old_error);
1162
1163   m = match_complex_part (&real);
1164   if (m == MATCH_NO)
1165     {
1166       gfc_free_error (&old_error);
1167       goto cleanup;
1168     }
1169
1170   if (gfc_match_char (',') == MATCH_NO)
1171     {
1172       gfc_pop_error (&old_error);
1173       m = MATCH_NO;
1174       goto cleanup;
1175     }
1176
1177   /* If m is error, then something was wrong with the real part and we
1178      assume we have a complex constant because we've seen the ','.  An
1179      ambiguous case here is the start of an iterator list of some
1180      sort. These sort of lists are matched prior to coming here.  */
1181
1182   if (m == MATCH_ERROR)
1183     {
1184       gfc_free_error (&old_error);
1185       goto cleanup;
1186     }
1187   gfc_pop_error (&old_error);
1188
1189   m = match_complex_part (&imag);
1190   if (m == MATCH_NO)
1191     goto syntax;
1192   if (m == MATCH_ERROR)
1193     goto cleanup;
1194
1195   m = gfc_match_char (')');
1196   if (m == MATCH_NO)
1197     {
1198       /* Give the matcher for implied do-loops a chance to run.  This
1199          yields a much saner error message for (/ (i, 4=i, 6) /).  */
1200       if (gfc_peek_char () == '=')
1201         {
1202           m = MATCH_ERROR;
1203           goto cleanup;
1204         }
1205       else
1206     goto syntax;
1207     }
1208
1209   if (m == MATCH_ERROR)
1210     goto cleanup;
1211
1212   /* Decide on the kind of this complex number.  */
1213   if (real->ts.type == BT_REAL)
1214     {
1215       if (imag->ts.type == BT_REAL)
1216         kind = gfc_kind_max (real, imag);
1217       else
1218         kind = real->ts.kind;
1219     }
1220   else
1221     {
1222       if (imag->ts.type == BT_REAL)
1223         kind = imag->ts.kind;
1224       else
1225         kind = gfc_default_real_kind;
1226     }
1227   target.type = BT_REAL;
1228   target.kind = kind;
1229
1230   if (real->ts.type != BT_REAL || kind != real->ts.kind)
1231     gfc_convert_type (real, &target, 2);
1232   if (imag->ts.type != BT_REAL || kind != imag->ts.kind)
1233     gfc_convert_type (imag, &target, 2);
1234
1235   e = gfc_convert_complex (real, imag, kind);
1236   e->where = gfc_current_locus;
1237
1238   gfc_free_expr (real);
1239   gfc_free_expr (imag);
1240
1241   *result = e;
1242   return MATCH_YES;
1243
1244 syntax:
1245   gfc_error ("Syntax error in COMPLEX constant at %C");
1246   m = MATCH_ERROR;
1247
1248 cleanup:
1249   gfc_free_expr (e);
1250   gfc_free_expr (real);
1251   gfc_free_expr (imag);
1252   gfc_current_locus = old_loc;
1253
1254   return m;
1255 }
1256
1257
1258 /* Match constants in any of several forms.  Returns nonzero for a
1259    match, zero for no match.  */
1260
1261 match
1262 gfc_match_literal_constant (gfc_expr **result, int signflag)
1263 {
1264   match m;
1265
1266   m = match_complex_constant (result);
1267   if (m != MATCH_NO)
1268     return m;
1269
1270   m = match_string_constant (result);
1271   if (m != MATCH_NO)
1272     return m;
1273
1274   m = match_boz_constant (result);
1275   if (m != MATCH_NO)
1276     return m;
1277
1278   m = match_real_constant (result, signflag);
1279   if (m != MATCH_NO)
1280     return m;
1281
1282   m = match_hollerith_constant (result);
1283   if (m != MATCH_NO)
1284     return m;
1285
1286   m = match_integer_constant (result, signflag);
1287   if (m != MATCH_NO)
1288     return m;
1289
1290   m = match_logical_constant (result);
1291   if (m != MATCH_NO)
1292     return m;
1293
1294   return MATCH_NO;
1295 }
1296
1297
1298 /* Match a single actual argument value.  An actual argument is
1299    usually an expression, but can also be a procedure name.  If the
1300    argument is a single name, it is not always possible to tell
1301    whether the name is a dummy procedure or not.  We treat these cases
1302    by creating an argument that looks like a dummy procedure and
1303    fixing things later during resolution.  */
1304
1305 static match
1306 match_actual_arg (gfc_expr **result)
1307 {
1308   char name[GFC_MAX_SYMBOL_LEN + 1];
1309   gfc_symtree *symtree;
1310   locus where, w;
1311   gfc_expr *e;
1312   int c;
1313
1314   where = gfc_current_locus;
1315
1316   switch (gfc_match_name (name))
1317     {
1318     case MATCH_ERROR:
1319       return MATCH_ERROR;
1320
1321     case MATCH_NO:
1322       break;
1323
1324     case MATCH_YES:
1325       w = gfc_current_locus;
1326       gfc_gobble_whitespace ();
1327       c = gfc_next_char ();
1328       gfc_current_locus = w;
1329
1330       if (c != ',' && c != ')')
1331         break;
1332
1333       if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1334         break;
1335       /* Handle error elsewhere.  */
1336
1337       /* Eliminate a couple of common cases where we know we don't
1338          have a function argument.  */
1339       if (symtree == NULL)
1340         {
1341           gfc_get_sym_tree (name, NULL, &symtree);
1342           gfc_set_sym_referenced (symtree->n.sym);
1343         }
1344       else
1345         {
1346           gfc_symbol *sym;
1347
1348           sym = symtree->n.sym;
1349           gfc_set_sym_referenced (sym);
1350           if (sym->attr.flavor != FL_PROCEDURE
1351               && sym->attr.flavor != FL_UNKNOWN)
1352             break;
1353
1354           /* If the symbol is a function with itself as the result and
1355              is being defined, then we have a variable.  */
1356           if (sym->attr.function && sym->result == sym)
1357             {
1358               if (gfc_current_ns->proc_name == sym
1359                   || (gfc_current_ns->parent != NULL
1360                       && gfc_current_ns->parent->proc_name == sym))
1361                 break;
1362
1363               if (sym->attr.entry
1364                   && (sym->ns == gfc_current_ns
1365                       || sym->ns == gfc_current_ns->parent))
1366                 {
1367                   gfc_entry_list *el = NULL;
1368
1369                   for (el = sym->ns->entries; el; el = el->next)
1370                     if (sym == el->sym)
1371                       break;
1372
1373                   if (el)
1374                     break;
1375                 }
1376             }
1377         }
1378
1379       e = gfc_get_expr ();      /* Leave it unknown for now */
1380       e->symtree = symtree;
1381       e->expr_type = EXPR_VARIABLE;
1382       e->ts.type = BT_PROCEDURE;
1383       e->where = where;
1384
1385       *result = e;
1386       return MATCH_YES;
1387     }
1388
1389   gfc_current_locus = where;
1390   return gfc_match_expr (result);
1391 }
1392
1393
1394 /* Match a keyword argument.  */
1395
1396 static match
1397 match_keyword_arg (gfc_actual_arglist *actual, gfc_actual_arglist *base)
1398 {
1399   char name[GFC_MAX_SYMBOL_LEN + 1];
1400   gfc_actual_arglist *a;
1401   locus name_locus;
1402   match m;
1403
1404   name_locus = gfc_current_locus;
1405   m = gfc_match_name (name);
1406
1407   if (m != MATCH_YES)
1408     goto cleanup;
1409   if (gfc_match_char ('=') != MATCH_YES)
1410     {
1411       m = MATCH_NO;
1412       goto cleanup;
1413     }
1414
1415   m = match_actual_arg (&actual->expr);
1416   if (m != MATCH_YES)
1417     goto cleanup;
1418
1419   /* Make sure this name has not appeared yet.  */
1420
1421   if (name[0] != '\0')
1422     {
1423       for (a = base; a; a = a->next)
1424         if (a->name != NULL && strcmp (a->name, name) == 0)
1425           {
1426             gfc_error ("Keyword '%s' at %C has already appeared in the "
1427                        "current argument list", name);
1428             return MATCH_ERROR;
1429           }
1430     }
1431
1432   actual->name = gfc_get_string (name);
1433   return MATCH_YES;
1434
1435 cleanup:
1436   gfc_current_locus = name_locus;
1437   return m;
1438 }
1439
1440
1441 /* Match an argument list function, such as %VAL.  */
1442
1443 static match
1444 match_arg_list_function (gfc_actual_arglist *result)
1445 {
1446   char name[GFC_MAX_SYMBOL_LEN + 1];
1447   locus old_locus;
1448   match m;
1449
1450   old_locus = gfc_current_locus;
1451
1452   if (gfc_match_char ('%') != MATCH_YES)
1453     {
1454       m = MATCH_NO;
1455       goto cleanup;
1456     }
1457
1458   m = gfc_match ("%n (", name);
1459   if (m != MATCH_YES)
1460     goto cleanup;
1461
1462   if (name[0] != '\0')
1463     {
1464       switch (name[0])
1465         {
1466         case 'l':
1467           if (strncmp (name, "loc", 3) == 0)
1468             {
1469               result->name = "%LOC";
1470               break;
1471             }
1472         case 'r':
1473           if (strncmp (name, "ref", 3) == 0)
1474             {
1475               result->name = "%REF";
1476               break;
1477             }
1478         case 'v':
1479           if (strncmp (name, "val", 3) == 0)
1480             {
1481               result->name = "%VAL";
1482               break;
1483             }
1484         default:
1485           m = MATCH_ERROR;
1486           goto cleanup;
1487         }
1488     }
1489
1490   if (gfc_notify_std (GFC_STD_GNU, "Extension: argument list "
1491                       "function at %C") == FAILURE)
1492     {
1493       m = MATCH_ERROR;
1494       goto cleanup;
1495     }
1496
1497   m = match_actual_arg (&result->expr);
1498   if (m != MATCH_YES)
1499     goto cleanup;
1500
1501   if (gfc_match_char (')') != MATCH_YES)
1502     {
1503       m = MATCH_NO;
1504       goto cleanup;
1505     }
1506
1507   return MATCH_YES;
1508
1509 cleanup:
1510   gfc_current_locus = old_locus;
1511   return m;
1512 }
1513
1514
1515 /* Matches an actual argument list of a function or subroutine, from
1516    the opening parenthesis to the closing parenthesis.  The argument
1517    list is assumed to allow keyword arguments because we don't know if
1518    the symbol associated with the procedure has an implicit interface
1519    or not.  We make sure keywords are unique. If SUB_FLAG is set,
1520    we're matching the argument list of a subroutine.  */
1521
1522 match
1523 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp)
1524 {
1525   gfc_actual_arglist *head, *tail;
1526   int seen_keyword;
1527   gfc_st_label *label;
1528   locus old_loc;
1529   match m;
1530
1531   *argp = tail = NULL;
1532   old_loc = gfc_current_locus;
1533
1534   seen_keyword = 0;
1535
1536   if (gfc_match_char ('(') == MATCH_NO)
1537     return (sub_flag) ? MATCH_YES : MATCH_NO;
1538
1539   if (gfc_match_char (')') == MATCH_YES)
1540     return MATCH_YES;
1541   head = NULL;
1542
1543   for (;;)
1544     {
1545       if (head == NULL)
1546         head = tail = gfc_get_actual_arglist ();
1547       else
1548         {
1549           tail->next = gfc_get_actual_arglist ();
1550           tail = tail->next;
1551         }
1552
1553       if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1554         {
1555           m = gfc_match_st_label (&label);
1556           if (m == MATCH_NO)
1557             gfc_error ("Expected alternate return label at %C");
1558           if (m != MATCH_YES)
1559             goto cleanup;
1560
1561           tail->label = label;
1562           goto next;
1563         }
1564
1565       /* After the first keyword argument is seen, the following
1566          arguments must also have keywords.  */
1567       if (seen_keyword)
1568         {
1569           m = match_keyword_arg (tail, head);
1570
1571           if (m == MATCH_ERROR)
1572             goto cleanup;
1573           if (m == MATCH_NO)
1574             {
1575               gfc_error ("Missing keyword name in actual argument list at %C");
1576               goto cleanup;
1577             }
1578
1579         }
1580       else
1581         {
1582           /* Try an argument list function, like %VAL.  */
1583           m = match_arg_list_function (tail);
1584           if (m == MATCH_ERROR)
1585             goto cleanup;
1586
1587           /* See if we have the first keyword argument.  */
1588           if (m == MATCH_NO)
1589             {
1590               m = match_keyword_arg (tail, head);
1591               if (m == MATCH_YES)
1592                 seen_keyword = 1;
1593               if (m == MATCH_ERROR)
1594                 goto cleanup;
1595             }
1596
1597           if (m == MATCH_NO)
1598             {
1599               /* Try for a non-keyword argument.  */
1600               m = match_actual_arg (&tail->expr);
1601               if (m == MATCH_ERROR)
1602                 goto cleanup;
1603               if (m == MATCH_NO)
1604                 goto syntax;
1605             }
1606         }
1607
1608
1609     next:
1610       if (gfc_match_char (')') == MATCH_YES)
1611         break;
1612       if (gfc_match_char (',') != MATCH_YES)
1613         goto syntax;
1614     }
1615
1616   *argp = head;
1617   return MATCH_YES;
1618
1619 syntax:
1620   gfc_error ("Syntax error in argument list at %C");
1621
1622 cleanup:
1623   gfc_free_actual_arglist (head);
1624   gfc_current_locus = old_loc;
1625
1626   return MATCH_ERROR;
1627 }
1628
1629
1630 /* Used by match_varspec() to extend the reference list by one
1631    element.  */
1632
1633 static gfc_ref *
1634 extend_ref (gfc_expr *primary, gfc_ref *tail)
1635 {
1636   if (primary->ref == NULL)
1637     primary->ref = tail = gfc_get_ref ();
1638   else
1639     {
1640       if (tail == NULL)
1641         gfc_internal_error ("extend_ref(): Bad tail");
1642       tail->next = gfc_get_ref ();
1643       tail = tail->next;
1644     }
1645
1646   return tail;
1647 }
1648
1649
1650 /* Match any additional specifications associated with the current
1651    variable like member references or substrings.  If equiv_flag is
1652    set we only match stuff that is allowed inside an EQUIVALENCE
1653    statement.  */
1654
1655 static match
1656 match_varspec (gfc_expr *primary, int equiv_flag)
1657 {
1658   char name[GFC_MAX_SYMBOL_LEN + 1];
1659   gfc_ref *substring, *tail;
1660   gfc_component *component;
1661   gfc_symbol *sym = primary->symtree->n.sym;
1662   match m;
1663
1664   tail = NULL;
1665
1666   if ((equiv_flag && gfc_peek_char () == '(') || sym->attr.dimension)
1667     {
1668       /* In EQUIVALENCE, we don't know yet whether we are seeing
1669          an array, character variable or array of character
1670          variables.  We'll leave the decision till resolve time.  */
1671       tail = extend_ref (primary, tail);
1672       tail->type = REF_ARRAY;
1673
1674       m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as,
1675                                equiv_flag);
1676       if (m != MATCH_YES)
1677         return m;
1678
1679       if (equiv_flag && gfc_peek_char () == '(')
1680         {
1681           tail = extend_ref (primary, tail);
1682           tail->type = REF_ARRAY;
1683
1684           m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag);
1685           if (m != MATCH_YES)
1686             return m;
1687         }
1688     }
1689
1690   primary->ts = sym->ts;
1691
1692   if (equiv_flag)
1693     return MATCH_YES;
1694
1695   if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1696     goto check_substring;
1697
1698   sym = sym->ts.derived;
1699
1700   for (;;)
1701     {
1702       m = gfc_match_name (name);
1703       if (m == MATCH_NO)
1704         gfc_error ("Expected structure component name at %C");
1705       if (m != MATCH_YES)
1706         return MATCH_ERROR;
1707
1708       component = gfc_find_component (sym, name);
1709       if (component == NULL)
1710         return MATCH_ERROR;
1711
1712       tail = extend_ref (primary, tail);
1713       tail->type = REF_COMPONENT;
1714
1715       tail->u.c.component = component;
1716       tail->u.c.sym = sym;
1717
1718       primary->ts = component->ts;
1719
1720       if (component->as != NULL)
1721         {
1722           tail = extend_ref (primary, tail);
1723           tail->type = REF_ARRAY;
1724
1725           m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1726           if (m != MATCH_YES)
1727             return m;
1728         }
1729
1730       if (component->ts.type != BT_DERIVED
1731           || gfc_match_char ('%') != MATCH_YES)
1732         break;
1733
1734       sym = component->ts.derived;
1735     }
1736
1737 check_substring:
1738   if (primary->ts.type == BT_UNKNOWN)
1739     {
1740       if (gfc_get_default_type (sym, sym->ns)->type == BT_CHARACTER)
1741        {
1742          gfc_set_default_type (sym, 0, sym->ns);
1743          primary->ts = sym->ts;
1744        }
1745     }
1746
1747   if (primary->ts.type == BT_CHARACTER)
1748     {
1749       switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1750         {
1751         case MATCH_YES:
1752           if (tail == NULL)
1753             primary->ref = substring;
1754           else
1755             tail->next = substring;
1756
1757           if (primary->expr_type == EXPR_CONSTANT)
1758             primary->expr_type = EXPR_SUBSTRING;
1759
1760           if (substring)
1761             primary->ts.cl = NULL;
1762
1763           break;
1764
1765         case MATCH_NO:
1766           break;
1767
1768         case MATCH_ERROR:
1769           return MATCH_ERROR;
1770         }
1771     }
1772
1773   return MATCH_YES;
1774 }
1775
1776
1777 /* Given an expression that is a variable, figure out what the
1778    ultimate variable's type and attribute is, traversing the reference
1779    structures if necessary.
1780
1781    This subroutine is trickier than it looks.  We start at the base
1782    symbol and store the attribute.  Component references load a
1783    completely new attribute.
1784
1785    A couple of rules come into play.  Subobjects of targets are always
1786    targets themselves.  If we see a component that goes through a
1787    pointer, then the expression must also be a target, since the
1788    pointer is associated with something (if it isn't core will soon be
1789    dumped).  If we see a full part or section of an array, the
1790    expression is also an array.
1791
1792    We can have at most one full array reference.  */
1793
1794 symbol_attribute
1795 gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
1796 {
1797   int dimension, pointer, allocatable, target;
1798   symbol_attribute attr;
1799   gfc_ref *ref;
1800
1801   if (expr->expr_type != EXPR_VARIABLE)
1802     gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1803
1804   ref = expr->ref;
1805   attr = expr->symtree->n.sym->attr;
1806
1807   dimension = attr.dimension;
1808   pointer = attr.pointer;
1809   allocatable = attr.allocatable;
1810
1811   target = attr.target;
1812   if (pointer)
1813     target = 1;
1814
1815   if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1816     *ts = expr->symtree->n.sym->ts;
1817
1818   for (; ref; ref = ref->next)
1819     switch (ref->type)
1820       {
1821       case REF_ARRAY:
1822
1823         switch (ref->u.ar.type)
1824           {
1825           case AR_FULL:
1826             dimension = 1;
1827             break;
1828
1829           case AR_SECTION:
1830             allocatable = pointer = 0;
1831             dimension = 1;
1832             break;
1833
1834           case AR_ELEMENT:
1835             allocatable = pointer = 0;
1836             break;
1837
1838           case AR_UNKNOWN:
1839             gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1840           }
1841
1842         break;
1843
1844       case REF_COMPONENT:
1845         gfc_get_component_attr (&attr, ref->u.c.component);
1846         if (ts != NULL)
1847           {
1848             *ts = ref->u.c.component->ts;
1849             /* Don't set the string length if a substring reference
1850                follows.  */
1851             if (ts->type == BT_CHARACTER
1852                 && ref->next && ref->next->type == REF_SUBSTRING)
1853                 ts->cl = NULL;
1854           }
1855
1856         pointer = ref->u.c.component->pointer;
1857         allocatable = ref->u.c.component->allocatable;
1858         if (pointer)
1859           target = 1;
1860
1861         break;
1862
1863       case REF_SUBSTRING:
1864         allocatable = pointer = 0;
1865         break;
1866       }
1867
1868   attr.dimension = dimension;
1869   attr.pointer = pointer;
1870   attr.allocatable = allocatable;
1871   attr.target = target;
1872
1873   return attr;
1874 }
1875
1876
1877 /* Return the attribute from a general expression.  */
1878
1879 symbol_attribute
1880 gfc_expr_attr (gfc_expr *e)
1881 {
1882   symbol_attribute attr;
1883
1884   switch (e->expr_type)
1885     {
1886     case EXPR_VARIABLE:
1887       attr = gfc_variable_attr (e, NULL);
1888       break;
1889
1890     case EXPR_FUNCTION:
1891       gfc_clear_attr (&attr);
1892
1893       if (e->value.function.esym != NULL)
1894         attr = e->value.function.esym->result->attr;
1895
1896       /* TODO: NULL() returns pointers.  May have to take care of this
1897          here.  */
1898
1899       break;
1900
1901     default:
1902       gfc_clear_attr (&attr);
1903       break;
1904     }
1905
1906   return attr;
1907 }
1908
1909
1910 /* Match a structure constructor.  The initial symbol has already been
1911    seen.  */
1912
1913 match
1914 gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
1915 {
1916   gfc_constructor *head, *tail;
1917   gfc_component *comp;
1918   gfc_expr *e;
1919   locus where;
1920   match m;
1921
1922   head = tail = NULL;
1923
1924   if (gfc_match_char ('(') != MATCH_YES)
1925     goto syntax;
1926
1927   where = gfc_current_locus;
1928
1929   gfc_find_component (sym, NULL);
1930
1931   for (comp = sym->components; comp; comp = comp->next)
1932     {
1933       if (head == NULL)
1934         tail = head = gfc_get_constructor ();
1935       else
1936         {
1937           tail->next = gfc_get_constructor ();
1938           tail = tail->next;
1939         }
1940
1941       m = gfc_match_expr (&tail->expr);
1942       if (m == MATCH_NO)
1943         goto syntax;
1944       if (m == MATCH_ERROR)
1945         goto cleanup;
1946
1947       if (gfc_match_char (',') == MATCH_YES)
1948         {
1949           if (comp->next == NULL)
1950             {
1951               gfc_error ("Too many components in structure constructor at %C");
1952               goto cleanup;
1953             }
1954
1955           continue;
1956         }
1957
1958       break;
1959     }
1960
1961   if (gfc_match_char (')') != MATCH_YES)
1962     goto syntax;
1963
1964   if (comp->next != NULL)
1965     {
1966       gfc_error ("Too few components in structure constructor at %C");
1967       goto cleanup;
1968     }
1969
1970   e = gfc_get_expr ();
1971
1972   e->expr_type = EXPR_STRUCTURE;
1973
1974   e->ts.type = BT_DERIVED;
1975   e->ts.derived = sym;
1976   e->where = where;
1977
1978   e->value.constructor = head;
1979
1980   *result = e;
1981   return MATCH_YES;
1982
1983 syntax:
1984   gfc_error ("Syntax error in structure constructor at %C");
1985
1986 cleanup:
1987   gfc_free_constructor (head);
1988   return MATCH_ERROR;
1989 }
1990
1991
1992 /* Matches a variable name followed by anything that might follow it--
1993    array reference, argument list of a function, etc.  */
1994
1995 match
1996 gfc_match_rvalue (gfc_expr **result)
1997 {
1998   gfc_actual_arglist *actual_arglist;
1999   char name[GFC_MAX_SYMBOL_LEN + 1], argname[GFC_MAX_SYMBOL_LEN + 1];
2000   gfc_state_data *st;
2001   gfc_symbol *sym;
2002   gfc_symtree *symtree;
2003   locus where, old_loc;
2004   gfc_expr *e;
2005   match m, m2;
2006   int i;
2007   gfc_typespec *ts;
2008   bool implicit_char;
2009
2010   m = gfc_match_name (name);
2011   if (m != MATCH_YES)
2012     return m;
2013
2014   if (gfc_find_state (COMP_INTERFACE) == SUCCESS
2015       && !gfc_current_ns->has_import_set)
2016     i = gfc_get_sym_tree (name, NULL, &symtree);
2017   else
2018     i = gfc_get_ha_sym_tree (name, &symtree);
2019
2020   if (i)
2021     return MATCH_ERROR;
2022
2023   sym = symtree->n.sym;
2024   e = NULL;
2025   where = gfc_current_locus;
2026
2027   gfc_set_sym_referenced (sym);
2028
2029   if (sym->attr.function && sym->result == sym)
2030     {
2031       /* See if this is a directly recursive function call.  */
2032       gfc_gobble_whitespace ();
2033       if (sym->attr.recursive
2034           && gfc_peek_char () == '('
2035           && gfc_current_ns->proc_name == sym)
2036         {
2037           if (!sym->attr.dimension)
2038             goto function0;
2039
2040           gfc_error ("'%s' is array valued and directly recursive "
2041                      "at %C , so the keyword RESULT must be specified "
2042                      "in the FUNCTION statement", sym->name);
2043           return MATCH_ERROR;
2044         }
2045         
2046       if (gfc_current_ns->proc_name == sym
2047           || (gfc_current_ns->parent != NULL
2048               && gfc_current_ns->parent->proc_name == sym))
2049         goto variable;
2050
2051       if (sym->attr.entry
2052           && (sym->ns == gfc_current_ns
2053               || sym->ns == gfc_current_ns->parent))
2054         {
2055           gfc_entry_list *el = NULL;
2056           
2057           for (el = sym->ns->entries; el; el = el->next)
2058             if (sym == el->sym)
2059               goto variable;
2060         }
2061     }
2062
2063   if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
2064     goto function0;
2065
2066   if (sym->attr.generic)
2067     goto generic_function;
2068
2069   switch (sym->attr.flavor)
2070     {
2071     case FL_VARIABLE:
2072     variable:
2073       if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
2074           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2075         gfc_set_default_type (sym, 0, sym->ns);
2076
2077       e = gfc_get_expr ();
2078
2079       e->expr_type = EXPR_VARIABLE;
2080       e->symtree = symtree;
2081
2082       m = match_varspec (e, 0);
2083       break;
2084
2085     case FL_PARAMETER:
2086       /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
2087          end up here.  Unfortunately, sym->value->expr_type is set to 
2088          EXPR_CONSTANT, and so the if () branch would be followed without
2089          the !sym->as check.  */
2090       if (sym->value && sym->value->expr_type != EXPR_ARRAY && !sym->as)
2091         e = gfc_copy_expr (sym->value);
2092       else
2093         {
2094           e = gfc_get_expr ();
2095           e->expr_type = EXPR_VARIABLE;
2096         }
2097
2098       e->symtree = symtree;
2099       m = match_varspec (e, 0);
2100       break;
2101
2102     case FL_DERIVED:
2103       sym = gfc_use_derived (sym);
2104       if (sym == NULL)
2105         m = MATCH_ERROR;
2106       else
2107         m = gfc_match_structure_constructor (sym, &e);
2108       break;
2109
2110     /* If we're here, then the name is known to be the name of a
2111        procedure, yet it is not sure to be the name of a function.  */
2112     case FL_PROCEDURE:
2113       if (sym->attr.subroutine)
2114         {
2115           gfc_error ("Unexpected use of subroutine name '%s' at %C",
2116                      sym->name);
2117           m = MATCH_ERROR;
2118           break;
2119         }
2120
2121       /* At this point, the name has to be a non-statement function.
2122          If the name is the same as the current function being
2123          compiled, then we have a variable reference (to the function
2124          result) if the name is non-recursive.  */
2125
2126       st = gfc_enclosing_unit (NULL);
2127
2128       if (st != NULL && st->state == COMP_FUNCTION
2129           && st->sym == sym
2130           && !sym->attr.recursive)
2131         {
2132           e = gfc_get_expr ();
2133           e->symtree = symtree;
2134           e->expr_type = EXPR_VARIABLE;
2135
2136           m = match_varspec (e, 0);
2137           break;
2138         }
2139
2140     /* Match a function reference.  */
2141     function0:
2142       m = gfc_match_actual_arglist (0, &actual_arglist);
2143       if (m == MATCH_NO)
2144         {
2145           if (sym->attr.proc == PROC_ST_FUNCTION)
2146             gfc_error ("Statement function '%s' requires argument list at %C",
2147                        sym->name);
2148           else
2149             gfc_error ("Function '%s' requires an argument list at %C",
2150                        sym->name);
2151
2152           m = MATCH_ERROR;
2153           break;
2154         }
2155
2156       if (m != MATCH_YES)
2157         {
2158           m = MATCH_ERROR;
2159           break;
2160         }
2161
2162       gfc_get_ha_sym_tree (name, &symtree);     /* Can't fail */
2163       sym = symtree->n.sym;
2164
2165       e = gfc_get_expr ();
2166       e->symtree = symtree;
2167       e->expr_type = EXPR_FUNCTION;
2168       e->value.function.actual = actual_arglist;
2169       e->where = gfc_current_locus;
2170
2171       if (sym->as != NULL)
2172         e->rank = sym->as->rank;
2173
2174       if (!sym->attr.function
2175           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2176         {
2177           m = MATCH_ERROR;
2178           break;
2179         }
2180
2181       if (sym->result == NULL)
2182         sym->result = sym;
2183
2184       m = MATCH_YES;
2185       break;
2186
2187     case FL_UNKNOWN:
2188
2189       /* Special case for derived type variables that get their types
2190          via an IMPLICIT statement.  This can't wait for the
2191          resolution phase.  */
2192
2193       if (gfc_peek_char () == '%'
2194           && sym->ts.type == BT_UNKNOWN
2195           && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2196         gfc_set_default_type (sym, 0, sym->ns);
2197
2198       /* If the symbol has a dimension attribute, the expression is a
2199          variable.  */
2200
2201       if (sym->attr.dimension)
2202         {
2203           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2204                               sym->name, NULL) == FAILURE)
2205             {
2206               m = MATCH_ERROR;
2207               break;
2208             }
2209
2210           e = gfc_get_expr ();
2211           e->symtree = symtree;
2212           e->expr_type = EXPR_VARIABLE;
2213           m = match_varspec (e, 0);
2214           break;
2215         }
2216
2217       /* Name is not an array, so we peek to see if a '(' implies a
2218          function call or a substring reference.  Otherwise the
2219          variable is just a scalar.  */
2220
2221       gfc_gobble_whitespace ();
2222       if (gfc_peek_char () != '(')
2223         {
2224           /* Assume a scalar variable */
2225           e = gfc_get_expr ();
2226           e->symtree = symtree;
2227           e->expr_type = EXPR_VARIABLE;
2228
2229           if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2230                               sym->name, NULL) == FAILURE)
2231             {
2232               m = MATCH_ERROR;
2233               break;
2234             }
2235
2236           e->ts = sym->ts;
2237           m = match_varspec (e, 0);
2238           break;
2239         }
2240
2241       /* See if this is a function reference with a keyword argument
2242          as first argument. We do this because otherwise a spurious
2243          symbol would end up in the symbol table.  */
2244
2245       old_loc = gfc_current_locus;
2246       m2 = gfc_match (" ( %n =", argname);
2247       gfc_current_locus = old_loc;
2248
2249       e = gfc_get_expr ();
2250       e->symtree = symtree;
2251
2252       if (m2 != MATCH_YES)
2253         {
2254           /* Try to figure out whether we're dealing with a character type.
2255              We're peeking ahead here, because we don't want to call 
2256              match_substring if we're dealing with an implicitly typed
2257              non-character variable.  */
2258           implicit_char = false;
2259           if (sym->ts.type == BT_UNKNOWN)
2260             {
2261               ts = gfc_get_default_type (sym,NULL);
2262               if (ts->type == BT_CHARACTER)
2263                 implicit_char = true;
2264             }
2265
2266           /* See if this could possibly be a substring reference of a name
2267              that we're not sure is a variable yet.  */
2268
2269           if ((implicit_char || sym->ts.type == BT_CHARACTER)
2270               && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2271             {
2272
2273               e->expr_type = EXPR_VARIABLE;
2274
2275               if (sym->attr.flavor != FL_VARIABLE
2276                   && gfc_add_flavor (&sym->attr, FL_VARIABLE,
2277                                      sym->name, NULL) == FAILURE)
2278                 {
2279                   m = MATCH_ERROR;
2280                   break;
2281                 }
2282
2283               if (sym->ts.type == BT_UNKNOWN
2284                   && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2285                 {
2286                   m = MATCH_ERROR;
2287                   break;
2288                 }
2289
2290               e->ts = sym->ts;
2291               if (e->ref)
2292                 e->ts.cl = NULL;
2293               m = MATCH_YES;
2294               break;
2295             }
2296         }
2297
2298       /* Give up, assume we have a function.  */
2299
2300       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2301       sym = symtree->n.sym;
2302       e->expr_type = EXPR_FUNCTION;
2303
2304       if (!sym->attr.function
2305           && gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2306         {
2307           m = MATCH_ERROR;
2308           break;
2309         }
2310
2311       sym->result = sym;
2312
2313       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2314       if (m == MATCH_NO)
2315         gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2316
2317       if (m != MATCH_YES)
2318         {
2319           m = MATCH_ERROR;
2320           break;
2321         }
2322
2323       /* If our new function returns a character, array or structure
2324          type, it might have subsequent references.  */
2325
2326       m = match_varspec (e, 0);
2327       if (m == MATCH_NO)
2328         m = MATCH_YES;
2329
2330       break;
2331
2332     generic_function:
2333       gfc_get_sym_tree (name, NULL, &symtree);  /* Can't fail */
2334
2335       e = gfc_get_expr ();
2336       e->symtree = symtree;
2337       e->expr_type = EXPR_FUNCTION;
2338
2339       m = gfc_match_actual_arglist (0, &e->value.function.actual);
2340       break;
2341
2342     default:
2343       gfc_error ("Symbol at %C is not appropriate for an expression");
2344       return MATCH_ERROR;
2345     }
2346
2347   if (m == MATCH_YES)
2348     {
2349       e->where = where;
2350       *result = e;
2351     }
2352   else
2353     gfc_free_expr (e);
2354
2355   return m;
2356 }
2357
2358
2359 /* Match a variable, ie something that can be assigned to.  This
2360    starts as a symbol, can be a structure component or an array
2361    reference.  It can be a function if the function doesn't have a
2362    separate RESULT variable.  If the symbol has not been previously
2363    seen, we assume it is a variable.
2364
2365    This function is called by two interface functions:
2366    gfc_match_variable, which has host_flag = 1, and
2367    gfc_match_equiv_variable, with host_flag = 0, to restrict the
2368    match of the symbol to the local scope.  */
2369
2370 static match
2371 match_variable (gfc_expr **result, int equiv_flag, int host_flag)
2372 {
2373   gfc_symbol *sym;
2374   gfc_symtree *st;
2375   gfc_expr *expr;
2376   locus where;
2377   match m;
2378
2379   /* Since nothing has any business being an lvalue in a module
2380      specification block, an interface block or a contains section,
2381      we force the changed_symbols mechanism to work by setting
2382      host_flag to 0. This prevents valid symbols that have the name
2383      of keywords, such as 'end', being turned into variables by
2384      failed matching to assignments for, eg., END INTERFACE.  */
2385   if (gfc_current_state () == COMP_MODULE
2386       || gfc_current_state () == COMP_INTERFACE
2387       || gfc_current_state () == COMP_CONTAINS)
2388     host_flag = 0;
2389
2390   m = gfc_match_sym_tree (&st, host_flag);
2391   if (m != MATCH_YES)
2392     return m;
2393   where = gfc_current_locus;
2394
2395   sym = st->n.sym;
2396   gfc_set_sym_referenced (sym);
2397   switch (sym->attr.flavor)
2398     {
2399     case FL_VARIABLE:
2400       if (sym->attr.protected && sym->attr.use_assoc)
2401         {
2402           gfc_error ("Assigning to PROTECTED variable at %C");
2403           return MATCH_ERROR;
2404         }
2405       break;
2406
2407     case FL_UNKNOWN:
2408       if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
2409                           sym->name, NULL) == FAILURE)
2410         return MATCH_ERROR;
2411       break;
2412
2413     case FL_PARAMETER:
2414       if (equiv_flag)
2415         gfc_error ("Named constant at %C in an EQUIVALENCE");
2416       else
2417         gfc_error ("Cannot assign to a named constant at %C");
2418       return MATCH_ERROR;
2419       break;
2420
2421     case FL_PROCEDURE:
2422       /* Check for a nonrecursive function result */
2423       if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2424         {
2425           /* If a function result is a derived type, then the derived
2426              type may still have to be resolved.  */
2427
2428           if (sym->ts.type == BT_DERIVED
2429               && gfc_use_derived (sym->ts.derived) == NULL)
2430             return MATCH_ERROR;
2431           break;
2432         }
2433
2434       /* Fall through to error */
2435
2436     default:
2437       gfc_error ("Expected VARIABLE at %C");
2438       return MATCH_ERROR;
2439     }
2440
2441   /* Special case for derived type variables that get their types
2442      via an IMPLICIT statement.  This can't wait for the
2443      resolution phase.  */
2444
2445     {
2446       gfc_namespace * implicit_ns;
2447
2448       if (gfc_current_ns->proc_name == sym)
2449         implicit_ns = gfc_current_ns;
2450       else
2451         implicit_ns = sym->ns;
2452         
2453       if (gfc_peek_char () == '%'
2454           && sym->ts.type == BT_UNKNOWN
2455           && gfc_get_default_type (sym, implicit_ns)->type == BT_DERIVED)
2456         gfc_set_default_type (sym, 0, implicit_ns);
2457     }
2458
2459   expr = gfc_get_expr ();
2460
2461   expr->expr_type = EXPR_VARIABLE;
2462   expr->symtree = st;
2463   expr->ts = sym->ts;
2464   expr->where = where;
2465
2466   /* Now see if we have to do more.  */
2467   m = match_varspec (expr, equiv_flag);
2468   if (m != MATCH_YES)
2469     {
2470       gfc_free_expr (expr);
2471       return m;
2472     }
2473
2474   *result = expr;
2475   return MATCH_YES;
2476 }
2477
2478
2479 match
2480 gfc_match_variable (gfc_expr **result, int equiv_flag)
2481 {
2482   return match_variable (result, equiv_flag, 1);
2483 }
2484
2485
2486 match
2487 gfc_match_equiv_variable (gfc_expr **result)
2488 {
2489   return match_variable (result, 1, 0);
2490 }
2491