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. */
304 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
305 "If a data-stmt-constant is a boz-literal-constant, the corresponding
306 variable shall be of type integer. The boz-literal-constant is treated
307 as if it were an int-literal-constant with a kind-param that specifies
308 the representation method with the largest decimal exponent range
309 supported by the processor." */
311 kind
= gfc_max_integer_kind
;
312 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
314 if (gfc_range_check (e
) != ARITH_OK
)
316 gfc_error ("Integer too big for integer kind %i at %C", kind
);
326 gfc_current_locus
= old_loc
;
331 /* Match a real constant of some sort. Allow a signed constant if signflag
332 is nonzero. Allow integer constants if allow_int is true. */
335 match_real_constant (gfc_expr
** result
, int signflag
)
337 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
338 locus old_loc
, temp_loc
;
343 old_loc
= gfc_current_locus
;
344 gfc_gobble_whitespace ();
354 c
= gfc_next_char ();
355 if (signflag
&& (c
== '+' || c
== '-'))
360 gfc_gobble_whitespace ();
361 c
= gfc_next_char ();
364 /* Scan significand. */
365 for (;; c
= gfc_next_char (), count
++)
372 /* Check to see if "." goes with a following operator like ".eq.". */
373 temp_loc
= gfc_current_locus
;
374 c
= gfc_next_char ();
376 if (c
== 'e' || c
== 'd' || c
== 'q')
378 c
= gfc_next_char ();
380 goto done
; /* Operator named .e. or .d. */
384 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
386 gfc_current_locus
= temp_loc
;
401 || (c
!= 'e' && c
!= 'd' && c
!= 'q'))
406 c
= gfc_next_char ();
409 if (c
== '+' || c
== '-')
410 { /* optional sign */
411 c
= gfc_next_char ();
417 gfc_error ("Missing exponent in real number at %C");
423 c
= gfc_next_char ();
428 /* Check that we have a numeric constant. */
429 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
431 gfc_current_locus
= old_loc
;
435 /* Convert the number. */
436 gfc_current_locus
= old_loc
;
437 gfc_gobble_whitespace ();
439 buffer
= alloca (count
+ 1);
440 memset (buffer
, '\0', count
+ 1);
443 c
= gfc_next_char ();
444 if (c
== '+' || c
== '-')
446 gfc_gobble_whitespace ();
447 c
= gfc_next_char ();
450 /* Hack for mpfr_set_str(). */
453 if (c
== 'd' || c
== 'q')
461 c
= gfc_next_char ();
474 ("Real number at %C has a 'd' exponent and an explicit kind");
477 kind
= gfc_default_double_kind
;
484 ("Real number at %C has a 'q' exponent and an explicit kind");
487 kind
= gfc_option
.q_kind
;
492 kind
= gfc_default_real_kind
;
494 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
496 gfc_error ("Invalid real kind %d at %C", kind
);
501 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
503 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
505 switch (gfc_range_check (e
))
510 gfc_error ("Real constant overflows its kind at %C");
513 case ARITH_UNDERFLOW
:
514 if (gfc_option
.warn_underflow
)
515 gfc_warning ("Real constant underflows its kind at %C");
516 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
520 gfc_internal_error ("gfc_range_check() returned bad value");
532 /* Match a substring reference. */
535 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
537 gfc_expr
*start
, *end
;
545 old_loc
= gfc_current_locus
;
547 m
= gfc_match_char ('(');
551 if (gfc_match_char (':') != MATCH_YES
)
554 m
= gfc_match_init_expr (&start
);
556 m
= gfc_match_expr (&start
);
564 m
= gfc_match_char (':');
569 if (gfc_match_char (')') != MATCH_YES
)
572 m
= gfc_match_init_expr (&end
);
574 m
= gfc_match_expr (&end
);
578 if (m
== MATCH_ERROR
)
581 m
= gfc_match_char (')');
586 /* Optimize away the (:) reference. */
587 if (start
== NULL
&& end
== NULL
)
591 ref
= gfc_get_ref ();
593 ref
->type
= REF_SUBSTRING
;
595 start
= gfc_int_expr (1);
596 ref
->u
.ss
.start
= start
;
597 if (end
== NULL
&& cl
)
598 end
= gfc_copy_expr (cl
->length
);
600 ref
->u
.ss
.length
= cl
;
607 gfc_error ("Syntax error in SUBSTRING specification at %C");
611 gfc_free_expr (start
);
614 gfc_current_locus
= old_loc
;
619 /* Reads the next character of a string constant, taking care to
620 return doubled delimiters on the input as a single instance of
623 Special return values are:
624 -1 End of the string, as determined by the delimiter
625 -2 Unterminated string detected
627 Backslash codes are also expanded at this time. */
630 next_string_char (char delimiter
)
635 c
= gfc_next_char_literal (1);
642 old_locus
= gfc_current_locus
;
644 switch (gfc_next_char_literal (1))
672 /* Unknown backslash codes are simply not expanded */
673 gfc_current_locus
= old_locus
;
681 old_locus
= gfc_current_locus
;
682 c
= gfc_next_char_literal (1);
686 gfc_current_locus
= old_locus
;
692 /* Special case of gfc_match_name() that matches a parameter kind name
693 before a string constant. This takes case of the weird but legal
694 case of: weird case of:
698 where kind____ is a parameter. gfc_match_name() will happily slurp
699 up all the underscores, which leads to problems. If we return
700 MATCH_YES, the parse pointer points to the final underscore, which
701 is not part of the name. We never return MATCH_ERROR-- errors in
702 the name will be detected later. */
705 match_charkind_name (char *name
)
711 gfc_gobble_whitespace ();
712 c
= gfc_next_char ();
721 old_loc
= gfc_current_locus
;
722 c
= gfc_next_char ();
726 peek
= gfc_peek_char ();
728 if (peek
== '\'' || peek
== '\"')
730 gfc_current_locus
= old_loc
;
738 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
742 if (++len
> GFC_MAX_SYMBOL_LEN
)
750 /* See if the current input matches a character constant. Lots of
751 contortions have to be done to match the kind parameter which comes
752 before the actual string. The main consideration is that we don't
753 want to error out too quickly. For example, we don't actually do
754 any validation of the kinds until we have actually seen a legal
755 delimiter. Using match_kind_param() generates errors too quickly. */
758 match_string_constant (gfc_expr
** result
)
760 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
761 int i
, c
, kind
, length
, delimiter
;
762 locus old_locus
, start_locus
;
768 old_locus
= gfc_current_locus
;
770 gfc_gobble_whitespace ();
772 start_locus
= gfc_current_locus
;
774 c
= gfc_next_char ();
775 if (c
== '\'' || c
== '"')
777 kind
= gfc_default_character_kind
;
787 kind
= kind
* 10 + c
- '0';
790 c
= gfc_next_char ();
796 gfc_current_locus
= old_locus
;
798 m
= match_charkind_name (name
);
802 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
804 || sym
->attr
.flavor
!= FL_PARAMETER
)
808 c
= gfc_next_char ();
813 gfc_gobble_whitespace ();
814 c
= gfc_next_char ();
820 gfc_gobble_whitespace ();
821 start_locus
= gfc_current_locus
;
823 c
= gfc_next_char ();
824 if (c
!= '\'' && c
!= '"')
829 q
= gfc_extract_int (sym
->value
, &kind
);
837 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
839 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
844 /* Scan the string into a block of memory by first figuring out how
845 long it is, allocating the structure, then re-reading it. This
846 isn't particularly efficient, but string constants aren't that
847 common in most code. TODO: Use obstacks? */
854 c
= next_string_char (delimiter
);
859 gfc_current_locus
= start_locus
;
860 gfc_error ("Unterminated character constant beginning at %C");
869 e
->expr_type
= EXPR_CONSTANT
;
871 e
->ts
.type
= BT_CHARACTER
;
873 e
->where
= start_locus
;
875 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
876 e
->value
.character
.length
= length
;
878 gfc_current_locus
= start_locus
;
879 gfc_next_char (); /* Skip delimiter */
881 for (i
= 0; i
< length
; i
++)
882 *p
++ = next_string_char (delimiter
);
884 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
886 if (next_string_char (delimiter
) != -1)
887 gfc_internal_error ("match_string_constant(): Delimiter not found");
889 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
890 e
->expr_type
= EXPR_SUBSTRING
;
897 gfc_current_locus
= old_locus
;
902 /* Match a .true. or .false. */
905 match_logical_constant (gfc_expr
** result
)
907 static mstring logical_ops
[] = {
908 minit (".false.", 0),
916 i
= gfc_match_strings (logical_ops
);
924 kind
= gfc_default_logical_kind
;
926 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
927 gfc_error ("Bad kind for logical constant at %C");
931 e
->expr_type
= EXPR_CONSTANT
;
932 e
->value
.logical
= i
;
933 e
->ts
.type
= BT_LOGICAL
;
935 e
->where
= gfc_current_locus
;
942 /* Match a real or imaginary part of a complex constant that is a
943 symbolic constant. */
946 match_sym_complex_part (gfc_expr
** result
)
948 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
953 m
= gfc_match_name (name
);
957 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
960 if (sym
->attr
.flavor
!= FL_PARAMETER
)
962 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
966 if (!gfc_numeric_ts (&sym
->value
->ts
))
968 gfc_error ("Numeric PARAMETER required in complex constant at %C");
972 if (sym
->value
->rank
!= 0)
974 gfc_error ("Scalar PARAMETER required in complex constant at %C");
978 switch (sym
->value
->ts
.type
)
981 e
= gfc_copy_expr (sym
->value
);
985 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
991 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
997 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1000 *result
= e
; /* e is a scalar, real, constant expression */
1004 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1009 /* Match a real or imaginary part of a complex number. */
1012 match_complex_part (gfc_expr
** result
)
1016 m
= match_sym_complex_part (result
);
1020 m
= match_real_constant (result
, 1);
1024 return match_integer_constant (result
, 1);
1028 /* Try to match a complex constant. */
1031 match_complex_constant (gfc_expr
** result
)
1033 gfc_expr
*e
, *real
, *imag
;
1034 gfc_error_buf old_error
;
1035 gfc_typespec target
;
1040 old_loc
= gfc_current_locus
;
1041 real
= imag
= e
= NULL
;
1043 m
= gfc_match_char ('(');
1047 gfc_push_error (&old_error
);
1049 m
= match_complex_part (&real
);
1053 if (gfc_match_char (',') == MATCH_NO
)
1055 gfc_pop_error (&old_error
);
1060 /* If m is error, then something was wrong with the real part and we
1061 assume we have a complex constant because we've seen the ','. An
1062 ambiguous case here is the start of an iterator list of some
1063 sort. These sort of lists are matched prior to coming here. */
1065 if (m
== MATCH_ERROR
)
1067 gfc_pop_error (&old_error
);
1069 m
= match_complex_part (&imag
);
1072 if (m
== MATCH_ERROR
)
1075 m
= gfc_match_char (')');
1078 /* Give the matcher for implied do-loops a chance to run. This
1079 yields a much saner error message for (/ (i, 4=i, 6) /). */
1080 if (gfc_peek_char () == '=')
1089 if (m
== MATCH_ERROR
)
1092 /* Decide on the kind of this complex number. */
1093 if (real
->ts
.type
== BT_REAL
)
1095 if (imag
->ts
.type
== BT_REAL
)
1096 kind
= gfc_kind_max (real
, imag
);
1098 kind
= real
->ts
.kind
;
1102 if (imag
->ts
.type
== BT_REAL
)
1103 kind
= imag
->ts
.kind
;
1105 kind
= gfc_default_real_kind
;
1107 target
.type
= BT_REAL
;
1110 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1111 gfc_convert_type (real
, &target
, 2);
1112 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1113 gfc_convert_type (imag
, &target
, 2);
1115 e
= gfc_convert_complex (real
, imag
, kind
);
1116 e
->where
= gfc_current_locus
;
1118 gfc_free_expr (real
);
1119 gfc_free_expr (imag
);
1125 gfc_error ("Syntax error in COMPLEX constant at %C");
1130 gfc_free_expr (real
);
1131 gfc_free_expr (imag
);
1132 gfc_current_locus
= old_loc
;
1138 /* Match constants in any of several forms. Returns nonzero for a
1139 match, zero for no match. */
1142 gfc_match_literal_constant (gfc_expr
** result
, int signflag
)
1146 m
= match_complex_constant (result
);
1150 m
= match_string_constant (result
);
1154 m
= match_boz_constant (result
);
1158 m
= match_real_constant (result
, signflag
);
1162 m
= match_integer_constant (result
, signflag
);
1166 m
= match_logical_constant (result
);
1174 /* Match a single actual argument value. An actual argument is
1175 usually an expression, but can also be a procedure name. If the
1176 argument is a single name, it is not always possible to tell
1177 whether the name is a dummy procedure or not. We treat these cases
1178 by creating an argument that looks like a dummy procedure and
1179 fixing things later during resolution. */
1182 match_actual_arg (gfc_expr
** result
)
1184 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1185 gfc_symtree
*symtree
;
1190 where
= gfc_current_locus
;
1192 switch (gfc_match_name (name
))
1201 w
= gfc_current_locus
;
1202 gfc_gobble_whitespace ();
1203 c
= gfc_next_char ();
1204 gfc_current_locus
= w
;
1206 if (c
!= ',' && c
!= ')')
1209 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1211 /* Handle error elsewhere. */
1213 /* Eliminate a couple of common cases where we know we don't
1214 have a function argument. */
1215 if (symtree
== NULL
)
1217 gfc_get_sym_tree (name
, NULL
, &symtree
);
1218 gfc_set_sym_referenced (symtree
->n
.sym
);
1224 sym
= symtree
->n
.sym
;
1225 gfc_set_sym_referenced (sym
);
1226 if (sym
->attr
.flavor
!= FL_PROCEDURE
1227 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1230 /* If the symbol is a function with itself as the result and
1231 is being defined, then we have a variable. */
1232 if (sym
->result
== sym
1233 && (gfc_current_ns
->proc_name
== sym
1234 || (gfc_current_ns
->parent
!= NULL
1235 && gfc_current_ns
->parent
->proc_name
== sym
)))
1239 e
= gfc_get_expr (); /* Leave it unknown for now */
1240 e
->symtree
= symtree
;
1241 e
->expr_type
= EXPR_VARIABLE
;
1242 e
->ts
.type
= BT_PROCEDURE
;
1249 gfc_current_locus
= where
;
1250 return gfc_match_expr (result
);
1254 /* Match a keyword argument. */
1257 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1259 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1260 gfc_actual_arglist
*a
;
1264 name_locus
= gfc_current_locus
;
1265 m
= gfc_match_name (name
);
1269 if (gfc_match_char ('=') != MATCH_YES
)
1275 m
= match_actual_arg (&actual
->expr
);
1279 /* Make sure this name has not appeared yet. */
1281 if (name
[0] != '\0')
1283 for (a
= base
; a
; a
= a
->next
)
1284 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1287 ("Keyword '%s' at %C has already appeared in the current "
1288 "argument list", name
);
1293 actual
->name
= gfc_get_string (name
);
1297 gfc_current_locus
= name_locus
;
1302 /* Matches an actual argument list of a function or subroutine, from
1303 the opening parenthesis to the closing parenthesis. The argument
1304 list is assumed to allow keyword arguments because we don't know if
1305 the symbol associated with the procedure has an implicit interface
1306 or not. We make sure keywords are unique. If SUB_FLAG is set,
1307 we're matching the argument list of a subroutine. */
1310 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1312 gfc_actual_arglist
*head
, *tail
;
1314 gfc_st_label
*label
;
1318 *argp
= tail
= NULL
;
1319 old_loc
= gfc_current_locus
;
1323 if (gfc_match_char ('(') == MATCH_NO
)
1324 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1326 if (gfc_match_char (')') == MATCH_YES
)
1333 head
= tail
= gfc_get_actual_arglist ();
1336 tail
->next
= gfc_get_actual_arglist ();
1340 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1342 m
= gfc_match_st_label (&label
, 0);
1344 gfc_error ("Expected alternate return label at %C");
1348 tail
->label
= label
;
1352 /* After the first keyword argument is seen, the following
1353 arguments must also have keywords. */
1356 m
= match_keyword_arg (tail
, head
);
1358 if (m
== MATCH_ERROR
)
1363 ("Missing keyword name in actual argument list at %C");
1370 /* See if we have the first keyword argument. */
1371 m
= match_keyword_arg (tail
, head
);
1374 if (m
== MATCH_ERROR
)
1379 /* Try for a non-keyword argument. */
1380 m
= match_actual_arg (&tail
->expr
);
1381 if (m
== MATCH_ERROR
)
1389 if (gfc_match_char (')') == MATCH_YES
)
1391 if (gfc_match_char (',') != MATCH_YES
)
1399 gfc_error ("Syntax error in argument list at %C");
1402 gfc_free_actual_arglist (head
);
1403 gfc_current_locus
= old_loc
;
1409 /* Used by match_varspec() to extend the reference list by one
1413 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1416 if (primary
->ref
== NULL
)
1417 primary
->ref
= tail
= gfc_get_ref ();
1421 gfc_internal_error ("extend_ref(): Bad tail");
1422 tail
->next
= gfc_get_ref ();
1430 /* Match any additional specifications associated with the current
1431 variable like member references or substrings. If equiv_flag is
1432 set we only match stuff that is allowed inside an EQUIVALENCE
1436 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1438 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1439 gfc_ref
*substring
, *tail
;
1440 gfc_component
*component
;
1446 if (primary
->symtree
->n
.sym
->attr
.dimension
1448 && gfc_peek_char () == '('))
1451 tail
= extend_ref (primary
, tail
);
1452 tail
->type
= REF_ARRAY
;
1454 m
= gfc_match_array_ref (&tail
->u
.ar
, primary
->symtree
->n
.sym
->as
,
1460 sym
= primary
->symtree
->n
.sym
;
1461 primary
->ts
= sym
->ts
;
1463 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1464 goto check_substring
;
1466 sym
= sym
->ts
.derived
;
1470 m
= gfc_match_name (name
);
1472 gfc_error ("Expected structure component name at %C");
1476 component
= gfc_find_component (sym
, name
);
1477 if (component
== NULL
)
1480 tail
= extend_ref (primary
, tail
);
1481 tail
->type
= REF_COMPONENT
;
1483 tail
->u
.c
.component
= component
;
1484 tail
->u
.c
.sym
= sym
;
1486 primary
->ts
= component
->ts
;
1488 if (component
->as
!= NULL
)
1490 tail
= extend_ref (primary
, tail
);
1491 tail
->type
= REF_ARRAY
;
1493 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1498 if (component
->ts
.type
!= BT_DERIVED
1499 || gfc_match_char ('%') != MATCH_YES
)
1502 sym
= component
->ts
.derived
;
1506 if (primary
->ts
.type
== BT_CHARACTER
)
1508 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1512 primary
->ref
= substring
;
1514 tail
->next
= substring
;
1516 if (primary
->expr_type
== EXPR_CONSTANT
)
1517 primary
->expr_type
= EXPR_SUBSTRING
;
1520 primary
->ts
.cl
= NULL
;
1536 /* Given an expression that is a variable, figure out what the
1537 ultimate variable's type and attribute is, traversing the reference
1538 structures if necessary.
1540 This subroutine is trickier than it looks. We start at the base
1541 symbol and store the attribute. Component references load a
1542 completely new attribute.
1544 A couple of rules come into play. Subobjects of targets are always
1545 targets themselves. If we see a component that goes through a
1546 pointer, then the expression must also be a target, since the
1547 pointer is associated with something (if it isn't core will soon be
1548 dumped). If we see a full part or section of an array, the
1549 expression is also an array.
1551 We can have at most one full array reference. */
1554 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1556 int dimension
, pointer
, target
;
1557 symbol_attribute attr
;
1560 if (expr
->expr_type
!= EXPR_VARIABLE
)
1561 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1564 attr
= expr
->symtree
->n
.sym
->attr
;
1566 dimension
= attr
.dimension
;
1567 pointer
= attr
.pointer
;
1569 target
= attr
.target
;
1573 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1574 *ts
= expr
->symtree
->n
.sym
->ts
;
1576 for (; ref
; ref
= ref
->next
)
1581 switch (ref
->u
.ar
.type
)
1597 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1603 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1605 *ts
= ref
->u
.c
.component
->ts
;
1607 pointer
= ref
->u
.c
.component
->pointer
;
1618 attr
.dimension
= dimension
;
1619 attr
.pointer
= pointer
;
1620 attr
.target
= target
;
1626 /* Return the attribute from a general expression. */
1629 gfc_expr_attr (gfc_expr
* e
)
1631 symbol_attribute attr
;
1633 switch (e
->expr_type
)
1636 attr
= gfc_variable_attr (e
, NULL
);
1640 gfc_clear_attr (&attr
);
1642 if (e
->value
.function
.esym
!= NULL
)
1643 attr
= e
->value
.function
.esym
->result
->attr
;
1645 /* TODO: NULL() returns pointers. May have to take care of this
1651 gfc_clear_attr (&attr
);
1659 /* Match a structure constructor. The initial symbol has already been
1663 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1665 gfc_constructor
*head
, *tail
;
1666 gfc_component
*comp
;
1673 if (gfc_match_char ('(') != MATCH_YES
)
1676 where
= gfc_current_locus
;
1678 gfc_find_component (sym
, NULL
);
1680 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1683 tail
= head
= gfc_get_constructor ();
1686 tail
->next
= gfc_get_constructor ();
1690 m
= gfc_match_expr (&tail
->expr
);
1693 if (m
== MATCH_ERROR
)
1696 if (gfc_match_char (',') == MATCH_YES
)
1698 if (comp
->next
== NULL
)
1701 ("Too many components in structure constructor at %C");
1711 if (gfc_match_char (')') != MATCH_YES
)
1714 if (comp
->next
!= NULL
)
1716 gfc_error ("Too few components in structure constructor at %C");
1720 e
= gfc_get_expr ();
1722 e
->expr_type
= EXPR_STRUCTURE
;
1724 e
->ts
.type
= BT_DERIVED
;
1725 e
->ts
.derived
= sym
;
1728 e
->value
.constructor
= head
;
1734 gfc_error ("Syntax error in structure constructor at %C");
1737 gfc_free_constructor (head
);
1742 /* Matches a variable name followed by anything that might follow it--
1743 array reference, argument list of a function, etc. */
1746 gfc_match_rvalue (gfc_expr
** result
)
1748 gfc_actual_arglist
*actual_arglist
;
1749 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
1752 gfc_symtree
*symtree
;
1753 locus where
, old_loc
;
1758 m
= gfc_match_name (name
);
1762 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1763 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1765 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1770 sym
= symtree
->n
.sym
;
1772 where
= gfc_current_locus
;
1774 gfc_set_sym_referenced (sym
);
1776 if (sym
->attr
.function
&& sym
->result
== sym
1777 && (gfc_current_ns
->proc_name
== sym
1778 || (gfc_current_ns
->parent
!= NULL
1779 && gfc_current_ns
->parent
->proc_name
== sym
)))
1782 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1785 if (sym
->attr
.generic
)
1786 goto generic_function
;
1788 switch (sym
->attr
.flavor
)
1792 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1793 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1794 gfc_set_default_type (sym
, 0, sym
->ns
);
1796 e
= gfc_get_expr ();
1798 e
->expr_type
= EXPR_VARIABLE
;
1799 e
->symtree
= symtree
;
1801 m
= match_varspec (e
, 0);
1806 && sym
->value
->expr_type
!= EXPR_ARRAY
)
1807 e
= gfc_copy_expr (sym
->value
);
1810 e
= gfc_get_expr ();
1811 e
->expr_type
= EXPR_VARIABLE
;
1814 e
->symtree
= symtree
;
1815 m
= match_varspec (e
, 0);
1819 sym
= gfc_use_derived (sym
);
1823 m
= gfc_match_structure_constructor (sym
, &e
);
1826 /* If we're here, then the name is known to be the name of a
1827 procedure, yet it is not sure to be the name of a function. */
1829 if (sym
->attr
.subroutine
)
1831 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1837 /* At this point, the name has to be a non-statement function.
1838 If the name is the same as the current function being
1839 compiled, then we have a variable reference (to the function
1840 result) if the name is non-recursive. */
1842 st
= gfc_enclosing_unit (NULL
);
1844 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
1846 && !sym
->attr
.recursive
)
1848 e
= gfc_get_expr ();
1849 e
->symtree
= symtree
;
1850 e
->expr_type
= EXPR_VARIABLE
;
1852 m
= match_varspec (e
, 0);
1856 /* Match a function reference. */
1858 m
= gfc_match_actual_arglist (0, &actual_arglist
);
1861 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1862 gfc_error ("Statement function '%s' requires argument list at %C",
1865 gfc_error ("Function '%s' requires an argument list at %C",
1878 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
1879 sym
= symtree
->n
.sym
;
1881 e
= gfc_get_expr ();
1882 e
->symtree
= symtree
;
1883 e
->expr_type
= EXPR_FUNCTION
;
1884 e
->value
.function
.actual
= actual_arglist
;
1885 e
->where
= gfc_current_locus
;
1887 if (sym
->as
!= NULL
)
1888 e
->rank
= sym
->as
->rank
;
1890 if (!sym
->attr
.function
1891 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
1897 if (sym
->result
== NULL
)
1905 /* Special case for derived type variables that get their types
1906 via an IMPLICIT statement. This can't wait for the
1907 resolution phase. */
1909 if (gfc_peek_char () == '%'
1910 && sym
->ts
.type
== BT_UNKNOWN
1911 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1912 gfc_set_default_type (sym
, 0, sym
->ns
);
1914 /* If the symbol has a dimension attribute, the expression is a
1917 if (sym
->attr
.dimension
)
1919 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1920 sym
->name
, NULL
) == FAILURE
)
1926 e
= gfc_get_expr ();
1927 e
->symtree
= symtree
;
1928 e
->expr_type
= EXPR_VARIABLE
;
1929 m
= match_varspec (e
, 0);
1933 /* Name is not an array, so we peek to see if a '(' implies a
1934 function call or a substring reference. Otherwise the
1935 variable is just a scalar. */
1937 gfc_gobble_whitespace ();
1938 if (gfc_peek_char () != '(')
1940 /* Assume a scalar variable */
1941 e
= gfc_get_expr ();
1942 e
->symtree
= symtree
;
1943 e
->expr_type
= EXPR_VARIABLE
;
1945 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1946 sym
->name
, NULL
) == FAILURE
)
1953 m
= match_varspec (e
, 0);
1957 /* See if this is a function reference with a keyword argument
1958 as first argument. We do this because otherwise a spurious
1959 symbol would end up in the symbol table. */
1961 old_loc
= gfc_current_locus
;
1962 m2
= gfc_match (" ( %n =", argname
);
1963 gfc_current_locus
= old_loc
;
1965 e
= gfc_get_expr ();
1966 e
->symtree
= symtree
;
1968 if (m2
!= MATCH_YES
)
1970 /* See if this could possibly be a substring reference of a name
1971 that we're not sure is a variable yet. */
1973 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
1974 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
1977 e
->expr_type
= EXPR_VARIABLE
;
1979 if (sym
->attr
.flavor
!= FL_VARIABLE
1980 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
1981 sym
->name
, NULL
) == FAILURE
)
1987 if (sym
->ts
.type
== BT_UNKNOWN
1988 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2002 /* Give up, assume we have a function. */
2004 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2005 sym
= symtree
->n
.sym
;
2006 e
->expr_type
= EXPR_FUNCTION
;
2008 if (!sym
->attr
.function
2009 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2017 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2019 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2027 /* If our new function returns a character, array or structure
2028 type, it might have subsequent references. */
2030 m
= match_varspec (e
, 0);
2037 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2039 e
= gfc_get_expr ();
2040 e
->symtree
= symtree
;
2041 e
->expr_type
= EXPR_FUNCTION
;
2043 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2047 gfc_error ("Symbol at %C is not appropriate for an expression");
2063 /* Match a variable, ie something that can be assigned to. This
2064 starts as a symbol, can be a structure component or an array
2065 reference. It can be a function if the function doesn't have a
2066 separate RESULT variable. If the symbol has not been previously
2067 seen, we assume it is a variable. */
2070 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2078 m
= gfc_match_sym_tree (&st
, 1);
2081 where
= gfc_current_locus
;
2084 gfc_set_sym_referenced (sym
);
2085 switch (sym
->attr
.flavor
)
2091 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2092 sym
->name
, NULL
) == FAILURE
)
2097 /* Check for a nonrecursive function result */
2098 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2100 /* If a function result is a derived type, then the derived
2101 type may still have to be resolved. */
2103 if (sym
->ts
.type
== BT_DERIVED
2104 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2109 /* Fall through to error */
2112 gfc_error ("Expected VARIABLE at %C");
2116 /* Special case for derived type variables that get their types
2117 via an IMPLICIT statement. This can't wait for the
2118 resolution phase. */
2121 gfc_namespace
* implicit_ns
;
2123 if (gfc_current_ns
->proc_name
== sym
)
2124 implicit_ns
= gfc_current_ns
;
2126 implicit_ns
= sym
->ns
;
2128 if (gfc_peek_char () == '%'
2129 && sym
->ts
.type
== BT_UNKNOWN
2130 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2131 gfc_set_default_type (sym
, 0, implicit_ns
);
2134 expr
= gfc_get_expr ();
2136 expr
->expr_type
= EXPR_VARIABLE
;
2139 expr
->where
= where
;
2141 /* Now see if we have to do more. */
2142 m
= match_varspec (expr
, equiv_flag
);
2145 gfc_free_expr (expr
);