1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
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
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
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
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. */
37 match_kind_param (int *kind
)
39 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
45 /* cnt is unused, here. */
46 m
= gfc_match_small_literal_int (kind
, &cnt
);
50 m
= gfc_match_name (name
);
54 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
60 if (sym
->attr
.flavor
!= FL_PARAMETER
)
63 p
= gfc_extract_int (sym
->value
, kind
);
74 /* Get a trailing kind-specification for non-character variables.
76 the integer kind value or:
77 -1 if an error was generated
78 -2 if no kind was found */
86 if (gfc_match_char ('_') != MATCH_YES
)
89 m
= match_kind_param (&kind
);
91 gfc_error ("Missing kind-parameter at %C");
93 return (m
== MATCH_YES
) ? kind
: -1;
97 /* Given a character and a radix, see if the character is a valid
98 digit in that radix. */
101 check_digit (int c
, int radix
)
108 r
= ('0' <= c
&& c
<= '1');
112 r
= ('0' <= c
&& c
<= '7');
116 r
= ('0' <= c
&& c
<= '9');
124 gfc_internal_error ("check_digit(): bad radix");
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. */
137 match_digits (int signflag
, int radix
, char *buffer
)
143 c
= gfc_next_char ();
145 if (signflag
&& (c
== '+' || c
== '-'))
149 gfc_gobble_whitespace ();
150 c
= gfc_next_char ();
154 if (!check_digit (c
, radix
))
163 old_loc
= gfc_current_locus
;
164 c
= gfc_next_char ();
166 if (!check_digit (c
, radix
))
174 gfc_current_locus
= old_loc
;
180 /* Match an integer (digit string and optional kind).
181 A sign will be accepted if signflag is set. */
184 match_integer_constant (gfc_expr
** result
, int signflag
)
191 old_loc
= gfc_current_locus
;
192 gfc_gobble_whitespace ();
194 length
= match_digits (signflag
, 10, NULL
);
195 gfc_current_locus
= old_loc
;
199 buffer
= alloca (length
+ 1);
200 memset (buffer
, '\0', length
+ 1);
202 gfc_gobble_whitespace ();
204 match_digits (signflag
, 10, buffer
);
208 kind
= gfc_default_integer_kind
;
212 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
214 gfc_error ("Integer kind %d at %C not available", kind
);
218 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
220 if (gfc_range_check (e
) != ARITH_OK
)
222 gfc_error ("Integer too big for its kind at %C");
233 /* Match a Hollerith constant. */
236 match_hollerith_constant (gfc_expr
** result
)
245 old_loc
= gfc_current_locus
;
246 gfc_gobble_whitespace ();
248 if (match_integer_constant (&e
, 0) == MATCH_YES
249 && gfc_match_char ('h') == MATCH_YES
)
251 if (gfc_notify_std (GFC_STD_LEGACY
,
252 "Extension: Hollerith constant at %C")
256 msg
= gfc_extract_int (e
, &num
);
264 gfc_error ("Invalid Hollerith constant: %L must contain at least one "
265 "character", &old_loc
);
268 if (e
->ts
.kind
!= gfc_default_integer_kind
)
270 gfc_error ("Invalid Hollerith constant: Interger kind at %L "
271 "should be default", &old_loc
);
276 buffer
= (char *) gfc_getmem (sizeof(char) * num
+ 1);
277 for (i
= 0; i
< num
; i
++)
279 buffer
[i
] = gfc_next_char_literal (1);
282 e
= gfc_constant_result (BT_HOLLERITH
,
283 gfc_default_character_kind
, &gfc_current_locus
);
284 e
->value
.character
.string
= gfc_getmem (num
+1);
285 memcpy (e
->value
.character
.string
, buffer
, num
);
286 e
->value
.character
.length
= num
;
293 gfc_current_locus
= old_loc
;
302 /* Match a binary, octal or hexadecimal constant that can be found in
303 a DATA statement. The standard permits b'010...', o'73...', and
304 z'a1...' where b, o, and z can be capital letters. This function
305 also accepts postfixed forms of the constants: '01...'b, '73...'o,
306 and 'a1...'z. An additional extension is the use of x for z. */
309 match_boz_constant (gfc_expr
** result
)
311 int post
, radix
, delim
, length
, x_hex
, kind
;
312 locus old_loc
, start_loc
;
316 start_loc
= old_loc
= gfc_current_locus
;
317 gfc_gobble_whitespace ();
320 switch (post
= gfc_next_char ())
342 radix
= 16; /* Set to accept any valid digit string. */
348 /* No whitespace allowed here. */
351 delim
= gfc_next_char ();
353 if (delim
!= '\'' && delim
!= '\"')
356 if (x_hex
&& pedantic
357 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
358 "constant at %C uses non-standard syntax.")
362 old_loc
= gfc_current_locus
;
364 length
= match_digits (0, radix
, NULL
);
367 gfc_error ("Empty set of digits in BOZ constant at %C");
371 if (gfc_next_char () != delim
)
373 gfc_error ("Illegal character in BOZ constant at %C");
379 switch (gfc_next_char ())
395 gfc_notify_std (GFC_STD_GNU
, "Extension: BOZ constant "
396 "at %C uses non-standard postfix syntax.");
399 gfc_current_locus
= old_loc
;
401 buffer
= alloca (length
+ 1);
402 memset (buffer
, '\0', length
+ 1);
404 match_digits (0, radix
, buffer
);
405 gfc_next_char (); /* Eat delimiter. */
407 gfc_next_char (); /* Eat postfixed b, o, z, or x. */
409 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
410 "If a data-stmt-constant is a boz-literal-constant, the corresponding
411 variable shall be of type integer. The boz-literal-constant is treated
412 as if it were an int-literal-constant with a kind-param that specifies
413 the representation method with the largest decimal exponent range
414 supported by the processor." */
416 kind
= gfc_max_integer_kind
;
417 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
419 if (gfc_range_check (e
) != ARITH_OK
)
421 gfc_error ("Integer too big for integer kind %i at %C", kind
);
430 gfc_current_locus
= start_loc
;
435 /* Match a real constant of some sort. Allow a signed constant if signflag
436 is nonzero. Allow integer constants if allow_int is true. */
439 match_real_constant (gfc_expr
** result
, int signflag
)
441 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
442 locus old_loc
, temp_loc
;
447 old_loc
= gfc_current_locus
;
448 gfc_gobble_whitespace ();
458 c
= gfc_next_char ();
459 if (signflag
&& (c
== '+' || c
== '-'))
464 gfc_gobble_whitespace ();
465 c
= gfc_next_char ();
468 /* Scan significand. */
469 for (;; c
= gfc_next_char (), count
++)
476 /* Check to see if "." goes with a following operator like ".eq.". */
477 temp_loc
= gfc_current_locus
;
478 c
= gfc_next_char ();
480 if (c
== 'e' || c
== 'd' || c
== 'q')
482 c
= gfc_next_char ();
484 goto done
; /* Operator named .e. or .d. */
488 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
490 gfc_current_locus
= temp_loc
;
505 || (c
!= 'e' && c
!= 'd' && c
!= 'q'))
510 c
= gfc_next_char ();
513 if (c
== '+' || c
== '-')
514 { /* optional sign */
515 c
= gfc_next_char ();
521 gfc_error ("Missing exponent in real number at %C");
527 c
= gfc_next_char ();
532 /* Check that we have a numeric constant. */
533 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
535 gfc_current_locus
= old_loc
;
539 /* Convert the number. */
540 gfc_current_locus
= old_loc
;
541 gfc_gobble_whitespace ();
543 buffer
= alloca (count
+ 1);
544 memset (buffer
, '\0', count
+ 1);
547 c
= gfc_next_char ();
548 if (c
== '+' || c
== '-')
550 gfc_gobble_whitespace ();
551 c
= gfc_next_char ();
554 /* Hack for mpfr_set_str(). */
557 if (c
== 'd' || c
== 'q')
565 c
= gfc_next_char ();
578 ("Real number at %C has a 'd' exponent and an explicit kind");
581 kind
= gfc_default_double_kind
;
588 ("Real number at %C has a 'q' exponent and an explicit kind");
591 kind
= gfc_option
.q_kind
;
596 kind
= gfc_default_real_kind
;
598 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
600 gfc_error ("Invalid real kind %d at %C", kind
);
605 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
607 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
609 switch (gfc_range_check (e
))
614 gfc_error ("Real constant overflows its kind at %C");
617 case ARITH_UNDERFLOW
:
618 if (gfc_option
.warn_underflow
)
619 gfc_warning ("Real constant underflows its kind at %C");
620 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
624 gfc_internal_error ("gfc_range_check() returned bad value");
636 /* Match a substring reference. */
639 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
641 gfc_expr
*start
, *end
;
649 old_loc
= gfc_current_locus
;
651 m
= gfc_match_char ('(');
655 if (gfc_match_char (':') != MATCH_YES
)
658 m
= gfc_match_init_expr (&start
);
660 m
= gfc_match_expr (&start
);
668 m
= gfc_match_char (':');
673 if (gfc_match_char (')') != MATCH_YES
)
676 m
= gfc_match_init_expr (&end
);
678 m
= gfc_match_expr (&end
);
682 if (m
== MATCH_ERROR
)
685 m
= gfc_match_char (')');
690 /* Optimize away the (:) reference. */
691 if (start
== NULL
&& end
== NULL
)
695 ref
= gfc_get_ref ();
697 ref
->type
= REF_SUBSTRING
;
699 start
= gfc_int_expr (1);
700 ref
->u
.ss
.start
= start
;
701 if (end
== NULL
&& cl
)
702 end
= gfc_copy_expr (cl
->length
);
704 ref
->u
.ss
.length
= cl
;
711 gfc_error ("Syntax error in SUBSTRING specification at %C");
715 gfc_free_expr (start
);
718 gfc_current_locus
= old_loc
;
723 /* Reads the next character of a string constant, taking care to
724 return doubled delimiters on the input as a single instance of
727 Special return values are:
728 -1 End of the string, as determined by the delimiter
729 -2 Unterminated string detected
731 Backslash codes are also expanded at this time. */
734 next_string_char (char delimiter
)
739 c
= gfc_next_char_literal (1);
744 if (gfc_option
.flag_backslash
&& c
== '\\')
746 old_locus
= gfc_current_locus
;
748 switch (gfc_next_char_literal (1))
776 /* Unknown backslash codes are simply not expanded */
777 gfc_current_locus
= old_locus
;
785 old_locus
= gfc_current_locus
;
786 c
= gfc_next_char_literal (1);
790 gfc_current_locus
= old_locus
;
796 /* Special case of gfc_match_name() that matches a parameter kind name
797 before a string constant. This takes case of the weird but legal
802 where kind____ is a parameter. gfc_match_name() will happily slurp
803 up all the underscores, which leads to problems. If we return
804 MATCH_YES, the parse pointer points to the final underscore, which
805 is not part of the name. We never return MATCH_ERROR-- errors in
806 the name will be detected later. */
809 match_charkind_name (char *name
)
815 gfc_gobble_whitespace ();
816 c
= gfc_next_char ();
825 old_loc
= gfc_current_locus
;
826 c
= gfc_next_char ();
830 peek
= gfc_peek_char ();
832 if (peek
== '\'' || peek
== '\"')
834 gfc_current_locus
= old_loc
;
842 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
846 if (++len
> GFC_MAX_SYMBOL_LEN
)
854 /* See if the current input matches a character constant. Lots of
855 contortions have to be done to match the kind parameter which comes
856 before the actual string. The main consideration is that we don't
857 want to error out too quickly. For example, we don't actually do
858 any validation of the kinds until we have actually seen a legal
859 delimiter. Using match_kind_param() generates errors too quickly. */
862 match_string_constant (gfc_expr
** result
)
864 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
865 int i
, c
, kind
, length
, delimiter
;
866 locus old_locus
, start_locus
;
872 old_locus
= gfc_current_locus
;
874 gfc_gobble_whitespace ();
876 start_locus
= gfc_current_locus
;
878 c
= gfc_next_char ();
879 if (c
== '\'' || c
== '"')
881 kind
= gfc_default_character_kind
;
891 kind
= kind
* 10 + c
- '0';
894 c
= gfc_next_char ();
900 gfc_current_locus
= old_locus
;
902 m
= match_charkind_name (name
);
906 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
908 || sym
->attr
.flavor
!= FL_PARAMETER
)
912 c
= gfc_next_char ();
917 gfc_gobble_whitespace ();
918 c
= gfc_next_char ();
924 gfc_gobble_whitespace ();
925 start_locus
= gfc_current_locus
;
927 c
= gfc_next_char ();
928 if (c
!= '\'' && c
!= '"')
933 q
= gfc_extract_int (sym
->value
, &kind
);
941 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
943 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
948 /* Scan the string into a block of memory by first figuring out how
949 long it is, allocating the structure, then re-reading it. This
950 isn't particularly efficient, but string constants aren't that
951 common in most code. TODO: Use obstacks? */
958 c
= next_string_char (delimiter
);
963 gfc_current_locus
= start_locus
;
964 gfc_error ("Unterminated character constant beginning at %C");
971 /* Peek at the next character to see if it is a b, o, z, or x for the
972 postfixed BOZ literal constants. */
973 c
= gfc_peek_char ();
974 if (c
== 'b' || c
== 'o' || c
=='z' || c
== 'x')
980 e
->expr_type
= EXPR_CONSTANT
;
982 e
->ts
.type
= BT_CHARACTER
;
984 e
->where
= start_locus
;
986 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
987 e
->value
.character
.length
= length
;
989 gfc_current_locus
= start_locus
;
990 gfc_next_char (); /* Skip delimiter */
992 for (i
= 0; i
< length
; i
++)
993 *p
++ = next_string_char (delimiter
);
995 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
997 if (next_string_char (delimiter
) != -1)
998 gfc_internal_error ("match_string_constant(): Delimiter not found");
1000 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
1001 e
->expr_type
= EXPR_SUBSTRING
;
1008 gfc_current_locus
= old_locus
;
1013 /* Match a .true. or .false. */
1016 match_logical_constant (gfc_expr
** result
)
1018 static mstring logical_ops
[] = {
1019 minit (".false.", 0),
1020 minit (".true.", 1),
1027 i
= gfc_match_strings (logical_ops
);
1035 kind
= gfc_default_logical_kind
;
1037 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1038 gfc_error ("Bad kind for logical constant at %C");
1040 e
= gfc_get_expr ();
1042 e
->expr_type
= EXPR_CONSTANT
;
1043 e
->value
.logical
= i
;
1044 e
->ts
.type
= BT_LOGICAL
;
1046 e
->where
= gfc_current_locus
;
1053 /* Match a real or imaginary part of a complex constant that is a
1054 symbolic constant. */
1057 match_sym_complex_part (gfc_expr
** result
)
1059 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1064 m
= gfc_match_name (name
);
1068 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1071 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1073 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1077 if (!gfc_numeric_ts (&sym
->value
->ts
))
1079 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1083 if (sym
->value
->rank
!= 0)
1085 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1089 switch (sym
->value
->ts
.type
)
1092 e
= gfc_copy_expr (sym
->value
);
1096 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1102 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1108 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1111 *result
= e
; /* e is a scalar, real, constant expression */
1115 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1120 /* Match a real or imaginary part of a complex number. */
1123 match_complex_part (gfc_expr
** result
)
1127 m
= match_sym_complex_part (result
);
1131 m
= match_real_constant (result
, 1);
1135 return match_integer_constant (result
, 1);
1139 /* Try to match a complex constant. */
1142 match_complex_constant (gfc_expr
** result
)
1144 gfc_expr
*e
, *real
, *imag
;
1145 gfc_error_buf old_error
;
1146 gfc_typespec target
;
1151 old_loc
= gfc_current_locus
;
1152 real
= imag
= e
= NULL
;
1154 m
= gfc_match_char ('(');
1158 gfc_push_error (&old_error
);
1160 m
= match_complex_part (&real
);
1163 gfc_free_error (&old_error
);
1167 if (gfc_match_char (',') == MATCH_NO
)
1169 gfc_pop_error (&old_error
);
1174 /* If m is error, then something was wrong with the real part and we
1175 assume we have a complex constant because we've seen the ','. An
1176 ambiguous case here is the start of an iterator list of some
1177 sort. These sort of lists are matched prior to coming here. */
1179 if (m
== MATCH_ERROR
)
1181 gfc_free_error (&old_error
);
1184 gfc_pop_error (&old_error
);
1186 m
= match_complex_part (&imag
);
1189 if (m
== MATCH_ERROR
)
1192 m
= gfc_match_char (')');
1195 /* Give the matcher for implied do-loops a chance to run. This
1196 yields a much saner error message for (/ (i, 4=i, 6) /). */
1197 if (gfc_peek_char () == '=')
1206 if (m
== MATCH_ERROR
)
1209 /* Decide on the kind of this complex number. */
1210 if (real
->ts
.type
== BT_REAL
)
1212 if (imag
->ts
.type
== BT_REAL
)
1213 kind
= gfc_kind_max (real
, imag
);
1215 kind
= real
->ts
.kind
;
1219 if (imag
->ts
.type
== BT_REAL
)
1220 kind
= imag
->ts
.kind
;
1222 kind
= gfc_default_real_kind
;
1224 target
.type
= BT_REAL
;
1227 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1228 gfc_convert_type (real
, &target
, 2);
1229 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1230 gfc_convert_type (imag
, &target
, 2);
1232 e
= gfc_convert_complex (real
, imag
, kind
);
1233 e
->where
= gfc_current_locus
;
1235 gfc_free_expr (real
);
1236 gfc_free_expr (imag
);
1242 gfc_error ("Syntax error in COMPLEX constant at %C");
1247 gfc_free_expr (real
);
1248 gfc_free_expr (imag
);
1249 gfc_current_locus
= old_loc
;
1255 /* Match constants in any of several forms. Returns nonzero for a
1256 match, zero for no match. */
1259 gfc_match_literal_constant (gfc_expr
** result
, int signflag
)
1263 m
= match_complex_constant (result
);
1267 m
= match_string_constant (result
);
1271 m
= match_boz_constant (result
);
1275 m
= match_real_constant (result
, signflag
);
1279 m
= match_hollerith_constant (result
);
1283 m
= match_integer_constant (result
, signflag
);
1287 m
= match_logical_constant (result
);
1295 /* Match a single actual argument value. An actual argument is
1296 usually an expression, but can also be a procedure name. If the
1297 argument is a single name, it is not always possible to tell
1298 whether the name is a dummy procedure or not. We treat these cases
1299 by creating an argument that looks like a dummy procedure and
1300 fixing things later during resolution. */
1303 match_actual_arg (gfc_expr
** result
)
1305 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1306 gfc_symtree
*symtree
;
1311 where
= gfc_current_locus
;
1313 switch (gfc_match_name (name
))
1322 w
= gfc_current_locus
;
1323 gfc_gobble_whitespace ();
1324 c
= gfc_next_char ();
1325 gfc_current_locus
= w
;
1327 if (c
!= ',' && c
!= ')')
1330 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1332 /* Handle error elsewhere. */
1334 /* Eliminate a couple of common cases where we know we don't
1335 have a function argument. */
1336 if (symtree
== NULL
)
1338 gfc_get_sym_tree (name
, NULL
, &symtree
);
1339 gfc_set_sym_referenced (symtree
->n
.sym
);
1345 sym
= symtree
->n
.sym
;
1346 gfc_set_sym_referenced (sym
);
1347 if (sym
->attr
.flavor
!= FL_PROCEDURE
1348 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1351 /* If the symbol is a function with itself as the result and
1352 is being defined, then we have a variable. */
1353 if (sym
->attr
.function
&& sym
->result
== sym
)
1355 if (gfc_current_ns
->proc_name
== sym
1356 || (gfc_current_ns
->parent
!= NULL
1357 && gfc_current_ns
->parent
->proc_name
== sym
))
1361 && (sym
->ns
== gfc_current_ns
1362 || sym
->ns
== gfc_current_ns
->parent
))
1364 gfc_entry_list
*el
= NULL
;
1366 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1376 e
= gfc_get_expr (); /* Leave it unknown for now */
1377 e
->symtree
= symtree
;
1378 e
->expr_type
= EXPR_VARIABLE
;
1379 e
->ts
.type
= BT_PROCEDURE
;
1386 gfc_current_locus
= where
;
1387 return gfc_match_expr (result
);
1391 /* Match a keyword argument. */
1394 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1396 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1397 gfc_actual_arglist
*a
;
1401 name_locus
= gfc_current_locus
;
1402 m
= gfc_match_name (name
);
1406 if (gfc_match_char ('=') != MATCH_YES
)
1412 m
= match_actual_arg (&actual
->expr
);
1416 /* Make sure this name has not appeared yet. */
1418 if (name
[0] != '\0')
1420 for (a
= base
; a
; a
= a
->next
)
1421 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1424 ("Keyword '%s' at %C has already appeared in the current "
1425 "argument list", name
);
1430 actual
->name
= gfc_get_string (name
);
1434 gfc_current_locus
= name_locus
;
1439 /* Matches an actual argument list of a function or subroutine, from
1440 the opening parenthesis to the closing parenthesis. The argument
1441 list is assumed to allow keyword arguments because we don't know if
1442 the symbol associated with the procedure has an implicit interface
1443 or not. We make sure keywords are unique. If SUB_FLAG is set,
1444 we're matching the argument list of a subroutine. */
1447 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1449 gfc_actual_arglist
*head
, *tail
;
1451 gfc_st_label
*label
;
1455 *argp
= tail
= NULL
;
1456 old_loc
= gfc_current_locus
;
1460 if (gfc_match_char ('(') == MATCH_NO
)
1461 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1463 if (gfc_match_char (')') == MATCH_YES
)
1470 head
= tail
= gfc_get_actual_arglist ();
1473 tail
->next
= gfc_get_actual_arglist ();
1477 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1479 m
= gfc_match_st_label (&label
);
1481 gfc_error ("Expected alternate return label at %C");
1485 tail
->label
= label
;
1489 /* After the first keyword argument is seen, the following
1490 arguments must also have keywords. */
1493 m
= match_keyword_arg (tail
, head
);
1495 if (m
== MATCH_ERROR
)
1500 ("Missing keyword name in actual argument list at %C");
1507 /* See if we have the first keyword argument. */
1508 m
= match_keyword_arg (tail
, head
);
1511 if (m
== MATCH_ERROR
)
1516 /* Try for a non-keyword argument. */
1517 m
= match_actual_arg (&tail
->expr
);
1518 if (m
== MATCH_ERROR
)
1526 if (gfc_match_char (')') == MATCH_YES
)
1528 if (gfc_match_char (',') != MATCH_YES
)
1536 gfc_error ("Syntax error in argument list at %C");
1539 gfc_free_actual_arglist (head
);
1540 gfc_current_locus
= old_loc
;
1546 /* Used by match_varspec() to extend the reference list by one
1550 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1553 if (primary
->ref
== NULL
)
1554 primary
->ref
= tail
= gfc_get_ref ();
1558 gfc_internal_error ("extend_ref(): Bad tail");
1559 tail
->next
= gfc_get_ref ();
1567 /* Match any additional specifications associated with the current
1568 variable like member references or substrings. If equiv_flag is
1569 set we only match stuff that is allowed inside an EQUIVALENCE
1573 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1575 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1576 gfc_ref
*substring
, *tail
;
1577 gfc_component
*component
;
1578 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1583 if ((equiv_flag
&& gfc_peek_char () == '(')
1584 || sym
->attr
.dimension
)
1586 /* In EQUIVALENCE, we don't know yet whether we are seeing
1587 an array, character variable or array of character
1588 variables. We'll leave the decision till resolve
1590 tail
= extend_ref (primary
, tail
);
1591 tail
->type
= REF_ARRAY
;
1593 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1598 if (equiv_flag
&& gfc_peek_char () == '(')
1600 tail
= extend_ref (primary
, tail
);
1601 tail
->type
= REF_ARRAY
;
1603 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
);
1609 primary
->ts
= sym
->ts
;
1614 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1615 goto check_substring
;
1617 sym
= sym
->ts
.derived
;
1621 m
= gfc_match_name (name
);
1623 gfc_error ("Expected structure component name at %C");
1627 component
= gfc_find_component (sym
, name
);
1628 if (component
== NULL
)
1631 tail
= extend_ref (primary
, tail
);
1632 tail
->type
= REF_COMPONENT
;
1634 tail
->u
.c
.component
= component
;
1635 tail
->u
.c
.sym
= sym
;
1637 primary
->ts
= component
->ts
;
1639 if (component
->as
!= NULL
)
1641 tail
= extend_ref (primary
, tail
);
1642 tail
->type
= REF_ARRAY
;
1644 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1649 if (component
->ts
.type
!= BT_DERIVED
1650 || gfc_match_char ('%') != MATCH_YES
)
1653 sym
= component
->ts
.derived
;
1657 if (primary
->ts
.type
== BT_UNKNOWN
)
1659 if (gfc_get_default_type (sym
, sym
->ns
)->type
== BT_CHARACTER
)
1661 gfc_set_default_type (sym
, 0, sym
->ns
);
1662 primary
->ts
= sym
->ts
;
1666 if (primary
->ts
.type
== BT_CHARACTER
)
1668 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1672 primary
->ref
= substring
;
1674 tail
->next
= substring
;
1676 if (primary
->expr_type
== EXPR_CONSTANT
)
1677 primary
->expr_type
= EXPR_SUBSTRING
;
1680 primary
->ts
.cl
= NULL
;
1696 /* Given an expression that is a variable, figure out what the
1697 ultimate variable's type and attribute is, traversing the reference
1698 structures if necessary.
1700 This subroutine is trickier than it looks. We start at the base
1701 symbol and store the attribute. Component references load a
1702 completely new attribute.
1704 A couple of rules come into play. Subobjects of targets are always
1705 targets themselves. If we see a component that goes through a
1706 pointer, then the expression must also be a target, since the
1707 pointer is associated with something (if it isn't core will soon be
1708 dumped). If we see a full part or section of an array, the
1709 expression is also an array.
1711 We can have at most one full array reference. */
1714 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1716 int dimension
, pointer
, target
;
1717 symbol_attribute attr
;
1720 if (expr
->expr_type
!= EXPR_VARIABLE
)
1721 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1724 attr
= expr
->symtree
->n
.sym
->attr
;
1726 dimension
= attr
.dimension
;
1727 pointer
= attr
.pointer
;
1729 target
= attr
.target
;
1733 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1734 *ts
= expr
->symtree
->n
.sym
->ts
;
1736 for (; ref
; ref
= ref
->next
)
1741 switch (ref
->u
.ar
.type
)
1757 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1763 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1765 *ts
= ref
->u
.c
.component
->ts
;
1767 pointer
= ref
->u
.c
.component
->pointer
;
1778 attr
.dimension
= dimension
;
1779 attr
.pointer
= pointer
;
1780 attr
.target
= target
;
1786 /* Return the attribute from a general expression. */
1789 gfc_expr_attr (gfc_expr
* e
)
1791 symbol_attribute attr
;
1793 switch (e
->expr_type
)
1796 attr
= gfc_variable_attr (e
, NULL
);
1800 gfc_clear_attr (&attr
);
1802 if (e
->value
.function
.esym
!= NULL
)
1803 attr
= e
->value
.function
.esym
->result
->attr
;
1805 /* TODO: NULL() returns pointers. May have to take care of this
1811 gfc_clear_attr (&attr
);
1819 /* Match a structure constructor. The initial symbol has already been
1823 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1825 gfc_constructor
*head
, *tail
;
1826 gfc_component
*comp
;
1833 if (gfc_match_char ('(') != MATCH_YES
)
1836 where
= gfc_current_locus
;
1838 gfc_find_component (sym
, NULL
);
1840 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1843 tail
= head
= gfc_get_constructor ();
1846 tail
->next
= gfc_get_constructor ();
1850 m
= gfc_match_expr (&tail
->expr
);
1853 if (m
== MATCH_ERROR
)
1856 if (gfc_match_char (',') == MATCH_YES
)
1858 if (comp
->next
== NULL
)
1861 ("Too many components in structure constructor at %C");
1871 if (gfc_match_char (')') != MATCH_YES
)
1874 if (comp
->next
!= NULL
)
1876 gfc_error ("Too few components in structure constructor at %C");
1880 e
= gfc_get_expr ();
1882 e
->expr_type
= EXPR_STRUCTURE
;
1884 e
->ts
.type
= BT_DERIVED
;
1885 e
->ts
.derived
= sym
;
1888 e
->value
.constructor
= head
;
1894 gfc_error ("Syntax error in structure constructor at %C");
1897 gfc_free_constructor (head
);
1902 /* Matches a variable name followed by anything that might follow it--
1903 array reference, argument list of a function, etc. */
1906 gfc_match_rvalue (gfc_expr
** result
)
1908 gfc_actual_arglist
*actual_arglist
;
1909 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
1912 gfc_symtree
*symtree
;
1913 locus where
, old_loc
;
1918 m
= gfc_match_name (name
);
1922 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1923 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1925 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1930 sym
= symtree
->n
.sym
;
1932 where
= gfc_current_locus
;
1934 gfc_set_sym_referenced (sym
);
1936 if (sym
->attr
.function
&& sym
->result
== sym
)
1938 if (gfc_current_ns
->proc_name
== sym
1939 || (gfc_current_ns
->parent
!= NULL
1940 && gfc_current_ns
->parent
->proc_name
== sym
))
1944 && (sym
->ns
== gfc_current_ns
1945 || sym
->ns
== gfc_current_ns
->parent
))
1947 gfc_entry_list
*el
= NULL
;
1949 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1955 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1958 if (sym
->attr
.generic
)
1959 goto generic_function
;
1961 switch (sym
->attr
.flavor
)
1965 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1966 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1967 gfc_set_default_type (sym
, 0, sym
->ns
);
1969 e
= gfc_get_expr ();
1971 e
->expr_type
= EXPR_VARIABLE
;
1972 e
->symtree
= symtree
;
1974 m
= match_varspec (e
, 0);
1978 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
1979 end up here. Unfortunately, sym->value->expr_type is set to
1980 EXPR_CONSTANT, and so the if () branch would be followed without
1981 the !sym->as check. */
1982 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
1983 e
= gfc_copy_expr (sym
->value
);
1986 e
= gfc_get_expr ();
1987 e
->expr_type
= EXPR_VARIABLE
;
1990 e
->symtree
= symtree
;
1991 m
= match_varspec (e
, 0);
1995 sym
= gfc_use_derived (sym
);
1999 m
= gfc_match_structure_constructor (sym
, &e
);
2002 /* If we're here, then the name is known to be the name of a
2003 procedure, yet it is not sure to be the name of a function. */
2005 if (sym
->attr
.subroutine
)
2007 gfc_error ("Unexpected use of subroutine name '%s' at %C",
2013 /* At this point, the name has to be a non-statement function.
2014 If the name is the same as the current function being
2015 compiled, then we have a variable reference (to the function
2016 result) if the name is non-recursive. */
2018 st
= gfc_enclosing_unit (NULL
);
2020 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
2022 && !sym
->attr
.recursive
)
2024 e
= gfc_get_expr ();
2025 e
->symtree
= symtree
;
2026 e
->expr_type
= EXPR_VARIABLE
;
2028 m
= match_varspec (e
, 0);
2032 /* Match a function reference. */
2034 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2037 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2038 gfc_error ("Statement function '%s' requires argument list at %C",
2041 gfc_error ("Function '%s' requires an argument list at %C",
2054 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2055 sym
= symtree
->n
.sym
;
2057 e
= gfc_get_expr ();
2058 e
->symtree
= symtree
;
2059 e
->expr_type
= EXPR_FUNCTION
;
2060 e
->value
.function
.actual
= actual_arglist
;
2061 e
->where
= gfc_current_locus
;
2063 if (sym
->as
!= NULL
)
2064 e
->rank
= sym
->as
->rank
;
2066 if (!sym
->attr
.function
2067 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2073 if (sym
->result
== NULL
)
2081 /* Special case for derived type variables that get their types
2082 via an IMPLICIT statement. This can't wait for the
2083 resolution phase. */
2085 if (gfc_peek_char () == '%'
2086 && sym
->ts
.type
== BT_UNKNOWN
2087 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2088 gfc_set_default_type (sym
, 0, sym
->ns
);
2090 /* If the symbol has a dimension attribute, the expression is a
2093 if (sym
->attr
.dimension
)
2095 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2096 sym
->name
, NULL
) == FAILURE
)
2102 e
= gfc_get_expr ();
2103 e
->symtree
= symtree
;
2104 e
->expr_type
= EXPR_VARIABLE
;
2105 m
= match_varspec (e
, 0);
2109 /* Name is not an array, so we peek to see if a '(' implies a
2110 function call or a substring reference. Otherwise the
2111 variable is just a scalar. */
2113 gfc_gobble_whitespace ();
2114 if (gfc_peek_char () != '(')
2116 /* Assume a scalar variable */
2117 e
= gfc_get_expr ();
2118 e
->symtree
= symtree
;
2119 e
->expr_type
= EXPR_VARIABLE
;
2121 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2122 sym
->name
, NULL
) == FAILURE
)
2129 m
= match_varspec (e
, 0);
2133 /* See if this is a function reference with a keyword argument
2134 as first argument. We do this because otherwise a spurious
2135 symbol would end up in the symbol table. */
2137 old_loc
= gfc_current_locus
;
2138 m2
= gfc_match (" ( %n =", argname
);
2139 gfc_current_locus
= old_loc
;
2141 e
= gfc_get_expr ();
2142 e
->symtree
= symtree
;
2144 if (m2
!= MATCH_YES
)
2146 /* See if this could possibly be a substring reference of a name
2147 that we're not sure is a variable yet. */
2149 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
2150 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2153 e
->expr_type
= EXPR_VARIABLE
;
2155 if (sym
->attr
.flavor
!= FL_VARIABLE
2156 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2157 sym
->name
, NULL
) == FAILURE
)
2163 if (sym
->ts
.type
== BT_UNKNOWN
2164 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2178 /* Give up, assume we have a function. */
2180 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2181 sym
= symtree
->n
.sym
;
2182 e
->expr_type
= EXPR_FUNCTION
;
2184 if (!sym
->attr
.function
2185 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2193 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2195 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2203 /* If our new function returns a character, array or structure
2204 type, it might have subsequent references. */
2206 m
= match_varspec (e
, 0);
2213 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2215 e
= gfc_get_expr ();
2216 e
->symtree
= symtree
;
2217 e
->expr_type
= EXPR_FUNCTION
;
2219 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2223 gfc_error ("Symbol at %C is not appropriate for an expression");
2239 /* Match a variable, ie something that can be assigned to. This
2240 starts as a symbol, can be a structure component or an array
2241 reference. It can be a function if the function doesn't have a
2242 separate RESULT variable. If the symbol has not been previously
2243 seen, we assume it is a variable.
2245 This function is called by two interface functions:
2246 gfc_match_variable, which has host_flag = 1, and
2247 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2248 match of the symbol to the local scope. */
2251 match_variable (gfc_expr
** result
, int equiv_flag
, int host_flag
)
2259 m
= gfc_match_sym_tree (&st
, host_flag
);
2262 where
= gfc_current_locus
;
2265 gfc_set_sym_referenced (sym
);
2266 switch (sym
->attr
.flavor
)
2272 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2273 sym
->name
, NULL
) == FAILURE
)
2278 /* Check for a nonrecursive function result */
2279 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2281 /* If a function result is a derived type, then the derived
2282 type may still have to be resolved. */
2284 if (sym
->ts
.type
== BT_DERIVED
2285 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2290 /* Fall through to error */
2293 gfc_error ("Expected VARIABLE at %C");
2297 /* Special case for derived type variables that get their types
2298 via an IMPLICIT statement. This can't wait for the
2299 resolution phase. */
2302 gfc_namespace
* implicit_ns
;
2304 if (gfc_current_ns
->proc_name
== sym
)
2305 implicit_ns
= gfc_current_ns
;
2307 implicit_ns
= sym
->ns
;
2309 if (gfc_peek_char () == '%'
2310 && sym
->ts
.type
== BT_UNKNOWN
2311 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2312 gfc_set_default_type (sym
, 0, implicit_ns
);
2315 expr
= gfc_get_expr ();
2317 expr
->expr_type
= EXPR_VARIABLE
;
2320 expr
->where
= where
;
2322 /* Now see if we have to do more. */
2323 m
= match_varspec (expr
, equiv_flag
);
2326 gfc_free_expr (expr
);
2335 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2337 return match_variable (result
, equiv_flag
, 1);
2341 gfc_match_equiv_variable (gfc_expr
** result
)
2343 return match_variable (result
, 1, 0);