OSDN Git Service

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