OSDN Git Service

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