1 /* Matching subroutines in all sizes, shapes and colors.
2 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation,
4 Contributed by Andy Vaught
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
31 /* For matching and debugging purposes. Order matters here! The
32 unary operators /must/ precede the binary plus and minus, or
33 the expression parser breaks. */
35 mstring intrinsic_operators
[] = {
36 minit ("+", INTRINSIC_UPLUS
),
37 minit ("-", INTRINSIC_UMINUS
),
38 minit ("+", INTRINSIC_PLUS
),
39 minit ("-", INTRINSIC_MINUS
),
40 minit ("**", INTRINSIC_POWER
),
41 minit ("//", INTRINSIC_CONCAT
),
42 minit ("*", INTRINSIC_TIMES
),
43 minit ("/", INTRINSIC_DIVIDE
),
44 minit (".and.", INTRINSIC_AND
),
45 minit (".or.", INTRINSIC_OR
),
46 minit (".eqv.", INTRINSIC_EQV
),
47 minit (".neqv.", INTRINSIC_NEQV
),
48 minit (".eq.", INTRINSIC_EQ
),
49 minit ("==", INTRINSIC_EQ
),
50 minit (".ne.", INTRINSIC_NE
),
51 minit ("/=", INTRINSIC_NE
),
52 minit (".ge.", INTRINSIC_GE
),
53 minit (">=", INTRINSIC_GE
),
54 minit (".le.", INTRINSIC_LE
),
55 minit ("<=", INTRINSIC_LE
),
56 minit (".lt.", INTRINSIC_LT
),
57 minit ("<", INTRINSIC_LT
),
58 minit (".gt.", INTRINSIC_GT
),
59 minit (">", INTRINSIC_GT
),
60 minit (".not.", INTRINSIC_NOT
),
61 minit (NULL
, INTRINSIC_NONE
)
65 /******************** Generic matching subroutines ************************/
67 /* In free form, match at least one space. Always matches in fixed
71 gfc_match_space (void)
76 if (gfc_current_form
== FORM_FIXED
)
79 old_loc
= gfc_current_locus
;
82 if (!gfc_is_whitespace (c
))
84 gfc_current_locus
= old_loc
;
88 gfc_gobble_whitespace ();
94 /* Match an end of statement. End of statement is optional
95 whitespace, followed by a ';' or '\n' or comment '!'. If a
96 semicolon is found, we continue to eat whitespace and semicolons. */
108 old_loc
= gfc_current_locus
;
109 gfc_gobble_whitespace ();
111 c
= gfc_next_char ();
117 c
= gfc_next_char ();
134 gfc_current_locus
= old_loc
;
135 return (flag
) ? MATCH_YES
: MATCH_NO
;
139 /* Match a literal integer on the input, setting the value on
140 MATCH_YES. Literal ints occur in kind-parameters as well as
141 old-style character length specifications. */
144 gfc_match_small_literal_int (int *value
)
150 old_loc
= gfc_current_locus
;
152 gfc_gobble_whitespace ();
153 c
= gfc_next_char ();
157 gfc_current_locus
= old_loc
;
165 old_loc
= gfc_current_locus
;
166 c
= gfc_next_char ();
171 i
= 10 * i
+ c
- '0';
175 gfc_error ("Integer too large at %C");
180 gfc_current_locus
= old_loc
;
187 /* Match a small, constant integer expression, like in a kind
188 statement. On MATCH_YES, 'value' is set. */
191 gfc_match_small_int (int *value
)
198 m
= gfc_match_expr (&expr
);
202 p
= gfc_extract_int (expr
, &i
);
203 gfc_free_expr (expr
);
216 /* Matches a statement label. Uses gfc_match_small_literal_int() to
217 do most of the work. */
220 gfc_match_st_label (gfc_st_label
** label
, int allow_zero
)
226 old_loc
= gfc_current_locus
;
228 m
= gfc_match_small_literal_int (&i
);
232 if (((i
== 0) && allow_zero
) || i
<= 99999)
234 *label
= gfc_get_st_label (i
);
238 gfc_error ("Statement label at %C is out of range");
239 gfc_current_locus
= old_loc
;
244 /* Match and validate a label associated with a named IF, DO or SELECT
245 statement. If the symbol does not have the label attribute, we add
246 it. We also make sure the symbol does not refer to another
247 (active) block. A matched label is pointed to by gfc_new_block. */
250 gfc_match_label (void)
252 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
256 gfc_new_block
= NULL
;
258 m
= gfc_match (" %n :", name
);
262 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
264 gfc_error ("Label name '%s' at %C is ambiguous", name
);
268 if (gfc_new_block
->attr
.flavor
!= FL_LABEL
269 && gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
270 gfc_new_block
->name
, NULL
) == FAILURE
)
273 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
274 if (p
->sym
== gfc_new_block
)
276 gfc_error ("Label %s at %C already in use by a parent block",
277 gfc_new_block
->name
);
285 /* Try and match the input against an array of possibilities. If one
286 potential matching string is a substring of another, the longest
287 match takes precedence. Spaces in the target strings are optional
288 spaces that do not necessarily have to be found in the input
289 stream. In fixed mode, spaces never appear. If whitespace is
290 matched, it matches unlimited whitespace in the input. For this
291 reason, the 'mp' member of the mstring structure is used to track
292 the progress of each potential match.
294 If there is no match we return the tag associated with the
295 terminating NULL mstring structure and leave the locus pointer
296 where it started. If there is a match we return the tag member of
297 the matched mstring and leave the locus pointer after the matched
300 A '%' character is a mandatory space. */
303 gfc_match_strings (mstring
* a
)
305 mstring
*p
, *best_match
;
306 int no_match
, c
, possibles
;
311 for (p
= a
; p
->string
!= NULL
; p
++)
320 match_loc
= gfc_current_locus
;
322 gfc_gobble_whitespace ();
324 while (possibles
> 0)
326 c
= gfc_next_char ();
328 /* Apply the next character to the current possibilities. */
329 for (p
= a
; p
->string
!= NULL
; p
++)
336 /* Space matches 1+ whitespace(s). */
337 if ((gfc_current_form
== FORM_FREE
)
338 && gfc_is_whitespace (c
))
356 match_loc
= gfc_current_locus
;
364 gfc_current_locus
= match_loc
;
366 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
370 /* See if the current input looks like a name of some sort. Modifies
371 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
374 gfc_match_name (char *buffer
)
379 old_loc
= gfc_current_locus
;
380 gfc_gobble_whitespace ();
382 c
= gfc_next_char ();
385 gfc_current_locus
= old_loc
;
395 if (i
> gfc_option
.max_identifier_length
)
397 gfc_error ("Name at %C is too long");
401 old_loc
= gfc_current_locus
;
402 c
= gfc_next_char ();
406 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
409 gfc_current_locus
= old_loc
;
415 /* Match a symbol on the input. Modifies the pointer to the symbol
416 pointer if successful. */
419 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
421 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
424 m
= gfc_match_name (buffer
);
429 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
430 ? MATCH_ERROR
: MATCH_YES
;
432 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
440 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
445 m
= gfc_match_sym_tree (&st
, host_assoc
);
450 *matched_symbol
= st
->n
.sym
;
452 *matched_symbol
= NULL
;
457 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
458 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
462 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
466 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
468 if (op
== INTRINSIC_NONE
)
476 /* Match a loop control phrase:
478 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
480 If the final integer expression is not present, a constant unity
481 expression is returned. We don't return MATCH_ERROR until after
482 the equals sign is seen. */
485 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
487 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
488 gfc_expr
*var
, *e1
, *e2
, *e3
;
492 /* Match the start of an iterator without affecting the symbol
495 start
= gfc_current_locus
;
496 m
= gfc_match (" %n =", name
);
497 gfc_current_locus
= start
;
502 m
= gfc_match_variable (&var
, 0);
506 gfc_match_char ('=');
510 if (var
->ref
!= NULL
)
512 gfc_error ("Loop variable at %C cannot be a sub-component");
516 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
518 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
519 var
->symtree
->n
.sym
->name
);
523 if (var
->symtree
->n
.sym
->attr
.pointer
)
525 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
529 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
532 if (m
== MATCH_ERROR
)
535 if (gfc_match_char (',') != MATCH_YES
)
538 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
541 if (m
== MATCH_ERROR
)
544 if (gfc_match_char (',') != MATCH_YES
)
546 e3
= gfc_int_expr (1);
550 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
551 if (m
== MATCH_ERROR
)
555 gfc_error ("Expected a step value in iterator at %C");
567 gfc_error ("Syntax error in iterator at %C");
578 /* Tries to match the next non-whitespace character on the input.
579 This subroutine does not return MATCH_ERROR. */
582 gfc_match_char (char c
)
586 where
= gfc_current_locus
;
587 gfc_gobble_whitespace ();
589 if (gfc_next_char () == c
)
592 gfc_current_locus
= where
;
597 /* General purpose matching subroutine. The target string is a
598 scanf-like format string in which spaces correspond to arbitrary
599 whitespace (including no whitespace), characters correspond to
600 themselves. The %-codes are:
602 %% Literal percent sign
603 %e Expression, pointer to a pointer is set
604 %s Symbol, pointer to the symbol is set
605 %n Name, character buffer is set to name
606 %t Matches end of statement.
607 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
608 %l Matches a statement label
609 %v Matches a variable expression (an lvalue)
610 % Matches a required space (in free form) and optional spaces. */
613 gfc_match (const char *target
, ...)
615 gfc_st_label
**label
;
624 old_loc
= gfc_current_locus
;
625 va_start (argp
, target
);
635 gfc_gobble_whitespace ();
646 vp
= va_arg (argp
, void **);
647 n
= gfc_match_expr ((gfc_expr
**) vp
);
658 vp
= va_arg (argp
, void **);
659 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
670 vp
= va_arg (argp
, void **);
671 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
682 np
= va_arg (argp
, char *);
683 n
= gfc_match_name (np
);
694 label
= va_arg (argp
, gfc_st_label
**);
695 n
= gfc_match_st_label (label
, 0);
706 ip
= va_arg (argp
, int *);
707 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
718 if (gfc_match_eos () != MATCH_YES
)
726 if (gfc_match_space () == MATCH_YES
)
732 break; /* Fall through to character matcher */
735 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
739 if (c
== gfc_next_char ())
749 /* Clean up after a failed match. */
750 gfc_current_locus
= old_loc
;
751 va_start (argp
, target
);
754 for (; matches
> 0; matches
--)
764 /* Matches that don't have to be undone */
769 (void)va_arg (argp
, void **);
774 vp
= va_arg (argp
, void **);
788 /*********************** Statement level matching **********************/
790 /* Matches the start of a program unit, which is the program keyword
791 followed by an obligatory symbol. */
794 gfc_match_program (void)
799 m
= gfc_match ("% %s%t", &sym
);
803 gfc_error ("Invalid form of PROGRAM statement at %C");
807 if (m
== MATCH_ERROR
)
810 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
819 /* Match a simple assignment statement. */
822 gfc_match_assignment (void)
824 gfc_expr
*lvalue
, *rvalue
;
828 old_loc
= gfc_current_locus
;
830 lvalue
= rvalue
= NULL
;
831 m
= gfc_match (" %v =", &lvalue
);
835 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
837 gfc_error ("Cannot assign to a PARAMETER variable at %C");
842 m
= gfc_match (" %e%t", &rvalue
);
846 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
848 new_st
.op
= EXEC_ASSIGN
;
849 new_st
.expr
= lvalue
;
850 new_st
.expr2
= rvalue
;
852 gfc_check_do_variable (lvalue
->symtree
);
857 gfc_current_locus
= old_loc
;
858 gfc_free_expr (lvalue
);
859 gfc_free_expr (rvalue
);
864 /* Match a pointer assignment statement. */
867 gfc_match_pointer_assignment (void)
869 gfc_expr
*lvalue
, *rvalue
;
873 old_loc
= gfc_current_locus
;
875 lvalue
= rvalue
= NULL
;
877 m
= gfc_match (" %v =>", &lvalue
);
884 m
= gfc_match (" %e%t", &rvalue
);
888 new_st
.op
= EXEC_POINTER_ASSIGN
;
889 new_st
.expr
= lvalue
;
890 new_st
.expr2
= rvalue
;
895 gfc_current_locus
= old_loc
;
896 gfc_free_expr (lvalue
);
897 gfc_free_expr (rvalue
);
902 /* The IF statement is a bit of a pain. First of all, there are three
903 forms of it, the simple IF, the IF that starts a block and the
906 There is a problem with the simple IF and that is the fact that we
907 only have a single level of undo information on symbols. What this
908 means is for a simple IF, we must re-match the whole IF statement
909 multiple times in order to guarantee that the symbol table ends up
910 in the proper state. */
912 static match
match_simple_forall (void);
913 static match
match_simple_where (void);
916 gfc_match_if (gfc_statement
* if_type
)
919 gfc_st_label
*l1
, *l2
, *l3
;
924 n
= gfc_match_label ();
925 if (n
== MATCH_ERROR
)
928 old_loc
= gfc_current_locus
;
930 m
= gfc_match (" if ( %e", &expr
);
934 if (gfc_match_char (')') != MATCH_YES
)
936 gfc_error ("Syntax error in IF-expression at %C");
937 gfc_free_expr (expr
);
941 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
948 ("Block label not appropriate for arithmetic IF statement "
951 gfc_free_expr (expr
);
955 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
956 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
957 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
960 gfc_free_expr (expr
);
964 new_st
.op
= EXEC_ARITHMETIC_IF
;
970 *if_type
= ST_ARITHMETIC_IF
;
974 if (gfc_match (" then%t") == MATCH_YES
)
979 *if_type
= ST_IF_BLOCK
;
985 gfc_error ("Block label is not appropriate IF statement at %C");
987 gfc_free_expr (expr
);
991 /* At this point the only thing left is a simple IF statement. At
992 this point, n has to be MATCH_NO, so we don't have to worry about
993 re-matching a block label. From what we've got so far, try
994 matching an assignment. */
996 *if_type
= ST_SIMPLE_IF
;
998 m
= gfc_match_assignment ();
1002 gfc_free_expr (expr
);
1003 gfc_undo_symbols ();
1004 gfc_current_locus
= old_loc
;
1006 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1008 m
= gfc_match_pointer_assignment ();
1012 gfc_free_expr (expr
);
1013 gfc_undo_symbols ();
1014 gfc_current_locus
= old_loc
;
1016 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1018 /* Look at the next keyword to see which matcher to call. Matching
1019 the keyword doesn't affect the symbol table, so we don't have to
1020 restore between tries. */
1022 #define match(string, subr, statement) \
1023 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1027 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1028 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1029 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1030 match ("call", gfc_match_call
, ST_CALL
)
1031 match ("close", gfc_match_close
, ST_CLOSE
)
1032 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1033 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1034 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1035 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1036 match ("exit", gfc_match_exit
, ST_EXIT
)
1037 match ("forall", match_simple_forall
, ST_FORALL
)
1038 match ("go to", gfc_match_goto
, ST_GOTO
)
1039 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1040 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1041 match ("open", gfc_match_open
, ST_OPEN
)
1042 match ("pause", gfc_match_pause
, ST_NONE
)
1043 match ("print", gfc_match_print
, ST_WRITE
)
1044 match ("read", gfc_match_read
, ST_READ
)
1045 match ("return", gfc_match_return
, ST_RETURN
)
1046 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1047 match ("stop", gfc_match_stop
, ST_STOP
)
1048 match ("where", match_simple_where
, ST_WHERE
)
1049 match ("write", gfc_match_write
, ST_WRITE
)
1051 /* All else has failed, so give up. See if any of the matchers has
1052 stored an error message of some sort. */
1053 if (gfc_error_check () == 0)
1054 gfc_error ("Unclassifiable statement in IF-clause at %C");
1056 gfc_free_expr (expr
);
1061 gfc_error ("Syntax error in IF-clause at %C");
1064 gfc_free_expr (expr
);
1068 /* At this point, we've matched the single IF and the action clause
1069 is in new_st. Rearrange things so that the IF statement appears
1072 p
= gfc_get_code ();
1073 p
->next
= gfc_get_code ();
1075 p
->next
->loc
= gfc_current_locus
;
1080 gfc_clear_new_st ();
1082 new_st
.op
= EXEC_IF
;
1091 /* Match an ELSE statement. */
1094 gfc_match_else (void)
1096 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1098 if (gfc_match_eos () == MATCH_YES
)
1101 if (gfc_match_name (name
) != MATCH_YES
1102 || gfc_current_block () == NULL
1103 || gfc_match_eos () != MATCH_YES
)
1105 gfc_error ("Unexpected junk after ELSE statement at %C");
1109 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1111 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1112 name
, gfc_current_block ()->name
);
1120 /* Match an ELSE IF statement. */
1123 gfc_match_elseif (void)
1125 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1129 m
= gfc_match (" ( %e ) then", &expr
);
1133 if (gfc_match_eos () == MATCH_YES
)
1136 if (gfc_match_name (name
) != MATCH_YES
1137 || gfc_current_block () == NULL
1138 || gfc_match_eos () != MATCH_YES
)
1140 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1144 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1146 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1147 name
, gfc_current_block ()->name
);
1152 new_st
.op
= EXEC_IF
;
1157 gfc_free_expr (expr
);
1162 /* Free a gfc_iterator structure. */
1165 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1171 gfc_free_expr (iter
->var
);
1172 gfc_free_expr (iter
->start
);
1173 gfc_free_expr (iter
->end
);
1174 gfc_free_expr (iter
->step
);
1181 /* Match a DO statement. */
1186 gfc_iterator iter
, *ip
;
1188 gfc_st_label
*label
;
1191 old_loc
= gfc_current_locus
;
1194 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1196 m
= gfc_match_label ();
1197 if (m
== MATCH_ERROR
)
1200 if (gfc_match (" do") != MATCH_YES
)
1203 m
= gfc_match_st_label (&label
, 0);
1204 if (m
== MATCH_ERROR
)
1207 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1209 if (gfc_match_eos () == MATCH_YES
)
1211 iter
.end
= gfc_logical_expr (1, NULL
);
1212 new_st
.op
= EXEC_DO_WHILE
;
1216 /* match an optional comma, if no comma is found a space is obligatory. */
1217 if (gfc_match_char(',') != MATCH_YES
1218 && gfc_match ("% ") != MATCH_YES
)
1221 /* See if we have a DO WHILE. */
1222 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1224 new_st
.op
= EXEC_DO_WHILE
;
1228 /* The abortive DO WHILE may have done something to the symbol
1229 table, so we start over: */
1230 gfc_undo_symbols ();
1231 gfc_current_locus
= old_loc
;
1233 gfc_match_label (); /* This won't error */
1234 gfc_match (" do "); /* This will work */
1236 gfc_match_st_label (&label
, 0); /* Can't error out */
1237 gfc_match_char (','); /* Optional comma */
1239 m
= gfc_match_iterator (&iter
, 0);
1242 if (m
== MATCH_ERROR
)
1245 gfc_check_do_variable (iter
.var
->symtree
);
1247 if (gfc_match_eos () != MATCH_YES
)
1249 gfc_syntax_error (ST_DO
);
1253 new_st
.op
= EXEC_DO
;
1257 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1260 new_st
.label
= label
;
1262 if (new_st
.op
== EXEC_DO_WHILE
)
1263 new_st
.expr
= iter
.end
;
1266 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1273 gfc_free_iterator (&iter
, 0);
1279 /* Match an EXIT or CYCLE statement. */
1282 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1288 if (gfc_match_eos () == MATCH_YES
)
1292 m
= gfc_match ("% %s%t", &sym
);
1293 if (m
== MATCH_ERROR
)
1297 gfc_syntax_error (st
);
1301 if (sym
->attr
.flavor
!= FL_LABEL
)
1303 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1304 sym
->name
, gfc_ascii_statement (st
));
1309 /* Find the loop mentioned specified by the label (or lack of a
1311 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1312 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1318 gfc_error ("%s statement at %C is not within a loop",
1319 gfc_ascii_statement (st
));
1321 gfc_error ("%s statement at %C is not within loop '%s'",
1322 gfc_ascii_statement (st
), sym
->name
);
1327 /* Save the first statement in the loop - needed by the backend. */
1328 new_st
.ext
.whichloop
= p
->head
;
1331 /* new_st.sym = sym;*/
1337 /* Match the EXIT statement. */
1340 gfc_match_exit (void)
1343 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1347 /* Match the CYCLE statement. */
1350 gfc_match_cycle (void)
1353 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1357 /* Match a number or character constant after a STOP or PAUSE statement. */
1360 gfc_match_stopcode (gfc_statement st
)
1369 if (gfc_match_eos () != MATCH_YES
)
1371 m
= gfc_match_small_literal_int (&stop_code
);
1372 if (m
== MATCH_ERROR
)
1375 if (m
== MATCH_YES
&& stop_code
> 99999)
1377 gfc_error ("STOP code out of range at %C");
1383 /* Try a character constant. */
1384 m
= gfc_match_expr (&e
);
1385 if (m
== MATCH_ERROR
)
1389 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1393 if (gfc_match_eos () != MATCH_YES
)
1397 if (gfc_pure (NULL
))
1399 gfc_error ("%s statement not allowed in PURE procedure at %C",
1400 gfc_ascii_statement (st
));
1404 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1406 new_st
.ext
.stop_code
= stop_code
;
1411 gfc_syntax_error (st
);
1419 /* Match the (deprecated) PAUSE statement. */
1422 gfc_match_pause (void)
1426 m
= gfc_match_stopcode (ST_PAUSE
);
1429 if (gfc_notify_std (GFC_STD_F95_DEL
,
1430 "Obsolete: PAUSE statement at %C")
1438 /* Match the STOP statement. */
1441 gfc_match_stop (void)
1443 return gfc_match_stopcode (ST_STOP
);
1447 /* Match a CONTINUE statement. */
1450 gfc_match_continue (void)
1453 if (gfc_match_eos () != MATCH_YES
)
1455 gfc_syntax_error (ST_CONTINUE
);
1459 new_st
.op
= EXEC_CONTINUE
;
1464 /* Match the (deprecated) ASSIGN statement. */
1467 gfc_match_assign (void)
1470 gfc_st_label
*label
;
1472 if (gfc_match (" %l", &label
) == MATCH_YES
)
1474 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1476 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1478 if (gfc_notify_std (GFC_STD_F95_DEL
,
1479 "Obsolete: ASSIGN statement at %C")
1483 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1485 new_st
.op
= EXEC_LABEL_ASSIGN
;
1486 new_st
.label
= label
;
1495 /* Match the GO TO statement. As a computed GOTO statement is
1496 matched, it is transformed into an equivalent SELECT block. No
1497 tree is necessary, and the resulting jumps-to-jumps are
1498 specifically optimized away by the back end. */
1501 gfc_match_goto (void)
1503 gfc_code
*head
, *tail
;
1506 gfc_st_label
*label
;
1510 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1512 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1515 new_st
.op
= EXEC_GOTO
;
1516 new_st
.label
= label
;
1520 /* The assigned GO TO statement. */
1522 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1524 if (gfc_notify_std (GFC_STD_F95_DEL
,
1525 "Obsolete: Assigned GOTO statement at %C")
1529 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1530 new_st
.op
= EXEC_GOTO
;
1533 if (gfc_match_eos () == MATCH_YES
)
1536 /* Match label list. */
1537 gfc_match_char (',');
1538 if (gfc_match_char ('(') != MATCH_YES
)
1540 gfc_syntax_error (ST_GOTO
);
1547 m
= gfc_match_st_label (&label
, 0);
1551 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1555 head
= tail
= gfc_get_code ();
1558 tail
->block
= gfc_get_code ();
1562 tail
->label
= label
;
1563 tail
->op
= EXEC_GOTO
;
1565 while (gfc_match_char (',') == MATCH_YES
);
1567 if (gfc_match (")%t") != MATCH_YES
)
1573 "Statement label list in GOTO at %C cannot be empty");
1576 new_st
.block
= head
;
1581 /* Last chance is a computed GO TO statement. */
1582 if (gfc_match_char ('(') != MATCH_YES
)
1584 gfc_syntax_error (ST_GOTO
);
1593 m
= gfc_match_st_label (&label
, 0);
1597 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1601 head
= tail
= gfc_get_code ();
1604 tail
->block
= gfc_get_code ();
1608 cp
= gfc_get_case ();
1609 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1611 tail
->op
= EXEC_SELECT
;
1612 tail
->ext
.case_list
= cp
;
1614 tail
->next
= gfc_get_code ();
1615 tail
->next
->op
= EXEC_GOTO
;
1616 tail
->next
->label
= label
;
1618 while (gfc_match_char (',') == MATCH_YES
);
1620 if (gfc_match_char (')') != MATCH_YES
)
1625 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1629 /* Get the rest of the statement. */
1630 gfc_match_char (',');
1632 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1635 /* At this point, a computed GOTO has been fully matched and an
1636 equivalent SELECT statement constructed. */
1638 new_st
.op
= EXEC_SELECT
;
1641 /* Hack: For a "real" SELECT, the expression is in expr. We put
1642 it in expr2 so we can distinguish then and produce the correct
1644 new_st
.expr2
= expr
;
1645 new_st
.block
= head
;
1649 gfc_syntax_error (ST_GOTO
);
1651 gfc_free_statements (head
);
1656 /* Frees a list of gfc_alloc structures. */
1659 gfc_free_alloc_list (gfc_alloc
* p
)
1666 gfc_free_expr (p
->expr
);
1672 /* Match an ALLOCATE statement. */
1675 gfc_match_allocate (void)
1677 gfc_alloc
*head
, *tail
;
1684 if (gfc_match_char ('(') != MATCH_YES
)
1690 head
= tail
= gfc_get_alloc ();
1693 tail
->next
= gfc_get_alloc ();
1697 m
= gfc_match_variable (&tail
->expr
, 0);
1700 if (m
== MATCH_ERROR
)
1703 if (gfc_check_do_variable (tail
->expr
->symtree
))
1707 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1709 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1714 if (gfc_match_char (',') != MATCH_YES
)
1717 m
= gfc_match (" stat = %v", &stat
);
1718 if (m
== MATCH_ERROR
)
1726 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1729 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1730 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1734 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1737 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1742 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1744 gfc_error("STAT expression at %C must be a variable");
1748 gfc_check_do_variable(stat
->symtree
);
1751 if (gfc_match (" )%t") != MATCH_YES
)
1754 new_st
.op
= EXEC_ALLOCATE
;
1756 new_st
.ext
.alloc_list
= head
;
1761 gfc_syntax_error (ST_ALLOCATE
);
1764 gfc_free_expr (stat
);
1765 gfc_free_alloc_list (head
);
1770 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1771 a set of pointer assignments to intrinsic NULL(). */
1774 gfc_match_nullify (void)
1782 if (gfc_match_char ('(') != MATCH_YES
)
1787 m
= gfc_match_variable (&p
, 0);
1788 if (m
== MATCH_ERROR
)
1793 if (gfc_check_do_variable(p
->symtree
))
1796 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1799 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1803 /* build ' => NULL() ' */
1804 e
= gfc_get_expr ();
1805 e
->where
= gfc_current_locus
;
1806 e
->expr_type
= EXPR_NULL
;
1807 e
->ts
.type
= BT_UNKNOWN
;
1814 tail
->next
= gfc_get_code ();
1818 tail
->op
= EXEC_POINTER_ASSIGN
;
1822 if (gfc_match (" )%t") == MATCH_YES
)
1824 if (gfc_match_char (',') != MATCH_YES
)
1831 gfc_syntax_error (ST_NULLIFY
);
1834 gfc_free_statements (tail
);
1839 /* Match a DEALLOCATE statement. */
1842 gfc_match_deallocate (void)
1844 gfc_alloc
*head
, *tail
;
1851 if (gfc_match_char ('(') != MATCH_YES
)
1857 head
= tail
= gfc_get_alloc ();
1860 tail
->next
= gfc_get_alloc ();
1864 m
= gfc_match_variable (&tail
->expr
, 0);
1865 if (m
== MATCH_ERROR
)
1870 if (gfc_check_do_variable (tail
->expr
->symtree
))
1874 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1877 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1882 if (gfc_match_char (',') != MATCH_YES
)
1885 m
= gfc_match (" stat = %v", &stat
);
1886 if (m
== MATCH_ERROR
)
1894 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1896 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1897 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1901 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1903 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1904 "for a PURE procedure");
1908 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1910 gfc_error("STAT expression at %C must be a variable");
1914 gfc_check_do_variable(stat
->symtree
);
1917 if (gfc_match (" )%t") != MATCH_YES
)
1920 new_st
.op
= EXEC_DEALLOCATE
;
1922 new_st
.ext
.alloc_list
= head
;
1927 gfc_syntax_error (ST_DEALLOCATE
);
1930 gfc_free_expr (stat
);
1931 gfc_free_alloc_list (head
);
1936 /* Match a RETURN statement. */
1939 gfc_match_return (void)
1943 gfc_compile_state s
;
1945 gfc_enclosing_unit (&s
);
1946 if (s
== COMP_PROGRAM
1947 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
1948 "main program at %C") == FAILURE
)
1952 if (gfc_match_eos () == MATCH_YES
)
1955 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
1957 gfc_error ("Alternate RETURN statement at %C is only allowed within "
1962 m
= gfc_match ("% %e%t", &e
);
1965 if (m
== MATCH_ERROR
)
1968 gfc_syntax_error (ST_RETURN
);
1975 new_st
.op
= EXEC_RETURN
;
1982 /* Match a CALL statement. The tricky part here are possible
1983 alternate return specifiers. We handle these by having all
1984 "subroutines" actually return an integer via a register that gives
1985 the return number. If the call specifies alternate returns, we
1986 generate code for a SELECT statement whose case clauses contain
1987 GOTOs to the various labels. */
1990 gfc_match_call (void)
1992 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1993 gfc_actual_arglist
*a
, *arglist
;
2003 m
= gfc_match ("% %n", name
);
2009 if (gfc_get_ha_sym_tree (name
, &st
))
2013 gfc_set_sym_referenced (sym
);
2015 if (!sym
->attr
.generic
2016 && !sym
->attr
.subroutine
2017 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2020 if (gfc_match_eos () != MATCH_YES
)
2022 m
= gfc_match_actual_arglist (1, &arglist
);
2025 if (m
== MATCH_ERROR
)
2028 if (gfc_match_eos () != MATCH_YES
)
2032 /* If any alternate return labels were found, construct a SELECT
2033 statement that will jump to the right place. */
2036 for (a
= arglist
; a
; a
= a
->next
)
2037 if (a
->expr
== NULL
)
2042 gfc_symtree
*select_st
;
2043 gfc_symbol
*select_sym
;
2044 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2046 new_st
.next
= c
= gfc_get_code ();
2047 c
->op
= EXEC_SELECT
;
2048 sprintf (name
, "_result_%s",sym
->name
);
2049 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2051 select_sym
= select_st
->n
.sym
;
2052 select_sym
->ts
.type
= BT_INTEGER
;
2053 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2054 gfc_set_sym_referenced (select_sym
);
2055 c
->expr
= gfc_get_expr ();
2056 c
->expr
->expr_type
= EXPR_VARIABLE
;
2057 c
->expr
->symtree
= select_st
;
2058 c
->expr
->ts
= select_sym
->ts
;
2059 c
->expr
->where
= gfc_current_locus
;
2062 for (a
= arglist
; a
; a
= a
->next
)
2064 if (a
->expr
!= NULL
)
2067 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2072 c
->block
= gfc_get_code ();
2074 c
->op
= EXEC_SELECT
;
2076 new_case
= gfc_get_case ();
2077 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2078 c
->ext
.case_list
= new_case
;
2080 c
->next
= gfc_get_code ();
2081 c
->next
->op
= EXEC_GOTO
;
2082 c
->next
->label
= a
->label
;
2086 new_st
.op
= EXEC_CALL
;
2087 new_st
.symtree
= st
;
2088 new_st
.ext
.actual
= arglist
;
2093 gfc_syntax_error (ST_CALL
);
2096 gfc_free_actual_arglist (arglist
);
2101 /* Given a name, return a pointer to the common head structure,
2102 creating it if it does not exist. If FROM_MODULE is nonzero, we
2103 mangle the name so that it doesn't interfere with commons defined
2104 in the using namespace.
2105 TODO: Add to global symbol tree. */
2108 gfc_get_common (const char *name
, int from_module
)
2111 static int serial
= 0;
2112 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2116 /* A use associated common block is only needed to correctly layout
2117 the variables it contains. */
2118 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2119 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2123 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2126 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2129 if (st
->n
.common
== NULL
)
2131 st
->n
.common
= gfc_get_common_head ();
2132 st
->n
.common
->where
= gfc_current_locus
;
2133 strcpy (st
->n
.common
->name
, name
);
2136 return st
->n
.common
;
2140 /* Match a common block name. */
2143 match_common_name (char *name
)
2147 if (gfc_match_char ('/') == MATCH_NO
)
2153 if (gfc_match_char ('/') == MATCH_YES
)
2159 m
= gfc_match_name (name
);
2161 if (m
== MATCH_ERROR
)
2163 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2166 gfc_error ("Syntax error in common block name at %C");
2171 /* Match a COMMON statement. */
2174 gfc_match_common (void)
2176 gfc_symbol
*sym
, **head
, *tail
, *old_blank_common
;
2177 char name
[GFC_MAX_SYMBOL_LEN
+1];
2182 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2183 if (old_blank_common
)
2185 while (old_blank_common
->common_next
)
2186 old_blank_common
= old_blank_common
->common_next
;
2191 if (gfc_match_eos () == MATCH_YES
)
2196 m
= match_common_name (name
);
2197 if (m
== MATCH_ERROR
)
2200 if (name
[0] == '\0')
2202 t
= &gfc_current_ns
->blank_common
;
2203 if (t
->head
== NULL
)
2204 t
->where
= gfc_current_locus
;
2209 t
= gfc_get_common (name
, 0);
2218 while (tail
->common_next
)
2219 tail
= tail
->common_next
;
2222 /* Grab the list of symbols. */
2223 if (gfc_match_eos () == MATCH_YES
)
2228 m
= gfc_match_symbol (&sym
, 0);
2229 if (m
== MATCH_ERROR
)
2234 if (sym
->attr
.in_common
)
2236 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2241 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2244 if (sym
->value
!= NULL
2245 && (name
[0] == '\0' || !sym
->attr
.data
))
2247 if (name
[0] == '\0')
2248 gfc_error ("Previously initialized symbol '%s' in "
2249 "blank COMMON block at %C", sym
->name
);
2251 gfc_error ("Previously initialized symbol '%s' in "
2252 "COMMON block '%s' at %C", sym
->name
, name
);
2256 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2259 /* Derived type names must have the SEQUENCE attribute. */
2260 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2263 ("Derived type variable in COMMON at %C does not have the "
2264 "SEQUENCE attribute");
2269 tail
->common_next
= sym
;
2275 /* Deal with an optional array specification after the
2277 m
= gfc_match_array_spec (&as
);
2278 if (m
== MATCH_ERROR
)
2283 if (as
->type
!= AS_EXPLICIT
)
2286 ("Array specification for symbol '%s' in COMMON at %C "
2287 "must be explicit", sym
->name
);
2291 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2294 if (sym
->attr
.pointer
)
2297 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2306 gfc_gobble_whitespace ();
2307 if (gfc_match_eos () == MATCH_YES
)
2309 if (gfc_peek_char () == '/')
2311 if (gfc_match_char (',') != MATCH_YES
)
2313 gfc_gobble_whitespace ();
2314 if (gfc_peek_char () == '/')
2323 gfc_syntax_error (ST_COMMON
);
2326 if (old_blank_common
)
2327 old_blank_common
->common_next
= NULL
;
2329 gfc_current_ns
->blank_common
.head
= NULL
;
2330 gfc_free_array_spec (as
);
2335 /* Match a BLOCK DATA program unit. */
2338 gfc_match_block_data (void)
2340 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2344 if (gfc_match_eos () == MATCH_YES
)
2346 gfc_new_block
= NULL
;
2350 m
= gfc_match ("% %n%t", name
);
2354 if (gfc_get_symbol (name
, NULL
, &sym
))
2357 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2360 gfc_new_block
= sym
;
2366 /* Free a namelist structure. */
2369 gfc_free_namelist (gfc_namelist
* name
)
2373 for (; name
; name
= n
)
2381 /* Match a NAMELIST statement. */
2384 gfc_match_namelist (void)
2386 gfc_symbol
*group_name
, *sym
;
2390 m
= gfc_match (" / %s /", &group_name
);
2393 if (m
== MATCH_ERROR
)
2398 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2401 ("Namelist group name '%s' at %C already has a basic type "
2402 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2406 if (group_name
->attr
.flavor
!= FL_NAMELIST
2407 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2408 group_name
->name
, NULL
) == FAILURE
)
2413 m
= gfc_match_symbol (&sym
, 1);
2416 if (m
== MATCH_ERROR
)
2419 if (sym
->attr
.in_namelist
== 0
2420 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2423 nl
= gfc_get_namelist ();
2426 if (group_name
->namelist
== NULL
)
2427 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2430 group_name
->namelist_tail
->next
= nl
;
2431 group_name
->namelist_tail
= nl
;
2434 if (gfc_match_eos () == MATCH_YES
)
2437 m
= gfc_match_char (',');
2439 if (gfc_match_char ('/') == MATCH_YES
)
2441 m2
= gfc_match (" %s /", &group_name
);
2442 if (m2
== MATCH_YES
)
2444 if (m2
== MATCH_ERROR
)
2458 gfc_syntax_error (ST_NAMELIST
);
2465 /* Match a MODULE statement. */
2468 gfc_match_module (void)
2472 m
= gfc_match (" %s%t", &gfc_new_block
);
2476 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2477 gfc_new_block
->name
, NULL
) == FAILURE
)
2484 /* Free equivalence sets and lists. Recursively is the easiest way to
2488 gfc_free_equiv (gfc_equiv
* eq
)
2494 gfc_free_equiv (eq
->eq
);
2495 gfc_free_equiv (eq
->next
);
2497 gfc_free_expr (eq
->expr
);
2502 /* Match an EQUIVALENCE statement. */
2505 gfc_match_equivalence (void)
2507 gfc_equiv
*eq
, *set
, *tail
;
2515 eq
= gfc_get_equiv ();
2519 eq
->next
= gfc_current_ns
->equiv
;
2520 gfc_current_ns
->equiv
= eq
;
2522 if (gfc_match_char ('(') != MATCH_YES
)
2529 m
= gfc_match_variable (&set
->expr
, 1);
2530 if (m
== MATCH_ERROR
)
2535 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2536 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2539 ("Array reference in EQUIVALENCE at %C cannot be an "
2544 if (gfc_match_char (')') == MATCH_YES
)
2546 if (gfc_match_char (',') != MATCH_YES
)
2549 set
->eq
= gfc_get_equiv ();
2553 if (gfc_match_eos () == MATCH_YES
)
2555 if (gfc_match_char (',') != MATCH_YES
)
2562 gfc_syntax_error (ST_EQUIVALENCE
);
2568 gfc_free_equiv (gfc_current_ns
->equiv
);
2569 gfc_current_ns
->equiv
= eq
;
2575 /* Match a statement function declaration. It is so easy to match
2576 non-statement function statements with a MATCH_ERROR as opposed to
2577 MATCH_NO that we suppress error message in most cases. */
2580 gfc_match_st_function (void)
2582 gfc_error_buf old_error
;
2587 m
= gfc_match_symbol (&sym
, 0);
2591 gfc_push_error (&old_error
);
2593 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2594 sym
->name
, NULL
) == FAILURE
)
2597 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2600 m
= gfc_match (" = %e%t", &expr
);
2603 if (m
== MATCH_ERROR
)
2611 gfc_pop_error (&old_error
);
2616 /***************** SELECT CASE subroutines ******************/
2618 /* Free a single case structure. */
2621 free_case (gfc_case
* p
)
2623 if (p
->low
== p
->high
)
2625 gfc_free_expr (p
->low
);
2626 gfc_free_expr (p
->high
);
2631 /* Free a list of case structures. */
2634 gfc_free_case_list (gfc_case
* p
)
2646 /* Match a single case selector. */
2649 match_case_selector (gfc_case
** cp
)
2654 c
= gfc_get_case ();
2655 c
->where
= gfc_current_locus
;
2657 if (gfc_match_char (':') == MATCH_YES
)
2659 m
= gfc_match_init_expr (&c
->high
);
2662 if (m
== MATCH_ERROR
)
2668 m
= gfc_match_init_expr (&c
->low
);
2669 if (m
== MATCH_ERROR
)
2674 /* If we're not looking at a ':' now, make a range out of a single
2675 target. Else get the upper bound for the case range. */
2676 if (gfc_match_char (':') != MATCH_YES
)
2680 m
= gfc_match_init_expr (&c
->high
);
2681 if (m
== MATCH_ERROR
)
2683 /* MATCH_NO is fine. It's OK if nothing is there! */
2691 gfc_error ("Expected initialization expression in CASE at %C");
2699 /* Match the end of a case statement. */
2702 match_case_eos (void)
2704 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2707 if (gfc_match_eos () == MATCH_YES
)
2710 gfc_gobble_whitespace ();
2712 m
= gfc_match_name (name
);
2716 if (strcmp (name
, gfc_current_block ()->name
) != 0)
2718 gfc_error ("Expected case name of '%s' at %C",
2719 gfc_current_block ()->name
);
2723 return gfc_match_eos ();
2727 /* Match a SELECT statement. */
2730 gfc_match_select (void)
2735 m
= gfc_match_label ();
2736 if (m
== MATCH_ERROR
)
2739 m
= gfc_match (" select case ( %e )%t", &expr
);
2743 new_st
.op
= EXEC_SELECT
;
2750 /* Match a CASE statement. */
2753 gfc_match_case (void)
2755 gfc_case
*c
, *head
, *tail
;
2760 if (gfc_current_state () != COMP_SELECT
)
2762 gfc_error ("Unexpected CASE statement at %C");
2766 if (gfc_match ("% default") == MATCH_YES
)
2768 m
= match_case_eos ();
2771 if (m
== MATCH_ERROR
)
2774 new_st
.op
= EXEC_SELECT
;
2775 c
= gfc_get_case ();
2776 c
->where
= gfc_current_locus
;
2777 new_st
.ext
.case_list
= c
;
2781 if (gfc_match_char ('(') != MATCH_YES
)
2786 if (match_case_selector (&c
) == MATCH_ERROR
)
2796 if (gfc_match_char (')') == MATCH_YES
)
2798 if (gfc_match_char (',') != MATCH_YES
)
2802 m
= match_case_eos ();
2805 if (m
== MATCH_ERROR
)
2808 new_st
.op
= EXEC_SELECT
;
2809 new_st
.ext
.case_list
= head
;
2814 gfc_error ("Syntax error in CASE-specification at %C");
2817 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
2821 /********************* WHERE subroutines ********************/
2823 /* Match the rest of a simple WHERE statement that follows an IF statement.
2827 match_simple_where (void)
2833 m
= gfc_match (" ( %e )", &expr
);
2837 m
= gfc_match_assignment ();
2840 if (m
== MATCH_ERROR
)
2843 if (gfc_match_eos () != MATCH_YES
)
2846 c
= gfc_get_code ();
2850 c
->next
= gfc_get_code ();
2853 gfc_clear_new_st ();
2855 new_st
.op
= EXEC_WHERE
;
2861 gfc_syntax_error (ST_WHERE
);
2864 gfc_free_expr (expr
);
2868 /* Match a WHERE statement. */
2871 gfc_match_where (gfc_statement
* st
)
2877 m0
= gfc_match_label ();
2878 if (m0
== MATCH_ERROR
)
2881 m
= gfc_match (" where ( %e )", &expr
);
2885 if (gfc_match_eos () == MATCH_YES
)
2887 *st
= ST_WHERE_BLOCK
;
2889 new_st
.op
= EXEC_WHERE
;
2894 m
= gfc_match_assignment ();
2896 gfc_syntax_error (ST_WHERE
);
2900 gfc_free_expr (expr
);
2904 /* We've got a simple WHERE statement. */
2906 c
= gfc_get_code ();
2910 c
->next
= gfc_get_code ();
2913 gfc_clear_new_st ();
2915 new_st
.op
= EXEC_WHERE
;
2922 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
2923 new_st if successful. */
2926 gfc_match_elsewhere (void)
2928 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2932 if (gfc_current_state () != COMP_WHERE
)
2934 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2940 if (gfc_match_char ('(') == MATCH_YES
)
2942 m
= gfc_match_expr (&expr
);
2945 if (m
== MATCH_ERROR
)
2948 if (gfc_match_char (')') != MATCH_YES
)
2952 if (gfc_match_eos () != MATCH_YES
)
2953 { /* Better be a name at this point */
2954 m
= gfc_match_name (name
);
2957 if (m
== MATCH_ERROR
)
2960 if (gfc_match_eos () != MATCH_YES
)
2963 if (strcmp (name
, gfc_current_block ()->name
) != 0)
2965 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
2966 name
, gfc_current_block ()->name
);
2971 new_st
.op
= EXEC_WHERE
;
2976 gfc_syntax_error (ST_ELSEWHERE
);
2979 gfc_free_expr (expr
);
2984 /******************** FORALL subroutines ********************/
2986 /* Free a list of FORALL iterators. */
2989 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
2991 gfc_forall_iterator
*next
;
2997 gfc_free_expr (iter
->var
);
2998 gfc_free_expr (iter
->start
);
2999 gfc_free_expr (iter
->end
);
3000 gfc_free_expr (iter
->stride
);
3008 /* Match an iterator as part of a FORALL statement. The format is:
3010 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3013 match_forall_iterator (gfc_forall_iterator
** result
)
3015 gfc_forall_iterator
*iter
;
3019 where
= gfc_current_locus
;
3020 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3022 m
= gfc_match_variable (&iter
->var
, 0);
3026 if (gfc_match_char ('=') != MATCH_YES
)
3032 m
= gfc_match_expr (&iter
->start
);
3035 if (m
== MATCH_ERROR
)
3038 if (gfc_match_char (':') != MATCH_YES
)
3041 m
= gfc_match_expr (&iter
->end
);
3044 if (m
== MATCH_ERROR
)
3047 if (gfc_match_char (':') == MATCH_NO
)
3048 iter
->stride
= gfc_int_expr (1);
3051 m
= gfc_match_expr (&iter
->stride
);
3054 if (m
== MATCH_ERROR
)
3062 gfc_error ("Syntax error in FORALL iterator at %C");
3066 gfc_current_locus
= where
;
3067 gfc_free_forall_iterator (iter
);
3072 /* Match the header of a FORALL statement. */
3075 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3077 gfc_forall_iterator
*head
, *tail
, *new;
3080 gfc_gobble_whitespace ();
3085 if (gfc_match_char ('(') != MATCH_YES
)
3088 m
= match_forall_iterator (&new);
3089 if (m
== MATCH_ERROR
)
3098 if (gfc_match_char (',') != MATCH_YES
)
3101 m
= match_forall_iterator (&new);
3102 if (m
== MATCH_ERROR
)
3111 /* Have to have a mask expression */
3113 m
= gfc_match_expr (mask
);
3116 if (m
== MATCH_ERROR
)
3122 if (gfc_match_char (')') == MATCH_NO
)
3129 gfc_syntax_error (ST_FORALL
);
3132 gfc_free_expr (*mask
);
3133 gfc_free_forall_iterator (head
);
3138 /* Match the rest of a simple FORALL statement that follows an IF statement.
3142 match_simple_forall (void)
3144 gfc_forall_iterator
*head
;
3153 m
= match_forall_header (&head
, &mask
);
3160 m
= gfc_match_assignment ();
3162 if (m
== MATCH_ERROR
)
3166 m
= gfc_match_pointer_assignment ();
3167 if (m
== MATCH_ERROR
)
3173 c
= gfc_get_code ();
3175 c
->loc
= gfc_current_locus
;
3177 if (gfc_match_eos () != MATCH_YES
)
3180 gfc_clear_new_st ();
3181 new_st
.op
= EXEC_FORALL
;
3183 new_st
.ext
.forall_iterator
= head
;
3184 new_st
.block
= gfc_get_code ();
3186 new_st
.block
->op
= EXEC_FORALL
;
3187 new_st
.block
->next
= c
;
3192 gfc_syntax_error (ST_FORALL
);
3195 gfc_free_forall_iterator (head
);
3196 gfc_free_expr (mask
);
3202 /* Match a FORALL statement. */
3205 gfc_match_forall (gfc_statement
* st
)
3207 gfc_forall_iterator
*head
;
3216 m0
= gfc_match_label ();
3217 if (m0
== MATCH_ERROR
)
3220 m
= gfc_match (" forall");
3224 m
= match_forall_header (&head
, &mask
);
3225 if (m
== MATCH_ERROR
)
3230 if (gfc_match_eos () == MATCH_YES
)
3232 *st
= ST_FORALL_BLOCK
;
3234 new_st
.op
= EXEC_FORALL
;
3236 new_st
.ext
.forall_iterator
= head
;
3241 m
= gfc_match_assignment ();
3242 if (m
== MATCH_ERROR
)
3246 m
= gfc_match_pointer_assignment ();
3247 if (m
== MATCH_ERROR
)
3253 c
= gfc_get_code ();
3256 if (gfc_match_eos () != MATCH_YES
)
3259 gfc_clear_new_st ();
3260 new_st
.op
= EXEC_FORALL
;
3262 new_st
.ext
.forall_iterator
= head
;
3263 new_st
.block
= gfc_get_code ();
3265 new_st
.block
->op
= EXEC_FORALL
;
3266 new_st
.block
->next
= c
;
3272 gfc_syntax_error (ST_FORALL
);
3275 gfc_free_forall_iterator (head
);
3276 gfc_free_expr (mask
);
3277 gfc_free_statements (c
);