OSDN Git Service

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