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, 51 Franklin Street, Fifth Floor, 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];
255 gfc_new_block
= NULL
;
257 m
= gfc_match (" %n :", name
);
261 if (gfc_get_symbol (name
, NULL
, &gfc_new_block
))
263 gfc_error ("Label name '%s' at %C is ambiguous", name
);
267 if (gfc_new_block
->attr
.flavor
== FL_LABEL
)
269 gfc_error ("Duplicate construct label '%s' at %C", name
);
273 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_LABEL
,
274 gfc_new_block
->name
, NULL
) == FAILURE
)
281 /* Try and match the input against an array of possibilities. If one
282 potential matching string is a substring of another, the longest
283 match takes precedence. Spaces in the target strings are optional
284 spaces that do not necessarily have to be found in the input
285 stream. In fixed mode, spaces never appear. If whitespace is
286 matched, it matches unlimited whitespace in the input. For this
287 reason, the 'mp' member of the mstring structure is used to track
288 the progress of each potential match.
290 If there is no match we return the tag associated with the
291 terminating NULL mstring structure and leave the locus pointer
292 where it started. If there is a match we return the tag member of
293 the matched mstring and leave the locus pointer after the matched
296 A '%' character is a mandatory space. */
299 gfc_match_strings (mstring
* a
)
301 mstring
*p
, *best_match
;
302 int no_match
, c
, possibles
;
307 for (p
= a
; p
->string
!= NULL
; p
++)
316 match_loc
= gfc_current_locus
;
318 gfc_gobble_whitespace ();
320 while (possibles
> 0)
322 c
= gfc_next_char ();
324 /* Apply the next character to the current possibilities. */
325 for (p
= a
; p
->string
!= NULL
; p
++)
332 /* Space matches 1+ whitespace(s). */
333 if ((gfc_current_form
== FORM_FREE
)
334 && gfc_is_whitespace (c
))
352 match_loc
= gfc_current_locus
;
360 gfc_current_locus
= match_loc
;
362 return (best_match
== NULL
) ? no_match
: best_match
->tag
;
366 /* See if the current input looks like a name of some sort. Modifies
367 the passed buffer which must be GFC_MAX_SYMBOL_LEN+1 bytes long. */
370 gfc_match_name (char *buffer
)
375 old_loc
= gfc_current_locus
;
376 gfc_gobble_whitespace ();
378 c
= gfc_next_char ();
381 gfc_current_locus
= old_loc
;
391 if (i
> gfc_option
.max_identifier_length
)
393 gfc_error ("Name at %C is too long");
397 old_loc
= gfc_current_locus
;
398 c
= gfc_next_char ();
402 || (gfc_option
.flag_dollar_ok
&& c
== '$'));
405 gfc_current_locus
= old_loc
;
411 /* Match a symbol on the input. Modifies the pointer to the symbol
412 pointer if successful. */
415 gfc_match_sym_tree (gfc_symtree
** matched_symbol
, int host_assoc
)
417 char buffer
[GFC_MAX_SYMBOL_LEN
+ 1];
420 m
= gfc_match_name (buffer
);
425 return (gfc_get_ha_sym_tree (buffer
, matched_symbol
))
426 ? MATCH_ERROR
: MATCH_YES
;
428 if (gfc_get_sym_tree (buffer
, NULL
, matched_symbol
))
436 gfc_match_symbol (gfc_symbol
** matched_symbol
, int host_assoc
)
441 m
= gfc_match_sym_tree (&st
, host_assoc
);
446 *matched_symbol
= st
->n
.sym
;
448 *matched_symbol
= NULL
;
453 /* Match an intrinsic operator. Returns an INTRINSIC enum. While matching,
454 we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this
458 gfc_match_intrinsic_op (gfc_intrinsic_op
* result
)
462 op
= (gfc_intrinsic_op
) gfc_match_strings (intrinsic_operators
);
464 if (op
== INTRINSIC_NONE
)
472 /* Match a loop control phrase:
474 <LVALUE> = <EXPR>, <EXPR> [, <EXPR> ]
476 If the final integer expression is not present, a constant unity
477 expression is returned. We don't return MATCH_ERROR until after
478 the equals sign is seen. */
481 gfc_match_iterator (gfc_iterator
* iter
, int init_flag
)
483 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
484 gfc_expr
*var
, *e1
, *e2
, *e3
;
488 /* Match the start of an iterator without affecting the symbol
491 start
= gfc_current_locus
;
492 m
= gfc_match (" %n =", name
);
493 gfc_current_locus
= start
;
498 m
= gfc_match_variable (&var
, 0);
502 gfc_match_char ('=');
506 if (var
->ref
!= NULL
)
508 gfc_error ("Loop variable at %C cannot be a sub-component");
512 if (var
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
514 gfc_error ("Loop variable '%s' at %C cannot be INTENT(IN)",
515 var
->symtree
->n
.sym
->name
);
519 if (var
->symtree
->n
.sym
->attr
.pointer
)
521 gfc_error ("Loop variable at %C cannot have the POINTER attribute");
525 m
= init_flag
? gfc_match_init_expr (&e1
) : gfc_match_expr (&e1
);
528 if (m
== MATCH_ERROR
)
531 if (gfc_match_char (',') != MATCH_YES
)
534 m
= init_flag
? gfc_match_init_expr (&e2
) : gfc_match_expr (&e2
);
537 if (m
== MATCH_ERROR
)
540 if (gfc_match_char (',') != MATCH_YES
)
542 e3
= gfc_int_expr (1);
546 m
= init_flag
? gfc_match_init_expr (&e3
) : gfc_match_expr (&e3
);
547 if (m
== MATCH_ERROR
)
551 gfc_error ("Expected a step value in iterator at %C");
563 gfc_error ("Syntax error in iterator at %C");
574 /* Tries to match the next non-whitespace character on the input.
575 This subroutine does not return MATCH_ERROR. */
578 gfc_match_char (char c
)
582 where
= gfc_current_locus
;
583 gfc_gobble_whitespace ();
585 if (gfc_next_char () == c
)
588 gfc_current_locus
= where
;
593 /* General purpose matching subroutine. The target string is a
594 scanf-like format string in which spaces correspond to arbitrary
595 whitespace (including no whitespace), characters correspond to
596 themselves. The %-codes are:
598 %% Literal percent sign
599 %e Expression, pointer to a pointer is set
600 %s Symbol, pointer to the symbol is set
601 %n Name, character buffer is set to name
602 %t Matches end of statement.
603 %o Matches an intrinsic operator, returned as an INTRINSIC enum.
604 %l Matches a statement label
605 %v Matches a variable expression (an lvalue)
606 % Matches a required space (in free form) and optional spaces. */
609 gfc_match (const char *target
, ...)
611 gfc_st_label
**label
;
620 old_loc
= gfc_current_locus
;
621 va_start (argp
, target
);
631 gfc_gobble_whitespace ();
642 vp
= va_arg (argp
, void **);
643 n
= gfc_match_expr ((gfc_expr
**) vp
);
654 vp
= va_arg (argp
, void **);
655 n
= gfc_match_variable ((gfc_expr
**) vp
, 0);
666 vp
= va_arg (argp
, void **);
667 n
= gfc_match_symbol ((gfc_symbol
**) vp
, 0);
678 np
= va_arg (argp
, char *);
679 n
= gfc_match_name (np
);
690 label
= va_arg (argp
, gfc_st_label
**);
691 n
= gfc_match_st_label (label
, 0);
702 ip
= va_arg (argp
, int *);
703 n
= gfc_match_intrinsic_op ((gfc_intrinsic_op
*) ip
);
714 if (gfc_match_eos () != MATCH_YES
)
722 if (gfc_match_space () == MATCH_YES
)
728 break; /* Fall through to character matcher */
731 gfc_internal_error ("gfc_match(): Bad match code %c", c
);
735 if (c
== gfc_next_char ())
745 /* Clean up after a failed match. */
746 gfc_current_locus
= old_loc
;
747 va_start (argp
, target
);
750 for (; matches
> 0; matches
--)
760 /* Matches that don't have to be undone */
765 (void)va_arg (argp
, void **);
770 vp
= va_arg (argp
, void **);
784 /*********************** Statement level matching **********************/
786 /* Matches the start of a program unit, which is the program keyword
787 followed by an obligatory symbol. */
790 gfc_match_program (void)
795 m
= gfc_match ("% %s%t", &sym
);
799 gfc_error ("Invalid form of PROGRAM statement at %C");
803 if (m
== MATCH_ERROR
)
806 if (gfc_add_flavor (&sym
->attr
, FL_PROGRAM
, sym
->name
, NULL
) == FAILURE
)
815 /* Match a simple assignment statement. */
818 gfc_match_assignment (void)
820 gfc_expr
*lvalue
, *rvalue
;
824 old_loc
= gfc_current_locus
;
826 lvalue
= rvalue
= NULL
;
827 m
= gfc_match (" %v =", &lvalue
);
831 if (lvalue
->symtree
->n
.sym
->attr
.flavor
== FL_PARAMETER
)
833 gfc_error ("Cannot assign to a PARAMETER variable at %C");
838 m
= gfc_match (" %e%t", &rvalue
);
842 gfc_set_sym_referenced (lvalue
->symtree
->n
.sym
);
844 new_st
.op
= EXEC_ASSIGN
;
845 new_st
.expr
= lvalue
;
846 new_st
.expr2
= rvalue
;
848 gfc_check_do_variable (lvalue
->symtree
);
853 gfc_current_locus
= old_loc
;
854 gfc_free_expr (lvalue
);
855 gfc_free_expr (rvalue
);
860 /* Match a pointer assignment statement. */
863 gfc_match_pointer_assignment (void)
865 gfc_expr
*lvalue
, *rvalue
;
869 old_loc
= gfc_current_locus
;
871 lvalue
= rvalue
= NULL
;
873 m
= gfc_match (" %v =>", &lvalue
);
880 m
= gfc_match (" %e%t", &rvalue
);
884 new_st
.op
= EXEC_POINTER_ASSIGN
;
885 new_st
.expr
= lvalue
;
886 new_st
.expr2
= rvalue
;
891 gfc_current_locus
= old_loc
;
892 gfc_free_expr (lvalue
);
893 gfc_free_expr (rvalue
);
898 /* We try to match an easy arithmetic IF statement. This only happens
899 when just after having encountered a simple IF statement. This code
900 is really duplicate with parts of the gfc_match_if code, but this is
903 match_arithmetic_if (void)
905 gfc_st_label
*l1
, *l2
, *l3
;
909 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
913 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
914 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
915 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
917 gfc_free_expr (expr
);
921 if (gfc_notify_std (GFC_STD_F95_DEL
,
922 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
925 new_st
.op
= EXEC_ARITHMETIC_IF
;
935 /* The IF statement is a bit of a pain. First of all, there are three
936 forms of it, the simple IF, the IF that starts a block and the
939 There is a problem with the simple IF and that is the fact that we
940 only have a single level of undo information on symbols. What this
941 means is for a simple IF, we must re-match the whole IF statement
942 multiple times in order to guarantee that the symbol table ends up
943 in the proper state. */
945 static match
match_simple_forall (void);
946 static match
match_simple_where (void);
949 gfc_match_if (gfc_statement
* if_type
)
952 gfc_st_label
*l1
, *l2
, *l3
;
957 n
= gfc_match_label ();
958 if (n
== MATCH_ERROR
)
961 old_loc
= gfc_current_locus
;
963 m
= gfc_match (" if ( %e", &expr
);
967 if (gfc_match_char (')') != MATCH_YES
)
969 gfc_error ("Syntax error in IF-expression at %C");
970 gfc_free_expr (expr
);
974 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
981 ("Block label not appropriate for arithmetic IF statement "
984 gfc_free_expr (expr
);
988 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
989 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
990 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
993 gfc_free_expr (expr
);
997 if (gfc_notify_std (GFC_STD_F95_DEL
,
998 "Obsolete: arithmetic IF statement at %C")
1002 new_st
.op
= EXEC_ARITHMETIC_IF
;
1008 *if_type
= ST_ARITHMETIC_IF
;
1012 if (gfc_match (" then%t") == MATCH_YES
)
1014 new_st
.op
= EXEC_IF
;
1017 *if_type
= ST_IF_BLOCK
;
1023 gfc_error ("Block label is not appropriate IF statement at %C");
1025 gfc_free_expr (expr
);
1029 /* At this point the only thing left is a simple IF statement. At
1030 this point, n has to be MATCH_NO, so we don't have to worry about
1031 re-matching a block label. From what we've got so far, try
1032 matching an assignment. */
1034 *if_type
= ST_SIMPLE_IF
;
1036 m
= gfc_match_assignment ();
1040 gfc_free_expr (expr
);
1041 gfc_undo_symbols ();
1042 gfc_current_locus
= old_loc
;
1044 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1046 m
= gfc_match_pointer_assignment ();
1050 gfc_free_expr (expr
);
1051 gfc_undo_symbols ();
1052 gfc_current_locus
= old_loc
;
1054 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1056 /* Look at the next keyword to see which matcher to call. Matching
1057 the keyword doesn't affect the symbol table, so we don't have to
1058 restore between tries. */
1060 #define match(string, subr, statement) \
1061 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1065 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1066 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1067 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1068 match ("call", gfc_match_call
, ST_CALL
)
1069 match ("close", gfc_match_close
, ST_CLOSE
)
1070 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1071 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1072 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1073 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1074 match ("exit", gfc_match_exit
, ST_EXIT
)
1075 match ("forall", match_simple_forall
, ST_FORALL
)
1076 match ("go to", gfc_match_goto
, ST_GOTO
)
1077 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1078 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1079 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1080 match ("open", gfc_match_open
, ST_OPEN
)
1081 match ("pause", gfc_match_pause
, ST_NONE
)
1082 match ("print", gfc_match_print
, ST_WRITE
)
1083 match ("read", gfc_match_read
, ST_READ
)
1084 match ("return", gfc_match_return
, ST_RETURN
)
1085 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1086 match ("stop", gfc_match_stop
, ST_STOP
)
1087 match ("where", match_simple_where
, ST_WHERE
)
1088 match ("write", gfc_match_write
, ST_WRITE
)
1090 /* All else has failed, so give up. See if any of the matchers has
1091 stored an error message of some sort. */
1092 if (gfc_error_check () == 0)
1093 gfc_error ("Unclassifiable statement in IF-clause at %C");
1095 gfc_free_expr (expr
);
1100 gfc_error ("Syntax error in IF-clause at %C");
1103 gfc_free_expr (expr
);
1107 /* At this point, we've matched the single IF and the action clause
1108 is in new_st. Rearrange things so that the IF statement appears
1111 p
= gfc_get_code ();
1112 p
->next
= gfc_get_code ();
1114 p
->next
->loc
= gfc_current_locus
;
1119 gfc_clear_new_st ();
1121 new_st
.op
= EXEC_IF
;
1130 /* Match an ELSE statement. */
1133 gfc_match_else (void)
1135 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1137 if (gfc_match_eos () == MATCH_YES
)
1140 if (gfc_match_name (name
) != MATCH_YES
1141 || gfc_current_block () == NULL
1142 || gfc_match_eos () != MATCH_YES
)
1144 gfc_error ("Unexpected junk after ELSE statement at %C");
1148 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1150 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1151 name
, gfc_current_block ()->name
);
1159 /* Match an ELSE IF statement. */
1162 gfc_match_elseif (void)
1164 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1168 m
= gfc_match (" ( %e ) then", &expr
);
1172 if (gfc_match_eos () == MATCH_YES
)
1175 if (gfc_match_name (name
) != MATCH_YES
1176 || gfc_current_block () == NULL
1177 || gfc_match_eos () != MATCH_YES
)
1179 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1183 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1185 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1186 name
, gfc_current_block ()->name
);
1191 new_st
.op
= EXEC_IF
;
1196 gfc_free_expr (expr
);
1201 /* Free a gfc_iterator structure. */
1204 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1210 gfc_free_expr (iter
->var
);
1211 gfc_free_expr (iter
->start
);
1212 gfc_free_expr (iter
->end
);
1213 gfc_free_expr (iter
->step
);
1220 /* Match a DO statement. */
1225 gfc_iterator iter
, *ip
;
1227 gfc_st_label
*label
;
1230 old_loc
= gfc_current_locus
;
1233 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1235 m
= gfc_match_label ();
1236 if (m
== MATCH_ERROR
)
1239 if (gfc_match (" do") != MATCH_YES
)
1242 m
= gfc_match_st_label (&label
, 0);
1243 if (m
== MATCH_ERROR
)
1246 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1248 if (gfc_match_eos () == MATCH_YES
)
1250 iter
.end
= gfc_logical_expr (1, NULL
);
1251 new_st
.op
= EXEC_DO_WHILE
;
1255 /* match an optional comma, if no comma is found a space is obligatory. */
1256 if (gfc_match_char(',') != MATCH_YES
1257 && gfc_match ("% ") != MATCH_YES
)
1260 /* See if we have a DO WHILE. */
1261 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1263 new_st
.op
= EXEC_DO_WHILE
;
1267 /* The abortive DO WHILE may have done something to the symbol
1268 table, so we start over: */
1269 gfc_undo_symbols ();
1270 gfc_current_locus
= old_loc
;
1272 gfc_match_label (); /* This won't error */
1273 gfc_match (" do "); /* This will work */
1275 gfc_match_st_label (&label
, 0); /* Can't error out */
1276 gfc_match_char (','); /* Optional comma */
1278 m
= gfc_match_iterator (&iter
, 0);
1281 if (m
== MATCH_ERROR
)
1284 gfc_check_do_variable (iter
.var
->symtree
);
1286 if (gfc_match_eos () != MATCH_YES
)
1288 gfc_syntax_error (ST_DO
);
1292 new_st
.op
= EXEC_DO
;
1296 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1299 new_st
.label
= label
;
1301 if (new_st
.op
== EXEC_DO_WHILE
)
1302 new_st
.expr
= iter
.end
;
1305 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1312 gfc_free_iterator (&iter
, 0);
1318 /* Match an EXIT or CYCLE statement. */
1321 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1327 if (gfc_match_eos () == MATCH_YES
)
1331 m
= gfc_match ("% %s%t", &sym
);
1332 if (m
== MATCH_ERROR
)
1336 gfc_syntax_error (st
);
1340 if (sym
->attr
.flavor
!= FL_LABEL
)
1342 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1343 sym
->name
, gfc_ascii_statement (st
));
1348 /* Find the loop mentioned specified by the label (or lack of a
1350 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1351 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1357 gfc_error ("%s statement at %C is not within a loop",
1358 gfc_ascii_statement (st
));
1360 gfc_error ("%s statement at %C is not within loop '%s'",
1361 gfc_ascii_statement (st
), sym
->name
);
1366 /* Save the first statement in the loop - needed by the backend. */
1367 new_st
.ext
.whichloop
= p
->head
;
1370 /* new_st.sym = sym;*/
1376 /* Match the EXIT statement. */
1379 gfc_match_exit (void)
1382 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1386 /* Match the CYCLE statement. */
1389 gfc_match_cycle (void)
1392 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1396 /* Match a number or character constant after a STOP or PAUSE statement. */
1399 gfc_match_stopcode (gfc_statement st
)
1408 if (gfc_match_eos () != MATCH_YES
)
1410 m
= gfc_match_small_literal_int (&stop_code
);
1411 if (m
== MATCH_ERROR
)
1414 if (m
== MATCH_YES
&& stop_code
> 99999)
1416 gfc_error ("STOP code out of range at %C");
1422 /* Try a character constant. */
1423 m
= gfc_match_expr (&e
);
1424 if (m
== MATCH_ERROR
)
1428 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1432 if (gfc_match_eos () != MATCH_YES
)
1436 if (gfc_pure (NULL
))
1438 gfc_error ("%s statement not allowed in PURE procedure at %C",
1439 gfc_ascii_statement (st
));
1443 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1445 new_st
.ext
.stop_code
= stop_code
;
1450 gfc_syntax_error (st
);
1458 /* Match the (deprecated) PAUSE statement. */
1461 gfc_match_pause (void)
1465 m
= gfc_match_stopcode (ST_PAUSE
);
1468 if (gfc_notify_std (GFC_STD_F95_DEL
,
1469 "Obsolete: PAUSE statement at %C")
1477 /* Match the STOP statement. */
1480 gfc_match_stop (void)
1482 return gfc_match_stopcode (ST_STOP
);
1486 /* Match a CONTINUE statement. */
1489 gfc_match_continue (void)
1492 if (gfc_match_eos () != MATCH_YES
)
1494 gfc_syntax_error (ST_CONTINUE
);
1498 new_st
.op
= EXEC_CONTINUE
;
1503 /* Match the (deprecated) ASSIGN statement. */
1506 gfc_match_assign (void)
1509 gfc_st_label
*label
;
1511 if (gfc_match (" %l", &label
) == MATCH_YES
)
1513 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1515 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1517 if (gfc_notify_std (GFC_STD_F95_DEL
,
1518 "Obsolete: ASSIGN statement at %C")
1522 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1524 new_st
.op
= EXEC_LABEL_ASSIGN
;
1525 new_st
.label
= label
;
1534 /* Match the GO TO statement. As a computed GOTO statement is
1535 matched, it is transformed into an equivalent SELECT block. No
1536 tree is necessary, and the resulting jumps-to-jumps are
1537 specifically optimized away by the back end. */
1540 gfc_match_goto (void)
1542 gfc_code
*head
, *tail
;
1545 gfc_st_label
*label
;
1549 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1551 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1554 new_st
.op
= EXEC_GOTO
;
1555 new_st
.label
= label
;
1559 /* The assigned GO TO statement. */
1561 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1563 if (gfc_notify_std (GFC_STD_F95_DEL
,
1564 "Obsolete: Assigned GOTO statement at %C")
1568 new_st
.op
= EXEC_GOTO
;
1571 if (gfc_match_eos () == MATCH_YES
)
1574 /* Match label list. */
1575 gfc_match_char (',');
1576 if (gfc_match_char ('(') != MATCH_YES
)
1578 gfc_syntax_error (ST_GOTO
);
1585 m
= gfc_match_st_label (&label
, 0);
1589 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1593 head
= tail
= gfc_get_code ();
1596 tail
->block
= gfc_get_code ();
1600 tail
->label
= label
;
1601 tail
->op
= EXEC_GOTO
;
1603 while (gfc_match_char (',') == MATCH_YES
);
1605 if (gfc_match (")%t") != MATCH_YES
)
1611 "Statement label list in GOTO at %C cannot be empty");
1614 new_st
.block
= head
;
1619 /* Last chance is a computed GO TO statement. */
1620 if (gfc_match_char ('(') != MATCH_YES
)
1622 gfc_syntax_error (ST_GOTO
);
1631 m
= gfc_match_st_label (&label
, 0);
1635 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1639 head
= tail
= gfc_get_code ();
1642 tail
->block
= gfc_get_code ();
1646 cp
= gfc_get_case ();
1647 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1649 tail
->op
= EXEC_SELECT
;
1650 tail
->ext
.case_list
= cp
;
1652 tail
->next
= gfc_get_code ();
1653 tail
->next
->op
= EXEC_GOTO
;
1654 tail
->next
->label
= label
;
1656 while (gfc_match_char (',') == MATCH_YES
);
1658 if (gfc_match_char (')') != MATCH_YES
)
1663 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1667 /* Get the rest of the statement. */
1668 gfc_match_char (',');
1670 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1673 /* At this point, a computed GOTO has been fully matched and an
1674 equivalent SELECT statement constructed. */
1676 new_st
.op
= EXEC_SELECT
;
1679 /* Hack: For a "real" SELECT, the expression is in expr. We put
1680 it in expr2 so we can distinguish then and produce the correct
1682 new_st
.expr2
= expr
;
1683 new_st
.block
= head
;
1687 gfc_syntax_error (ST_GOTO
);
1689 gfc_free_statements (head
);
1694 /* Frees a list of gfc_alloc structures. */
1697 gfc_free_alloc_list (gfc_alloc
* p
)
1704 gfc_free_expr (p
->expr
);
1710 /* Match an ALLOCATE statement. */
1713 gfc_match_allocate (void)
1715 gfc_alloc
*head
, *tail
;
1722 if (gfc_match_char ('(') != MATCH_YES
)
1728 head
= tail
= gfc_get_alloc ();
1731 tail
->next
= gfc_get_alloc ();
1735 m
= gfc_match_variable (&tail
->expr
, 0);
1738 if (m
== MATCH_ERROR
)
1741 if (gfc_check_do_variable (tail
->expr
->symtree
))
1745 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1747 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1752 if (gfc_match_char (',') != MATCH_YES
)
1755 m
= gfc_match (" stat = %v", &stat
);
1756 if (m
== MATCH_ERROR
)
1764 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1767 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1768 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1772 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1775 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1780 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1782 gfc_error("STAT expression at %C must be a variable");
1786 gfc_check_do_variable(stat
->symtree
);
1789 if (gfc_match (" )%t") != MATCH_YES
)
1792 new_st
.op
= EXEC_ALLOCATE
;
1794 new_st
.ext
.alloc_list
= head
;
1799 gfc_syntax_error (ST_ALLOCATE
);
1802 gfc_free_expr (stat
);
1803 gfc_free_alloc_list (head
);
1808 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1809 a set of pointer assignments to intrinsic NULL(). */
1812 gfc_match_nullify (void)
1820 if (gfc_match_char ('(') != MATCH_YES
)
1825 m
= gfc_match_variable (&p
, 0);
1826 if (m
== MATCH_ERROR
)
1831 if (gfc_check_do_variable(p
->symtree
))
1834 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1837 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1841 /* build ' => NULL() ' */
1842 e
= gfc_get_expr ();
1843 e
->where
= gfc_current_locus
;
1844 e
->expr_type
= EXPR_NULL
;
1845 e
->ts
.type
= BT_UNKNOWN
;
1852 tail
->next
= gfc_get_code ();
1856 tail
->op
= EXEC_POINTER_ASSIGN
;
1860 if (gfc_match (" )%t") == MATCH_YES
)
1862 if (gfc_match_char (',') != MATCH_YES
)
1869 gfc_syntax_error (ST_NULLIFY
);
1872 gfc_free_statements (tail
);
1877 /* Match a DEALLOCATE statement. */
1880 gfc_match_deallocate (void)
1882 gfc_alloc
*head
, *tail
;
1889 if (gfc_match_char ('(') != MATCH_YES
)
1895 head
= tail
= gfc_get_alloc ();
1898 tail
->next
= gfc_get_alloc ();
1902 m
= gfc_match_variable (&tail
->expr
, 0);
1903 if (m
== MATCH_ERROR
)
1908 if (gfc_check_do_variable (tail
->expr
->symtree
))
1912 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1915 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1920 if (gfc_match_char (',') != MATCH_YES
)
1923 m
= gfc_match (" stat = %v", &stat
);
1924 if (m
== MATCH_ERROR
)
1932 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1934 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1935 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1939 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1941 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1942 "for a PURE procedure");
1946 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1948 gfc_error("STAT expression at %C must be a variable");
1952 gfc_check_do_variable(stat
->symtree
);
1955 if (gfc_match (" )%t") != MATCH_YES
)
1958 new_st
.op
= EXEC_DEALLOCATE
;
1960 new_st
.ext
.alloc_list
= head
;
1965 gfc_syntax_error (ST_DEALLOCATE
);
1968 gfc_free_expr (stat
);
1969 gfc_free_alloc_list (head
);
1974 /* Match a RETURN statement. */
1977 gfc_match_return (void)
1981 gfc_compile_state s
;
1985 if (gfc_match_eos () == MATCH_YES
)
1988 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
1990 gfc_error ("Alternate RETURN statement at %C is only allowed within "
1995 if (gfc_current_form
== FORM_FREE
)
1997 /* The following are valid, so we can't require a blank after the
2001 c
= gfc_peek_char ();
2002 if (ISALPHA (c
) || ISDIGIT (c
))
2006 m
= gfc_match (" %e%t", &e
);
2009 if (m
== MATCH_ERROR
)
2012 gfc_syntax_error (ST_RETURN
);
2019 gfc_enclosing_unit (&s
);
2020 if (s
== COMP_PROGRAM
2021 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
2022 "main program at %C") == FAILURE
)
2025 new_st
.op
= EXEC_RETURN
;
2032 /* Match a CALL statement. The tricky part here are possible
2033 alternate return specifiers. We handle these by having all
2034 "subroutines" actually return an integer via a register that gives
2035 the return number. If the call specifies alternate returns, we
2036 generate code for a SELECT statement whose case clauses contain
2037 GOTOs to the various labels. */
2040 gfc_match_call (void)
2042 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2043 gfc_actual_arglist
*a
, *arglist
;
2053 m
= gfc_match ("% %n", name
);
2059 if (gfc_get_ha_sym_tree (name
, &st
))
2063 gfc_set_sym_referenced (sym
);
2065 if (!sym
->attr
.generic
2066 && !sym
->attr
.subroutine
2067 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2070 if (gfc_match_eos () != MATCH_YES
)
2072 m
= gfc_match_actual_arglist (1, &arglist
);
2075 if (m
== MATCH_ERROR
)
2078 if (gfc_match_eos () != MATCH_YES
)
2082 /* If any alternate return labels were found, construct a SELECT
2083 statement that will jump to the right place. */
2086 for (a
= arglist
; a
; a
= a
->next
)
2087 if (a
->expr
== NULL
)
2092 gfc_symtree
*select_st
;
2093 gfc_symbol
*select_sym
;
2094 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2096 new_st
.next
= c
= gfc_get_code ();
2097 c
->op
= EXEC_SELECT
;
2098 sprintf (name
, "_result_%s",sym
->name
);
2099 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2101 select_sym
= select_st
->n
.sym
;
2102 select_sym
->ts
.type
= BT_INTEGER
;
2103 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2104 gfc_set_sym_referenced (select_sym
);
2105 c
->expr
= gfc_get_expr ();
2106 c
->expr
->expr_type
= EXPR_VARIABLE
;
2107 c
->expr
->symtree
= select_st
;
2108 c
->expr
->ts
= select_sym
->ts
;
2109 c
->expr
->where
= gfc_current_locus
;
2112 for (a
= arglist
; a
; a
= a
->next
)
2114 if (a
->expr
!= NULL
)
2117 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2122 c
->block
= gfc_get_code ();
2124 c
->op
= EXEC_SELECT
;
2126 new_case
= gfc_get_case ();
2127 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2128 c
->ext
.case_list
= new_case
;
2130 c
->next
= gfc_get_code ();
2131 c
->next
->op
= EXEC_GOTO
;
2132 c
->next
->label
= a
->label
;
2136 new_st
.op
= EXEC_CALL
;
2137 new_st
.symtree
= st
;
2138 new_st
.ext
.actual
= arglist
;
2143 gfc_syntax_error (ST_CALL
);
2146 gfc_free_actual_arglist (arglist
);
2151 /* Given a name, return a pointer to the common head structure,
2152 creating it if it does not exist. If FROM_MODULE is nonzero, we
2153 mangle the name so that it doesn't interfere with commons defined
2154 in the using namespace.
2155 TODO: Add to global symbol tree. */
2158 gfc_get_common (const char *name
, int from_module
)
2161 static int serial
= 0;
2162 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2166 /* A use associated common block is only needed to correctly layout
2167 the variables it contains. */
2168 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2169 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2173 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2176 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2179 if (st
->n
.common
== NULL
)
2181 st
->n
.common
= gfc_get_common_head ();
2182 st
->n
.common
->where
= gfc_current_locus
;
2183 strcpy (st
->n
.common
->name
, name
);
2186 return st
->n
.common
;
2190 /* Match a common block name. */
2193 match_common_name (char *name
)
2197 if (gfc_match_char ('/') == MATCH_NO
)
2203 if (gfc_match_char ('/') == MATCH_YES
)
2209 m
= gfc_match_name (name
);
2211 if (m
== MATCH_ERROR
)
2213 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2216 gfc_error ("Syntax error in common block name at %C");
2221 /* Match a COMMON statement. */
2224 gfc_match_common (void)
2226 gfc_symbol
*sym
, **head
, *tail
, *old_blank_common
;
2227 char name
[GFC_MAX_SYMBOL_LEN
+1];
2232 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2233 if (old_blank_common
)
2235 while (old_blank_common
->common_next
)
2236 old_blank_common
= old_blank_common
->common_next
;
2241 if (gfc_match_eos () == MATCH_YES
)
2246 m
= match_common_name (name
);
2247 if (m
== MATCH_ERROR
)
2250 if (name
[0] == '\0')
2252 t
= &gfc_current_ns
->blank_common
;
2253 if (t
->head
== NULL
)
2254 t
->where
= gfc_current_locus
;
2259 t
= gfc_get_common (name
, 0);
2268 while (tail
->common_next
)
2269 tail
= tail
->common_next
;
2272 /* Grab the list of symbols. */
2273 if (gfc_match_eos () == MATCH_YES
)
2278 m
= gfc_match_symbol (&sym
, 0);
2279 if (m
== MATCH_ERROR
)
2284 if (sym
->attr
.in_common
)
2286 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2291 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2294 if (sym
->value
!= NULL
2295 && (name
[0] == '\0' || !sym
->attr
.data
))
2297 if (name
[0] == '\0')
2298 gfc_error ("Previously initialized symbol '%s' in "
2299 "blank COMMON block at %C", sym
->name
);
2301 gfc_error ("Previously initialized symbol '%s' in "
2302 "COMMON block '%s' at %C", sym
->name
, name
);
2306 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2309 /* Derived type names must have the SEQUENCE attribute. */
2310 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2313 ("Derived type variable in COMMON at %C does not have the "
2314 "SEQUENCE attribute");
2319 tail
->common_next
= sym
;
2325 /* Deal with an optional array specification after the
2327 m
= gfc_match_array_spec (&as
);
2328 if (m
== MATCH_ERROR
)
2333 if (as
->type
!= AS_EXPLICIT
)
2336 ("Array specification for symbol '%s' in COMMON at %C "
2337 "must be explicit", sym
->name
);
2341 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2344 if (sym
->attr
.pointer
)
2347 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2356 gfc_gobble_whitespace ();
2357 if (gfc_match_eos () == MATCH_YES
)
2359 if (gfc_peek_char () == '/')
2361 if (gfc_match_char (',') != MATCH_YES
)
2363 gfc_gobble_whitespace ();
2364 if (gfc_peek_char () == '/')
2373 gfc_syntax_error (ST_COMMON
);
2376 if (old_blank_common
)
2377 old_blank_common
->common_next
= NULL
;
2379 gfc_current_ns
->blank_common
.head
= NULL
;
2380 gfc_free_array_spec (as
);
2385 /* Match a BLOCK DATA program unit. */
2388 gfc_match_block_data (void)
2390 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2394 if (gfc_match_eos () == MATCH_YES
)
2396 gfc_new_block
= NULL
;
2400 m
= gfc_match ("% %n%t", name
);
2404 if (gfc_get_symbol (name
, NULL
, &sym
))
2407 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2410 gfc_new_block
= sym
;
2416 /* Free a namelist structure. */
2419 gfc_free_namelist (gfc_namelist
* name
)
2423 for (; name
; name
= n
)
2431 /* Match a NAMELIST statement. */
2434 gfc_match_namelist (void)
2436 gfc_symbol
*group_name
, *sym
;
2440 m
= gfc_match (" / %s /", &group_name
);
2443 if (m
== MATCH_ERROR
)
2448 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2451 ("Namelist group name '%s' at %C already has a basic type "
2452 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2456 if (group_name
->attr
.flavor
!= FL_NAMELIST
2457 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2458 group_name
->name
, NULL
) == FAILURE
)
2463 m
= gfc_match_symbol (&sym
, 1);
2466 if (m
== MATCH_ERROR
)
2469 if (sym
->attr
.in_namelist
== 0
2470 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2473 nl
= gfc_get_namelist ();
2476 if (group_name
->namelist
== NULL
)
2477 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2480 group_name
->namelist_tail
->next
= nl
;
2481 group_name
->namelist_tail
= nl
;
2484 if (gfc_match_eos () == MATCH_YES
)
2487 m
= gfc_match_char (',');
2489 if (gfc_match_char ('/') == MATCH_YES
)
2491 m2
= gfc_match (" %s /", &group_name
);
2492 if (m2
== MATCH_YES
)
2494 if (m2
== MATCH_ERROR
)
2508 gfc_syntax_error (ST_NAMELIST
);
2515 /* Match a MODULE statement. */
2518 gfc_match_module (void)
2522 m
= gfc_match (" %s%t", &gfc_new_block
);
2526 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2527 gfc_new_block
->name
, NULL
) == FAILURE
)
2534 /* Free equivalence sets and lists. Recursively is the easiest way to
2538 gfc_free_equiv (gfc_equiv
* eq
)
2544 gfc_free_equiv (eq
->eq
);
2545 gfc_free_equiv (eq
->next
);
2547 gfc_free_expr (eq
->expr
);
2552 /* Match an EQUIVALENCE statement. */
2555 gfc_match_equivalence (void)
2557 gfc_equiv
*eq
, *set
, *tail
;
2565 eq
= gfc_get_equiv ();
2569 eq
->next
= gfc_current_ns
->equiv
;
2570 gfc_current_ns
->equiv
= eq
;
2572 if (gfc_match_char ('(') != MATCH_YES
)
2579 m
= gfc_match_variable (&set
->expr
, 1);
2580 if (m
== MATCH_ERROR
)
2585 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2586 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2589 ("Array reference in EQUIVALENCE at %C cannot be an "
2594 if (gfc_match_char (')') == MATCH_YES
)
2596 if (gfc_match_char (',') != MATCH_YES
)
2599 set
->eq
= gfc_get_equiv ();
2603 if (gfc_match_eos () == MATCH_YES
)
2605 if (gfc_match_char (',') != MATCH_YES
)
2612 gfc_syntax_error (ST_EQUIVALENCE
);
2618 gfc_free_equiv (gfc_current_ns
->equiv
);
2619 gfc_current_ns
->equiv
= eq
;
2625 /* Match a statement function declaration. It is so easy to match
2626 non-statement function statements with a MATCH_ERROR as opposed to
2627 MATCH_NO that we suppress error message in most cases. */
2630 gfc_match_st_function (void)
2632 gfc_error_buf old_error
;
2637 m
= gfc_match_symbol (&sym
, 0);
2641 gfc_push_error (&old_error
);
2643 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2644 sym
->name
, NULL
) == FAILURE
)
2647 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2650 m
= gfc_match (" = %e%t", &expr
);
2654 gfc_free_error (&old_error
);
2655 if (m
== MATCH_ERROR
)
2663 gfc_pop_error (&old_error
);
2668 /***************** SELECT CASE subroutines ******************/
2670 /* Free a single case structure. */
2673 free_case (gfc_case
* p
)
2675 if (p
->low
== p
->high
)
2677 gfc_free_expr (p
->low
);
2678 gfc_free_expr (p
->high
);
2683 /* Free a list of case structures. */
2686 gfc_free_case_list (gfc_case
* p
)
2698 /* Match a single case selector. */
2701 match_case_selector (gfc_case
** cp
)
2706 c
= gfc_get_case ();
2707 c
->where
= gfc_current_locus
;
2709 if (gfc_match_char (':') == MATCH_YES
)
2711 m
= gfc_match_init_expr (&c
->high
);
2714 if (m
== MATCH_ERROR
)
2720 m
= gfc_match_init_expr (&c
->low
);
2721 if (m
== MATCH_ERROR
)
2726 /* If we're not looking at a ':' now, make a range out of a single
2727 target. Else get the upper bound for the case range. */
2728 if (gfc_match_char (':') != MATCH_YES
)
2732 m
= gfc_match_init_expr (&c
->high
);
2733 if (m
== MATCH_ERROR
)
2735 /* MATCH_NO is fine. It's OK if nothing is there! */
2743 gfc_error ("Expected initialization expression in CASE at %C");
2751 /* Match the end of a case statement. */
2754 match_case_eos (void)
2756 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2759 if (gfc_match_eos () == MATCH_YES
)
2762 gfc_gobble_whitespace ();
2764 m
= gfc_match_name (name
);
2768 if (strcmp (name
, gfc_current_block ()->name
) != 0)
2770 gfc_error ("Expected case name of '%s' at %C",
2771 gfc_current_block ()->name
);
2775 return gfc_match_eos ();
2779 /* Match a SELECT statement. */
2782 gfc_match_select (void)
2787 m
= gfc_match_label ();
2788 if (m
== MATCH_ERROR
)
2791 m
= gfc_match (" select case ( %e )%t", &expr
);
2795 new_st
.op
= EXEC_SELECT
;
2802 /* Match a CASE statement. */
2805 gfc_match_case (void)
2807 gfc_case
*c
, *head
, *tail
;
2812 if (gfc_current_state () != COMP_SELECT
)
2814 gfc_error ("Unexpected CASE statement at %C");
2818 if (gfc_match ("% default") == MATCH_YES
)
2820 m
= match_case_eos ();
2823 if (m
== MATCH_ERROR
)
2826 new_st
.op
= EXEC_SELECT
;
2827 c
= gfc_get_case ();
2828 c
->where
= gfc_current_locus
;
2829 new_st
.ext
.case_list
= c
;
2833 if (gfc_match_char ('(') != MATCH_YES
)
2838 if (match_case_selector (&c
) == MATCH_ERROR
)
2848 if (gfc_match_char (')') == MATCH_YES
)
2850 if (gfc_match_char (',') != MATCH_YES
)
2854 m
= match_case_eos ();
2857 if (m
== MATCH_ERROR
)
2860 new_st
.op
= EXEC_SELECT
;
2861 new_st
.ext
.case_list
= head
;
2866 gfc_error ("Syntax error in CASE-specification at %C");
2869 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
2873 /********************* WHERE subroutines ********************/
2875 /* Match the rest of a simple WHERE statement that follows an IF statement.
2879 match_simple_where (void)
2885 m
= gfc_match (" ( %e )", &expr
);
2889 m
= gfc_match_assignment ();
2892 if (m
== MATCH_ERROR
)
2895 if (gfc_match_eos () != MATCH_YES
)
2898 c
= gfc_get_code ();
2902 c
->next
= gfc_get_code ();
2905 gfc_clear_new_st ();
2907 new_st
.op
= EXEC_WHERE
;
2913 gfc_syntax_error (ST_WHERE
);
2916 gfc_free_expr (expr
);
2920 /* Match a WHERE statement. */
2923 gfc_match_where (gfc_statement
* st
)
2929 m0
= gfc_match_label ();
2930 if (m0
== MATCH_ERROR
)
2933 m
= gfc_match (" where ( %e )", &expr
);
2937 if (gfc_match_eos () == MATCH_YES
)
2939 *st
= ST_WHERE_BLOCK
;
2941 new_st
.op
= EXEC_WHERE
;
2946 m
= gfc_match_assignment ();
2948 gfc_syntax_error (ST_WHERE
);
2952 gfc_free_expr (expr
);
2956 /* We've got a simple WHERE statement. */
2958 c
= gfc_get_code ();
2962 c
->next
= gfc_get_code ();
2965 gfc_clear_new_st ();
2967 new_st
.op
= EXEC_WHERE
;
2974 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
2975 new_st if successful. */
2978 gfc_match_elsewhere (void)
2980 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2984 if (gfc_current_state () != COMP_WHERE
)
2986 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2992 if (gfc_match_char ('(') == MATCH_YES
)
2994 m
= gfc_match_expr (&expr
);
2997 if (m
== MATCH_ERROR
)
3000 if (gfc_match_char (')') != MATCH_YES
)
3004 if (gfc_match_eos () != MATCH_YES
)
3005 { /* Better be a name at this point */
3006 m
= gfc_match_name (name
);
3009 if (m
== MATCH_ERROR
)
3012 if (gfc_match_eos () != MATCH_YES
)
3015 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3017 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3018 name
, gfc_current_block ()->name
);
3023 new_st
.op
= EXEC_WHERE
;
3028 gfc_syntax_error (ST_ELSEWHERE
);
3031 gfc_free_expr (expr
);
3036 /******************** FORALL subroutines ********************/
3038 /* Free a list of FORALL iterators. */
3041 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3043 gfc_forall_iterator
*next
;
3049 gfc_free_expr (iter
->var
);
3050 gfc_free_expr (iter
->start
);
3051 gfc_free_expr (iter
->end
);
3052 gfc_free_expr (iter
->stride
);
3060 /* Match an iterator as part of a FORALL statement. The format is:
3062 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3065 match_forall_iterator (gfc_forall_iterator
** result
)
3067 gfc_forall_iterator
*iter
;
3071 where
= gfc_current_locus
;
3072 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3074 m
= gfc_match_variable (&iter
->var
, 0);
3078 if (gfc_match_char ('=') != MATCH_YES
)
3084 m
= gfc_match_expr (&iter
->start
);
3088 if (gfc_match_char (':') != MATCH_YES
)
3091 m
= gfc_match_expr (&iter
->end
);
3094 if (m
== MATCH_ERROR
)
3097 if (gfc_match_char (':') == MATCH_NO
)
3098 iter
->stride
= gfc_int_expr (1);
3101 m
= gfc_match_expr (&iter
->stride
);
3104 if (m
== MATCH_ERROR
)
3112 gfc_error ("Syntax error in FORALL iterator at %C");
3116 gfc_current_locus
= where
;
3117 gfc_free_forall_iterator (iter
);
3122 /* Match the header of a FORALL statement. */
3125 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3127 gfc_forall_iterator
*head
, *tail
, *new;
3130 gfc_gobble_whitespace ();
3135 if (gfc_match_char ('(') != MATCH_YES
)
3138 m
= match_forall_iterator (&new);
3139 if (m
== MATCH_ERROR
)
3148 if (gfc_match_char (',') != MATCH_YES
)
3151 m
= match_forall_iterator (&new);
3152 if (m
== MATCH_ERROR
)
3161 /* Have to have a mask expression */
3163 m
= gfc_match_expr (mask
);
3166 if (m
== MATCH_ERROR
)
3172 if (gfc_match_char (')') == MATCH_NO
)
3179 gfc_syntax_error (ST_FORALL
);
3182 gfc_free_expr (*mask
);
3183 gfc_free_forall_iterator (head
);
3188 /* Match the rest of a simple FORALL statement that follows an IF statement.
3192 match_simple_forall (void)
3194 gfc_forall_iterator
*head
;
3203 m
= match_forall_header (&head
, &mask
);
3210 m
= gfc_match_assignment ();
3212 if (m
== MATCH_ERROR
)
3216 m
= gfc_match_pointer_assignment ();
3217 if (m
== MATCH_ERROR
)
3223 c
= gfc_get_code ();
3225 c
->loc
= gfc_current_locus
;
3227 if (gfc_match_eos () != MATCH_YES
)
3230 gfc_clear_new_st ();
3231 new_st
.op
= EXEC_FORALL
;
3233 new_st
.ext
.forall_iterator
= head
;
3234 new_st
.block
= gfc_get_code ();
3236 new_st
.block
->op
= EXEC_FORALL
;
3237 new_st
.block
->next
= c
;
3242 gfc_syntax_error (ST_FORALL
);
3245 gfc_free_forall_iterator (head
);
3246 gfc_free_expr (mask
);
3252 /* Match a FORALL statement. */
3255 gfc_match_forall (gfc_statement
* st
)
3257 gfc_forall_iterator
*head
;
3266 m0
= gfc_match_label ();
3267 if (m0
== MATCH_ERROR
)
3270 m
= gfc_match (" forall");
3274 m
= match_forall_header (&head
, &mask
);
3275 if (m
== MATCH_ERROR
)
3280 if (gfc_match_eos () == MATCH_YES
)
3282 *st
= ST_FORALL_BLOCK
;
3284 new_st
.op
= EXEC_FORALL
;
3286 new_st
.ext
.forall_iterator
= head
;
3291 m
= gfc_match_assignment ();
3292 if (m
== MATCH_ERROR
)
3296 m
= gfc_match_pointer_assignment ();
3297 if (m
== MATCH_ERROR
)
3303 c
= gfc_get_code ();
3306 if (gfc_match_eos () != MATCH_YES
)
3309 gfc_clear_new_st ();
3310 new_st
.op
= EXEC_FORALL
;
3312 new_st
.ext
.forall_iterator
= head
;
3313 new_st
.block
= gfc_get_code ();
3315 new_st
.block
->op
= EXEC_FORALL
;
3316 new_st
.block
->next
= c
;
3322 gfc_syntax_error (ST_FORALL
);
3325 gfc_free_forall_iterator (head
);
3326 gfc_free_expr (mask
);
3327 gfc_free_statements (c
);