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];
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 Hollerith constant. */
234 match_hollerith_constant (gfc_expr
** result
)
243 old_loc
= gfc_current_locus
;
244 gfc_gobble_whitespace ();
246 if (match_integer_constant (&e
, 0) == MATCH_YES
247 && gfc_match_char ('h') == MATCH_YES
)
249 if (gfc_notify_std (GFC_STD_LEGACY
,
250 "Extension: Hollerith constant at %C")
254 msg
= gfc_extract_int (e
, &num
);
262 gfc_error ("Invalid Hollerith constant: %L must contain at least one "
263 "character", &old_loc
);
266 if (e
->ts
.kind
!= gfc_default_integer_kind
)
268 gfc_error ("Invalid Hollerith constant: Interger kind at %L "
269 "should be default", &old_loc
);
274 buffer
= (char *) gfc_getmem (sizeof(char) * num
+ 1);
275 for (i
= 0; i
< num
; i
++)
277 buffer
[i
] = gfc_next_char_literal (1);
280 e
= gfc_constant_result (BT_HOLLERITH
,
281 gfc_default_character_kind
, &gfc_current_locus
);
282 e
->value
.character
.string
= gfc_getmem (num
+1);
283 memcpy (e
->value
.character
.string
, buffer
, num
);
284 e
->value
.character
.length
= num
;
291 gfc_current_locus
= old_loc
;
300 /* Match a binary, octal or hexadecimal constant that can be found in
304 match_boz_constant (gfc_expr
** result
)
306 int radix
, delim
, length
, x_hex
, kind
;
311 old_loc
= gfc_current_locus
;
312 gfc_gobble_whitespace ();
315 switch (gfc_next_char ())
333 /* No whitespace allowed here. */
335 delim
= gfc_next_char ();
336 if (delim
!= '\'' && delim
!= '\"')
339 if (x_hex
&& pedantic
340 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
341 "constant at %C uses non-standard syntax.")
345 old_loc
= gfc_current_locus
;
347 length
= match_digits (0, radix
, NULL
);
353 gfc_error ("Empty set of digits in binary constant at %C");
356 gfc_error ("Empty set of digits in octal constant at %C");
359 gfc_error ("Empty set of digits in hexadecimal constant at %C");
367 if (gfc_next_char () != delim
)
372 gfc_error ("Illegal character in binary constant at %C");
375 gfc_error ("Illegal character in octal constant at %C");
378 gfc_error ("Illegal character in hexadecimal constant at %C");
386 gfc_current_locus
= old_loc
;
388 buffer
= alloca (length
+ 1);
389 memset (buffer
, '\0', length
+ 1);
391 match_digits (0, radix
, buffer
);
392 gfc_next_char (); /* Eat delimiter. */
395 /* In section 5.2.5 and following C567 in the Fortran 2003 standard, we find
396 "If a data-stmt-constant is a boz-literal-constant, the corresponding
397 variable shall be of type integer. The boz-literal-constant is treated
398 as if it were an int-literal-constant with a kind-param that specifies
399 the representation method with the largest decimal exponent range
400 supported by the processor." */
402 kind
= gfc_max_integer_kind
;
403 e
= gfc_convert_integer (buffer
, kind
, radix
, &gfc_current_locus
);
405 if (gfc_range_check (e
) != ARITH_OK
)
407 gfc_error ("Integer too big for integer kind %i at %C", kind
);
417 gfc_current_locus
= old_loc
;
422 /* Match a real constant of some sort. Allow a signed constant if signflag
423 is nonzero. Allow integer constants if allow_int is true. */
426 match_real_constant (gfc_expr
** result
, int signflag
)
428 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
429 locus old_loc
, temp_loc
;
434 old_loc
= gfc_current_locus
;
435 gfc_gobble_whitespace ();
445 c
= gfc_next_char ();
446 if (signflag
&& (c
== '+' || c
== '-'))
451 gfc_gobble_whitespace ();
452 c
= gfc_next_char ();
455 /* Scan significand. */
456 for (;; c
= gfc_next_char (), count
++)
463 /* Check to see if "." goes with a following operator like ".eq.". */
464 temp_loc
= gfc_current_locus
;
465 c
= gfc_next_char ();
467 if (c
== 'e' || c
== 'd' || c
== 'q')
469 c
= gfc_next_char ();
471 goto done
; /* Operator named .e. or .d. */
475 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
477 gfc_current_locus
= temp_loc
;
492 || (c
!= 'e' && c
!= 'd' && c
!= 'q'))
497 c
= gfc_next_char ();
500 if (c
== '+' || c
== '-')
501 { /* optional sign */
502 c
= gfc_next_char ();
508 gfc_error ("Missing exponent in real number at %C");
514 c
= gfc_next_char ();
519 /* Check that we have a numeric constant. */
520 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
522 gfc_current_locus
= old_loc
;
526 /* Convert the number. */
527 gfc_current_locus
= old_loc
;
528 gfc_gobble_whitespace ();
530 buffer
= alloca (count
+ 1);
531 memset (buffer
, '\0', count
+ 1);
534 c
= gfc_next_char ();
535 if (c
== '+' || c
== '-')
537 gfc_gobble_whitespace ();
538 c
= gfc_next_char ();
541 /* Hack for mpfr_set_str(). */
544 if (c
== 'd' || c
== 'q')
552 c
= gfc_next_char ();
565 ("Real number at %C has a 'd' exponent and an explicit kind");
568 kind
= gfc_default_double_kind
;
575 ("Real number at %C has a 'q' exponent and an explicit kind");
578 kind
= gfc_option
.q_kind
;
583 kind
= gfc_default_real_kind
;
585 if (gfc_validate_kind (BT_REAL
, kind
, true) < 0)
587 gfc_error ("Invalid real kind %d at %C", kind
);
592 e
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
594 mpfr_neg (e
->value
.real
, e
->value
.real
, GFC_RND_MODE
);
596 switch (gfc_range_check (e
))
601 gfc_error ("Real constant overflows its kind at %C");
604 case ARITH_UNDERFLOW
:
605 if (gfc_option
.warn_underflow
)
606 gfc_warning ("Real constant underflows its kind at %C");
607 mpfr_set_ui (e
->value
.real
, 0, GFC_RND_MODE
);
611 gfc_internal_error ("gfc_range_check() returned bad value");
623 /* Match a substring reference. */
626 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
628 gfc_expr
*start
, *end
;
636 old_loc
= gfc_current_locus
;
638 m
= gfc_match_char ('(');
642 if (gfc_match_char (':') != MATCH_YES
)
645 m
= gfc_match_init_expr (&start
);
647 m
= gfc_match_expr (&start
);
655 m
= gfc_match_char (':');
660 if (gfc_match_char (')') != MATCH_YES
)
663 m
= gfc_match_init_expr (&end
);
665 m
= gfc_match_expr (&end
);
669 if (m
== MATCH_ERROR
)
672 m
= gfc_match_char (')');
677 /* Optimize away the (:) reference. */
678 if (start
== NULL
&& end
== NULL
)
682 ref
= gfc_get_ref ();
684 ref
->type
= REF_SUBSTRING
;
686 start
= gfc_int_expr (1);
687 ref
->u
.ss
.start
= start
;
688 if (end
== NULL
&& cl
)
689 end
= gfc_copy_expr (cl
->length
);
691 ref
->u
.ss
.length
= cl
;
698 gfc_error ("Syntax error in SUBSTRING specification at %C");
702 gfc_free_expr (start
);
705 gfc_current_locus
= old_loc
;
710 /* Reads the next character of a string constant, taking care to
711 return doubled delimiters on the input as a single instance of
714 Special return values are:
715 -1 End of the string, as determined by the delimiter
716 -2 Unterminated string detected
718 Backslash codes are also expanded at this time. */
721 next_string_char (char delimiter
)
726 c
= gfc_next_char_literal (1);
731 if (gfc_option
.flag_backslash
&& c
== '\\')
733 old_locus
= gfc_current_locus
;
735 switch (gfc_next_char_literal (1))
763 /* Unknown backslash codes are simply not expanded */
764 gfc_current_locus
= old_locus
;
772 old_locus
= gfc_current_locus
;
773 c
= gfc_next_char_literal (1);
777 gfc_current_locus
= old_locus
;
783 /* Special case of gfc_match_name() that matches a parameter kind name
784 before a string constant. This takes case of the weird but legal
789 where kind____ is a parameter. gfc_match_name() will happily slurp
790 up all the underscores, which leads to problems. If we return
791 MATCH_YES, the parse pointer points to the final underscore, which
792 is not part of the name. We never return MATCH_ERROR-- errors in
793 the name will be detected later. */
796 match_charkind_name (char *name
)
802 gfc_gobble_whitespace ();
803 c
= gfc_next_char ();
812 old_loc
= gfc_current_locus
;
813 c
= gfc_next_char ();
817 peek
= gfc_peek_char ();
819 if (peek
== '\'' || peek
== '\"')
821 gfc_current_locus
= old_loc
;
829 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
833 if (++len
> GFC_MAX_SYMBOL_LEN
)
841 /* See if the current input matches a character constant. Lots of
842 contortions have to be done to match the kind parameter which comes
843 before the actual string. The main consideration is that we don't
844 want to error out too quickly. For example, we don't actually do
845 any validation of the kinds until we have actually seen a legal
846 delimiter. Using match_kind_param() generates errors too quickly. */
849 match_string_constant (gfc_expr
** result
)
851 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
852 int i
, c
, kind
, length
, delimiter
;
853 locus old_locus
, start_locus
;
859 old_locus
= gfc_current_locus
;
861 gfc_gobble_whitespace ();
863 start_locus
= gfc_current_locus
;
865 c
= gfc_next_char ();
866 if (c
== '\'' || c
== '"')
868 kind
= gfc_default_character_kind
;
878 kind
= kind
* 10 + c
- '0';
881 c
= gfc_next_char ();
887 gfc_current_locus
= old_locus
;
889 m
= match_charkind_name (name
);
893 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
895 || sym
->attr
.flavor
!= FL_PARAMETER
)
899 c
= gfc_next_char ();
904 gfc_gobble_whitespace ();
905 c
= gfc_next_char ();
911 gfc_gobble_whitespace ();
912 start_locus
= gfc_current_locus
;
914 c
= gfc_next_char ();
915 if (c
!= '\'' && c
!= '"')
920 q
= gfc_extract_int (sym
->value
, &kind
);
928 if (gfc_validate_kind (BT_CHARACTER
, kind
, true) < 0)
930 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
935 /* Scan the string into a block of memory by first figuring out how
936 long it is, allocating the structure, then re-reading it. This
937 isn't particularly efficient, but string constants aren't that
938 common in most code. TODO: Use obstacks? */
945 c
= next_string_char (delimiter
);
950 gfc_current_locus
= start_locus
;
951 gfc_error ("Unterminated character constant beginning at %C");
960 e
->expr_type
= EXPR_CONSTANT
;
962 e
->ts
.type
= BT_CHARACTER
;
964 e
->where
= start_locus
;
966 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
967 e
->value
.character
.length
= length
;
969 gfc_current_locus
= start_locus
;
970 gfc_next_char (); /* Skip delimiter */
972 for (i
= 0; i
< length
; i
++)
973 *p
++ = next_string_char (delimiter
);
975 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
977 if (next_string_char (delimiter
) != -1)
978 gfc_internal_error ("match_string_constant(): Delimiter not found");
980 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
981 e
->expr_type
= EXPR_SUBSTRING
;
988 gfc_current_locus
= old_locus
;
993 /* Match a .true. or .false. */
996 match_logical_constant (gfc_expr
** result
)
998 static mstring logical_ops
[] = {
999 minit (".false.", 0),
1000 minit (".true.", 1),
1007 i
= gfc_match_strings (logical_ops
);
1015 kind
= gfc_default_logical_kind
;
1017 if (gfc_validate_kind (BT_LOGICAL
, kind
, true) < 0)
1018 gfc_error ("Bad kind for logical constant at %C");
1020 e
= gfc_get_expr ();
1022 e
->expr_type
= EXPR_CONSTANT
;
1023 e
->value
.logical
= i
;
1024 e
->ts
.type
= BT_LOGICAL
;
1026 e
->where
= gfc_current_locus
;
1033 /* Match a real or imaginary part of a complex constant that is a
1034 symbolic constant. */
1037 match_sym_complex_part (gfc_expr
** result
)
1039 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1044 m
= gfc_match_name (name
);
1048 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
1051 if (sym
->attr
.flavor
!= FL_PARAMETER
)
1053 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
1057 if (!gfc_numeric_ts (&sym
->value
->ts
))
1059 gfc_error ("Numeric PARAMETER required in complex constant at %C");
1063 if (sym
->value
->rank
!= 0)
1065 gfc_error ("Scalar PARAMETER required in complex constant at %C");
1069 switch (sym
->value
->ts
.type
)
1072 e
= gfc_copy_expr (sym
->value
);
1076 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
1082 e
= gfc_int2real (sym
->value
, gfc_default_real_kind
);
1088 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
1091 *result
= e
; /* e is a scalar, real, constant expression */
1095 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
1100 /* Match a real or imaginary part of a complex number. */
1103 match_complex_part (gfc_expr
** result
)
1107 m
= match_sym_complex_part (result
);
1111 m
= match_real_constant (result
, 1);
1115 return match_integer_constant (result
, 1);
1119 /* Try to match a complex constant. */
1122 match_complex_constant (gfc_expr
** result
)
1124 gfc_expr
*e
, *real
, *imag
;
1125 gfc_error_buf old_error
;
1126 gfc_typespec target
;
1131 old_loc
= gfc_current_locus
;
1132 real
= imag
= e
= NULL
;
1134 m
= gfc_match_char ('(');
1138 gfc_push_error (&old_error
);
1140 m
= match_complex_part (&real
);
1143 gfc_free_error (&old_error
);
1147 if (gfc_match_char (',') == MATCH_NO
)
1149 gfc_pop_error (&old_error
);
1154 /* If m is error, then something was wrong with the real part and we
1155 assume we have a complex constant because we've seen the ','. An
1156 ambiguous case here is the start of an iterator list of some
1157 sort. These sort of lists are matched prior to coming here. */
1159 if (m
== MATCH_ERROR
)
1161 gfc_free_error (&old_error
);
1164 gfc_pop_error (&old_error
);
1166 m
= match_complex_part (&imag
);
1169 if (m
== MATCH_ERROR
)
1172 m
= gfc_match_char (')');
1175 /* Give the matcher for implied do-loops a chance to run. This
1176 yields a much saner error message for (/ (i, 4=i, 6) /). */
1177 if (gfc_peek_char () == '=')
1186 if (m
== MATCH_ERROR
)
1189 /* Decide on the kind of this complex number. */
1190 if (real
->ts
.type
== BT_REAL
)
1192 if (imag
->ts
.type
== BT_REAL
)
1193 kind
= gfc_kind_max (real
, imag
);
1195 kind
= real
->ts
.kind
;
1199 if (imag
->ts
.type
== BT_REAL
)
1200 kind
= imag
->ts
.kind
;
1202 kind
= gfc_default_real_kind
;
1204 target
.type
= BT_REAL
;
1207 if (real
->ts
.type
!= BT_REAL
|| kind
!= real
->ts
.kind
)
1208 gfc_convert_type (real
, &target
, 2);
1209 if (imag
->ts
.type
!= BT_REAL
|| kind
!= imag
->ts
.kind
)
1210 gfc_convert_type (imag
, &target
, 2);
1212 e
= gfc_convert_complex (real
, imag
, kind
);
1213 e
->where
= gfc_current_locus
;
1215 gfc_free_expr (real
);
1216 gfc_free_expr (imag
);
1222 gfc_error ("Syntax error in COMPLEX constant at %C");
1227 gfc_free_expr (real
);
1228 gfc_free_expr (imag
);
1229 gfc_current_locus
= old_loc
;
1235 /* Match constants in any of several forms. Returns nonzero for a
1236 match, zero for no match. */
1239 gfc_match_literal_constant (gfc_expr
** result
, int signflag
)
1243 m
= match_complex_constant (result
);
1247 m
= match_string_constant (result
);
1251 m
= match_boz_constant (result
);
1255 m
= match_real_constant (result
, signflag
);
1259 m
= match_hollerith_constant (result
);
1263 m
= match_integer_constant (result
, signflag
);
1267 m
= match_logical_constant (result
);
1275 /* Match a single actual argument value. An actual argument is
1276 usually an expression, but can also be a procedure name. If the
1277 argument is a single name, it is not always possible to tell
1278 whether the name is a dummy procedure or not. We treat these cases
1279 by creating an argument that looks like a dummy procedure and
1280 fixing things later during resolution. */
1283 match_actual_arg (gfc_expr
** result
)
1285 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1286 gfc_symtree
*symtree
;
1291 where
= gfc_current_locus
;
1293 switch (gfc_match_name (name
))
1302 w
= gfc_current_locus
;
1303 gfc_gobble_whitespace ();
1304 c
= gfc_next_char ();
1305 gfc_current_locus
= w
;
1307 if (c
!= ',' && c
!= ')')
1310 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1312 /* Handle error elsewhere. */
1314 /* Eliminate a couple of common cases where we know we don't
1315 have a function argument. */
1316 if (symtree
== NULL
)
1318 gfc_get_sym_tree (name
, NULL
, &symtree
);
1319 gfc_set_sym_referenced (symtree
->n
.sym
);
1325 sym
= symtree
->n
.sym
;
1326 gfc_set_sym_referenced (sym
);
1327 if (sym
->attr
.flavor
!= FL_PROCEDURE
1328 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1331 /* If the symbol is a function with itself as the result and
1332 is being defined, then we have a variable. */
1333 if (sym
->attr
.function
&& sym
->result
== sym
)
1335 if (gfc_current_ns
->proc_name
== sym
1336 || (gfc_current_ns
->parent
!= NULL
1337 && gfc_current_ns
->parent
->proc_name
== sym
))
1341 && (sym
->ns
== gfc_current_ns
1342 || sym
->ns
== gfc_current_ns
->parent
))
1344 gfc_entry_list
*el
= NULL
;
1346 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1356 e
= gfc_get_expr (); /* Leave it unknown for now */
1357 e
->symtree
= symtree
;
1358 e
->expr_type
= EXPR_VARIABLE
;
1359 e
->ts
.type
= BT_PROCEDURE
;
1366 gfc_current_locus
= where
;
1367 return gfc_match_expr (result
);
1371 /* Match a keyword argument. */
1374 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1376 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1377 gfc_actual_arglist
*a
;
1381 name_locus
= gfc_current_locus
;
1382 m
= gfc_match_name (name
);
1386 if (gfc_match_char ('=') != MATCH_YES
)
1392 m
= match_actual_arg (&actual
->expr
);
1396 /* Make sure this name has not appeared yet. */
1398 if (name
[0] != '\0')
1400 for (a
= base
; a
; a
= a
->next
)
1401 if (a
->name
!= NULL
&& strcmp (a
->name
, name
) == 0)
1404 ("Keyword '%s' at %C has already appeared in the current "
1405 "argument list", name
);
1410 actual
->name
= gfc_get_string (name
);
1414 gfc_current_locus
= name_locus
;
1419 /* Matches an actual argument list of a function or subroutine, from
1420 the opening parenthesis to the closing parenthesis. The argument
1421 list is assumed to allow keyword arguments because we don't know if
1422 the symbol associated with the procedure has an implicit interface
1423 or not. We make sure keywords are unique. If SUB_FLAG is set,
1424 we're matching the argument list of a subroutine. */
1427 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1429 gfc_actual_arglist
*head
, *tail
;
1431 gfc_st_label
*label
;
1435 *argp
= tail
= NULL
;
1436 old_loc
= gfc_current_locus
;
1440 if (gfc_match_char ('(') == MATCH_NO
)
1441 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1443 if (gfc_match_char (')') == MATCH_YES
)
1450 head
= tail
= gfc_get_actual_arglist ();
1453 tail
->next
= gfc_get_actual_arglist ();
1457 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1459 m
= gfc_match_st_label (&label
, 0);
1461 gfc_error ("Expected alternate return label at %C");
1465 tail
->label
= label
;
1469 /* After the first keyword argument is seen, the following
1470 arguments must also have keywords. */
1473 m
= match_keyword_arg (tail
, head
);
1475 if (m
== MATCH_ERROR
)
1480 ("Missing keyword name in actual argument list at %C");
1487 /* See if we have the first keyword argument. */
1488 m
= match_keyword_arg (tail
, head
);
1491 if (m
== MATCH_ERROR
)
1496 /* Try for a non-keyword argument. */
1497 m
= match_actual_arg (&tail
->expr
);
1498 if (m
== MATCH_ERROR
)
1506 if (gfc_match_char (')') == MATCH_YES
)
1508 if (gfc_match_char (',') != MATCH_YES
)
1516 gfc_error ("Syntax error in argument list at %C");
1519 gfc_free_actual_arglist (head
);
1520 gfc_current_locus
= old_loc
;
1526 /* Used by match_varspec() to extend the reference list by one
1530 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1533 if (primary
->ref
== NULL
)
1534 primary
->ref
= tail
= gfc_get_ref ();
1538 gfc_internal_error ("extend_ref(): Bad tail");
1539 tail
->next
= gfc_get_ref ();
1547 /* Match any additional specifications associated with the current
1548 variable like member references or substrings. If equiv_flag is
1549 set we only match stuff that is allowed inside an EQUIVALENCE
1553 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1555 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1556 gfc_ref
*substring
, *tail
;
1557 gfc_component
*component
;
1558 gfc_symbol
*sym
= primary
->symtree
->n
.sym
;
1563 if ((equiv_flag
&& gfc_peek_char () == '(')
1564 || sym
->attr
.dimension
)
1566 /* In EQUIVALENCE, we don't know yet whether we are seeing
1567 an array, character variable or array of character
1568 variables. We'll leave the decision till resolve
1570 tail
= extend_ref (primary
, tail
);
1571 tail
->type
= REF_ARRAY
;
1573 m
= gfc_match_array_ref (&tail
->u
.ar
, equiv_flag
? NULL
: sym
->as
,
1578 if (equiv_flag
&& gfc_peek_char () == '(')
1580 tail
= extend_ref (primary
, tail
);
1581 tail
->type
= REF_ARRAY
;
1583 m
= gfc_match_array_ref (&tail
->u
.ar
, NULL
, equiv_flag
);
1589 primary
->ts
= sym
->ts
;
1594 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1595 goto check_substring
;
1597 sym
= sym
->ts
.derived
;
1601 m
= gfc_match_name (name
);
1603 gfc_error ("Expected structure component name at %C");
1607 component
= gfc_find_component (sym
, name
);
1608 if (component
== NULL
)
1611 tail
= extend_ref (primary
, tail
);
1612 tail
->type
= REF_COMPONENT
;
1614 tail
->u
.c
.component
= component
;
1615 tail
->u
.c
.sym
= sym
;
1617 primary
->ts
= component
->ts
;
1619 if (component
->as
!= NULL
)
1621 tail
= extend_ref (primary
, tail
);
1622 tail
->type
= REF_ARRAY
;
1624 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1629 if (component
->ts
.type
!= BT_DERIVED
1630 || gfc_match_char ('%') != MATCH_YES
)
1633 sym
= component
->ts
.derived
;
1637 if (primary
->ts
.type
== BT_CHARACTER
)
1639 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1643 primary
->ref
= substring
;
1645 tail
->next
= substring
;
1647 if (primary
->expr_type
== EXPR_CONSTANT
)
1648 primary
->expr_type
= EXPR_SUBSTRING
;
1651 primary
->ts
.cl
= NULL
;
1667 /* Given an expression that is a variable, figure out what the
1668 ultimate variable's type and attribute is, traversing the reference
1669 structures if necessary.
1671 This subroutine is trickier than it looks. We start at the base
1672 symbol and store the attribute. Component references load a
1673 completely new attribute.
1675 A couple of rules come into play. Subobjects of targets are always
1676 targets themselves. If we see a component that goes through a
1677 pointer, then the expression must also be a target, since the
1678 pointer is associated with something (if it isn't core will soon be
1679 dumped). If we see a full part or section of an array, the
1680 expression is also an array.
1682 We can have at most one full array reference. */
1685 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1687 int dimension
, pointer
, target
;
1688 symbol_attribute attr
;
1691 if (expr
->expr_type
!= EXPR_VARIABLE
)
1692 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1695 attr
= expr
->symtree
->n
.sym
->attr
;
1697 dimension
= attr
.dimension
;
1698 pointer
= attr
.pointer
;
1700 target
= attr
.target
;
1704 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1705 *ts
= expr
->symtree
->n
.sym
->ts
;
1707 for (; ref
; ref
= ref
->next
)
1712 switch (ref
->u
.ar
.type
)
1728 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1734 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1736 *ts
= ref
->u
.c
.component
->ts
;
1738 pointer
= ref
->u
.c
.component
->pointer
;
1749 attr
.dimension
= dimension
;
1750 attr
.pointer
= pointer
;
1751 attr
.target
= target
;
1757 /* Return the attribute from a general expression. */
1760 gfc_expr_attr (gfc_expr
* e
)
1762 symbol_attribute attr
;
1764 switch (e
->expr_type
)
1767 attr
= gfc_variable_attr (e
, NULL
);
1771 gfc_clear_attr (&attr
);
1773 if (e
->value
.function
.esym
!= NULL
)
1774 attr
= e
->value
.function
.esym
->result
->attr
;
1776 /* TODO: NULL() returns pointers. May have to take care of this
1782 gfc_clear_attr (&attr
);
1790 /* Match a structure constructor. The initial symbol has already been
1794 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1796 gfc_constructor
*head
, *tail
;
1797 gfc_component
*comp
;
1804 if (gfc_match_char ('(') != MATCH_YES
)
1807 where
= gfc_current_locus
;
1809 gfc_find_component (sym
, NULL
);
1811 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1814 tail
= head
= gfc_get_constructor ();
1817 tail
->next
= gfc_get_constructor ();
1821 m
= gfc_match_expr (&tail
->expr
);
1824 if (m
== MATCH_ERROR
)
1827 if (gfc_match_char (',') == MATCH_YES
)
1829 if (comp
->next
== NULL
)
1832 ("Too many components in structure constructor at %C");
1842 if (gfc_match_char (')') != MATCH_YES
)
1845 if (comp
->next
!= NULL
)
1847 gfc_error ("Too few components in structure constructor at %C");
1851 e
= gfc_get_expr ();
1853 e
->expr_type
= EXPR_STRUCTURE
;
1855 e
->ts
.type
= BT_DERIVED
;
1856 e
->ts
.derived
= sym
;
1859 e
->value
.constructor
= head
;
1865 gfc_error ("Syntax error in structure constructor at %C");
1868 gfc_free_constructor (head
);
1873 /* Matches a variable name followed by anything that might follow it--
1874 array reference, argument list of a function, etc. */
1877 gfc_match_rvalue (gfc_expr
** result
)
1879 gfc_actual_arglist
*actual_arglist
;
1880 char name
[GFC_MAX_SYMBOL_LEN
+ 1], argname
[GFC_MAX_SYMBOL_LEN
+ 1];
1883 gfc_symtree
*symtree
;
1884 locus where
, old_loc
;
1889 m
= gfc_match_name (name
);
1893 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1894 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1896 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1901 sym
= symtree
->n
.sym
;
1903 where
= gfc_current_locus
;
1905 gfc_set_sym_referenced (sym
);
1907 if (sym
->attr
.function
&& sym
->result
== sym
)
1909 if (gfc_current_ns
->proc_name
== sym
1910 || (gfc_current_ns
->parent
!= NULL
1911 && gfc_current_ns
->parent
->proc_name
== sym
))
1915 && (sym
->ns
== gfc_current_ns
1916 || sym
->ns
== gfc_current_ns
->parent
))
1918 gfc_entry_list
*el
= NULL
;
1920 for (el
= sym
->ns
->entries
; el
; el
= el
->next
)
1926 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1929 if (sym
->attr
.generic
)
1930 goto generic_function
;
1932 switch (sym
->attr
.flavor
)
1936 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1937 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1938 gfc_set_default_type (sym
, 0, sym
->ns
);
1940 e
= gfc_get_expr ();
1942 e
->expr_type
= EXPR_VARIABLE
;
1943 e
->symtree
= symtree
;
1945 m
= match_varspec (e
, 0);
1949 /* A statement of the form "REAL, parameter :: a(0:10) = 1" will
1950 end up here. Unfortunately, sym->value->expr_type is set to
1951 EXPR_CONSTANT, and so the if () branch would be followed without
1952 the !sym->as check. */
1953 if (sym
->value
&& sym
->value
->expr_type
!= EXPR_ARRAY
&& !sym
->as
)
1954 e
= gfc_copy_expr (sym
->value
);
1957 e
= gfc_get_expr ();
1958 e
->expr_type
= EXPR_VARIABLE
;
1961 e
->symtree
= symtree
;
1962 m
= match_varspec (e
, 0);
1966 sym
= gfc_use_derived (sym
);
1970 m
= gfc_match_structure_constructor (sym
, &e
);
1973 /* If we're here, then the name is known to be the name of a
1974 procedure, yet it is not sure to be the name of a function. */
1976 if (sym
->attr
.subroutine
)
1978 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1984 /* At this point, the name has to be a non-statement function.
1985 If the name is the same as the current function being
1986 compiled, then we have a variable reference (to the function
1987 result) if the name is non-recursive. */
1989 st
= gfc_enclosing_unit (NULL
);
1991 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
1993 && !sym
->attr
.recursive
)
1995 e
= gfc_get_expr ();
1996 e
->symtree
= symtree
;
1997 e
->expr_type
= EXPR_VARIABLE
;
1999 m
= match_varspec (e
, 0);
2003 /* Match a function reference. */
2005 m
= gfc_match_actual_arglist (0, &actual_arglist
);
2008 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
2009 gfc_error ("Statement function '%s' requires argument list at %C",
2012 gfc_error ("Function '%s' requires an argument list at %C",
2025 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
2026 sym
= symtree
->n
.sym
;
2028 e
= gfc_get_expr ();
2029 e
->symtree
= symtree
;
2030 e
->expr_type
= EXPR_FUNCTION
;
2031 e
->value
.function
.actual
= actual_arglist
;
2032 e
->where
= gfc_current_locus
;
2034 if (sym
->as
!= NULL
)
2035 e
->rank
= sym
->as
->rank
;
2037 if (!sym
->attr
.function
2038 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2044 if (sym
->result
== NULL
)
2052 /* Special case for derived type variables that get their types
2053 via an IMPLICIT statement. This can't wait for the
2054 resolution phase. */
2056 if (gfc_peek_char () == '%'
2057 && sym
->ts
.type
== BT_UNKNOWN
2058 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2059 gfc_set_default_type (sym
, 0, sym
->ns
);
2061 /* If the symbol has a dimension attribute, the expression is a
2064 if (sym
->attr
.dimension
)
2066 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2067 sym
->name
, NULL
) == FAILURE
)
2073 e
= gfc_get_expr ();
2074 e
->symtree
= symtree
;
2075 e
->expr_type
= EXPR_VARIABLE
;
2076 m
= match_varspec (e
, 0);
2080 /* Name is not an array, so we peek to see if a '(' implies a
2081 function call or a substring reference. Otherwise the
2082 variable is just a scalar. */
2084 gfc_gobble_whitespace ();
2085 if (gfc_peek_char () != '(')
2087 /* Assume a scalar variable */
2088 e
= gfc_get_expr ();
2089 e
->symtree
= symtree
;
2090 e
->expr_type
= EXPR_VARIABLE
;
2092 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2093 sym
->name
, NULL
) == FAILURE
)
2100 m
= match_varspec (e
, 0);
2104 /* See if this is a function reference with a keyword argument
2105 as first argument. We do this because otherwise a spurious
2106 symbol would end up in the symbol table. */
2108 old_loc
= gfc_current_locus
;
2109 m2
= gfc_match (" ( %n =", argname
);
2110 gfc_current_locus
= old_loc
;
2112 e
= gfc_get_expr ();
2113 e
->symtree
= symtree
;
2115 if (m2
!= MATCH_YES
)
2117 /* See if this could possibly be a substring reference of a name
2118 that we're not sure is a variable yet. */
2120 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
2121 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2124 e
->expr_type
= EXPR_VARIABLE
;
2126 if (sym
->attr
.flavor
!= FL_VARIABLE
2127 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2128 sym
->name
, NULL
) == FAILURE
)
2134 if (sym
->ts
.type
== BT_UNKNOWN
2135 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2149 /* Give up, assume we have a function. */
2151 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2152 sym
= symtree
->n
.sym
;
2153 e
->expr_type
= EXPR_FUNCTION
;
2155 if (!sym
->attr
.function
2156 && gfc_add_function (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2164 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2166 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2174 /* If our new function returns a character, array or structure
2175 type, it might have subsequent references. */
2177 m
= match_varspec (e
, 0);
2184 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2186 e
= gfc_get_expr ();
2187 e
->symtree
= symtree
;
2188 e
->expr_type
= EXPR_FUNCTION
;
2190 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2194 gfc_error ("Symbol at %C is not appropriate for an expression");
2210 /* Match a variable, ie something that can be assigned to. This
2211 starts as a symbol, can be a structure component or an array
2212 reference. It can be a function if the function doesn't have a
2213 separate RESULT variable. If the symbol has not been previously
2214 seen, we assume it is a variable.
2216 This function is called by two interface functions:
2217 gfc_match_variable, which has host_flag = 1, and
2218 gfc_match_equiv_variable, with host_flag = 0, to restrict the
2219 match of the symbol to the local scope. */
2222 match_variable (gfc_expr
** result
, int equiv_flag
, int host_flag
)
2230 m
= gfc_match_sym_tree (&st
, host_flag
);
2233 where
= gfc_current_locus
;
2236 gfc_set_sym_referenced (sym
);
2237 switch (sym
->attr
.flavor
)
2243 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
,
2244 sym
->name
, NULL
) == FAILURE
)
2249 /* Check for a nonrecursive function result */
2250 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2252 /* If a function result is a derived type, then the derived
2253 type may still have to be resolved. */
2255 if (sym
->ts
.type
== BT_DERIVED
2256 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2261 /* Fall through to error */
2264 gfc_error ("Expected VARIABLE at %C");
2268 /* Special case for derived type variables that get their types
2269 via an IMPLICIT statement. This can't wait for the
2270 resolution phase. */
2273 gfc_namespace
* implicit_ns
;
2275 if (gfc_current_ns
->proc_name
== sym
)
2276 implicit_ns
= gfc_current_ns
;
2278 implicit_ns
= sym
->ns
;
2280 if (gfc_peek_char () == '%'
2281 && sym
->ts
.type
== BT_UNKNOWN
2282 && gfc_get_default_type (sym
, implicit_ns
)->type
== BT_DERIVED
)
2283 gfc_set_default_type (sym
, 0, implicit_ns
);
2286 expr
= gfc_get_expr ();
2288 expr
->expr_type
= EXPR_VARIABLE
;
2291 expr
->where
= where
;
2293 /* Now see if we have to do more. */
2294 m
= match_varspec (expr
, equiv_flag
);
2297 gfc_free_expr (expr
);
2306 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2308 return match_variable (result
, equiv_flag
, 1);
2312 gfc_match_equiv_variable (gfc_expr
** result
)
2314 return match_variable (result
, 1, 0);