]>
git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/primary.c
1 /* Primary expression subroutines
2 Copyright (C) 2000, 2001, 2002 Free Software Foundation, Inc.
3 Contributed by Andy Vaught
5 This file is part of GNU G95.
7 GNU G95 is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU G95 is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU G95; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
34 /* Matches a kind-parameter expression, which is either a named
35 symbolic constant or a nonnegative integer constant. If
36 successful, sets the kind value to the correct integer. */
39 match_kind_param (int *kind
)
41 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
46 m
= gfc_match_small_literal_int (kind
);
50 m
= gfc_match_name (name
);
54 if (gfc_find_symbol (name
, NULL
, 1, &sym
))
60 if (sym
->attr
.flavor
!= FL_PARAMETER
)
63 p
= gfc_extract_int (sym
->value
, kind
);
74 /* Get a trailing kind-specification for non-character variables.
76 the integer kind value or:
77 -1 if an error was generated
78 -2 if no kind was found */
86 if (gfc_match_char ('_') != MATCH_YES
)
89 m
= match_kind_param (&kind
);
91 gfc_error ("Missing kind-parameter at %C");
93 return (m
== MATCH_YES
) ? kind
: -1;
97 /* Given a character and a radix, see if the character is a valid
98 digit in that radix. */
101 check_digit (int c
, int radix
)
108 r
= ('0' <= c
&& c
<= '1');
112 r
= ('0' <= c
&& c
<= '7');
116 r
= ('0' <= c
&& c
<= '9');
120 r
= ('0' <= c
&& c
<= '9') || ('a' <= c
&& c
<= 'f');
124 gfc_internal_error ("check_digit(): bad radix");
131 /* Match the digit string part of an integer if signflag is not set,
132 the signed digit string part if signflag is set. If the buffer
133 is NULL, we just count characters for the resolution pass. Returns
134 the number of characters matched, -1 for no match. */
137 match_digits (int signflag
, int radix
, char *buffer
)
143 c
= gfc_next_char ();
145 if (signflag
&& (c
== '+' || c
== '-'))
149 c
= gfc_next_char ();
153 if (!check_digit (c
, radix
))
162 old_loc
= *gfc_current_locus ();
163 c
= gfc_next_char ();
165 if (!check_digit (c
, radix
))
173 gfc_set_locus (&old_loc
);
179 /* Match an integer (digit string and optional kind).
180 A sign will be accepted if signflag is set. */
183 match_integer_constant (gfc_expr
** result
, int signflag
)
190 old_loc
= *gfc_current_locus ();
191 gfc_gobble_whitespace ();
193 length
= match_digits (signflag
, 10, NULL
);
194 gfc_set_locus (&old_loc
);
198 buffer
= alloca (length
+ 1);
199 memset (buffer
, '\0', length
+ 1);
201 gfc_gobble_whitespace ();
203 match_digits (signflag
, 10, buffer
);
207 kind
= gfc_default_integer_kind ();
211 if (gfc_validate_kind (BT_INTEGER
, kind
) == -1)
213 gfc_error ("Integer kind %d at %C not available", kind
);
217 e
= gfc_convert_integer (buffer
, kind
, 10, gfc_current_locus ());
219 if (gfc_range_check (e
) != ARITH_OK
)
221 gfc_error ("Integer too big for its kind at %C");
232 /* Match a binary, octal or hexadecimal constant that can be found in
236 match_boz_constant (gfc_expr
** result
)
238 int radix
, delim
, length
;
244 old_loc
= *gfc_current_locus ();
245 gfc_gobble_whitespace ();
247 switch (gfc_next_char ())
259 && (gfc_notify_std (GFC_STD_GNU
, "Extension: Hexadecimal "
260 "constant at %C uses non-standard syntax.")
267 rname
= "hexadecimal";
273 /* No whitespace allowed here. */
275 delim
= gfc_next_char ();
276 if (delim
!= '\'' && delim
!= '\"')
279 old_loc
= *gfc_current_locus ();
281 length
= match_digits (0, radix
, NULL
);
284 gfc_error ("Empty set of digits in %s constants at %C", rname
);
288 if (gfc_next_char () != delim
)
290 gfc_error ("Illegal character in %s constant at %C.", rname
);
294 gfc_set_locus (&old_loc
);
296 buffer
= alloca (length
+ 1);
297 memset (buffer
, '\0', length
+ 1);
299 match_digits (0, radix
, buffer
);
302 e
= gfc_convert_integer (buffer
, gfc_default_integer_kind (), radix
,
303 gfc_current_locus ());
305 if (gfc_range_check (e
) != ARITH_OK
)
307 gfc_error ("Integer too big for default integer kind at %C");
317 gfc_set_locus (&old_loc
);
322 /* Match a real constant of some sort. */
325 match_real_constant (gfc_expr
** result
, int signflag
)
327 int kind
, c
, count
, seen_dp
, seen_digits
, exp_char
;
328 locus old_loc
, temp_loc
;
332 old_loc
= *gfc_current_locus ();
333 gfc_gobble_whitespace ();
342 c
= gfc_next_char ();
343 if (signflag
&& (c
== '+' || c
== '-'))
345 c
= gfc_next_char ();
349 /* Scan significand. */
350 for (;; c
= gfc_next_char (), count
++)
357 /* Check to see if "." goes with a following operator like ".eq.". */
358 temp_loc
= *gfc_current_locus ();
359 c
= gfc_next_char ();
361 if (c
== 'e' || c
== 'd' || c
== 'q')
363 c
= gfc_next_char ();
365 goto done
; /* Operator named .e. or .d. */
369 goto done
; /* Distinguish 1.e9 from 1.eq.2 */
371 gfc_set_locus (&temp_loc
);
385 if (!seen_digits
|| (c
!= 'e' && c
!= 'd' && c
!= 'q'))
390 c
= gfc_next_char ();
393 if (c
== '+' || c
== '-')
394 { /* optional sign */
395 c
= gfc_next_char ();
401 /* TODO: seen_digits is always true at this point */
404 gfc_set_locus (&old_loc
);
405 return MATCH_NO
; /* ".e" can be something else */
408 gfc_error ("Missing exponent in real number at %C");
414 c
= gfc_next_char ();
419 /* See what we've got! */
420 if (!seen_digits
|| (!seen_dp
&& exp_char
== ' '))
422 gfc_set_locus (&old_loc
);
426 /* Convert the number. */
427 gfc_set_locus (&old_loc
);
428 gfc_gobble_whitespace ();
430 buffer
= alloca (count
+ 1);
431 memset (buffer
, '\0', count
+ 1);
433 /* Hack for mpf_init_set_str(). */
437 *p
= gfc_next_char ();
438 if (*p
== 'd' || *p
== 'q')
454 ("Real number at %C has a 'd' exponent and an explicit kind");
457 kind
= gfc_default_double_kind ();
464 ("Real number at %C has a 'q' exponent and an explicit kind");
467 kind
= gfc_option
.q_kind
;
472 kind
= gfc_default_real_kind ();
474 if (gfc_validate_kind (BT_REAL
, kind
) == -1)
476 gfc_error ("Invalid real kind %d at %C", kind
);
481 e
= gfc_convert_real (buffer
, kind
, gfc_current_locus ());
483 switch (gfc_range_check (e
))
488 gfc_error ("Real constant overflows its kind at %C");
491 case ARITH_UNDERFLOW
:
492 gfc_error ("Real constant underflows its kind at %C");
496 gfc_internal_error ("gfc_range_check() returned bad value");
508 /* Match a substring reference. */
511 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
513 gfc_expr
*start
, *end
;
521 old_loc
= *gfc_current_locus ();
523 m
= gfc_match_char ('(');
527 if (gfc_match_char (':') != MATCH_YES
)
530 m
= gfc_match_init_expr (&start
);
532 m
= gfc_match_expr (&start
);
540 m
= gfc_match_char (':');
545 if (gfc_match_char (')') != MATCH_YES
)
548 m
= gfc_match_init_expr (&end
);
550 m
= gfc_match_expr (&end
);
554 if (m
== MATCH_ERROR
)
557 m
= gfc_match_char (')');
562 /* Optimize away the (:) reference. */
563 if (start
== NULL
&& end
== NULL
)
567 ref
= gfc_get_ref ();
569 ref
->type
= REF_SUBSTRING
;
571 start
= gfc_int_expr (1);
572 ref
->u
.ss
.start
= start
;
573 if (end
== NULL
&& cl
)
574 end
= gfc_copy_expr (cl
->length
);
576 ref
->u
.ss
.length
= cl
;
583 gfc_error ("Syntax error in SUBSTRING specification at %C");
587 gfc_free_expr (start
);
590 gfc_set_locus (&old_loc
);
595 /* Reads the next character of a string constant, taking care to
596 return doubled delimiters on the input as a single instance of
599 Special return values are:
600 -1 End of the string, as determined by the delimiter
601 -2 Unterminated string detected
603 Backslash codes are also expanded at this time. */
606 next_string_char (char delimiter
)
611 c
= gfc_next_char_literal (1);
618 old_locus
= *gfc_current_locus ();
620 switch (gfc_next_char_literal (1))
648 /* Unknown backslash codes are simply not expanded */
649 gfc_set_locus (&old_locus
);
657 old_locus
= *gfc_current_locus ();
658 c
= gfc_next_char_literal (1);
662 gfc_set_locus (&old_locus
);
668 /* Special case of gfc_match_name() that matches a parameter kind name
669 before a string constant. This takes case of the weird but legal
670 case of: weird case of:
674 where kind____ is a parameter. gfc_match_name() will happily slurp
675 up all the underscores, which leads to problems. If we return
676 MATCH_YES, the parse pointer points to the final underscore, which
677 is not part of the name. We never return MATCH_ERROR-- errors in
678 the name will be detected later. */
681 match_charkind_name (char *name
)
687 gfc_gobble_whitespace ();
688 c
= gfc_next_char ();
697 old_loc
= *gfc_current_locus ();
698 c
= gfc_next_char ();
702 peek
= gfc_peek_char ();
704 if (peek
== '\'' || peek
== '\"')
706 gfc_set_locus (&old_loc
);
714 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
718 if (++len
> GFC_MAX_SYMBOL_LEN
)
726 /* See if the current input matches a character constant. Lots of
727 contortions have to be done to match the kind parameter which comes
728 before the actual string. The main consideration is that we don't
729 want to error out too quickly. For example, we don't actually do
730 any validation of the kinds until we have actually seen a legal
731 delimiter. Using match_kind_param() generates errors too quickly. */
734 match_string_constant (gfc_expr
** result
)
736 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
737 int i
, c
, kind
, length
, delimiter
;
738 locus old_locus
, start_locus
;
744 old_locus
= *gfc_current_locus ();
746 gfc_gobble_whitespace ();
748 start_locus
= *gfc_current_locus ();
750 c
= gfc_next_char ();
751 if (c
== '\'' || c
== '"')
753 kind
= gfc_default_character_kind ();
763 kind
= kind
* 10 + c
- '0';
766 c
= gfc_next_char ();
772 gfc_set_locus (&old_locus
);
774 m
= match_charkind_name (name
);
778 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
780 || sym
->attr
.flavor
!= FL_PARAMETER
)
784 c
= gfc_next_char ();
789 gfc_gobble_whitespace ();
790 c
= gfc_next_char ();
796 gfc_gobble_whitespace ();
797 start_locus
= *gfc_current_locus ();
799 c
= gfc_next_char ();
800 if (c
!= '\'' && c
!= '"')
805 q
= gfc_extract_int (sym
->value
, &kind
);
813 if (gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
815 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
820 /* Scan the string into a block of memory by first figuring out how
821 long it is, allocating the structure, then re-reading it. This
822 isn't particularly efficient, but string constants aren't that
823 common in most code. TODO: Use obstacks? */
830 c
= next_string_char (delimiter
);
835 gfc_set_locus (&start_locus
);
836 gfc_error ("Unterminated character constant beginning at %C");
845 e
->expr_type
= EXPR_CONSTANT
;
847 e
->ts
.type
= BT_CHARACTER
;
849 e
->where
= start_locus
;
851 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
852 e
->value
.character
.length
= length
;
854 gfc_set_locus (&start_locus
);
855 gfc_next_char (); /* Skip delimiter */
857 for (i
= 0; i
< length
; i
++)
858 *p
++ = next_string_char (delimiter
);
860 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
862 if (next_string_char (delimiter
) != -1)
863 gfc_internal_error ("match_string_constant(): Delimiter not found");
865 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
866 e
->expr_type
= EXPR_SUBSTRING
;
873 gfc_set_locus (&old_locus
);
878 /* Match a .true. or .false. */
881 match_logical_constant (gfc_expr
** result
)
883 static mstring logical_ops
[] = {
884 minit (".false.", 0),
892 i
= gfc_match_strings (logical_ops
);
900 kind
= gfc_default_logical_kind ();
902 if (gfc_validate_kind (BT_LOGICAL
, kind
) == -1)
903 gfc_error ("Bad kind for logical constant at %C");
907 e
->expr_type
= EXPR_CONSTANT
;
908 e
->value
.logical
= i
;
909 e
->ts
.type
= BT_LOGICAL
;
911 e
->where
= *gfc_current_locus ();
918 /* Match a real or imaginary part of a complex constant that is a
919 symbolic constant. */
922 match_sym_complex_part (gfc_expr
** result
)
924 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
929 m
= gfc_match_name (name
);
933 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
936 if (sym
->attr
.flavor
!= FL_PARAMETER
)
938 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
942 if (!gfc_numeric_ts (&sym
->value
->ts
))
944 gfc_error ("Numeric PARAMETER required in complex constant at %C");
948 if (sym
->value
->rank
!= 0)
950 gfc_error ("Scalar PARAMETER required in complex constant at %C");
954 switch (sym
->value
->ts
.type
)
957 e
= gfc_copy_expr (sym
->value
);
961 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
967 e
= gfc_int2real (sym
->value
, gfc_default_real_kind ());
973 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
976 *result
= e
; /* e is a scalar, real, constant expression */
980 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
985 /* Match the real and imaginary parts of a complex number. This
986 subroutine is essentially match_real_constant() modified in a
987 couple of ways: A sign is always allowed and numbers that would
988 look like an integer to match_real_constant() are automatically
989 created as floating point numbers. The messiness involved with
990 making sure a decimal point belongs to the number and not a
991 trailing operator is not necessary here either (Hooray!). */
994 match_const_complex_part (gfc_expr
** result
)
996 int kind
, seen_digits
, seen_dp
, count
;
997 char *p
, c
, exp_char
, *buffer
;
1000 old_loc
= *gfc_current_locus ();
1001 gfc_gobble_whitespace ();
1008 c
= gfc_next_char ();
1009 if (c
== '-' || c
== '+')
1011 c
= gfc_next_char ();
1015 for (;; c
= gfc_next_char (), count
++)
1034 if (!seen_digits
|| (c
!= 'd' && c
!= 'e'))
1038 /* Scan exponent. */
1039 c
= gfc_next_char ();
1042 if (c
== '+' || c
== '-')
1043 { /* optional sign */
1044 c
= gfc_next_char ();
1050 gfc_error ("Missing exponent in real number at %C");
1056 c
= gfc_next_char ();
1064 /* Convert the number. */
1065 gfc_set_locus (&old_loc
);
1066 gfc_gobble_whitespace ();
1068 buffer
= alloca (count
+ 1);
1069 memset (buffer
, '\0', count
+ 1);
1071 /* Hack for mpf_init_set_str(). */
1075 c
= gfc_next_char ();
1088 /* If the number looked like an integer, forget about a kind we may
1089 have seen, otherwise validate the kind against real kinds. */
1090 if (seen_dp
== 0 && exp_char
== ' ')
1093 kind
= gfc_default_integer_kind ();
1098 if (exp_char
== 'd')
1103 ("Real number at %C has a 'd' exponent and an explicit kind");
1106 kind
= gfc_default_double_kind ();
1112 kind
= gfc_default_real_kind ();
1115 if (gfc_validate_kind (BT_REAL
, kind
) == -1)
1117 gfc_error ("Invalid real kind %d at %C", kind
);
1122 *result
= gfc_convert_real (buffer
, kind
, gfc_current_locus ());
1126 gfc_set_locus (&old_loc
);
1131 /* Match a real or imaginary part of a complex number. */
1134 match_complex_part (gfc_expr
** result
)
1138 m
= match_sym_complex_part (result
);
1142 return match_const_complex_part (result
);
1146 /* Try to match a complex constant. */
1149 match_complex_constant (gfc_expr
** result
)
1151 gfc_expr
*e
, *real
, *imag
;
1152 gfc_error_buf old_error
;
1153 gfc_typespec target
;
1158 old_loc
= *gfc_current_locus ();
1159 real
= imag
= e
= NULL
;
1161 m
= gfc_match_char ('(');
1165 gfc_push_error (&old_error
);
1167 m
= match_complex_part (&real
);
1171 if (gfc_match_char (',') == MATCH_NO
)
1173 gfc_pop_error (&old_error
);
1178 /* If m is error, then something was wrong with the real part and we
1179 assume we have a complex constant because we've seen the ','. An
1180 ambiguous case here is the start of an iterator list of some
1181 sort. These sort of lists are matched prior to coming here. */
1183 if (m
== MATCH_ERROR
)
1185 gfc_pop_error (&old_error
);
1187 m
= match_complex_part (&imag
);
1190 if (m
== MATCH_ERROR
)
1193 m
= gfc_match_char (')');
1197 if (m
== MATCH_ERROR
)
1200 /* Decide on the kind of this complex number. */
1201 kind
= gfc_kind_max (real
, imag
);
1202 target
.type
= BT_REAL
;
1205 if (kind
!= real
->ts
.kind
)
1206 gfc_convert_type (real
, &target
, 2);
1207 if (kind
!= imag
->ts
.kind
)
1208 gfc_convert_type (imag
, &target
, 2);
1210 e
= gfc_convert_complex (real
, imag
, kind
);
1211 e
->where
= *gfc_current_locus ();
1213 gfc_free_expr (real
);
1214 gfc_free_expr (imag
);
1220 gfc_error ("Syntax error in COMPLEX constant at %C");
1225 gfc_free_expr (real
);
1226 gfc_free_expr (imag
);
1227 gfc_set_locus (&old_loc
);
1233 /* Match constants in any of several forms. Returns nonzero for a
1234 match, zero for no match. */
1237 gfc_match_literal_constant (gfc_expr
** result
, int signflag
)
1241 m
= match_complex_constant (result
);
1245 m
= match_string_constant (result
);
1249 m
= match_boz_constant (result
);
1253 m
= match_real_constant (result
, signflag
);
1257 m
= match_integer_constant (result
, signflag
);
1261 m
= match_logical_constant (result
);
1269 /* Match a single actual argument value. An actual argument is
1270 usually an expression, but can also be a procedure name. If the
1271 argument is a single name, it is not always possible to tell
1272 whether the name is a dummy procedure or not. We treat these cases
1273 by creating an argument that looks like a dummy procedure and
1274 fixing things later during resolution. */
1277 match_actual_arg (gfc_expr
** result
)
1279 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1280 gfc_symtree
*symtree
;
1285 where
= *gfc_current_locus ();
1287 switch (gfc_match_name (name
))
1296 w
= *gfc_current_locus ();
1297 gfc_gobble_whitespace ();
1298 c
= gfc_next_char ();
1301 if (c
!= ',' && c
!= ')')
1304 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1306 /* Handle error elsewhere. */
1308 /* Eliminate a couple of common cases where we know we don't
1309 have a function argument. */
1310 if (symtree
== NULL
)
1312 gfc_get_sym_tree (name
, NULL
, &symtree
);
1313 gfc_set_sym_referenced (symtree
->n
.sym
);
1319 sym
= symtree
->n
.sym
;
1320 gfc_set_sym_referenced (sym
);
1321 if (sym
->attr
.flavor
!= FL_PROCEDURE
1322 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1325 /* If the symbol is a function with itself as the result and
1326 is being defined, then we have a variable. */
1327 if (sym
->result
== sym
1328 && (gfc_current_ns
->proc_name
== sym
1329 || (gfc_current_ns
->parent
!= NULL
1330 && gfc_current_ns
->parent
->proc_name
== sym
)))
1334 e
= gfc_get_expr (); /* Leave it unknown for now */
1335 e
->symtree
= symtree
;
1336 e
->expr_type
= EXPR_VARIABLE
;
1337 e
->ts
.type
= BT_PROCEDURE
;
1344 gfc_set_locus (&where
);
1345 return gfc_match_expr (result
);
1349 /* Match a keyword argument. */
1352 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1354 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1355 gfc_actual_arglist
*a
;
1359 name_locus
= *gfc_current_locus ();
1360 m
= gfc_match_name (name
);
1364 if (gfc_match_char ('=') != MATCH_YES
)
1370 m
= match_actual_arg (&actual
->expr
);
1374 /* Make sure this name has not appeared yet. */
1376 if (name
[0] != '\0')
1378 for (a
= base
; a
; a
= a
->next
)
1379 if (strcmp (a
->name
, name
) == 0)
1382 ("Keyword '%s' at %C has already appeared in the current "
1383 "argument list", name
);
1388 strcpy (actual
->name
, name
);
1392 gfc_set_locus (&name_locus
);
1397 /* Matches an actual argument list of a function or subroutine, from
1398 the opening parenthesis to the closing parenthesis. The argument
1399 list is assumed to allow keyword arguments because we don't know if
1400 the symbol associated with the procedure has an implicit interface
1401 or not. We make sure keywords are unique. */
1404 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1406 gfc_actual_arglist
*head
, *tail
;
1408 gfc_st_label
*label
;
1412 *argp
= tail
= NULL
;
1413 old_loc
= *gfc_current_locus ();
1417 if (gfc_match_char ('(') == MATCH_NO
)
1418 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1420 if (gfc_match_char (')') == MATCH_YES
)
1427 head
= tail
= gfc_get_actual_arglist ();
1430 tail
->next
= gfc_get_actual_arglist ();
1434 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1436 m
= gfc_match_st_label (&label
, 0);
1438 gfc_error ("Expected alternate return label at %C");
1442 tail
->label
= label
;
1446 /* After the first keyword argument is seen, the following
1447 arguments must also have keywords. */
1450 m
= match_keyword_arg (tail
, head
);
1452 if (m
== MATCH_ERROR
)
1457 ("Missing keyword name in actual argument list at %C");
1464 /* See if we have the first keyword argument. */
1465 m
= match_keyword_arg (tail
, head
);
1468 if (m
== MATCH_ERROR
)
1473 /* Try for a non-keyword argument. */
1474 m
= match_actual_arg (&tail
->expr
);
1475 if (m
== MATCH_ERROR
)
1483 if (gfc_match_char (')') == MATCH_YES
)
1485 if (gfc_match_char (',') != MATCH_YES
)
1493 gfc_error ("Syntax error in argument list at %C");
1496 gfc_free_actual_arglist (head
);
1497 gfc_set_locus (&old_loc
);
1503 /* Used by match_varspec() to extend the reference list by one
1507 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1510 if (primary
->ref
== NULL
)
1511 primary
->ref
= tail
= gfc_get_ref ();
1515 gfc_internal_error ("extend_ref(): Bad tail");
1516 tail
->next
= gfc_get_ref ();
1524 /* Match any additional specifications associated with the current
1525 variable like member references or substrings. If equiv_flag is
1526 set we only match stuff that is allowed inside an EQUIVALENCE
1530 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1532 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1533 gfc_ref
*substring
, *tail
;
1534 gfc_component
*component
;
1540 if (primary
->symtree
->n
.sym
->attr
.dimension
1542 && gfc_peek_char () == '('))
1545 tail
= extend_ref (primary
, tail
);
1546 tail
->type
= REF_ARRAY
;
1548 m
= gfc_match_array_ref (&tail
->u
.ar
, primary
->symtree
->n
.sym
->as
,
1554 sym
= primary
->symtree
->n
.sym
;
1555 primary
->ts
= sym
->ts
;
1557 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1558 goto check_substring
;
1560 sym
= sym
->ts
.derived
;
1564 m
= gfc_match_name (name
);
1566 gfc_error ("Expected structure component name at %C");
1570 component
= gfc_find_component (sym
, name
);
1571 if (component
== NULL
)
1574 tail
= extend_ref (primary
, tail
);
1575 tail
->type
= REF_COMPONENT
;
1577 tail
->u
.c
.component
= component
;
1578 tail
->u
.c
.sym
= sym
;
1580 primary
->ts
= component
->ts
;
1582 if (component
->as
!= NULL
)
1584 tail
= extend_ref (primary
, tail
);
1585 tail
->type
= REF_ARRAY
;
1587 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1592 if (component
->ts
.type
!= BT_DERIVED
1593 || gfc_match_char ('%') != MATCH_YES
)
1596 sym
= component
->ts
.derived
;
1600 if (primary
->ts
.type
== BT_CHARACTER
)
1602 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1606 primary
->ref
= substring
;
1608 tail
->next
= substring
;
1610 if (primary
->expr_type
== EXPR_CONSTANT
)
1611 primary
->expr_type
= EXPR_SUBSTRING
;
1627 /* Given an expression that is a variable, figure out what the
1628 ultimate variable's type and attribute is, traversing the reference
1629 structures if necessary.
1631 This subroutine is trickier than it looks. We start at the base
1632 symbol and store the attribute. Component references load a
1633 completely new attribute.
1635 A couple of rules come into play. Subobjects of targets are always
1636 targets themselves. If we see a component that goes through a
1637 pointer, then the expression must also be a target, since the
1638 pointer is associated with something (if it isn't core will soon be
1639 dumped). If we see a full part or section of an array, the
1640 expression is also an array.
1642 We can have at most one full array reference. */
1645 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1647 int dimension
, pointer
, target
;
1648 symbol_attribute attr
;
1651 if (expr
->expr_type
!= EXPR_VARIABLE
)
1652 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1655 attr
= expr
->symtree
->n
.sym
->attr
;
1657 dimension
= attr
.dimension
;
1658 pointer
= attr
.pointer
;
1660 target
= attr
.target
;
1664 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1665 *ts
= expr
->symtree
->n
.sym
->ts
;
1667 for (; ref
; ref
= ref
->next
)
1672 switch (ref
->u
.ar
.type
)
1688 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1694 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1696 *ts
= ref
->u
.c
.component
->ts
;
1698 pointer
= ref
->u
.c
.component
->pointer
;
1709 attr
.dimension
= dimension
;
1710 attr
.pointer
= pointer
;
1711 attr
.target
= target
;
1717 /* Return the attribute from a general expression. */
1720 gfc_expr_attr (gfc_expr
* e
)
1722 symbol_attribute attr
;
1724 switch (e
->expr_type
)
1727 attr
= gfc_variable_attr (e
, NULL
);
1731 gfc_clear_attr (&attr
);
1733 if (e
->value
.function
.esym
!= NULL
)
1734 attr
= e
->value
.function
.esym
->result
->attr
;
1736 /* TODO: NULL() returns pointers. May have to take care of this
1742 gfc_clear_attr (&attr
);
1750 /* Match a structure constructor. The initial symbol has already been
1754 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1756 gfc_constructor
*head
, *tail
;
1757 gfc_component
*comp
;
1764 if (gfc_match_char ('(') != MATCH_YES
)
1767 where
= *gfc_current_locus ();
1769 gfc_find_component (sym
, NULL
);
1771 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1774 tail
= head
= gfc_get_constructor ();
1777 tail
->next
= gfc_get_constructor ();
1781 m
= gfc_match_expr (&tail
->expr
);
1784 if (m
== MATCH_ERROR
)
1787 if (gfc_match_char (',') == MATCH_YES
)
1789 if (comp
->next
== NULL
)
1792 ("Too many components in structure constructor at %C");
1802 if (gfc_match_char (')') != MATCH_YES
)
1805 if (comp
->next
!= NULL
)
1807 gfc_error ("Too few components in structure constructor at %C");
1811 e
= gfc_get_expr ();
1813 e
->expr_type
= EXPR_STRUCTURE
;
1815 e
->ts
.type
= BT_DERIVED
;
1816 e
->ts
.derived
= sym
;
1819 e
->value
.constructor
= head
;
1825 gfc_error ("Syntax error in structure constructor at %C");
1828 gfc_free_constructor (head
);
1833 /* Matches a variable name followed by anything that might follow it--
1834 array reference, argument list of a function, etc. */
1837 gfc_match_rvalue (gfc_expr
** result
)
1839 gfc_actual_arglist
*actual_arglist
;
1840 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1843 gfc_symtree
*symtree
;
1849 m
= gfc_match_name (name
);
1853 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1854 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1856 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1861 sym
= symtree
->n
.sym
;
1863 where
= *gfc_current_locus ();
1865 gfc_set_sym_referenced (sym
);
1867 if (sym
->attr
.function
&& sym
->result
== sym
1868 && (gfc_current_ns
->proc_name
== sym
1869 || (gfc_current_ns
->parent
!= NULL
1870 && gfc_current_ns
->parent
->proc_name
== sym
)))
1873 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1876 if (sym
->attr
.generic
)
1877 goto generic_function
;
1879 switch (sym
->attr
.flavor
)
1883 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1884 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1885 gfc_set_default_type (sym
, 0, sym
->ns
);
1887 e
= gfc_get_expr ();
1889 e
->expr_type
= EXPR_VARIABLE
;
1890 e
->symtree
= symtree
;
1892 m
= match_varspec (e
, 0);
1897 && sym
->value
->expr_type
!= EXPR_ARRAY
)
1898 e
= gfc_copy_expr (sym
->value
);
1901 e
= gfc_get_expr ();
1902 e
->expr_type
= EXPR_VARIABLE
;
1905 e
->symtree
= symtree
;
1906 m
= match_varspec (e
, 0);
1910 sym
= gfc_use_derived (sym
);
1914 m
= gfc_match_structure_constructor (sym
, &e
);
1917 /* If we're here, then the name is known to be the name of a
1918 procedure, yet it is not sure to be the name of a function. */
1920 if (sym
->attr
.subroutine
)
1922 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1928 /* At this point, the name has to be a non-statement function.
1929 If the name is the same as the current function being
1930 compiled, then we have a variable reference (to the function
1931 result) if the name is non-recursive. */
1933 st
= gfc_enclosing_unit (NULL
);
1935 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
1937 && !sym
->attr
.recursive
)
1939 e
= gfc_get_expr ();
1940 e
->symtree
= symtree
;
1941 e
->expr_type
= EXPR_VARIABLE
;
1943 m
= match_varspec (e
, 0);
1947 /* Match a function reference. */
1949 m
= gfc_match_actual_arglist (0, &actual_arglist
);
1952 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1953 gfc_error ("Statement function '%s' requires argument list at %C",
1956 gfc_error ("Function '%s' requires an argument list at %C",
1969 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
1970 sym
= symtree
->n
.sym
;
1972 e
= gfc_get_expr ();
1973 e
->symtree
= symtree
;
1974 e
->expr_type
= EXPR_FUNCTION
;
1975 e
->value
.function
.actual
= actual_arglist
;
1976 e
->where
= *gfc_current_locus ();
1978 if (sym
->as
!= NULL
)
1979 e
->rank
= sym
->as
->rank
;
1981 if (!sym
->attr
.function
1982 && gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
1988 if (sym
->result
== NULL
)
1996 /* Special case for derived type variables that get their types
1997 via an IMPLICIT statement. This can't wait for the
1998 resolution phase. */
2000 if (gfc_peek_char () == '%'
2001 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2002 gfc_set_default_type (sym
, 0, sym
->ns
);
2004 /* If the symbol has a dimension attribute, the expression is a
2007 if (sym
->attr
.dimension
)
2009 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2015 e
= gfc_get_expr ();
2016 e
->symtree
= symtree
;
2017 e
->expr_type
= EXPR_VARIABLE
;
2018 m
= match_varspec (e
, 0);
2022 /* Name is not an array, so we peek to see if a '(' implies a
2023 function call or a substring reference. Otherwise the
2024 variable is just a scalar. */
2026 gfc_gobble_whitespace ();
2027 if (gfc_peek_char () != '(')
2029 /* Assume a scalar variable */
2030 e
= gfc_get_expr ();
2031 e
->symtree
= symtree
;
2032 e
->expr_type
= EXPR_VARIABLE
;
2034 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2041 m
= match_varspec (e
, 0);
2045 /* See if this could possibly be a substring reference of a name
2046 that we're not sure is a variable yet. */
2048 e
= gfc_get_expr ();
2049 e
->symtree
= symtree
;
2051 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
2052 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2055 e
->expr_type
= EXPR_VARIABLE
;
2057 if (sym
->attr
.flavor
!= FL_VARIABLE
2058 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2064 if (sym
->ts
.type
== BT_UNKNOWN
2065 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2076 /* Give up, assume we have a function. */
2078 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2079 sym
= symtree
->n
.sym
;
2080 e
->expr_type
= EXPR_FUNCTION
;
2082 if (!sym
->attr
.function
2083 && gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
2091 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2093 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2101 /* If our new function returns a character, array or structure
2102 type, it might have subsequent references. */
2104 m
= match_varspec (e
, 0);
2111 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2113 e
= gfc_get_expr ();
2114 e
->symtree
= symtree
;
2115 e
->expr_type
= EXPR_FUNCTION
;
2117 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2121 gfc_error ("Symbol at %C is not appropriate for an expression");
2137 /* Match a variable, ie something that can be assigned to. This
2138 starts as a symbol, can be a structure component or an array
2139 reference. It can be a function if the function doesn't have a
2140 separate RESULT variable. If the symbol has not been previously
2141 seen, we assume it is a variable. */
2144 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2152 m
= gfc_match_sym_tree (&st
, 1);
2155 where
= *gfc_current_locus ();
2158 gfc_set_sym_referenced (sym
);
2159 switch (sym
->attr
.flavor
)
2165 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2168 /* Special case for derived type variables that get their types
2169 via an IMPLICIT statement. This can't wait for the
2170 resolution phase. */
2172 if (gfc_peek_char () == '%'
2173 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2174 gfc_set_default_type (sym
, 0, sym
->ns
);
2179 /* Check for a nonrecursive function result */
2180 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2183 /* If a function result is a derived type, then the derived
2184 type may still have to be resolved. */
2186 if (sym
->ts
.type
== BT_DERIVED
2187 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2193 /* Fall through to error */
2196 gfc_error ("Expected VARIABLE at %C");
2200 expr
= gfc_get_expr ();
2202 expr
->expr_type
= EXPR_VARIABLE
;
2205 expr
->where
= where
;
2207 /* Now see if we have to do more. */
2208 m
= match_varspec (expr
, equiv_flag
);
2211 gfc_free_expr (expr
);