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