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_current_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_current_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_current_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
,
305 if (gfc_range_check (e
) != ARITH_OK
)
307 gfc_error ("Integer too big for default integer kind at %C");
317 gfc_current_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_current_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_current_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_current_locus
= old_loc
;
426 /* Convert the number. */
427 gfc_current_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 if (gfc_option
.warn_underflow
)
493 gfc_warning ("Real constant underflows its kind at %C");
494 mpf_set_ui(e
->value
.real
, 0);
498 gfc_internal_error ("gfc_range_check() returned bad value");
510 /* Match a substring reference. */
513 match_substring (gfc_charlen
* cl
, int init
, gfc_ref
** result
)
515 gfc_expr
*start
, *end
;
523 old_loc
= gfc_current_locus
;
525 m
= gfc_match_char ('(');
529 if (gfc_match_char (':') != MATCH_YES
)
532 m
= gfc_match_init_expr (&start
);
534 m
= gfc_match_expr (&start
);
542 m
= gfc_match_char (':');
547 if (gfc_match_char (')') != MATCH_YES
)
550 m
= gfc_match_init_expr (&end
);
552 m
= gfc_match_expr (&end
);
556 if (m
== MATCH_ERROR
)
559 m
= gfc_match_char (')');
564 /* Optimize away the (:) reference. */
565 if (start
== NULL
&& end
== NULL
)
569 ref
= gfc_get_ref ();
571 ref
->type
= REF_SUBSTRING
;
573 start
= gfc_int_expr (1);
574 ref
->u
.ss
.start
= start
;
575 if (end
== NULL
&& cl
)
576 end
= gfc_copy_expr (cl
->length
);
578 ref
->u
.ss
.length
= cl
;
585 gfc_error ("Syntax error in SUBSTRING specification at %C");
589 gfc_free_expr (start
);
592 gfc_current_locus
= old_loc
;
597 /* Reads the next character of a string constant, taking care to
598 return doubled delimiters on the input as a single instance of
601 Special return values are:
602 -1 End of the string, as determined by the delimiter
603 -2 Unterminated string detected
605 Backslash codes are also expanded at this time. */
608 next_string_char (char delimiter
)
613 c
= gfc_next_char_literal (1);
620 old_locus
= gfc_current_locus
;
622 switch (gfc_next_char_literal (1))
650 /* Unknown backslash codes are simply not expanded */
651 gfc_current_locus
= old_locus
;
659 old_locus
= gfc_current_locus
;
660 c
= gfc_next_char_literal (1);
664 gfc_current_locus
= old_locus
;
670 /* Special case of gfc_match_name() that matches a parameter kind name
671 before a string constant. This takes case of the weird but legal
672 case of: weird case of:
676 where kind____ is a parameter. gfc_match_name() will happily slurp
677 up all the underscores, which leads to problems. If we return
678 MATCH_YES, the parse pointer points to the final underscore, which
679 is not part of the name. We never return MATCH_ERROR-- errors in
680 the name will be detected later. */
683 match_charkind_name (char *name
)
689 gfc_gobble_whitespace ();
690 c
= gfc_next_char ();
699 old_loc
= gfc_current_locus
;
700 c
= gfc_next_char ();
704 peek
= gfc_peek_char ();
706 if (peek
== '\'' || peek
== '\"')
708 gfc_current_locus
= old_loc
;
716 && (gfc_option
.flag_dollar_ok
&& c
!= '$'))
720 if (++len
> GFC_MAX_SYMBOL_LEN
)
728 /* See if the current input matches a character constant. Lots of
729 contortions have to be done to match the kind parameter which comes
730 before the actual string. The main consideration is that we don't
731 want to error out too quickly. For example, we don't actually do
732 any validation of the kinds until we have actually seen a legal
733 delimiter. Using match_kind_param() generates errors too quickly. */
736 match_string_constant (gfc_expr
** result
)
738 char *p
, name
[GFC_MAX_SYMBOL_LEN
+ 1];
739 int i
, c
, kind
, length
, delimiter
;
740 locus old_locus
, start_locus
;
746 old_locus
= gfc_current_locus
;
748 gfc_gobble_whitespace ();
750 start_locus
= gfc_current_locus
;
752 c
= gfc_next_char ();
753 if (c
== '\'' || c
== '"')
755 kind
= gfc_default_character_kind ();
765 kind
= kind
* 10 + c
- '0';
768 c
= gfc_next_char ();
774 gfc_current_locus
= old_locus
;
776 m
= match_charkind_name (name
);
780 if (gfc_find_symbol (name
, NULL
, 1, &sym
)
782 || sym
->attr
.flavor
!= FL_PARAMETER
)
786 c
= gfc_next_char ();
791 gfc_gobble_whitespace ();
792 c
= gfc_next_char ();
798 gfc_gobble_whitespace ();
799 start_locus
= gfc_current_locus
;
801 c
= gfc_next_char ();
802 if (c
!= '\'' && c
!= '"')
807 q
= gfc_extract_int (sym
->value
, &kind
);
815 if (gfc_validate_kind (BT_CHARACTER
, kind
) == -1)
817 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind
);
822 /* Scan the string into a block of memory by first figuring out how
823 long it is, allocating the structure, then re-reading it. This
824 isn't particularly efficient, but string constants aren't that
825 common in most code. TODO: Use obstacks? */
832 c
= next_string_char (delimiter
);
837 gfc_current_locus
= start_locus
;
838 gfc_error ("Unterminated character constant beginning at %C");
847 e
->expr_type
= EXPR_CONSTANT
;
849 e
->ts
.type
= BT_CHARACTER
;
851 e
->where
= start_locus
;
853 e
->value
.character
.string
= p
= gfc_getmem (length
+ 1);
854 e
->value
.character
.length
= length
;
856 gfc_current_locus
= start_locus
;
857 gfc_next_char (); /* Skip delimiter */
859 for (i
= 0; i
< length
; i
++)
860 *p
++ = next_string_char (delimiter
);
862 *p
= '\0'; /* TODO: C-style string is for development/debug purposes. */
864 if (next_string_char (delimiter
) != -1)
865 gfc_internal_error ("match_string_constant(): Delimiter not found");
867 if (match_substring (NULL
, 0, &e
->ref
) != MATCH_NO
)
868 e
->expr_type
= EXPR_SUBSTRING
;
875 gfc_current_locus
= old_locus
;
880 /* Match a .true. or .false. */
883 match_logical_constant (gfc_expr
** result
)
885 static mstring logical_ops
[] = {
886 minit (".false.", 0),
894 i
= gfc_match_strings (logical_ops
);
902 kind
= gfc_default_logical_kind ();
904 if (gfc_validate_kind (BT_LOGICAL
, kind
) == -1)
905 gfc_error ("Bad kind for logical constant at %C");
909 e
->expr_type
= EXPR_CONSTANT
;
910 e
->value
.logical
= i
;
911 e
->ts
.type
= BT_LOGICAL
;
913 e
->where
= gfc_current_locus
;
920 /* Match a real or imaginary part of a complex constant that is a
921 symbolic constant. */
924 match_sym_complex_part (gfc_expr
** result
)
926 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
931 m
= gfc_match_name (name
);
935 if (gfc_find_symbol (name
, NULL
, 1, &sym
) || sym
== NULL
)
938 if (sym
->attr
.flavor
!= FL_PARAMETER
)
940 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
944 if (!gfc_numeric_ts (&sym
->value
->ts
))
946 gfc_error ("Numeric PARAMETER required in complex constant at %C");
950 if (sym
->value
->rank
!= 0)
952 gfc_error ("Scalar PARAMETER required in complex constant at %C");
956 switch (sym
->value
->ts
.type
)
959 e
= gfc_copy_expr (sym
->value
);
963 e
= gfc_complex2real (sym
->value
, sym
->value
->ts
.kind
);
969 e
= gfc_int2real (sym
->value
, gfc_default_real_kind ());
975 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
978 *result
= e
; /* e is a scalar, real, constant expression */
982 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
987 /* Match the real and imaginary parts of a complex number. This
988 subroutine is essentially match_real_constant() modified in a
989 couple of ways: A sign is always allowed and numbers that would
990 look like an integer to match_real_constant() are automatically
991 created as floating point numbers. The messiness involved with
992 making sure a decimal point belongs to the number and not a
993 trailing operator is not necessary here either (Hooray!). */
996 match_const_complex_part (gfc_expr
** result
)
998 int kind
, seen_digits
, seen_dp
, count
;
999 char *p
, c
, exp_char
, *buffer
;
1002 old_loc
= gfc_current_locus
;
1003 gfc_gobble_whitespace ();
1010 c
= gfc_next_char ();
1011 if (c
== '-' || c
== '+')
1013 c
= gfc_next_char ();
1017 for (;; c
= gfc_next_char (), count
++)
1036 if (!seen_digits
|| (c
!= 'd' && c
!= 'e'))
1040 /* Scan exponent. */
1041 c
= gfc_next_char ();
1044 if (c
== '+' || c
== '-')
1045 { /* optional sign */
1046 c
= gfc_next_char ();
1052 gfc_error ("Missing exponent in real number at %C");
1058 c
= gfc_next_char ();
1066 /* Convert the number. */
1067 gfc_current_locus
= old_loc
;
1068 gfc_gobble_whitespace ();
1070 buffer
= alloca (count
+ 1);
1071 memset (buffer
, '\0', count
+ 1);
1073 /* Hack for mpf_init_set_str(). */
1077 c
= gfc_next_char ();
1090 /* If the number looked like an integer, forget about a kind we may
1091 have seen, otherwise validate the kind against real kinds. */
1092 if (seen_dp
== 0 && exp_char
== ' ')
1095 kind
= gfc_default_integer_kind ();
1100 if (exp_char
== 'd')
1105 ("Real number at %C has a 'd' exponent and an explicit kind");
1108 kind
= gfc_default_double_kind ();
1114 kind
= gfc_default_real_kind ();
1117 if (gfc_validate_kind (BT_REAL
, kind
) == -1)
1119 gfc_error ("Invalid real kind %d at %C", kind
);
1124 *result
= gfc_convert_real (buffer
, kind
, &gfc_current_locus
);
1128 gfc_current_locus
= old_loc
;
1133 /* Match a real or imaginary part of a complex number. */
1136 match_complex_part (gfc_expr
** result
)
1140 m
= match_sym_complex_part (result
);
1144 return match_const_complex_part (result
);
1148 /* Try to match a complex constant. */
1151 match_complex_constant (gfc_expr
** result
)
1153 gfc_expr
*e
, *real
, *imag
;
1154 gfc_error_buf old_error
;
1155 gfc_typespec target
;
1160 old_loc
= gfc_current_locus
;
1161 real
= imag
= e
= NULL
;
1163 m
= gfc_match_char ('(');
1167 gfc_push_error (&old_error
);
1169 m
= match_complex_part (&real
);
1173 if (gfc_match_char (',') == MATCH_NO
)
1175 gfc_pop_error (&old_error
);
1180 /* If m is error, then something was wrong with the real part and we
1181 assume we have a complex constant because we've seen the ','. An
1182 ambiguous case here is the start of an iterator list of some
1183 sort. These sort of lists are matched prior to coming here. */
1185 if (m
== MATCH_ERROR
)
1187 gfc_pop_error (&old_error
);
1189 m
= match_complex_part (&imag
);
1192 if (m
== MATCH_ERROR
)
1195 m
= gfc_match_char (')');
1199 if (m
== MATCH_ERROR
)
1202 /* Decide on the kind of this complex number. */
1203 kind
= gfc_kind_max (real
, imag
);
1204 target
.type
= BT_REAL
;
1207 if (kind
!= real
->ts
.kind
)
1208 gfc_convert_type (real
, &target
, 2);
1209 if (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_integer_constant (result
, signflag
);
1263 m
= match_logical_constant (result
);
1271 /* Match a single actual argument value. An actual argument is
1272 usually an expression, but can also be a procedure name. If the
1273 argument is a single name, it is not always possible to tell
1274 whether the name is a dummy procedure or not. We treat these cases
1275 by creating an argument that looks like a dummy procedure and
1276 fixing things later during resolution. */
1279 match_actual_arg (gfc_expr
** result
)
1281 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1282 gfc_symtree
*symtree
;
1287 where
= gfc_current_locus
;
1289 switch (gfc_match_name (name
))
1298 w
= gfc_current_locus
;
1299 gfc_gobble_whitespace ();
1300 c
= gfc_next_char ();
1301 gfc_current_locus
= w
;
1303 if (c
!= ',' && c
!= ')')
1306 if (gfc_find_sym_tree (name
, NULL
, 1, &symtree
))
1308 /* Handle error elsewhere. */
1310 /* Eliminate a couple of common cases where we know we don't
1311 have a function argument. */
1312 if (symtree
== NULL
)
1314 gfc_get_sym_tree (name
, NULL
, &symtree
);
1315 gfc_set_sym_referenced (symtree
->n
.sym
);
1321 sym
= symtree
->n
.sym
;
1322 gfc_set_sym_referenced (sym
);
1323 if (sym
->attr
.flavor
!= FL_PROCEDURE
1324 && sym
->attr
.flavor
!= FL_UNKNOWN
)
1327 /* If the symbol is a function with itself as the result and
1328 is being defined, then we have a variable. */
1329 if (sym
->result
== sym
1330 && (gfc_current_ns
->proc_name
== sym
1331 || (gfc_current_ns
->parent
!= NULL
1332 && gfc_current_ns
->parent
->proc_name
== sym
)))
1336 e
= gfc_get_expr (); /* Leave it unknown for now */
1337 e
->symtree
= symtree
;
1338 e
->expr_type
= EXPR_VARIABLE
;
1339 e
->ts
.type
= BT_PROCEDURE
;
1346 gfc_current_locus
= where
;
1347 return gfc_match_expr (result
);
1351 /* Match a keyword argument. */
1354 match_keyword_arg (gfc_actual_arglist
* actual
, gfc_actual_arglist
* base
)
1356 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1357 gfc_actual_arglist
*a
;
1361 name_locus
= gfc_current_locus
;
1362 m
= gfc_match_name (name
);
1366 if (gfc_match_char ('=') != MATCH_YES
)
1372 m
= match_actual_arg (&actual
->expr
);
1376 /* Make sure this name has not appeared yet. */
1378 if (name
[0] != '\0')
1380 for (a
= base
; a
; a
= a
->next
)
1381 if (strcmp (a
->name
, name
) == 0)
1384 ("Keyword '%s' at %C has already appeared in the current "
1385 "argument list", name
);
1390 strcpy (actual
->name
, name
);
1394 gfc_current_locus
= name_locus
;
1399 /* Matches an actual argument list of a function or subroutine, from
1400 the opening parenthesis to the closing parenthesis. The argument
1401 list is assumed to allow keyword arguments because we don't know if
1402 the symbol associated with the procedure has an implicit interface
1403 or not. We make sure keywords are unique. */
1406 gfc_match_actual_arglist (int sub_flag
, gfc_actual_arglist
** argp
)
1408 gfc_actual_arglist
*head
, *tail
;
1410 gfc_st_label
*label
;
1414 *argp
= tail
= NULL
;
1415 old_loc
= gfc_current_locus
;
1419 if (gfc_match_char ('(') == MATCH_NO
)
1420 return (sub_flag
) ? MATCH_YES
: MATCH_NO
;
1422 if (gfc_match_char (')') == MATCH_YES
)
1429 head
= tail
= gfc_get_actual_arglist ();
1432 tail
->next
= gfc_get_actual_arglist ();
1436 if (sub_flag
&& gfc_match_char ('*') == MATCH_YES
)
1438 m
= gfc_match_st_label (&label
, 0);
1440 gfc_error ("Expected alternate return label at %C");
1444 tail
->label
= label
;
1448 /* After the first keyword argument is seen, the following
1449 arguments must also have keywords. */
1452 m
= match_keyword_arg (tail
, head
);
1454 if (m
== MATCH_ERROR
)
1459 ("Missing keyword name in actual argument list at %C");
1466 /* See if we have the first keyword argument. */
1467 m
= match_keyword_arg (tail
, head
);
1470 if (m
== MATCH_ERROR
)
1475 /* Try for a non-keyword argument. */
1476 m
= match_actual_arg (&tail
->expr
);
1477 if (m
== MATCH_ERROR
)
1485 if (gfc_match_char (')') == MATCH_YES
)
1487 if (gfc_match_char (',') != MATCH_YES
)
1495 gfc_error ("Syntax error in argument list at %C");
1498 gfc_free_actual_arglist (head
);
1499 gfc_current_locus
= old_loc
;
1505 /* Used by match_varspec() to extend the reference list by one
1509 extend_ref (gfc_expr
* primary
, gfc_ref
* tail
)
1512 if (primary
->ref
== NULL
)
1513 primary
->ref
= tail
= gfc_get_ref ();
1517 gfc_internal_error ("extend_ref(): Bad tail");
1518 tail
->next
= gfc_get_ref ();
1526 /* Match any additional specifications associated with the current
1527 variable like member references or substrings. If equiv_flag is
1528 set we only match stuff that is allowed inside an EQUIVALENCE
1532 match_varspec (gfc_expr
* primary
, int equiv_flag
)
1534 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1535 gfc_ref
*substring
, *tail
;
1536 gfc_component
*component
;
1542 if (primary
->symtree
->n
.sym
->attr
.dimension
1544 && gfc_peek_char () == '('))
1547 tail
= extend_ref (primary
, tail
);
1548 tail
->type
= REF_ARRAY
;
1550 m
= gfc_match_array_ref (&tail
->u
.ar
, primary
->symtree
->n
.sym
->as
,
1556 sym
= primary
->symtree
->n
.sym
;
1557 primary
->ts
= sym
->ts
;
1559 if (sym
->ts
.type
!= BT_DERIVED
|| gfc_match_char ('%') != MATCH_YES
)
1560 goto check_substring
;
1562 sym
= sym
->ts
.derived
;
1566 m
= gfc_match_name (name
);
1568 gfc_error ("Expected structure component name at %C");
1572 component
= gfc_find_component (sym
, name
);
1573 if (component
== NULL
)
1576 tail
= extend_ref (primary
, tail
);
1577 tail
->type
= REF_COMPONENT
;
1579 tail
->u
.c
.component
= component
;
1580 tail
->u
.c
.sym
= sym
;
1582 primary
->ts
= component
->ts
;
1584 if (component
->as
!= NULL
)
1586 tail
= extend_ref (primary
, tail
);
1587 tail
->type
= REF_ARRAY
;
1589 m
= gfc_match_array_ref (&tail
->u
.ar
, component
->as
, equiv_flag
);
1594 if (component
->ts
.type
!= BT_DERIVED
1595 || gfc_match_char ('%') != MATCH_YES
)
1598 sym
= component
->ts
.derived
;
1602 if (primary
->ts
.type
== BT_CHARACTER
)
1604 switch (match_substring (primary
->ts
.cl
, equiv_flag
, &substring
))
1608 primary
->ref
= substring
;
1610 tail
->next
= substring
;
1612 if (primary
->expr_type
== EXPR_CONSTANT
)
1613 primary
->expr_type
= EXPR_SUBSTRING
;
1629 /* Given an expression that is a variable, figure out what the
1630 ultimate variable's type and attribute is, traversing the reference
1631 structures if necessary.
1633 This subroutine is trickier than it looks. We start at the base
1634 symbol and store the attribute. Component references load a
1635 completely new attribute.
1637 A couple of rules come into play. Subobjects of targets are always
1638 targets themselves. If we see a component that goes through a
1639 pointer, then the expression must also be a target, since the
1640 pointer is associated with something (if it isn't core will soon be
1641 dumped). If we see a full part or section of an array, the
1642 expression is also an array.
1644 We can have at most one full array reference. */
1647 gfc_variable_attr (gfc_expr
* expr
, gfc_typespec
* ts
)
1649 int dimension
, pointer
, target
;
1650 symbol_attribute attr
;
1653 if (expr
->expr_type
!= EXPR_VARIABLE
)
1654 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1657 attr
= expr
->symtree
->n
.sym
->attr
;
1659 dimension
= attr
.dimension
;
1660 pointer
= attr
.pointer
;
1662 target
= attr
.target
;
1666 if (ts
!= NULL
&& expr
->ts
.type
== BT_UNKNOWN
)
1667 *ts
= expr
->symtree
->n
.sym
->ts
;
1669 for (; ref
; ref
= ref
->next
)
1674 switch (ref
->u
.ar
.type
)
1690 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1696 gfc_get_component_attr (&attr
, ref
->u
.c
.component
);
1698 *ts
= ref
->u
.c
.component
->ts
;
1700 pointer
= ref
->u
.c
.component
->pointer
;
1711 attr
.dimension
= dimension
;
1712 attr
.pointer
= pointer
;
1713 attr
.target
= target
;
1719 /* Return the attribute from a general expression. */
1722 gfc_expr_attr (gfc_expr
* e
)
1724 symbol_attribute attr
;
1726 switch (e
->expr_type
)
1729 attr
= gfc_variable_attr (e
, NULL
);
1733 gfc_clear_attr (&attr
);
1735 if (e
->value
.function
.esym
!= NULL
)
1736 attr
= e
->value
.function
.esym
->result
->attr
;
1738 /* TODO: NULL() returns pointers. May have to take care of this
1744 gfc_clear_attr (&attr
);
1752 /* Match a structure constructor. The initial symbol has already been
1756 gfc_match_structure_constructor (gfc_symbol
* sym
, gfc_expr
** result
)
1758 gfc_constructor
*head
, *tail
;
1759 gfc_component
*comp
;
1766 if (gfc_match_char ('(') != MATCH_YES
)
1769 where
= gfc_current_locus
;
1771 gfc_find_component (sym
, NULL
);
1773 for (comp
= sym
->components
; comp
; comp
= comp
->next
)
1776 tail
= head
= gfc_get_constructor ();
1779 tail
->next
= gfc_get_constructor ();
1783 m
= gfc_match_expr (&tail
->expr
);
1786 if (m
== MATCH_ERROR
)
1789 if (gfc_match_char (',') == MATCH_YES
)
1791 if (comp
->next
== NULL
)
1794 ("Too many components in structure constructor at %C");
1804 if (gfc_match_char (')') != MATCH_YES
)
1807 if (comp
->next
!= NULL
)
1809 gfc_error ("Too few components in structure constructor at %C");
1813 e
= gfc_get_expr ();
1815 e
->expr_type
= EXPR_STRUCTURE
;
1817 e
->ts
.type
= BT_DERIVED
;
1818 e
->ts
.derived
= sym
;
1821 e
->value
.constructor
= head
;
1827 gfc_error ("Syntax error in structure constructor at %C");
1830 gfc_free_constructor (head
);
1835 /* Matches a variable name followed by anything that might follow it--
1836 array reference, argument list of a function, etc. */
1839 gfc_match_rvalue (gfc_expr
** result
)
1841 gfc_actual_arglist
*actual_arglist
;
1842 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1845 gfc_symtree
*symtree
;
1851 m
= gfc_match_name (name
);
1855 if (gfc_find_state (COMP_INTERFACE
) == SUCCESS
)
1856 i
= gfc_get_sym_tree (name
, NULL
, &symtree
);
1858 i
= gfc_get_ha_sym_tree (name
, &symtree
);
1863 sym
= symtree
->n
.sym
;
1865 where
= gfc_current_locus
;
1867 gfc_set_sym_referenced (sym
);
1869 if (sym
->attr
.function
&& sym
->result
== sym
1870 && (gfc_current_ns
->proc_name
== sym
1871 || (gfc_current_ns
->parent
!= NULL
1872 && gfc_current_ns
->parent
->proc_name
== sym
)))
1875 if (sym
->attr
.function
|| sym
->attr
.external
|| sym
->attr
.intrinsic
)
1878 if (sym
->attr
.generic
)
1879 goto generic_function
;
1881 switch (sym
->attr
.flavor
)
1885 if (sym
->ts
.type
== BT_UNKNOWN
&& gfc_peek_char () == '%'
1886 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
1887 gfc_set_default_type (sym
, 0, sym
->ns
);
1889 e
= gfc_get_expr ();
1891 e
->expr_type
= EXPR_VARIABLE
;
1892 e
->symtree
= symtree
;
1894 m
= match_varspec (e
, 0);
1899 && sym
->value
->expr_type
!= EXPR_ARRAY
)
1900 e
= gfc_copy_expr (sym
->value
);
1903 e
= gfc_get_expr ();
1904 e
->expr_type
= EXPR_VARIABLE
;
1907 e
->symtree
= symtree
;
1908 m
= match_varspec (e
, 0);
1912 sym
= gfc_use_derived (sym
);
1916 m
= gfc_match_structure_constructor (sym
, &e
);
1919 /* If we're here, then the name is known to be the name of a
1920 procedure, yet it is not sure to be the name of a function. */
1922 if (sym
->attr
.subroutine
)
1924 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1930 /* At this point, the name has to be a non-statement function.
1931 If the name is the same as the current function being
1932 compiled, then we have a variable reference (to the function
1933 result) if the name is non-recursive. */
1935 st
= gfc_enclosing_unit (NULL
);
1937 if (st
!= NULL
&& st
->state
== COMP_FUNCTION
1939 && !sym
->attr
.recursive
)
1941 e
= gfc_get_expr ();
1942 e
->symtree
= symtree
;
1943 e
->expr_type
= EXPR_VARIABLE
;
1945 m
= match_varspec (e
, 0);
1949 /* Match a function reference. */
1951 m
= gfc_match_actual_arglist (0, &actual_arglist
);
1954 if (sym
->attr
.proc
== PROC_ST_FUNCTION
)
1955 gfc_error ("Statement function '%s' requires argument list at %C",
1958 gfc_error ("Function '%s' requires an argument list at %C",
1971 gfc_get_ha_sym_tree (name
, &symtree
); /* Can't fail */
1972 sym
= symtree
->n
.sym
;
1974 e
= gfc_get_expr ();
1975 e
->symtree
= symtree
;
1976 e
->expr_type
= EXPR_FUNCTION
;
1977 e
->value
.function
.actual
= actual_arglist
;
1978 e
->where
= gfc_current_locus
;
1980 if (sym
->as
!= NULL
)
1981 e
->rank
= sym
->as
->rank
;
1983 if (!sym
->attr
.function
1984 && gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
1990 if (sym
->result
== NULL
)
1998 /* Special case for derived type variables that get their types
1999 via an IMPLICIT statement. This can't wait for the
2000 resolution phase. */
2002 if (gfc_peek_char () == '%'
2003 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2004 gfc_set_default_type (sym
, 0, sym
->ns
);
2006 /* If the symbol has a dimension attribute, the expression is a
2009 if (sym
->attr
.dimension
)
2011 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2017 e
= gfc_get_expr ();
2018 e
->symtree
= symtree
;
2019 e
->expr_type
= EXPR_VARIABLE
;
2020 m
= match_varspec (e
, 0);
2024 /* Name is not an array, so we peek to see if a '(' implies a
2025 function call or a substring reference. Otherwise the
2026 variable is just a scalar. */
2028 gfc_gobble_whitespace ();
2029 if (gfc_peek_char () != '(')
2031 /* Assume a scalar variable */
2032 e
= gfc_get_expr ();
2033 e
->symtree
= symtree
;
2034 e
->expr_type
= EXPR_VARIABLE
;
2036 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2043 m
= match_varspec (e
, 0);
2047 /* See if this could possibly be a substring reference of a name
2048 that we're not sure is a variable yet. */
2050 e
= gfc_get_expr ();
2051 e
->symtree
= symtree
;
2053 if ((sym
->ts
.type
== BT_UNKNOWN
|| sym
->ts
.type
== BT_CHARACTER
)
2054 && match_substring (sym
->ts
.cl
, 0, &e
->ref
) == MATCH_YES
)
2057 e
->expr_type
= EXPR_VARIABLE
;
2059 if (sym
->attr
.flavor
!= FL_VARIABLE
2060 && gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2066 if (sym
->ts
.type
== BT_UNKNOWN
2067 && gfc_set_default_type (sym
, 1, NULL
) == FAILURE
)
2078 /* Give up, assume we have a function. */
2080 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2081 sym
= symtree
->n
.sym
;
2082 e
->expr_type
= EXPR_FUNCTION
;
2084 if (!sym
->attr
.function
2085 && gfc_add_function (&sym
->attr
, NULL
) == FAILURE
)
2093 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2095 gfc_error ("Missing argument list in function '%s' at %C", sym
->name
);
2103 /* If our new function returns a character, array or structure
2104 type, it might have subsequent references. */
2106 m
= match_varspec (e
, 0);
2113 gfc_get_sym_tree (name
, NULL
, &symtree
); /* Can't fail */
2115 e
= gfc_get_expr ();
2116 e
->symtree
= symtree
;
2117 e
->expr_type
= EXPR_FUNCTION
;
2119 m
= gfc_match_actual_arglist (0, &e
->value
.function
.actual
);
2123 gfc_error ("Symbol at %C is not appropriate for an expression");
2139 /* Match a variable, ie something that can be assigned to. This
2140 starts as a symbol, can be a structure component or an array
2141 reference. It can be a function if the function doesn't have a
2142 separate RESULT variable. If the symbol has not been previously
2143 seen, we assume it is a variable. */
2146 gfc_match_variable (gfc_expr
** result
, int equiv_flag
)
2154 m
= gfc_match_sym_tree (&st
, 1);
2157 where
= gfc_current_locus
;
2160 gfc_set_sym_referenced (sym
);
2161 switch (sym
->attr
.flavor
)
2167 if (gfc_add_flavor (&sym
->attr
, FL_VARIABLE
, NULL
) == FAILURE
)
2170 /* Special case for derived type variables that get their types
2171 via an IMPLICIT statement. This can't wait for the
2172 resolution phase. */
2174 if (gfc_peek_char () == '%'
2175 && gfc_get_default_type (sym
, sym
->ns
)->type
== BT_DERIVED
)
2176 gfc_set_default_type (sym
, 0, sym
->ns
);
2181 /* Check for a nonrecursive function result */
2182 if (sym
->attr
.function
&& (sym
->result
== sym
|| sym
->attr
.entry
))
2185 /* If a function result is a derived type, then the derived
2186 type may still have to be resolved. */
2188 if (sym
->ts
.type
== BT_DERIVED
2189 && gfc_use_derived (sym
->ts
.derived
) == NULL
)
2195 /* Fall through to error */
2198 gfc_error ("Expected VARIABLE at %C");
2202 expr
= gfc_get_expr ();
2204 expr
->expr_type
= EXPR_VARIABLE
;
2207 expr
->where
= where
;
2209 /* Now see if we have to do more. */
2210 m
= match_varspec (expr
, equiv_flag
);
2213 gfc_free_expr (expr
);