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_warning_now ("Hexadecimal constant at %C uses non-standard "
260 "syntax. Use \"Z\" instead.");
264 rname = "hexadecimal";
270 /* No whitespace allowed here. */
272 delim = gfc_next_char ();
273 if (delim != '\'' && delim != '\"')
276 old_loc = *gfc_current_locus ();
278 length = match_digits (0, radix, NULL);
281 gfc_error ("Empty set of digits in %s constants at %C", rname);
285 if (gfc_next_char () != delim)
287 gfc_error ("Illegal character in %s constant at %C.", rname);
291 gfc_set_locus (&old_loc);
293 buffer = alloca (length + 1);
294 memset (buffer, '\0', length + 1);
296 match_digits (0, radix, buffer);
299 e = gfc_convert_integer (buffer, gfc_default_integer_kind (), radix,
300 gfc_current_locus ());
302 if (gfc_range_check (e) != ARITH_OK)
304 gfc_error ("Integer too big for default integer kind at %C");
314 gfc_set_locus (&old_loc);
319 /* Match a real constant of some sort. */
322 match_real_constant (gfc_expr ** result, int signflag)
324 int kind, c, count, seen_dp, seen_digits, exp_char;
325 locus old_loc, temp_loc;
329 old_loc = *gfc_current_locus ();
330 gfc_gobble_whitespace ();
339 c = gfc_next_char ();
340 if (signflag && (c == '+' || c == '-'))
342 c = gfc_next_char ();
346 /* Scan significand. */
347 for (;; c = gfc_next_char (), count++)
354 /* Check to see if "." goes with a following operator like ".eq.". */
355 temp_loc = *gfc_current_locus ();
356 c = gfc_next_char ();
358 if (c == 'e' || c == 'd' || c == 'q')
360 c = gfc_next_char ();
362 goto done; /* Operator named .e. or .d. */
366 goto done; /* Distinguish 1.e9 from 1.eq.2 */
368 gfc_set_locus (&temp_loc);
382 if (!seen_digits || (c != 'e' && c != 'd' && c != 'q'))
387 c = gfc_next_char ();
390 if (c == '+' || c == '-')
391 { /* optional sign */
392 c = gfc_next_char ();
398 /* TODO: seen_digits is always true at this point */
401 gfc_set_locus (&old_loc);
402 return MATCH_NO; /* ".e" can be something else */
405 gfc_error ("Missing exponent in real number at %C");
411 c = gfc_next_char ();
416 /* See what we've got! */
417 if (!seen_digits || (!seen_dp && exp_char == ' '))
419 gfc_set_locus (&old_loc);
423 /* Convert the number. */
424 gfc_set_locus (&old_loc);
425 gfc_gobble_whitespace ();
427 buffer = alloca (count + 1);
428 memset (buffer, '\0', count + 1);
430 /* Hack for mpf_init_set_str(). */
434 *p = gfc_next_char ();
435 if (*p == 'd' || *p == 'q')
451 ("Real number at %C has a 'd' exponent and an explicit kind");
454 kind = gfc_default_double_kind ();
461 ("Real number at %C has a 'q' exponent and an explicit kind");
464 kind = gfc_option.q_kind;
469 kind = gfc_default_real_kind ();
471 if (gfc_validate_kind (BT_REAL, kind) == -1)
473 gfc_error ("Invalid real kind %d at %C", kind);
478 e = gfc_convert_real (buffer, kind, gfc_current_locus ());
480 switch (gfc_range_check (e))
485 gfc_error ("Real constant overflows its kind at %C");
488 case ARITH_UNDERFLOW:
489 gfc_error ("Real constant underflows its kind at %C");
493 gfc_internal_error ("gfc_range_check() returned bad value");
505 /* Match a substring reference. */
508 match_substring (gfc_charlen * cl, int init, gfc_ref ** result)
510 gfc_expr *start, *end;
518 old_loc = *gfc_current_locus ();
520 m = gfc_match_char ('(');
524 if (gfc_match_char (':') != MATCH_YES)
527 m = gfc_match_init_expr (&start);
529 m = gfc_match_expr (&start);
537 m = gfc_match_char (':');
542 if (gfc_match_char (')') != MATCH_YES)
545 m = gfc_match_init_expr (&end);
547 m = gfc_match_expr (&end);
551 if (m == MATCH_ERROR)
554 m = gfc_match_char (')');
559 /* Optimize away the (:) reference. */
560 if (start == NULL && end == NULL)
564 ref = gfc_get_ref ();
566 ref->type = REF_SUBSTRING;
568 start = gfc_int_expr (1);
569 ref->u.ss.start = start;
570 if (end == NULL && cl)
571 end = gfc_copy_expr (cl->length);
573 ref->u.ss.length = cl;
580 gfc_error ("Syntax error in SUBSTRING specification at %C");
584 gfc_free_expr (start);
587 gfc_set_locus (&old_loc);
592 /* Reads the next character of a string constant, taking care to
593 return doubled delimiters on the input as a single instance of
596 Special return values are:
597 -1 End of the string, as determined by the delimiter
598 -2 Unterminated string detected
600 Backslash codes are also expanded at this time. */
603 next_string_char (char delimiter)
608 c = gfc_next_char_literal (1);
615 old_locus = *gfc_current_locus ();
617 switch (gfc_next_char_literal (1))
645 /* Unknown backslash codes are simply not expanded */
646 gfc_set_locus (&old_locus);
654 old_locus = *gfc_current_locus ();
655 c = gfc_next_char_literal (1);
659 gfc_set_locus (&old_locus);
665 /* Special case of gfc_match_name() that matches a parameter kind name
666 before a string constant. This takes case of the weird but legal
667 case of: weird case of:
671 where kind____ is a parameter. gfc_match_name() will happily slurp
672 up all the underscores, which leads to problems. If we return
673 MATCH_YES, the parse pointer points to the final underscore, which
674 is not part of the name. We never return MATCH_ERROR-- errors in
675 the name will be detected later. */
678 match_charkind_name (char *name)
684 gfc_gobble_whitespace ();
685 c = gfc_next_char ();
694 old_loc = *gfc_current_locus ();
695 c = gfc_next_char ();
699 peek = gfc_peek_char ();
701 if (peek == '\'' || peek == '\"')
703 gfc_set_locus (&old_loc);
711 && (gfc_option.flag_dollar_ok && c != '$'))
715 if (++len > GFC_MAX_SYMBOL_LEN)
723 /* See if the current input matches a character constant. Lots of
724 contortions have to be done to match the kind parameter which comes
725 before the actual string. The main consideration is that we don't
726 want to error out too quickly. For example, we don't actually do
727 any validation of the kinds until we have actually seen a legal
728 delimiter. Using match_kind_param() generates errors too quickly. */
731 match_string_constant (gfc_expr ** result)
733 char *p, name[GFC_MAX_SYMBOL_LEN + 1];
734 int i, c, kind, length, delimiter;
735 locus old_locus, start_locus;
741 old_locus = *gfc_current_locus ();
743 gfc_gobble_whitespace ();
745 start_locus = *gfc_current_locus ();
747 c = gfc_next_char ();
748 if (c == '\'' || c == '"')
750 kind = gfc_default_character_kind ();
760 kind = kind * 10 + c - '0';
763 c = gfc_next_char ();
769 gfc_set_locus (&old_locus);
771 m = match_charkind_name (name);
775 if (gfc_find_symbol (name, NULL, 1, &sym)
777 || sym->attr.flavor != FL_PARAMETER)
781 c = gfc_next_char ();
786 gfc_gobble_whitespace ();
787 c = gfc_next_char ();
793 gfc_gobble_whitespace ();
794 start_locus = *gfc_current_locus ();
796 c = gfc_next_char ();
797 if (c != '\'' && c != '"')
802 q = gfc_extract_int (sym->value, &kind);
810 if (gfc_validate_kind (BT_CHARACTER, kind) == -1)
812 gfc_error ("Invalid kind %d for CHARACTER constant at %C", kind);
817 /* Scan the string into a block of memory by first figuring out how
818 long it is, allocating the structure, then re-reading it. This
819 isn't particularly efficient, but string constants aren't that
820 common in most code. TODO: Use obstacks? */
827 c = next_string_char (delimiter);
832 gfc_set_locus (&start_locus);
833 gfc_error ("Unterminated character constant beginning at %C");
842 e->expr_type = EXPR_CONSTANT;
844 e->ts.type = BT_CHARACTER;
846 e->where = start_locus;
848 e->value.character.string = p = gfc_getmem (length + 1);
849 e->value.character.length = length;
851 gfc_set_locus (&start_locus);
852 gfc_next_char (); /* Skip delimiter */
854 for (i = 0; i < length; i++)
855 *p++ = next_string_char (delimiter);
857 *p = '\0'; /* TODO: C-style string is for development/debug purposes. */
859 if (next_string_char (delimiter) != -1)
860 gfc_internal_error ("match_string_constant(): Delimiter not found");
862 if (match_substring (NULL, 0, &e->ref) != MATCH_NO)
863 e->expr_type = EXPR_SUBSTRING;
870 gfc_set_locus (&old_locus);
875 /* Match a .true. or .false. */
878 match_logical_constant (gfc_expr ** result)
880 static mstring logical_ops[] = {
881 minit (".false.", 0),
889 i = gfc_match_strings (logical_ops);
897 kind = gfc_default_logical_kind ();
899 if (gfc_validate_kind (BT_LOGICAL, kind) == -1)
900 gfc_error ("Bad kind for logical constant at %C");
904 e->expr_type = EXPR_CONSTANT;
905 e->value.logical = i;
906 e->ts.type = BT_LOGICAL;
908 e->where = *gfc_current_locus ();
915 /* Match a real or imaginary part of a complex constant that is a
916 symbolic constant. */
919 match_sym_complex_part (gfc_expr ** result)
921 char name[GFC_MAX_SYMBOL_LEN + 1];
926 m = gfc_match_name (name);
930 if (gfc_find_symbol (name, NULL, 1, &sym) || sym == NULL)
933 if (sym->attr.flavor != FL_PARAMETER)
935 gfc_error ("Expected PARAMETER symbol in complex constant at %C");
939 if (!gfc_numeric_ts (&sym->value->ts))
941 gfc_error ("Numeric PARAMETER required in complex constant at %C");
945 if (sym->value->rank != 0)
947 gfc_error ("Scalar PARAMETER required in complex constant at %C");
951 switch (sym->value->ts.type)
954 e = gfc_copy_expr (sym->value);
958 e = gfc_complex2real (sym->value, sym->value->ts.kind);
964 e = gfc_int2real (sym->value, gfc_default_real_kind ());
970 gfc_internal_error ("gfc_match_sym_complex_part(): Bad type");
973 *result = e; /* e is a scalar, real, constant expression */
977 gfc_error ("Error converting PARAMETER constant in complex constant at %C");
982 /* Match the real and imaginary parts of a complex number. This
983 subroutine is essentially match_real_constant() modified in a
984 couple of ways: A sign is always allowed and numbers that would
985 look like an integer to match_real_constant() are automatically
986 created as floating point numbers. The messiness involved with
987 making sure a decimal point belongs to the number and not a
988 trailing operator is not necessary here either (Hooray!). */
991 match_const_complex_part (gfc_expr ** result)
993 int kind, seen_digits, seen_dp, count;
994 char *p, c, exp_char, *buffer;
997 old_loc = *gfc_current_locus ();
998 gfc_gobble_whitespace ();
1005 c = gfc_next_char ();
1006 if (c == '-' || c == '+')
1008 c = gfc_next_char ();
1012 for (;; c = gfc_next_char (), count++)
1031 if (!seen_digits || (c != 'd' && c != 'e'))
1035 /* Scan exponent. */
1036 c = gfc_next_char ();
1039 if (c == '+' || c == '-')
1040 { /* optional sign */
1041 c = gfc_next_char ();
1047 gfc_error ("Missing exponent in real number at %C");
1053 c = gfc_next_char ();
1061 /* Convert the number. */
1062 gfc_set_locus (&old_loc);
1063 gfc_gobble_whitespace ();
1065 buffer = alloca (count + 1);
1066 memset (buffer, '\0', count + 1);
1068 /* Hack for mpf_init_set_str(). */
1072 c = gfc_next_char ();
1085 /* If the number looked like an integer, forget about a kind we may
1086 have seen, otherwise validate the kind against real kinds. */
1087 if (seen_dp == 0 && exp_char == ' ')
1090 kind = gfc_default_integer_kind ();
1095 if (exp_char == 'd')
1100 ("Real number at %C has a 'd' exponent and an explicit kind");
1103 kind = gfc_default_double_kind ();
1109 kind = gfc_default_real_kind ();
1112 if (gfc_validate_kind (BT_REAL, kind) == -1)
1114 gfc_error ("Invalid real kind %d at %C", kind);
1119 *result = gfc_convert_real (buffer, kind, gfc_current_locus ());
1123 gfc_set_locus (&old_loc);
1128 /* Match a real or imaginary part of a complex number. */
1131 match_complex_part (gfc_expr ** result)
1135 m = match_sym_complex_part (result);
1139 return match_const_complex_part (result);
1143 /* Try to match a complex constant. */
1146 match_complex_constant (gfc_expr ** result)
1148 gfc_expr *e, *real, *imag;
1149 gfc_error_buf old_error;
1150 gfc_typespec target;
1155 old_loc = *gfc_current_locus ();
1156 real = imag = e = NULL;
1158 m = gfc_match_char ('(');
1162 gfc_push_error (&old_error);
1164 m = match_complex_part (&real);
1168 if (gfc_match_char (',') == MATCH_NO)
1170 gfc_pop_error (&old_error);
1175 /* If m is error, then something was wrong with the real part and we
1176 assume we have a complex constant because we've seen the ','. An
1177 ambiguous case here is the start of an iterator list of some
1178 sort. These sort of lists are matched prior to coming here. */
1180 if (m == MATCH_ERROR)
1182 gfc_pop_error (&old_error);
1184 m = match_complex_part (&imag);
1187 if (m == MATCH_ERROR)
1190 m = gfc_match_char (')');
1194 if (m == MATCH_ERROR)
1197 /* Decide on the kind of this complex number. */
1198 kind = gfc_kind_max (real, imag);
1199 target.type = BT_REAL;
1202 if (kind != real->ts.kind)
1203 gfc_convert_type (real, &target, 2);
1204 if (kind != imag->ts.kind)
1205 gfc_convert_type (imag, &target, 2);
1207 e = gfc_convert_complex (real, imag, kind);
1208 e->where = *gfc_current_locus ();
1210 gfc_free_expr (real);
1211 gfc_free_expr (imag);
1217 gfc_error ("Syntax error in COMPLEX constant at %C");
1222 gfc_free_expr (real);
1223 gfc_free_expr (imag);
1224 gfc_set_locus (&old_loc);
1230 /* Match constants in any of several forms. Returns nonzero for a
1231 match, zero for no match. */
1234 gfc_match_literal_constant (gfc_expr ** result, int signflag)
1238 m = match_complex_constant (result);
1242 m = match_string_constant (result);
1246 m = match_boz_constant (result);
1250 m = match_real_constant (result, signflag);
1254 m = match_integer_constant (result, signflag);
1258 m = match_logical_constant (result);
1266 /* Match a single actual argument value. An actual argument is
1267 usually an expression, but can also be a procedure name. If the
1268 argument is a single name, it is not always possible to tell
1269 whether the name is a dummy procedure or not. We treat these cases
1270 by creating an argument that looks like a dummy procedure and
1271 fixing things later during resolution. */
1274 match_actual_arg (gfc_expr ** result)
1276 char name[GFC_MAX_SYMBOL_LEN + 1];
1277 gfc_symtree *symtree;
1282 where = *gfc_current_locus ();
1284 switch (gfc_match_name (name))
1293 w = *gfc_current_locus ();
1294 gfc_gobble_whitespace ();
1295 c = gfc_next_char ();
1298 if (c != ',' && c != ')')
1301 if (gfc_find_sym_tree (name, NULL, 1, &symtree))
1303 /* Handle error elsewhere. */
1305 /* Eliminate a couple of common cases where we know we don't
1306 have a function argument. */
1307 if (symtree == NULL)
1309 gfc_get_sym_tree (name, NULL, &symtree);
1310 gfc_set_sym_referenced (symtree->n.sym);
1316 sym = symtree->n.sym;
1317 gfc_set_sym_referenced (sym);
1318 if (sym->attr.flavor != FL_PROCEDURE
1319 && sym->attr.flavor != FL_UNKNOWN)
1322 /* If the symbol is a function with itself as the result and
1323 is being defined, then we have a variable. */
1324 if (sym->result == sym
1325 && (gfc_current_ns->proc_name == sym
1326 || (gfc_current_ns->parent != NULL
1327 && gfc_current_ns->parent->proc_name == sym)))
1331 e = gfc_get_expr (); /* Leave it unknown for now */
1332 e->symtree = symtree;
1333 e->expr_type = EXPR_VARIABLE;
1334 e->ts.type = BT_PROCEDURE;
1341 gfc_set_locus (&where);
1342 return gfc_match_expr (result);
1346 /* Match a keyword argument. */
1349 match_keyword_arg (gfc_actual_arglist * actual, gfc_actual_arglist * base)
1351 char name[GFC_MAX_SYMBOL_LEN + 1];
1352 gfc_actual_arglist *a;
1356 name_locus = *gfc_current_locus ();
1357 m = gfc_match_name (name);
1361 if (gfc_match_char ('=') != MATCH_YES)
1367 m = match_actual_arg (&actual->expr);
1371 /* Make sure this name has not appeared yet. */
1373 if (name[0] != '\0')
1375 for (a = base; a; a = a->next)
1376 if (strcmp (a->name, name) == 0)
1379 ("Keyword '%s' at %C has already appeared in the current "
1380 "argument list", name);
1385 strcpy (actual->name, name);
1389 gfc_set_locus (&name_locus);
1394 /* Matches an actual argument list of a function or subroutine, from
1395 the opening parenthesis to the closing parenthesis. The argument
1396 list is assumed to allow keyword arguments because we don't know if
1397 the symbol associated with the procedure has an implicit interface
1398 or not. We make sure keywords are unique. */
1401 gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist ** argp)
1403 gfc_actual_arglist *head, *tail;
1405 gfc_st_label *label;
1409 *argp = tail = NULL;
1410 old_loc = *gfc_current_locus ();
1414 if (gfc_match_char ('(') == MATCH_NO)
1415 return (sub_flag) ? MATCH_YES : MATCH_NO;
1417 if (gfc_match_char (')') == MATCH_YES)
1424 head = tail = gfc_get_actual_arglist ();
1427 tail->next = gfc_get_actual_arglist ();
1431 if (sub_flag && gfc_match_char ('*') == MATCH_YES)
1433 m = gfc_match_st_label (&label, 0);
1435 gfc_error ("Expected alternate return label at %C");
1439 tail->label = label;
1443 /* After the first keyword argument is seen, the following
1444 arguments must also have keywords. */
1447 m = match_keyword_arg (tail, head);
1449 if (m == MATCH_ERROR)
1454 ("Missing keyword name in actual argument list at %C");
1461 /* See if we have the first keyword argument. */
1462 m = match_keyword_arg (tail, head);
1465 if (m == MATCH_ERROR)
1470 /* Try for a non-keyword argument. */
1471 m = match_actual_arg (&tail->expr);
1472 if (m == MATCH_ERROR)
1480 if (gfc_match_char (')') == MATCH_YES)
1482 if (gfc_match_char (',') != MATCH_YES)
1490 gfc_error ("Syntax error in argument list at %C");
1493 gfc_free_actual_arglist (head);
1494 gfc_set_locus (&old_loc);
1500 /* Used by match_varspec() to extend the reference list by one
1504 extend_ref (gfc_expr * primary, gfc_ref * tail)
1507 if (primary->ref == NULL)
1508 primary->ref = tail = gfc_get_ref ();
1512 gfc_internal_error ("extend_ref(): Bad tail");
1513 tail->next = gfc_get_ref ();
1521 /* Match any additional specifications associated with the current
1522 variable like member references or substrings. If equiv_flag is
1523 set we only match stuff that is allowed inside an EQUIVALENCE
1527 match_varspec (gfc_expr * primary, int equiv_flag)
1529 char name[GFC_MAX_SYMBOL_LEN + 1];
1530 gfc_ref *substring, *tail;
1531 gfc_component *component;
1537 if (primary->symtree->n.sym->attr.dimension
1539 && gfc_peek_char () == '('))
1542 tail = extend_ref (primary, tail);
1543 tail->type = REF_ARRAY;
1545 m = gfc_match_array_ref (&tail->u.ar, primary->symtree->n.sym->as,
1551 sym = primary->symtree->n.sym;
1552 primary->ts = sym->ts;
1554 if (sym->ts.type != BT_DERIVED || gfc_match_char ('%') != MATCH_YES)
1555 goto check_substring;
1557 sym = sym->ts.derived;
1561 m = gfc_match_name (name);
1563 gfc_error ("Expected structure component name at %C");
1567 component = gfc_find_component (sym, name);
1568 if (component == NULL)
1571 tail = extend_ref (primary, tail);
1572 tail->type = REF_COMPONENT;
1574 tail->u.c.component = component;
1575 tail->u.c.sym = sym;
1577 primary->ts = component->ts;
1579 if (component->as != NULL)
1581 tail = extend_ref (primary, tail);
1582 tail->type = REF_ARRAY;
1584 m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag);
1589 if (component->ts.type != BT_DERIVED
1590 || gfc_match_char ('%') != MATCH_YES)
1593 sym = component->ts.derived;
1597 if (primary->ts.type == BT_CHARACTER)
1599 switch (match_substring (primary->ts.cl, equiv_flag, &substring))
1603 primary->ref = substring;
1605 tail->next = substring;
1607 if (primary->expr_type == EXPR_CONSTANT)
1608 primary->expr_type = EXPR_SUBSTRING;
1624 /* Given an expression that is a variable, figure out what the
1625 ultimate variable's type and attribute is, traversing the reference
1626 structures if necessary.
1628 This subroutine is trickier than it looks. We start at the base
1629 symbol and store the attribute. Component references load a
1630 completely new attribute.
1632 A couple of rules come into play. Subobjects of targets are always
1633 targets themselves. If we see a component that goes through a
1634 pointer, then the expression must also be a target, since the
1635 pointer is associated with something (if it isn't core will soon be
1636 dumped). If we see a full part or section of an array, the
1637 expression is also an array.
1639 We can have at most one full array reference. */
1642 gfc_variable_attr (gfc_expr * expr, gfc_typespec * ts)
1644 int dimension, pointer, target;
1645 symbol_attribute attr;
1648 if (expr->expr_type != EXPR_VARIABLE)
1649 gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
1652 attr = expr->symtree->n.sym->attr;
1654 dimension = attr.dimension;
1655 pointer = attr.pointer;
1657 target = attr.target;
1661 if (ts != NULL && expr->ts.type == BT_UNKNOWN)
1662 *ts = expr->symtree->n.sym->ts;
1664 for (; ref; ref = ref->next)
1669 switch (ref->u.ar.type)
1685 gfc_internal_error ("gfc_variable_attr(): Bad array reference");
1691 gfc_get_component_attr (&attr, ref->u.c.component);
1693 *ts = ref->u.c.component->ts;
1695 pointer = ref->u.c.component->pointer;
1706 attr.dimension = dimension;
1707 attr.pointer = pointer;
1708 attr.target = target;
1714 /* Return the attribute from a general expression. */
1717 gfc_expr_attr (gfc_expr * e)
1719 symbol_attribute attr;
1721 switch (e->expr_type)
1724 attr = gfc_variable_attr (e, NULL);
1728 gfc_clear_attr (&attr);
1730 if (e->value.function.esym != NULL)
1731 attr = e->value.function.esym->result->attr;
1733 /* TODO: NULL() returns pointers. May have to take care of this
1739 gfc_clear_attr (&attr);
1747 /* Match a structure constructor. The initial symbol has already been
1751 match_structure_constructor (gfc_symbol * sym, gfc_expr ** result)
1753 gfc_constructor *head, *tail;
1754 gfc_component *comp;
1761 if (gfc_match_char ('(') != MATCH_YES)
1764 where = *gfc_current_locus ();
1766 gfc_find_component (sym, NULL);
1768 for (comp = sym->components; comp; comp = comp->next)
1771 tail = head = gfc_get_constructor ();
1774 tail->next = gfc_get_constructor ();
1778 m = gfc_match_expr (&tail->expr);
1781 if (m == MATCH_ERROR)
1784 if (gfc_match_char (',') == MATCH_YES)
1786 if (comp->next == NULL)
1789 ("Too many components in structure constructor at %C");
1799 if (gfc_match_char (')') != MATCH_YES)
1802 if (comp->next != NULL)
1804 gfc_error ("Too few components in structure constructor at %C");
1808 e = gfc_get_expr ();
1810 e->expr_type = EXPR_STRUCTURE;
1812 e->ts.type = BT_DERIVED;
1813 e->ts.derived = sym;
1816 e->value.constructor = head;
1822 gfc_error ("Syntax error in structure constructor at %C");
1825 gfc_free_constructor (head);
1830 /* Matches a variable name followed by anything that might follow it--
1831 array reference, argument list of a function, etc. */
1834 gfc_match_rvalue (gfc_expr ** result)
1836 gfc_actual_arglist *actual_arglist;
1837 char name[GFC_MAX_SYMBOL_LEN + 1];
1840 gfc_symtree *symtree;
1846 m = gfc_match_name (name);
1850 if (gfc_find_state (COMP_INTERFACE) == SUCCESS)
1851 i = gfc_get_sym_tree (name, NULL, &symtree);
1853 i = gfc_get_ha_sym_tree (name, &symtree);
1858 sym = symtree->n.sym;
1860 where = *gfc_current_locus ();
1862 gfc_set_sym_referenced (sym);
1864 if (sym->attr.function && sym->result == sym
1865 && (gfc_current_ns->proc_name == sym
1866 || (gfc_current_ns->parent != NULL
1867 && gfc_current_ns->parent->proc_name == sym)))
1870 if (sym->attr.function || sym->attr.external || sym->attr.intrinsic)
1873 if (sym->attr.generic)
1874 goto generic_function;
1876 switch (sym->attr.flavor)
1880 if (sym->ts.type == BT_UNKNOWN && gfc_peek_char () == '%'
1881 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1882 gfc_set_default_type (sym, 0, sym->ns);
1884 e = gfc_get_expr ();
1886 e->expr_type = EXPR_VARIABLE;
1887 e->symtree = symtree;
1889 m = match_varspec (e, 0);
1894 && sym->value->expr_type != EXPR_ARRAY)
1895 e = gfc_copy_expr (sym->value);
1898 e = gfc_get_expr ();
1899 e->expr_type = EXPR_VARIABLE;
1902 e->symtree = symtree;
1903 m = match_varspec (e, 0);
1907 sym = gfc_use_derived (sym);
1911 m = match_structure_constructor (sym, &e);
1914 /* If we're here, then the name is known to be the name of a
1915 procedure, yet it is not sure to be the name of a function. */
1917 if (sym->attr.subroutine)
1919 gfc_error ("Unexpected use of subroutine name '%s' at %C",
1925 /* At this point, the name has to be a non-statement function.
1926 If the name is the same as the current function being
1927 compiled, then we have a variable reference (to the function
1928 result) if the name is non-recursive. */
1930 st = gfc_enclosing_unit (NULL);
1932 if (st != NULL && st->state == COMP_FUNCTION
1934 && !sym->attr.recursive)
1936 e = gfc_get_expr ();
1937 e->symtree = symtree;
1938 e->expr_type = EXPR_VARIABLE;
1940 m = match_varspec (e, 0);
1944 /* Match a function reference. */
1946 m = gfc_match_actual_arglist (0, &actual_arglist);
1949 if (sym->attr.proc == PROC_ST_FUNCTION)
1950 gfc_error ("Statement function '%s' requires argument list at %C",
1953 gfc_error ("Function '%s' requires an argument list at %C",
1966 gfc_get_ha_sym_tree (name, &symtree); /* Can't fail */
1967 sym = symtree->n.sym;
1969 e = gfc_get_expr ();
1970 e->symtree = symtree;
1971 e->expr_type = EXPR_FUNCTION;
1972 e->value.function.actual = actual_arglist;
1973 e->where = *gfc_current_locus ();
1975 if (sym->as != NULL)
1976 e->rank = sym->as->rank;
1978 if (!sym->attr.function
1979 && gfc_add_function (&sym->attr, NULL) == FAILURE)
1985 if (sym->result == NULL)
1993 /* Special case for derived type variables that get their types
1994 via an IMPLICIT statement. This can't wait for the
1995 resolution phase. */
1997 if (gfc_peek_char () == '%'
1998 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
1999 gfc_set_default_type (sym, 0, sym->ns);
2001 /* If the symbol has a dimension attribute, the expression is a
2004 if (sym->attr.dimension)
2006 if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2012 e = gfc_get_expr ();
2013 e->symtree = symtree;
2014 e->expr_type = EXPR_VARIABLE;
2015 m = match_varspec (e, 0);
2019 /* Name is not an array, so we peek to see if a '(' implies a
2020 function call or a substring reference. Otherwise the
2021 variable is just a scalar. */
2023 gfc_gobble_whitespace ();
2024 if (gfc_peek_char () != '(')
2026 /* Assume a scalar variable */
2027 e = gfc_get_expr ();
2028 e->symtree = symtree;
2029 e->expr_type = EXPR_VARIABLE;
2031 if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2038 m = match_varspec (e, 0);
2042 /* See if this could possibly be a substring reference of a name
2043 that we're not sure is a variable yet. */
2045 e = gfc_get_expr ();
2046 e->symtree = symtree;
2048 if ((sym->ts.type == BT_UNKNOWN || sym->ts.type == BT_CHARACTER)
2049 && match_substring (sym->ts.cl, 0, &e->ref) == MATCH_YES)
2052 e->expr_type = EXPR_VARIABLE;
2054 if (sym->attr.flavor != FL_VARIABLE
2055 && gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2061 if (sym->ts.type == BT_UNKNOWN
2062 && gfc_set_default_type (sym, 1, NULL) == FAILURE)
2073 /* Give up, assume we have a function. */
2075 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2076 sym = symtree->n.sym;
2077 e->expr_type = EXPR_FUNCTION;
2079 if (!sym->attr.function
2080 && gfc_add_function (&sym->attr, NULL) == FAILURE)
2088 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2090 gfc_error ("Missing argument list in function '%s' at %C", sym->name);
2098 /* If our new function returns a character, array or structure
2099 type, it might have subsequent references. */
2101 m = match_varspec (e, 0);
2108 gfc_get_sym_tree (name, NULL, &symtree); /* Can't fail */
2110 e = gfc_get_expr ();
2111 e->symtree = symtree;
2112 e->expr_type = EXPR_FUNCTION;
2114 m = gfc_match_actual_arglist (0, &e->value.function.actual);
2118 gfc_error ("Symbol at %C is not appropriate for an expression");
2134 /* Match a variable, ie something that can be assigned to. This
2135 starts as a symbol, can be a structure component or an array
2136 reference. It can be a function if the function doesn't have a
2137 separate RESULT variable. If the symbol has not been previously
2138 seen, we assume it is a variable. */
2141 gfc_match_variable (gfc_expr ** result, int equiv_flag)
2149 m = gfc_match_sym_tree (&st, 1);
2152 where = *gfc_current_locus ();
2155 gfc_set_sym_referenced (sym);
2156 switch (sym->attr.flavor)
2162 if (gfc_add_flavor (&sym->attr, FL_VARIABLE, NULL) == FAILURE)
2165 /* Special case for derived type variables that get their types
2166 via an IMPLICIT statement. This can't wait for the
2167 resolution phase. */
2169 if (gfc_peek_char () == '%'
2170 && gfc_get_default_type (sym, sym->ns)->type == BT_DERIVED)
2171 gfc_set_default_type (sym, 0, sym->ns);
2176 /* Check for a nonrecursive function result */
2177 if (sym->attr.function && (sym->result == sym || sym->attr.entry))
2180 /* If a function result is a derived type, then the derived
2181 type may still have to be resolved. */
2183 if (sym->ts.type == BT_DERIVED
2184 && gfc_use_derived (sym->ts.derived) == NULL)
2190 /* Fall through to error */
2193 gfc_error ("Expected VARIABLE at %C");
2197 expr = gfc_get_expr ();
2199 expr->expr_type = EXPR_VARIABLE;
2202 expr->where = where;
2204 /* Now see if we have to do more. */
2205 m = match_varspec (expr, equiv_flag);
2208 gfc_free_expr (expr);