OSDN Git Service

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