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, 59 Temple Place - Suite 330, 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];
44 m
= gfc_match_small_literal_int (kind
);
48 m
= gfc_match_name (name
);
52 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
58 if (sym
->attr
.flavor
!= FL_PARAMETER
)
61 p
= gfc_extract_int (sym
->value
, kind
);
72 /* Get a trailing kind-specification for non-character variables.
74 the integer kind value or:
75 -1 if an error was generated
76 -2 if no kind was found */
84 if (gfc_match_char ('_') != MATCH_YES
)
87 m
= match_kind_param (&kind
);
89 gfc_error ("Missing kind-parameter at %C");
91 return (m
== MATCH_YES
) ? kind
: -1;
95 /* Given a character and a radix, see if the character is a valid
96 digit in that radix. */
99 check_digit (int c
, int radix
)
106 r
= ('0' <= c
&& c
<= '1');
110 r
= ('0' <= c
&& c
<= '7');
114 r
= ('0' <= c
&& c
<= '9');
122 gfc_internal_error ("check_digit(): bad radix");
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. */
135 match_digits (int signflag
, int radix
, char *buffer
)
141 c
= gfc_next_char ();
143 if (signflag
&& (c
== '+' || c
== '-'))
147 gfc_gobble_whitespace ();
148 c
= gfc_next_char ();
152 if (!check_digit (c
, radix
))
161 old_loc
= gfc_current_locus
;
162 c
= gfc_next_char ();
164 if (!check_digit (c
, radix
))
172 gfc_current_locus
= old_loc
;
178 /* Match an integer (digit string and optional kind).
179 A sign will be accepted if signflag is set. */
182 match_integer_constant (gfc_expr
** result
, int signflag
)
189 old_loc
= gfc_current_locus
;
190 gfc_gobble_whitespace ();
192 length
= match_digits (signflag
, 10, NULL
);
193 gfc_current_locus
= old_loc
;
197 buffer
= alloca (length
+ 1);
198 memset (buffer
, '\0', length
+ 1);
200 gfc_gobble_whitespace ();
202 match_digits (signflag
, 10, buffer
);
206 kind
= gfc_default_integer_kind
;
210 if (gfc_validate_kind (BT_INTEGER
, kind
, true) < 0)
212 gfc_error ("Integer kind %d at %C not available", kind
);
216 e
= gfc_convert_integer (buffer
, kind
, 10, &gfc_current_locus
);
218 if (gfc_range_check (e
) != ARITH_OK
)
220 gfc_error ("Integer too big for its kind at %C");
231 /* Match a binary, octal or hexadecimal constant that can be found in
235 match_boz_constant (gfc_expr
** result
)
237 int radix
, delim
, length
, x_hex
, kind
;
243 old_loc
= gfc_current_locus
;
244 gfc_gobble_whitespace ();
247 switch (gfc_next_char ())
262 rname
= "hexadecimal";
268 /* No whitespace allowed here. */
270 delim
= gfc_next_char ();
271 if (delim
!= '\'' && delim
!= '\"')
274 if (x_hex
&& pedantic
275 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
276 "constant at %C uses non-standard syntax.")
280 old_loc
= gfc_current_locus
;
282 length
= match_digits (0, radix
, NULL
);
285 gfc_error ("Empty set of digits in %s constants at %C", rname
);
289 if (gfc_next_char () != delim
)
291 gfc_error ("Illegal character in %s constant at %C.", rname
);
295 gfc_current_locus
= old_loc
;
297 buffer
= alloca (length
+ 1);
298 memset (buffer
, '\0', length
+ 1);
300 match_digits (0, radix
, buffer
);
301 gfc_next_char (); /* Eat delimiter. */
307 kind
= gfc_default_integer_kind
;
309 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Kind parameter "
310 "suffix to boz literal constant at %C.")
314 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
316 if (gfc_range_check (e
) != ARITH_OK
)
318 gfc_error ("Integer too big for integer kind %i at %C", kind
);
328 gfc_current_locus
= old_loc
;
333 /* Match a real constant of some sort. Allow a signed constant if signflag
334 is nonzero. Allow integer constants if allow_int is true. */
337 match_real_constant (gfc_expr
** result
, int signflag
)
339 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
340 locus old_loc
, temp_loc
;
345 old_loc
= gfc_current_locus
;
346 gfc_gobble_whitespace ();
356 c
= gfc_next_char ();
357 if (signflag
&& (c
== '+' || c
== '-'))
362 gfc_gobble_whitespace ();
363 c
= gfc_next_char ();
366 /* Scan significand. */
367 for (;; c
= gfc_next_char (), count
++)
374 /* Check to see if "." goes with a following operator like ".eq.". */
375 temp_loc
= gfc_current_locus
;
376 c
= gfc_next_char ();
378 if (c
== 'e' || c
== 'd' || c
== 'q')
380 c
= gfc_next_char ();
382 goto done
; /* Operator named .e. or .d. */
386 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
388 gfc_current_locus
= temp_loc
;
403 || (c
!= 'e' && c
!= 'd' && c
!= 'q'))
408 c
= gfc_next_char ();
411 if (c
== '+' || c
== '-')
412 { /* optional sign */
413 c
= gfc_next_char ();
419 gfc_error ("Missing exponent in real number at %C");
425 c
= gfc_next_char ();
430 /* Check that we have a numeric constant. */
431 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
433 gfc_current_locus
= old_loc
;
437 /* Convert the number. */
438 gfc_current_locus
= old_loc
;
439 gfc_gobble_whitespace ();
441 buffer
= alloca (count
+ 1);
442 memset (buffer
, '\0', count
+ 1);
445 c
= gfc_next_char ();
446 if (c
== '+' || c
== '-')
448 gfc_gobble_whitespace ();
449 c
= gfc_next_char ();
452 /* Hack for mpfr_set_str(). */
455 if (c
== 'd' || c
== 'q')
463 c
= gfc_next_char ();
476 ("Real number at %C has a 'd' exponent and an explicit kind");
479 kind
= gfc_default_double_kind
;
486 ("Real number at %C has a 'q' exponent and an explicit kind");
489 kind
= gfc_option
.q_kind
;
494 kind
= gfc_default_real_kind
;
496 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
498 gfc_error ("Invalid real kind %d at %C", kind
);
503 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
505 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
507 switch (gfc_range_check (e
))
512 gfc_error ("Real constant overflows its kind at %C");
515 case ARITH_UNDERFLOW
:
516 if (gfc_option
.warn_underflow
)
517 gfc_warning ("Real constant underflows its kind at %C");
518 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
522 gfc_internal_error ("gfc_range_check() returned bad value");
534 /* Match a substring reference. */
537 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
539 gfc_expr
*start
, *end
;
547 old_loc
= gfc_current_locus
;
549 m
= gfc_match_char ('(');
553 if (gfc_match_char (':') != MATCH_YES
)
556 m
= gfc_match_init_expr (&start
);
558 m
= gfc_match_expr (&start
);
566 m
= gfc_match_char (':');
571 if (gfc_match_char (')') != MATCH_YES
)
574 m
= gfc_match_init_expr (&end
);
576 m
= gfc_match_expr (&end
);
580 if (m
== MATCH_ERROR
)
583 m
= gfc_match_char (')');
588 /* Optimize away the (:) reference. */
589 if (start
== NULL
&& end
== NULL
)
593 ref
= gfc_get_ref ();
595 ref
->type
= REF_SUBSTRING
;
597 start
= gfc_int_expr (1);
598 ref
->u
.ss
.start
= start
;
599 if (end
== NULL
&& cl
)
600 end
= gfc_copy_expr (cl
->length
);
602 ref
->u
.ss
.length
= cl
;
609 gfc_error ("Syntax error in SUBSTRING specification at %C");
613 gfc_free_expr (start
);
616 gfc_current_locus
= old_loc
;
621 /* Reads the next character of a string constant, taking care to
622 return doubled delimiters on the input as a single instance of
625 Special return values are:
626 -1 End of the string, as determined by the delimiter
627 -2 Unterminated string detected
629 Backslash codes are also expanded at this time. */
632 next_string_char (char delimiter
)
637 c
= gfc_next_char_literal (1);
644 old_locus
= gfc_current_locus
;
646 switch (gfc_next_char_literal (1))
674 /* Unknown backslash codes are simply not expanded */
675 gfc_current_locus
= old_locus
;
683 old_locus
= gfc_current_locus
;
684 c
= gfc_next_char_literal (1);
688 gfc_current_locus
= old_locus
;
694 /* Special case of gfc_match_name() that matches a parameter kind name
695 before a string constant. This takes case of the weird but legal
696 case of: weird case of:
700 where kind____ is a parameter. gfc_match_name() will happily slurp
701 up all the underscores, which leads to problems. If we return
702 MATCH_YES, the parse pointer points to the final underscore, which
703 is not part of the name. We never return MATCH_ERROR-- errors in
704 the name will be detected later. */
707 match_charkind_name (char *name
)
713 gfc_gobble_whitespace ();
714 c
= gfc_next_char ();
723 old_loc
= gfc_current_locus
;
724 c
= gfc_next_char ();
728 peek
= gfc_peek_char ();
730 if (peek
== '\'' || peek
== '\"')
732 gfc_current_locus
= old_loc
;
740 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
744 if (++len
> GFC_MAX_SYMBOL_LEN
)
752 /* See if the current input matches a character constant. Lots of
753 contortions have to be done to match the kind parameter which comes
754 before the actual string. The main consideration is that we don't
755 want to error out too quickly. For example, we don't actually do
756 any validation of the kinds until we have actually seen a legal
757 delimiter. Using match_kind_param() generates errors too quickly. */
760 match_string_constant (gfc_expr
** result
)
762 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
763 int i
, c
, kind
, length
, delimiter
;
764 locus old_locus
, start_locus
;
770 old_locus
= gfc_current_locus
;
772 gfc_gobble_whitespace ();
774 start_locus
= gfc_current_locus
;
776 c
= gfc_next_char ();
777 if (c
== '\'' || c
== '"')
779 kind
= gfc_default_character_kind
;
789 kind
= kind
* 10 + c
- '0';
792 c
= gfc_next_char ();
798 gfc_current_locus
= old_locus
;
800 m
= match_charkind_name (name
);
804 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
806 || sym
->attr
.flavor
!= FL_PARAMETER
)
810 c
= gfc_next_char ();
815 gfc_gobble_whitespace ();
816 c
= gfc_next_char ();
822 gfc_gobble_whitespace ();
823 start_locus
= gfc_current_locus
;
825 c
= gfc_next_char ();
826 if (c
!= '\'' && c
!= '"')
831 q
= gfc_extract_int (sym
->value
, &kind
);
839 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
841 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
846 /* Scan the string into a block of memory by first figuring out how
847 long it is, allocating the structure, then re-reading it. This
848 isn't particularly efficient, but string constants aren't that
849 common in most code. TODO: Use obstacks? */
856 c
= next_string_char (delimiter
);
861 gfc_current_locus
= start_locus
;
862 gfc_error ("Unterminated character constant beginning at %C");
871 e
->expr_type
= EXPR_CONSTANT
;
873 e
->ts
.type
= BT_CHARACTER
;
875 e
->where
= start_locus
;
877 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
878 e
->value
.character
.length
= length
;
880 gfc_current_locus
= start_locus
;
881 gfc_next_char (); /* Skip delimiter */
883 for (i
= 0; i
< length
; i
++)
884 *p
++ = next_string_char (delimiter
);
886 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
888 if (next_string_char (delimiter
) != -1)
889 gfc_internal_error ("match_string_constant(): Delimiter not found");
891 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
892 e
->expr_type
= EXPR_SUBSTRING
;
899 gfc_current_locus
= old_locus
;
904 /* Match a .true. or .false. */
907 match_logical_constant (gfc_expr
** result
)
909 static mstring logical_ops
[] = {
910 minit (".false.", 0),
918 i
= gfc_match_strings (logical_ops
);
926 kind
= gfc_default_logical_kind
;
928 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
929 gfc_error ("Bad kind for logical constant at %C");
933 e
->expr_type
= EXPR_CONSTANT
;
934 e
->value
.logical
= i
;
935 e
->ts
.type
= BT_LOGICAL
;
937 e
->where
= gfc_current_locus
;
944 /* Match a real or imaginary part of a complex constant that is a
945 symbolic constant. */
948 match_sym_complex_part (gfc_expr
** result
)
950 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
955 m
= gfc_match_name (name
);
959 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
962 if (sym
->attr
.flavor
!= FL_PARAMETER
)
964 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
968 if (!gfc_numeric_ts (&sym
->value
->ts
))
970 gfc_error ("Numeric PARAMETER required in complex constant at %C");
974 if (sym
->value
->rank
!= 0)
976 gfc_error ("Scalar PARAMETER required in complex constant at %C");
980 switch (sym
->value
->ts
.type
)
983 e
= gfc_copy_expr (sym
->value
);
987 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
993 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
999 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1002 *result
= e
; /* e is a scalar, real, constant expression */
1006 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1011 /* Match a real or imaginary part of a complex number. */
1014 match_complex_part (gfc_expr
** result
)
1018 m
= match_sym_complex_part (result
);
1022 m
= match_real_constant (result
, 1);
1026 return match_integer_constant (result
, 1);
1030 /* Try to match a complex constant. */
1033 match_complex_constant (gfc_expr
** result
)
1035 gfc_expr
*e
, *real
, *imag
;
1036 gfc_error_buf old_error
;
1037 gfc_typespec target
;
1042 old_loc
= gfc_current_locus
;
1043 real
= imag
= e
= NULL
;
1045 m
= gfc_match_char ('(');
1049 gfc_push_error (&old_error
);
1051 m
= match_complex_part (&real
);
1055 if (gfc_match_char (',') == MATCH_NO
)
1057 gfc_pop_error (&old_error
);
1062 /* If m is error, then something was wrong with the real part and we
1063 assume we have a complex constant because we've seen the ','. An
1064 ambiguous case here is the start of an iterator list of some
1065 sort. These sort of lists are matched prior to coming here. */
1067 if (m
== MATCH_ERROR
)
1069 gfc_pop_error (&old_error
);
1071 m
= match_complex_part (&imag
);
1074 if (m
== MATCH_ERROR
)
1077 m
= gfc_match_char (')');
1081 if (m
== MATCH_ERROR
)
1084 /* Decide on the kind of this complex number. */
1085 if (real
->ts
.type
== BT_REAL
)
1087 if (imag
->ts
.type
== BT_REAL
)
1088 kind
= gfc_kind_max (real
, imag
);
1090 kind
= real
->ts
.kind
;
1094 if (imag
->ts
.type
== BT_REAL
)
1095 kind
= imag
->ts
.kind
;
1097 kind
= gfc_default_real_kind
;
1099 target
.type
= BT_REAL
;
1102 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1103 gfc_convert_type (real
, &target
, 2);
1104 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1105 gfc_convert_type (imag
, &target
, 2);
1107 e
= gfc_convert_complex (real
, imag
, kind
);
1108 e
->where
= gfc_current_locus
;
1110 gfc_free_expr (real
);
1111 gfc_free_expr (imag
);
1117 gfc_error ("Syntax error in COMPLEX constant at %C");
1122 gfc_free_expr (real
);
1123 gfc_free_expr (imag
);
1124 gfc_current_locus
= old_loc
;
1130 /* Match constants in any of several forms. Returns nonzero for a
1131 match, zero for no match. */
1134 gfc_match_literal_constant (gfc_expr
** result
, int signflag
)
1138 m
= match_complex_constant (result
);
1142 m
= match_string_constant (result
);
1146 m
= match_boz_constant (result
);
1150 m
= match_real_constant (result
, signflag
);
1154 m
= match_integer_constant (result
, signflag
);
1158 m
= match_logical_constant (result
);
1166 /* Match a single actual argument value. An actual argument is
1167 usually an expression, but can also be a procedure name. If the
1168 argument is a single name, it is not always possible to tell
1169 whether the name is a dummy procedure or not. We treat these cases
1170 by creating an argument that looks like a dummy procedure and
1171 fixing things later during resolution. */
1174 match_actual_arg (gfc_expr
** result
)
1176 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1177 gfc_symtree
*symtree
;
1182 where
= gfc_current_locus
;
1184 switch (gfc_match_name (name
))
1193 w
= gfc_current_locus
;
1194 gfc_gobble_whitespace ();
1195 c
= gfc_next_char ();
1196 gfc_current_locus
= w
;
1198 if (c
!= ',' && c
!= ')')
1201 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1203 /* Handle error elsewhere. */
1205 /* Eliminate a couple of common cases where we know we don't
1206 have a function argument. */
1207 if (symtree
== NULL
)
1209 gfc_get_sym_tree (name
, NULL
, &symtree
);
1210 gfc_set_sym_referenced (symtree
->n
.sym
);
1216 sym
= symtree
->n
.sym
;
1217 gfc_set_sym_referenced (sym
);
1218 if (sym
->attr
.flavor
!= FL_PROCEDURE
1219 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1222 /* If the symbol is a function with itself as the result and
1223 is being defined, then we have a variable. */
1224 if (sym
->result
== sym
1225 && (gfc_current_ns
->proc_name
== sym
1226 || (gfc_current_ns
->parent
!= NULL
1227 && gfc_current_ns
->parent
->proc_name
== sym
)))
1231 e
= gfc_get_expr (); /* Leave it unknown for now */
1232 e
->symtree
= symtree
;
1233 e
->expr_type
= EXPR_VARIABLE
;
1234 e
->ts
.type
= BT_PROCEDURE
;
1241 gfc_current_locus
= where
;
1242 return gfc_match_expr (result
);
1246 /* Match a keyword argument. */
1249 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1251 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1252 gfc_actual_arglist
*a
;
1256 name_locus
= gfc_current_locus
;
1257 m
= gfc_match_name (name
);
1261 if (gfc_match_char ('=') != MATCH_YES
)
1267 m
= match_actual_arg (&actual
->expr
);
1271 /* Make sure this name has not appeared yet. */
1273 if (name
[0] != '\0')
1275 for (a
= base
; a
; a
= a
->next
)
1276 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1279 ("Keyword '%s' at %C has already appeared in the current "
1280 "argument list", name
);
1285 actual
->name
= gfc_get_string (name
);
1289 gfc_current_locus
= name_locus
;
1294 /* Matches an actual argument list of a function or subroutine, from
1295 the opening parenthesis to the closing parenthesis. The argument
1296 list is assumed to allow keyword arguments because we don't know if
1297 the symbol associated with the procedure has an implicit interface
1298 or not. We make sure keywords are unique. If SUB_FLAG is set,
1299 we're matching the argument list of a subroutine. */
1302 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1304 gfc_actual_arglist
*head
, *tail
;
1306 gfc_st_label
*label
;
1310 *argp
= tail
= NULL
;
1311 old_loc
= gfc_current_locus
;
1315 if (gfc_match_char ('(') == MATCH_NO
)
1316 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1318 if (gfc_match_char (')') == MATCH_YES
)
1325 head
= tail
= gfc_get_actual_arglist ();
1328 tail
->next
= gfc_get_actual_arglist ();
1332 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1334 m
= gfc_match_st_label (&label
, 0);
1336 gfc_error ("Expected alternate return label at %C");
1340 tail
->label
= label
;
1344 /* After the first keyword argument is seen, the following
1345 arguments must also have keywords. */
1348 m
= match_keyword_arg (tail
, head
);
1350 if (m
== MATCH_ERROR
)
1355 ("Missing keyword name in actual argument list at %C");
1362 /* See if we have the first keyword argument. */
1363 m
= match_keyword_arg (tail
, head
);
1366 if (m
== MATCH_ERROR
)
1371 /* Try for a non-keyword argument. */
1372 m
= match_actual_arg (&tail
->expr
);
1373 if (m
== MATCH_ERROR
)
1381 if (gfc_match_char (')') == MATCH_YES
)
1383 if (gfc_match_char (',') != MATCH_YES
)
1391 gfc_error ("Syntax error in argument list at %C");
1394 gfc_free_actual_arglist (head
);
1395 gfc_current_locus
= old_loc
;
1401 /* Used by match_varspec() to extend the reference list by one
1405 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1408 if (primary
->ref
== NULL
)
1409 primary
->ref
= tail
= gfc_get_ref ();
1413 gfc_internal_error ("extend_ref(): Bad tail");
1414 tail
->next
= gfc_get_ref ();
1422 /* Match any additional specifications associated with the current
1423 variable like member references or substrings. If equiv_flag is
1424 set we only match stuff that is allowed inside an EQUIVALENCE
1428 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1430 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1431 gfc_ref
*substring
, *tail
;
1432 gfc_component
*component
;
1438 if (primary
->symtree
->n
.sym
->attr
.dimension
1440 && gfc_peek_char () == '('))
1443 tail
= extend_ref (primary
, tail
);
1444 tail
->type
= REF_ARRAY
;
1446 m
= gfc_match_array_ref (&tail
->u
.ar
, primary
->symtree
->n
.sym
->as
,
1452 sym
= primary
->symtree
->n
.sym
;
1453 primary
->ts
= sym
->ts
;
1455 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1456 goto check_substring
;
1458 sym
= sym
->ts
.derived
;
1462 m
= gfc_match_name (name
);
1464 gfc_error ("Expected structure component name at %C");
1468 component
= gfc_find_component (sym
, name
);
1469 if (component
== NULL
)
1472 tail
= extend_ref (primary
, tail
);
1473 tail
->type
= REF_COMPONENT
;
1475 tail
->u
.c
.component
= component
;
1476 tail
->u
.c
.sym
= sym
;
1478 primary
->ts
= component
->ts
;
1480 if (component
->as
!= NULL
)
1482 tail
= extend_ref (primary
, tail
);
1483 tail
->type
= REF_ARRAY
;
1485 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1490 if (component
->ts
.type
!= BT_DERIVED
1491 || gfc_match_char ('%') != MATCH_YES
)
1494 sym
= component
->ts
.derived
;
1498 if (primary
->ts
.type
== BT_CHARACTER
)
1500 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1504 primary
->ref
= substring
;
1506 tail
->next
= substring
;
1508 if (primary
->expr_type
== EXPR_CONSTANT
)
1509 primary
->expr_type
= EXPR_SUBSTRING
;
1525 /* Given an expression that is a variable, figure out what the
1526 ultimate variable's type and attribute is, traversing the reference
1527 structures if necessary.
1529 This subroutine is trickier than it looks. We start at the base
1530 symbol and store the attribute. Component references load a
1531 completely new attribute.
1533 A couple of rules come into play. Subobjects of targets are always
1534 targets themselves. If we see a component that goes through a
1535 pointer, then the expression must also be a target, since the
1536 pointer is associated with something (if it isn't core will soon be
1537 dumped). If we see a full part or section of an array, the
1538 expression is also an array.
1540 We can have at most one full array reference. */
1543 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1545 int dimension
, pointer
, target
;
1546 symbol_attribute attr
;
1549 if (expr
->expr_type
!= EXPR_VARIABLE
)
1550 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1553 attr
= expr
->symtree
->n
.sym
->attr
;
1555 dimension
= attr
.dimension
;
1556 pointer
= attr
.pointer
;
1558 target
= attr
.target
;
1562 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1563 *ts
= expr
->symtree
->n
.sym
->ts
;
1565 for (; ref
; ref
= ref
->next
)
1570 switch (ref
->u
.ar
.type
)
1586 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1592 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1594 *ts
= ref
->u
.c
.component
->ts
;
1596 pointer
= ref
->u
.c
.component
->pointer
;
1607 attr
.dimension
= dimension
;
1608 attr
.pointer
= pointer
;
1609 attr
.target
= target
;
1615 /* Return the attribute from a general expression. */
1618 gfc_expr_attr (gfc_expr
* e
)
1620 symbol_attribute attr
;
1622 switch (e
->expr_type
)
1625 attr
= gfc_variable_attr (e
, NULL
);
1629 gfc_clear_attr (&attr
);
1631 if (e
->value
.function
.esym
!= NULL
)
1632 attr
= e
->value
.function
.esym
->result
->attr
;
1634 /* TODO: NULL() returns pointers. May have to take care of this
1640 gfc_clear_attr (&attr
);
1648 /* Match a structure constructor. The initial symbol has already been
1652 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1654 gfc_constructor
*head
, *tail
;
1655 gfc_component
*comp
;
1662 if (gfc_match_char ('(') != MATCH_YES
)
1665 where
= gfc_current_locus
;
1667 gfc_find_component (sym
, NULL
);
1669 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1672 tail
= head
= gfc_get_constructor ();
1675 tail
->next
= gfc_get_constructor ();
1679 m
= gfc_match_expr (&tail
->expr
);
1682 if (m
== MATCH_ERROR
)
1685 if (gfc_match_char (',') == MATCH_YES
)
1687 if (comp
->next
== NULL
)
1690 ("Too many components in structure constructor at %C");
1700 if (gfc_match_char (')') != MATCH_YES
)
1703 if (comp
->next
!= NULL
)
1705 gfc_error ("Too few components in structure constructor at %C");
1709 e
= gfc_get_expr ();
1711 e
->expr_type
= EXPR_STRUCTURE
;
1713 e
->ts
.type
= BT_DERIVED
;
1714 e
->ts
.derived
= sym
;
1717 e
->value
.constructor
= head
;
1723 gfc_error ("Syntax error in structure constructor at %C");
1726 gfc_free_constructor (head
);
1731 /* Matches a variable name followed by anything that might follow it--
1732 array reference, argument list of a function, etc. */
1735 gfc_match_rvalue (gfc_expr
** result
)
1737 gfc_actual_arglist
*actual_arglist
;
1738 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
1741 gfc_symtree
*symtree
;
1742 locus where
, old_loc
;
1747 m
= gfc_match_name (name
);
1751 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1752 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1754 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1759 sym
= symtree
->n
.sym
;
1761 where
= gfc_current_locus
;
1763 gfc_set_sym_referenced (sym
);
1765 if (sym
->attr
.function
&& sym
->result
== sym
1766 && (gfc_current_ns
->proc_name
== sym
1767 || (gfc_current_ns
->parent
!= NULL
1768 && gfc_current_ns
->parent
->proc_name
== sym
)))
1771 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1774 if (sym
->attr
.generic
)
1775 goto generic_function
;
1777 switch (sym
->attr
.flavor
)
1781 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1782 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1783 gfc_set_default_type (sym
, 0, sym
->ns
);
1785 e
= gfc_get_expr ();
1787 e
->expr_type
= EXPR_VARIABLE
;
1788 e
->symtree
= symtree
;
1790 m
= match_varspec (e
, 0);
1795 && sym
->value
->expr_type
!= EXPR_ARRAY
)
1796 e
= gfc_copy_expr (sym
->value
);
1799 e
= gfc_get_expr ();
1800 e
->expr_type
= EXPR_VARIABLE
;
1803 e
->symtree
= symtree
;
1804 m
= match_varspec (e
, 0);
1808 sym
= gfc_use_derived (sym
);
1812 m
= gfc_match_structure_constructor (sym
, &e
);
1815 /* If we're here, then the name is known to be the name of a
1816 procedure, yet it is not sure to be the name of a function. */
1818 if (sym
->attr
.subroutine
)
1820 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1826 /* At this point, the name has to be a non-statement function.
1827 If the name is the same as the current function being
1828 compiled, then we have a variable reference (to the function
1829 result) if the name is non-recursive. */
1831 st
= gfc_enclosing_unit (NULL
);
1833 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
1835 && !sym
->attr
.recursive
)
1837 e
= gfc_get_expr ();
1838 e
->symtree
= symtree
;
1839 e
->expr_type
= EXPR_VARIABLE
;
1841 m
= match_varspec (e
, 0);
1845 /* Match a function reference. */
1847 m
= gfc_match_actual_arglist (0, &actual_arglist
);
1850 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1851 gfc_error ("Statement function '%s' requires argument list at %C",
1854 gfc_error ("Function '%s' requires an argument list at %C",
1867 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
1868 sym
= symtree
->n
.sym
;
1870 e
= gfc_get_expr ();
1871 e
->symtree
= symtree
;
1872 e
->expr_type
= EXPR_FUNCTION
;
1873 e
->value
.function
.actual
= actual_arglist
;
1874 e
->where
= gfc_current_locus
;
1876 if (sym
->as
!= NULL
)
1877 e
->rank
= sym
->as
->rank
;
1879 if (!sym
->attr
.function
1880 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
1886 if (sym
->result
== NULL
)
1894 /* Special case for derived type variables that get their types
1895 via an IMPLICIT statement. This can't wait for the
1896 resolution phase. */
1898 if (gfc_peek_char () == '%'
1899 && sym
->ts
.type
== BT_UNKNOWN
1900 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1901 gfc_set_default_type (sym
, 0, sym
->ns
);
1903 /* If the symbol has a dimension attribute, the expression is a
1906 if (sym
->attr
.dimension
)
1908 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1909 sym
->name
, NULL
) == FAILURE
)
1915 e
= gfc_get_expr ();
1916 e
->symtree
= symtree
;
1917 e
->expr_type
= EXPR_VARIABLE
;
1918 m
= match_varspec (e
, 0);
1922 /* Name is not an array, so we peek to see if a '(' implies a
1923 function call or a substring reference. Otherwise the
1924 variable is just a scalar. */
1926 gfc_gobble_whitespace ();
1927 if (gfc_peek_char () != '(')
1929 /* Assume a scalar variable */
1930 e
= gfc_get_expr ();
1931 e
->symtree
= symtree
;
1932 e
->expr_type
= EXPR_VARIABLE
;
1934 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1935 sym
->name
, NULL
) == FAILURE
)
1942 m
= match_varspec (e
, 0);
1946 /* See if this is a function reference with a keyword argument
1947 as first argument. We do this because otherwise a spurious
1948 symbol would end up in the symbol table. */
1950 old_loc
= gfc_current_locus
;
1951 m2
= gfc_match (" ( %n =", argname
);
1952 gfc_current_locus
= old_loc
;
1954 e
= gfc_get_expr ();
1955 e
->symtree
= symtree
;
1957 if (m2
!= MATCH_YES
)
1959 /* See if this could possibly be a substring reference of a name
1960 that we're not sure is a variable yet. */
1962 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
1963 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
1966 e
->expr_type
= EXPR_VARIABLE
;
1968 if (sym
->attr
.flavor
!= FL_VARIABLE
1969 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1970 sym
->name
, NULL
) == FAILURE
)
1976 if (sym
->ts
.type
== BT_UNKNOWN
1977 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
1989 /* Give up, assume we have a function. */
1991 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
1992 sym
= symtree
->n
.sym
;
1993 e
->expr_type
= EXPR_FUNCTION
;
1995 if (!sym
->attr
.function
1996 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2004 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2006 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2014 /* If our new function returns a character, array or structure
2015 type, it might have subsequent references. */
2017 m
= match_varspec (e
, 0);
2024 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2026 e
= gfc_get_expr ();
2027 e
->symtree
= symtree
;
2028 e
->expr_type
= EXPR_FUNCTION
;
2030 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2034 gfc_error ("Symbol at %C is not appropriate for an expression");
2050 /* Match a variable, ie something that can be assigned to. This
2051 starts as a symbol, can be a structure component or an array
2052 reference. It can be a function if the function doesn't have a
2053 separate RESULT variable. If the symbol has not been previously
2054 seen, we assume it is a variable. */
2057 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2065 m
= gfc_match_sym_tree (&st
, 1);
2068 where
= gfc_current_locus
;
2071 gfc_set_sym_referenced (sym
);
2072 switch (sym
->attr
.flavor
)
2078 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2079 sym
->name
, NULL
) == FAILURE
)
2084 /* Check for a nonrecursive function result */
2085 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2087 /* If a function result is a derived type, then the derived
2088 type may still have to be resolved. */
2090 if (sym
->ts
.type
== BT_DERIVED
2091 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2096 /* Fall through to error */
2099 gfc_error ("Expected VARIABLE at %C");
2103 /* Special case for derived type variables that get their types
2104 via an IMPLICIT statement. This can't wait for the
2105 resolution phase. */
2108 gfc_namespace
* implicit_ns
;
2110 if (gfc_current_ns
->proc_name
== sym
)
2111 implicit_ns
= gfc_current_ns
;
2113 implicit_ns
= sym
->ns
;
2115 if (gfc_peek_char () == '%'
2116 && sym
->ts
.type
== BT_UNKNOWN
2117 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2118 gfc_set_default_type (sym
, 0, implicit_ns
);
2121 expr
= gfc_get_expr ();
2123 expr
->expr_type
= EXPR_VARIABLE
;
2126 expr
->where
= where
;
2128 /* Now see if we have to do more. */
2129 m
= match_varspec (expr
, equiv_flag
);
2132 gfc_free_expr (expr
);