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 /* We try to match an easy arithmetic IF statement. This only happens
903 when just after having encountered a simple IF statement. This code
904 is really duplicate with parts of the gfc_match_if code, but this is
907 match_arithmetic_if (void)
909 gfc_st_label
*l1
, *l2
, *l3
;
913 m
= gfc_match (" ( %e ) %l , %l , %l%t", &expr
, &l1
, &l2
, &l3
);
917 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
918 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
919 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
921 gfc_free_expr (expr
);
925 if (gfc_notify_std (GFC_STD_F95_DEL
,
926 "Obsolete: arithmetic IF statement at %C") == FAILURE
)
929 new_st
.op
= EXEC_ARITHMETIC_IF
;
939 /* The IF statement is a bit of a pain. First of all, there are three
940 forms of it, the simple IF, the IF that starts a block and the
943 There is a problem with the simple IF and that is the fact that we
944 only have a single level of undo information on symbols. What this
945 means is for a simple IF, we must re-match the whole IF statement
946 multiple times in order to guarantee that the symbol table ends up
947 in the proper state. */
949 static match
match_simple_forall (void);
950 static match
match_simple_where (void);
953 gfc_match_if (gfc_statement
* if_type
)
956 gfc_st_label
*l1
, *l2
, *l3
;
961 n
= gfc_match_label ();
962 if (n
== MATCH_ERROR
)
965 old_loc
= gfc_current_locus
;
967 m
= gfc_match (" if ( %e", &expr
);
971 if (gfc_match_char (')') != MATCH_YES
)
973 gfc_error ("Syntax error in IF-expression at %C");
974 gfc_free_expr (expr
);
978 m
= gfc_match (" %l , %l , %l%t", &l1
, &l2
, &l3
);
985 ("Block label not appropriate for arithmetic IF statement "
988 gfc_free_expr (expr
);
992 if (gfc_reference_st_label (l1
, ST_LABEL_TARGET
) == FAILURE
993 || gfc_reference_st_label (l2
, ST_LABEL_TARGET
) == FAILURE
994 || gfc_reference_st_label (l3
, ST_LABEL_TARGET
) == FAILURE
)
997 gfc_free_expr (expr
);
1001 if (gfc_notify_std (GFC_STD_F95_DEL
,
1002 "Obsolete: arithmetic IF statement at %C")
1006 new_st
.op
= EXEC_ARITHMETIC_IF
;
1012 *if_type
= ST_ARITHMETIC_IF
;
1016 if (gfc_match (" then%t") == MATCH_YES
)
1018 new_st
.op
= EXEC_IF
;
1021 *if_type
= ST_IF_BLOCK
;
1027 gfc_error ("Block label is not appropriate IF statement at %C");
1029 gfc_free_expr (expr
);
1033 /* At this point the only thing left is a simple IF statement. At
1034 this point, n has to be MATCH_NO, so we don't have to worry about
1035 re-matching a block label. From what we've got so far, try
1036 matching an assignment. */
1038 *if_type
= ST_SIMPLE_IF
;
1040 m
= gfc_match_assignment ();
1044 gfc_free_expr (expr
);
1045 gfc_undo_symbols ();
1046 gfc_current_locus
= old_loc
;
1048 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1050 m
= gfc_match_pointer_assignment ();
1054 gfc_free_expr (expr
);
1055 gfc_undo_symbols ();
1056 gfc_current_locus
= old_loc
;
1058 gfc_match (" if ( %e ) ", &expr
); /* Guaranteed to match */
1060 /* Look at the next keyword to see which matcher to call. Matching
1061 the keyword doesn't affect the symbol table, so we don't have to
1062 restore between tries. */
1064 #define match(string, subr, statement) \
1065 if (gfc_match(string) == MATCH_YES) { m = subr(); goto got_match; }
1069 match ("allocate", gfc_match_allocate
, ST_ALLOCATE
)
1070 match ("assign", gfc_match_assign
, ST_LABEL_ASSIGNMENT
)
1071 match ("backspace", gfc_match_backspace
, ST_BACKSPACE
)
1072 match ("call", gfc_match_call
, ST_CALL
)
1073 match ("close", gfc_match_close
, ST_CLOSE
)
1074 match ("continue", gfc_match_continue
, ST_CONTINUE
)
1075 match ("cycle", gfc_match_cycle
, ST_CYCLE
)
1076 match ("deallocate", gfc_match_deallocate
, ST_DEALLOCATE
)
1077 match ("end file", gfc_match_endfile
, ST_END_FILE
)
1078 match ("exit", gfc_match_exit
, ST_EXIT
)
1079 match ("forall", match_simple_forall
, ST_FORALL
)
1080 match ("go to", gfc_match_goto
, ST_GOTO
)
1081 match ("if", match_arithmetic_if
, ST_ARITHMETIC_IF
)
1082 match ("inquire", gfc_match_inquire
, ST_INQUIRE
)
1083 match ("nullify", gfc_match_nullify
, ST_NULLIFY
)
1084 match ("open", gfc_match_open
, ST_OPEN
)
1085 match ("pause", gfc_match_pause
, ST_NONE
)
1086 match ("print", gfc_match_print
, ST_WRITE
)
1087 match ("read", gfc_match_read
, ST_READ
)
1088 match ("return", gfc_match_return
, ST_RETURN
)
1089 match ("rewind", gfc_match_rewind
, ST_REWIND
)
1090 match ("stop", gfc_match_stop
, ST_STOP
)
1091 match ("where", match_simple_where
, ST_WHERE
)
1092 match ("write", gfc_match_write
, ST_WRITE
)
1094 /* All else has failed, so give up. See if any of the matchers has
1095 stored an error message of some sort. */
1096 if (gfc_error_check () == 0)
1097 gfc_error ("Unclassifiable statement in IF-clause at %C");
1099 gfc_free_expr (expr
);
1104 gfc_error ("Syntax error in IF-clause at %C");
1107 gfc_free_expr (expr
);
1111 /* At this point, we've matched the single IF and the action clause
1112 is in new_st. Rearrange things so that the IF statement appears
1115 p
= gfc_get_code ();
1116 p
->next
= gfc_get_code ();
1118 p
->next
->loc
= gfc_current_locus
;
1123 gfc_clear_new_st ();
1125 new_st
.op
= EXEC_IF
;
1134 /* Match an ELSE statement. */
1137 gfc_match_else (void)
1139 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1141 if (gfc_match_eos () == MATCH_YES
)
1144 if (gfc_match_name (name
) != MATCH_YES
1145 || gfc_current_block () == NULL
1146 || gfc_match_eos () != MATCH_YES
)
1148 gfc_error ("Unexpected junk after ELSE statement at %C");
1152 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1154 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1155 name
, gfc_current_block ()->name
);
1163 /* Match an ELSE IF statement. */
1166 gfc_match_elseif (void)
1168 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
1172 m
= gfc_match (" ( %e ) then", &expr
);
1176 if (gfc_match_eos () == MATCH_YES
)
1179 if (gfc_match_name (name
) != MATCH_YES
1180 || gfc_current_block () == NULL
1181 || gfc_match_eos () != MATCH_YES
)
1183 gfc_error ("Unexpected junk after ELSE IF statement at %C");
1187 if (strcmp (name
, gfc_current_block ()->name
) != 0)
1189 gfc_error ("Label '%s' at %C doesn't match IF label '%s'",
1190 name
, gfc_current_block ()->name
);
1195 new_st
.op
= EXEC_IF
;
1200 gfc_free_expr (expr
);
1205 /* Free a gfc_iterator structure. */
1208 gfc_free_iterator (gfc_iterator
* iter
, int flag
)
1214 gfc_free_expr (iter
->var
);
1215 gfc_free_expr (iter
->start
);
1216 gfc_free_expr (iter
->end
);
1217 gfc_free_expr (iter
->step
);
1224 /* Match a DO statement. */
1229 gfc_iterator iter
, *ip
;
1231 gfc_st_label
*label
;
1234 old_loc
= gfc_current_locus
;
1237 iter
.var
= iter
.start
= iter
.end
= iter
.step
= NULL
;
1239 m
= gfc_match_label ();
1240 if (m
== MATCH_ERROR
)
1243 if (gfc_match (" do") != MATCH_YES
)
1246 m
= gfc_match_st_label (&label
, 0);
1247 if (m
== MATCH_ERROR
)
1250 /* Match an infinite DO, make it like a DO WHILE(.TRUE.) */
1252 if (gfc_match_eos () == MATCH_YES
)
1254 iter
.end
= gfc_logical_expr (1, NULL
);
1255 new_st
.op
= EXEC_DO_WHILE
;
1259 /* match an optional comma, if no comma is found a space is obligatory. */
1260 if (gfc_match_char(',') != MATCH_YES
1261 && gfc_match ("% ") != MATCH_YES
)
1264 /* See if we have a DO WHILE. */
1265 if (gfc_match (" while ( %e )%t", &iter
.end
) == MATCH_YES
)
1267 new_st
.op
= EXEC_DO_WHILE
;
1271 /* The abortive DO WHILE may have done something to the symbol
1272 table, so we start over: */
1273 gfc_undo_symbols ();
1274 gfc_current_locus
= old_loc
;
1276 gfc_match_label (); /* This won't error */
1277 gfc_match (" do "); /* This will work */
1279 gfc_match_st_label (&label
, 0); /* Can't error out */
1280 gfc_match_char (','); /* Optional comma */
1282 m
= gfc_match_iterator (&iter
, 0);
1285 if (m
== MATCH_ERROR
)
1288 gfc_check_do_variable (iter
.var
->symtree
);
1290 if (gfc_match_eos () != MATCH_YES
)
1292 gfc_syntax_error (ST_DO
);
1296 new_st
.op
= EXEC_DO
;
1300 && gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1303 new_st
.label
= label
;
1305 if (new_st
.op
== EXEC_DO_WHILE
)
1306 new_st
.expr
= iter
.end
;
1309 new_st
.ext
.iterator
= ip
= gfc_get_iterator ();
1316 gfc_free_iterator (&iter
, 0);
1322 /* Match an EXIT or CYCLE statement. */
1325 match_exit_cycle (gfc_statement st
, gfc_exec_op op
)
1331 if (gfc_match_eos () == MATCH_YES
)
1335 m
= gfc_match ("% %s%t", &sym
);
1336 if (m
== MATCH_ERROR
)
1340 gfc_syntax_error (st
);
1344 if (sym
->attr
.flavor
!= FL_LABEL
)
1346 gfc_error ("Name '%s' in %s statement at %C is not a loop name",
1347 sym
->name
, gfc_ascii_statement (st
));
1352 /* Find the loop mentioned specified by the label (or lack of a
1354 for (p
= gfc_state_stack
; p
; p
= p
->previous
)
1355 if (p
->state
== COMP_DO
&& (sym
== NULL
|| sym
== p
->sym
))
1361 gfc_error ("%s statement at %C is not within a loop",
1362 gfc_ascii_statement (st
));
1364 gfc_error ("%s statement at %C is not within loop '%s'",
1365 gfc_ascii_statement (st
), sym
->name
);
1370 /* Save the first statement in the loop - needed by the backend. */
1371 new_st
.ext
.whichloop
= p
->head
;
1374 /* new_st.sym = sym;*/
1380 /* Match the EXIT statement. */
1383 gfc_match_exit (void)
1386 return match_exit_cycle (ST_EXIT
, EXEC_EXIT
);
1390 /* Match the CYCLE statement. */
1393 gfc_match_cycle (void)
1396 return match_exit_cycle (ST_CYCLE
, EXEC_CYCLE
);
1400 /* Match a number or character constant after a STOP or PAUSE statement. */
1403 gfc_match_stopcode (gfc_statement st
)
1412 if (gfc_match_eos () != MATCH_YES
)
1414 m
= gfc_match_small_literal_int (&stop_code
);
1415 if (m
== MATCH_ERROR
)
1418 if (m
== MATCH_YES
&& stop_code
> 99999)
1420 gfc_error ("STOP code out of range at %C");
1426 /* Try a character constant. */
1427 m
= gfc_match_expr (&e
);
1428 if (m
== MATCH_ERROR
)
1432 if (e
->ts
.type
!= BT_CHARACTER
|| e
->expr_type
!= EXPR_CONSTANT
)
1436 if (gfc_match_eos () != MATCH_YES
)
1440 if (gfc_pure (NULL
))
1442 gfc_error ("%s statement not allowed in PURE procedure at %C",
1443 gfc_ascii_statement (st
));
1447 new_st
.op
= st
== ST_STOP
? EXEC_STOP
: EXEC_PAUSE
;
1449 new_st
.ext
.stop_code
= stop_code
;
1454 gfc_syntax_error (st
);
1462 /* Match the (deprecated) PAUSE statement. */
1465 gfc_match_pause (void)
1469 m
= gfc_match_stopcode (ST_PAUSE
);
1472 if (gfc_notify_std (GFC_STD_F95_DEL
,
1473 "Obsolete: PAUSE statement at %C")
1481 /* Match the STOP statement. */
1484 gfc_match_stop (void)
1486 return gfc_match_stopcode (ST_STOP
);
1490 /* Match a CONTINUE statement. */
1493 gfc_match_continue (void)
1496 if (gfc_match_eos () != MATCH_YES
)
1498 gfc_syntax_error (ST_CONTINUE
);
1502 new_st
.op
= EXEC_CONTINUE
;
1507 /* Match the (deprecated) ASSIGN statement. */
1510 gfc_match_assign (void)
1513 gfc_st_label
*label
;
1515 if (gfc_match (" %l", &label
) == MATCH_YES
)
1517 if (gfc_reference_st_label (label
, ST_LABEL_UNKNOWN
) == FAILURE
)
1519 if (gfc_match (" to %v%t", &expr
) == MATCH_YES
)
1521 if (gfc_notify_std (GFC_STD_F95_DEL
,
1522 "Obsolete: ASSIGN statement at %C")
1526 expr
->symtree
->n
.sym
->attr
.assign
= 1;
1528 new_st
.op
= EXEC_LABEL_ASSIGN
;
1529 new_st
.label
= label
;
1538 /* Match the GO TO statement. As a computed GOTO statement is
1539 matched, it is transformed into an equivalent SELECT block. No
1540 tree is necessary, and the resulting jumps-to-jumps are
1541 specifically optimized away by the back end. */
1544 gfc_match_goto (void)
1546 gfc_code
*head
, *tail
;
1549 gfc_st_label
*label
;
1553 if (gfc_match (" %l%t", &label
) == MATCH_YES
)
1555 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1558 new_st
.op
= EXEC_GOTO
;
1559 new_st
.label
= label
;
1563 /* The assigned GO TO statement. */
1565 if (gfc_match_variable (&expr
, 0) == MATCH_YES
)
1567 if (gfc_notify_std (GFC_STD_F95_DEL
,
1568 "Obsolete: Assigned GOTO statement at %C")
1572 new_st
.op
= EXEC_GOTO
;
1575 if (gfc_match_eos () == MATCH_YES
)
1578 /* Match label list. */
1579 gfc_match_char (',');
1580 if (gfc_match_char ('(') != MATCH_YES
)
1582 gfc_syntax_error (ST_GOTO
);
1589 m
= gfc_match_st_label (&label
, 0);
1593 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1597 head
= tail
= gfc_get_code ();
1600 tail
->block
= gfc_get_code ();
1604 tail
->label
= label
;
1605 tail
->op
= EXEC_GOTO
;
1607 while (gfc_match_char (',') == MATCH_YES
);
1609 if (gfc_match (")%t") != MATCH_YES
)
1615 "Statement label list in GOTO at %C cannot be empty");
1618 new_st
.block
= head
;
1623 /* Last chance is a computed GO TO statement. */
1624 if (gfc_match_char ('(') != MATCH_YES
)
1626 gfc_syntax_error (ST_GOTO
);
1635 m
= gfc_match_st_label (&label
, 0);
1639 if (gfc_reference_st_label (label
, ST_LABEL_TARGET
) == FAILURE
)
1643 head
= tail
= gfc_get_code ();
1646 tail
->block
= gfc_get_code ();
1650 cp
= gfc_get_case ();
1651 cp
->low
= cp
->high
= gfc_int_expr (i
++);
1653 tail
->op
= EXEC_SELECT
;
1654 tail
->ext
.case_list
= cp
;
1656 tail
->next
= gfc_get_code ();
1657 tail
->next
->op
= EXEC_GOTO
;
1658 tail
->next
->label
= label
;
1660 while (gfc_match_char (',') == MATCH_YES
);
1662 if (gfc_match_char (')') != MATCH_YES
)
1667 gfc_error ("Statement label list in GOTO at %C cannot be empty");
1671 /* Get the rest of the statement. */
1672 gfc_match_char (',');
1674 if (gfc_match (" %e%t", &expr
) != MATCH_YES
)
1677 /* At this point, a computed GOTO has been fully matched and an
1678 equivalent SELECT statement constructed. */
1680 new_st
.op
= EXEC_SELECT
;
1683 /* Hack: For a "real" SELECT, the expression is in expr. We put
1684 it in expr2 so we can distinguish then and produce the correct
1686 new_st
.expr2
= expr
;
1687 new_st
.block
= head
;
1691 gfc_syntax_error (ST_GOTO
);
1693 gfc_free_statements (head
);
1698 /* Frees a list of gfc_alloc structures. */
1701 gfc_free_alloc_list (gfc_alloc
* p
)
1708 gfc_free_expr (p
->expr
);
1714 /* Match an ALLOCATE statement. */
1717 gfc_match_allocate (void)
1719 gfc_alloc
*head
, *tail
;
1726 if (gfc_match_char ('(') != MATCH_YES
)
1732 head
= tail
= gfc_get_alloc ();
1735 tail
->next
= gfc_get_alloc ();
1739 m
= gfc_match_variable (&tail
->expr
, 0);
1742 if (m
== MATCH_ERROR
)
1745 if (gfc_check_do_variable (tail
->expr
->symtree
))
1749 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1751 gfc_error ("Bad allocate-object in ALLOCATE statement at %C for a "
1756 if (gfc_match_char (',') != MATCH_YES
)
1759 m
= gfc_match (" stat = %v", &stat
);
1760 if (m
== MATCH_ERROR
)
1768 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1771 ("STAT variable '%s' of ALLOCATE statement at %C cannot be "
1772 "INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1776 if (gfc_pure (NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1779 ("Illegal STAT variable in ALLOCATE statement at %C for a PURE "
1784 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1786 gfc_error("STAT expression at %C must be a variable");
1790 gfc_check_do_variable(stat
->symtree
);
1793 if (gfc_match (" )%t") != MATCH_YES
)
1796 new_st
.op
= EXEC_ALLOCATE
;
1798 new_st
.ext
.alloc_list
= head
;
1803 gfc_syntax_error (ST_ALLOCATE
);
1806 gfc_free_expr (stat
);
1807 gfc_free_alloc_list (head
);
1812 /* Match a NULLIFY statement. A NULLIFY statement is transformed into
1813 a set of pointer assignments to intrinsic NULL(). */
1816 gfc_match_nullify (void)
1824 if (gfc_match_char ('(') != MATCH_YES
)
1829 m
= gfc_match_variable (&p
, 0);
1830 if (m
== MATCH_ERROR
)
1835 if (gfc_check_do_variable(p
->symtree
))
1838 if (gfc_pure (NULL
) && gfc_impure_variable (p
->symtree
->n
.sym
))
1841 ("Illegal variable in NULLIFY at %C for a PURE procedure");
1845 /* build ' => NULL() ' */
1846 e
= gfc_get_expr ();
1847 e
->where
= gfc_current_locus
;
1848 e
->expr_type
= EXPR_NULL
;
1849 e
->ts
.type
= BT_UNKNOWN
;
1856 tail
->next
= gfc_get_code ();
1860 tail
->op
= EXEC_POINTER_ASSIGN
;
1864 if (gfc_match (" )%t") == MATCH_YES
)
1866 if (gfc_match_char (',') != MATCH_YES
)
1873 gfc_syntax_error (ST_NULLIFY
);
1876 gfc_free_statements (tail
);
1881 /* Match a DEALLOCATE statement. */
1884 gfc_match_deallocate (void)
1886 gfc_alloc
*head
, *tail
;
1893 if (gfc_match_char ('(') != MATCH_YES
)
1899 head
= tail
= gfc_get_alloc ();
1902 tail
->next
= gfc_get_alloc ();
1906 m
= gfc_match_variable (&tail
->expr
, 0);
1907 if (m
== MATCH_ERROR
)
1912 if (gfc_check_do_variable (tail
->expr
->symtree
))
1916 && gfc_impure_variable (tail
->expr
->symtree
->n
.sym
))
1919 ("Illegal deallocate-expression in DEALLOCATE at %C for a PURE "
1924 if (gfc_match_char (',') != MATCH_YES
)
1927 m
= gfc_match (" stat = %v", &stat
);
1928 if (m
== MATCH_ERROR
)
1936 if (stat
->symtree
->n
.sym
->attr
.intent
== INTENT_IN
)
1938 gfc_error ("STAT variable '%s' of DEALLOCATE statement at %C "
1939 "cannot be INTENT(IN)", stat
->symtree
->n
.sym
->name
);
1943 if (gfc_pure(NULL
) && gfc_impure_variable (stat
->symtree
->n
.sym
))
1945 gfc_error ("Illegal STAT variable in DEALLOCATE statement at %C "
1946 "for a PURE procedure");
1950 if (stat
->symtree
->n
.sym
->attr
.flavor
!= FL_VARIABLE
)
1952 gfc_error("STAT expression at %C must be a variable");
1956 gfc_check_do_variable(stat
->symtree
);
1959 if (gfc_match (" )%t") != MATCH_YES
)
1962 new_st
.op
= EXEC_DEALLOCATE
;
1964 new_st
.ext
.alloc_list
= head
;
1969 gfc_syntax_error (ST_DEALLOCATE
);
1972 gfc_free_expr (stat
);
1973 gfc_free_alloc_list (head
);
1978 /* Match a RETURN statement. */
1981 gfc_match_return (void)
1985 gfc_compile_state s
;
1987 gfc_enclosing_unit (&s
);
1988 if (s
== COMP_PROGRAM
1989 && gfc_notify_std (GFC_STD_GNU
, "Extension: RETURN statement in "
1990 "main program at %C") == FAILURE
)
1994 if (gfc_match_eos () == MATCH_YES
)
1997 if (gfc_find_state (COMP_SUBROUTINE
) == FAILURE
)
1999 gfc_error ("Alternate RETURN statement at %C is only allowed within "
2004 m
= gfc_match ("% %e%t", &e
);
2007 if (m
== MATCH_ERROR
)
2010 gfc_syntax_error (ST_RETURN
);
2017 new_st
.op
= EXEC_RETURN
;
2024 /* Match a CALL statement. The tricky part here are possible
2025 alternate return specifiers. We handle these by having all
2026 "subroutines" actually return an integer via a register that gives
2027 the return number. If the call specifies alternate returns, we
2028 generate code for a SELECT statement whose case clauses contain
2029 GOTOs to the various labels. */
2032 gfc_match_call (void)
2034 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2035 gfc_actual_arglist
*a
, *arglist
;
2045 m
= gfc_match ("% %n", name
);
2051 if (gfc_get_ha_sym_tree (name
, &st
))
2055 gfc_set_sym_referenced (sym
);
2057 if (!sym
->attr
.generic
2058 && !sym
->attr
.subroutine
2059 && gfc_add_subroutine (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2062 if (gfc_match_eos () != MATCH_YES
)
2064 m
= gfc_match_actual_arglist (1, &arglist
);
2067 if (m
== MATCH_ERROR
)
2070 if (gfc_match_eos () != MATCH_YES
)
2074 /* If any alternate return labels were found, construct a SELECT
2075 statement that will jump to the right place. */
2078 for (a
= arglist
; a
; a
= a
->next
)
2079 if (a
->expr
== NULL
)
2084 gfc_symtree
*select_st
;
2085 gfc_symbol
*select_sym
;
2086 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2088 new_st
.next
= c
= gfc_get_code ();
2089 c
->op
= EXEC_SELECT
;
2090 sprintf (name
, "_result_%s",sym
->name
);
2091 gfc_get_ha_sym_tree (name
, &select_st
); /* Can't fail */
2093 select_sym
= select_st
->n
.sym
;
2094 select_sym
->ts
.type
= BT_INTEGER
;
2095 select_sym
->ts
.kind
= gfc_default_integer_kind
;
2096 gfc_set_sym_referenced (select_sym
);
2097 c
->expr
= gfc_get_expr ();
2098 c
->expr
->expr_type
= EXPR_VARIABLE
;
2099 c
->expr
->symtree
= select_st
;
2100 c
->expr
->ts
= select_sym
->ts
;
2101 c
->expr
->where
= gfc_current_locus
;
2104 for (a
= arglist
; a
; a
= a
->next
)
2106 if (a
->expr
!= NULL
)
2109 if (gfc_reference_st_label (a
->label
, ST_LABEL_TARGET
) == FAILURE
)
2114 c
->block
= gfc_get_code ();
2116 c
->op
= EXEC_SELECT
;
2118 new_case
= gfc_get_case ();
2119 new_case
->high
= new_case
->low
= gfc_int_expr (i
);
2120 c
->ext
.case_list
= new_case
;
2122 c
->next
= gfc_get_code ();
2123 c
->next
->op
= EXEC_GOTO
;
2124 c
->next
->label
= a
->label
;
2128 new_st
.op
= EXEC_CALL
;
2129 new_st
.symtree
= st
;
2130 new_st
.ext
.actual
= arglist
;
2135 gfc_syntax_error (ST_CALL
);
2138 gfc_free_actual_arglist (arglist
);
2143 /* Given a name, return a pointer to the common head structure,
2144 creating it if it does not exist. If FROM_MODULE is nonzero, we
2145 mangle the name so that it doesn't interfere with commons defined
2146 in the using namespace.
2147 TODO: Add to global symbol tree. */
2150 gfc_get_common (const char *name
, int from_module
)
2153 static int serial
= 0;
2154 char mangled_name
[GFC_MAX_SYMBOL_LEN
+1];
2158 /* A use associated common block is only needed to correctly layout
2159 the variables it contains. */
2160 snprintf(mangled_name
, GFC_MAX_SYMBOL_LEN
, "_%d_%s", serial
++, name
);
2161 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, mangled_name
);
2165 st
= gfc_find_symtree (gfc_current_ns
->common_root
, name
);
2168 st
= gfc_new_symtree (&gfc_current_ns
->common_root
, name
);
2171 if (st
->n
.common
== NULL
)
2173 st
->n
.common
= gfc_get_common_head ();
2174 st
->n
.common
->where
= gfc_current_locus
;
2175 strcpy (st
->n
.common
->name
, name
);
2178 return st
->n
.common
;
2182 /* Match a common block name. */
2185 match_common_name (char *name
)
2189 if (gfc_match_char ('/') == MATCH_NO
)
2195 if (gfc_match_char ('/') == MATCH_YES
)
2201 m
= gfc_match_name (name
);
2203 if (m
== MATCH_ERROR
)
2205 if (m
== MATCH_YES
&& gfc_match_char ('/') == MATCH_YES
)
2208 gfc_error ("Syntax error in common block name at %C");
2213 /* Match a COMMON statement. */
2216 gfc_match_common (void)
2218 gfc_symbol
*sym
, **head
, *tail
, *old_blank_common
;
2219 char name
[GFC_MAX_SYMBOL_LEN
+1];
2224 old_blank_common
= gfc_current_ns
->blank_common
.head
;
2225 if (old_blank_common
)
2227 while (old_blank_common
->common_next
)
2228 old_blank_common
= old_blank_common
->common_next
;
2233 if (gfc_match_eos () == MATCH_YES
)
2238 m
= match_common_name (name
);
2239 if (m
== MATCH_ERROR
)
2242 if (name
[0] == '\0')
2244 t
= &gfc_current_ns
->blank_common
;
2245 if (t
->head
== NULL
)
2246 t
->where
= gfc_current_locus
;
2251 t
= gfc_get_common (name
, 0);
2260 while (tail
->common_next
)
2261 tail
= tail
->common_next
;
2264 /* Grab the list of symbols. */
2265 if (gfc_match_eos () == MATCH_YES
)
2270 m
= gfc_match_symbol (&sym
, 0);
2271 if (m
== MATCH_ERROR
)
2276 if (sym
->attr
.in_common
)
2278 gfc_error ("Symbol '%s' at %C is already in a COMMON block",
2283 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2286 if (sym
->value
!= NULL
2287 && (name
[0] == '\0' || !sym
->attr
.data
))
2289 if (name
[0] == '\0')
2290 gfc_error ("Previously initialized symbol '%s' in "
2291 "blank COMMON block at %C", sym
->name
);
2293 gfc_error ("Previously initialized symbol '%s' in "
2294 "COMMON block '%s' at %C", sym
->name
, name
);
2298 if (gfc_add_in_common (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2301 /* Derived type names must have the SEQUENCE attribute. */
2302 if (sym
->ts
.type
== BT_DERIVED
&& !sym
->ts
.derived
->attr
.sequence
)
2305 ("Derived type variable in COMMON at %C does not have the "
2306 "SEQUENCE attribute");
2311 tail
->common_next
= sym
;
2317 /* Deal with an optional array specification after the
2319 m
= gfc_match_array_spec (&as
);
2320 if (m
== MATCH_ERROR
)
2325 if (as
->type
!= AS_EXPLICIT
)
2328 ("Array specification for symbol '%s' in COMMON at %C "
2329 "must be explicit", sym
->name
);
2333 if (gfc_add_dimension (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2336 if (sym
->attr
.pointer
)
2339 ("Symbol '%s' in COMMON at %C cannot be a POINTER array",
2348 gfc_gobble_whitespace ();
2349 if (gfc_match_eos () == MATCH_YES
)
2351 if (gfc_peek_char () == '/')
2353 if (gfc_match_char (',') != MATCH_YES
)
2355 gfc_gobble_whitespace ();
2356 if (gfc_peek_char () == '/')
2365 gfc_syntax_error (ST_COMMON
);
2368 if (old_blank_common
)
2369 old_blank_common
->common_next
= NULL
;
2371 gfc_current_ns
->blank_common
.head
= NULL
;
2372 gfc_free_array_spec (as
);
2377 /* Match a BLOCK DATA program unit. */
2380 gfc_match_block_data (void)
2382 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2386 if (gfc_match_eos () == MATCH_YES
)
2388 gfc_new_block
= NULL
;
2392 m
= gfc_match ("% %n%t", name
);
2396 if (gfc_get_symbol (name
, NULL
, &sym
))
2399 if (gfc_add_flavor (&sym
->attr
, FL_BLOCK_DATA
, sym
->name
, NULL
) == FAILURE
)
2402 gfc_new_block
= sym
;
2408 /* Free a namelist structure. */
2411 gfc_free_namelist (gfc_namelist
* name
)
2415 for (; name
; name
= n
)
2423 /* Match a NAMELIST statement. */
2426 gfc_match_namelist (void)
2428 gfc_symbol
*group_name
, *sym
;
2432 m
= gfc_match (" / %s /", &group_name
);
2435 if (m
== MATCH_ERROR
)
2440 if (group_name
->ts
.type
!= BT_UNKNOWN
)
2443 ("Namelist group name '%s' at %C already has a basic type "
2444 "of %s", group_name
->name
, gfc_typename (&group_name
->ts
));
2448 if (group_name
->attr
.flavor
!= FL_NAMELIST
2449 && gfc_add_flavor (&group_name
->attr
, FL_NAMELIST
,
2450 group_name
->name
, NULL
) == FAILURE
)
2455 m
= gfc_match_symbol (&sym
, 1);
2458 if (m
== MATCH_ERROR
)
2461 if (sym
->attr
.in_namelist
== 0
2462 && gfc_add_in_namelist (&sym
->attr
, sym
->name
, NULL
) == FAILURE
)
2465 nl
= gfc_get_namelist ();
2468 if (group_name
->namelist
== NULL
)
2469 group_name
->namelist
= group_name
->namelist_tail
= nl
;
2472 group_name
->namelist_tail
->next
= nl
;
2473 group_name
->namelist_tail
= nl
;
2476 if (gfc_match_eos () == MATCH_YES
)
2479 m
= gfc_match_char (',');
2481 if (gfc_match_char ('/') == MATCH_YES
)
2483 m2
= gfc_match (" %s /", &group_name
);
2484 if (m2
== MATCH_YES
)
2486 if (m2
== MATCH_ERROR
)
2500 gfc_syntax_error (ST_NAMELIST
);
2507 /* Match a MODULE statement. */
2510 gfc_match_module (void)
2514 m
= gfc_match (" %s%t", &gfc_new_block
);
2518 if (gfc_add_flavor (&gfc_new_block
->attr
, FL_MODULE
,
2519 gfc_new_block
->name
, NULL
) == FAILURE
)
2526 /* Free equivalence sets and lists. Recursively is the easiest way to
2530 gfc_free_equiv (gfc_equiv
* eq
)
2536 gfc_free_equiv (eq
->eq
);
2537 gfc_free_equiv (eq
->next
);
2539 gfc_free_expr (eq
->expr
);
2544 /* Match an EQUIVALENCE statement. */
2547 gfc_match_equivalence (void)
2549 gfc_equiv
*eq
, *set
, *tail
;
2557 eq
= gfc_get_equiv ();
2561 eq
->next
= gfc_current_ns
->equiv
;
2562 gfc_current_ns
->equiv
= eq
;
2564 if (gfc_match_char ('(') != MATCH_YES
)
2571 m
= gfc_match_variable (&set
->expr
, 1);
2572 if (m
== MATCH_ERROR
)
2577 for (ref
= set
->expr
->ref
; ref
; ref
= ref
->next
)
2578 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
2581 ("Array reference in EQUIVALENCE at %C cannot be an "
2586 if (gfc_match_char (')') == MATCH_YES
)
2588 if (gfc_match_char (',') != MATCH_YES
)
2591 set
->eq
= gfc_get_equiv ();
2595 if (gfc_match_eos () == MATCH_YES
)
2597 if (gfc_match_char (',') != MATCH_YES
)
2604 gfc_syntax_error (ST_EQUIVALENCE
);
2610 gfc_free_equiv (gfc_current_ns
->equiv
);
2611 gfc_current_ns
->equiv
= eq
;
2617 /* Match a statement function declaration. It is so easy to match
2618 non-statement function statements with a MATCH_ERROR as opposed to
2619 MATCH_NO that we suppress error message in most cases. */
2622 gfc_match_st_function (void)
2624 gfc_error_buf old_error
;
2629 m
= gfc_match_symbol (&sym
, 0);
2633 gfc_push_error (&old_error
);
2635 if (gfc_add_procedure (&sym
->attr
, PROC_ST_FUNCTION
,
2636 sym
->name
, NULL
) == FAILURE
)
2639 if (gfc_match_formal_arglist (sym
, 1, 0) != MATCH_YES
)
2642 m
= gfc_match (" = %e%t", &expr
);
2645 if (m
== MATCH_ERROR
)
2653 gfc_pop_error (&old_error
);
2658 /***************** SELECT CASE subroutines ******************/
2660 /* Free a single case structure. */
2663 free_case (gfc_case
* p
)
2665 if (p
->low
== p
->high
)
2667 gfc_free_expr (p
->low
);
2668 gfc_free_expr (p
->high
);
2673 /* Free a list of case structures. */
2676 gfc_free_case_list (gfc_case
* p
)
2688 /* Match a single case selector. */
2691 match_case_selector (gfc_case
** cp
)
2696 c
= gfc_get_case ();
2697 c
->where
= gfc_current_locus
;
2699 if (gfc_match_char (':') == MATCH_YES
)
2701 m
= gfc_match_init_expr (&c
->high
);
2704 if (m
== MATCH_ERROR
)
2710 m
= gfc_match_init_expr (&c
->low
);
2711 if (m
== MATCH_ERROR
)
2716 /* If we're not looking at a ':' now, make a range out of a single
2717 target. Else get the upper bound for the case range. */
2718 if (gfc_match_char (':') != MATCH_YES
)
2722 m
= gfc_match_init_expr (&c
->high
);
2723 if (m
== MATCH_ERROR
)
2725 /* MATCH_NO is fine. It's OK if nothing is there! */
2733 gfc_error ("Expected initialization expression in CASE at %C");
2741 /* Match the end of a case statement. */
2744 match_case_eos (void)
2746 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2749 if (gfc_match_eos () == MATCH_YES
)
2752 gfc_gobble_whitespace ();
2754 m
= gfc_match_name (name
);
2758 if (strcmp (name
, gfc_current_block ()->name
) != 0)
2760 gfc_error ("Expected case name of '%s' at %C",
2761 gfc_current_block ()->name
);
2765 return gfc_match_eos ();
2769 /* Match a SELECT statement. */
2772 gfc_match_select (void)
2777 m
= gfc_match_label ();
2778 if (m
== MATCH_ERROR
)
2781 m
= gfc_match (" select case ( %e )%t", &expr
);
2785 new_st
.op
= EXEC_SELECT
;
2792 /* Match a CASE statement. */
2795 gfc_match_case (void)
2797 gfc_case
*c
, *head
, *tail
;
2802 if (gfc_current_state () != COMP_SELECT
)
2804 gfc_error ("Unexpected CASE statement at %C");
2808 if (gfc_match ("% default") == MATCH_YES
)
2810 m
= match_case_eos ();
2813 if (m
== MATCH_ERROR
)
2816 new_st
.op
= EXEC_SELECT
;
2817 c
= gfc_get_case ();
2818 c
->where
= gfc_current_locus
;
2819 new_st
.ext
.case_list
= c
;
2823 if (gfc_match_char ('(') != MATCH_YES
)
2828 if (match_case_selector (&c
) == MATCH_ERROR
)
2838 if (gfc_match_char (')') == MATCH_YES
)
2840 if (gfc_match_char (',') != MATCH_YES
)
2844 m
= match_case_eos ();
2847 if (m
== MATCH_ERROR
)
2850 new_st
.op
= EXEC_SELECT
;
2851 new_st
.ext
.case_list
= head
;
2856 gfc_error ("Syntax error in CASE-specification at %C");
2859 gfc_free_case_list (head
); /* new_st is cleaned up in parse.c. */
2863 /********************* WHERE subroutines ********************/
2865 /* Match the rest of a simple WHERE statement that follows an IF statement.
2869 match_simple_where (void)
2875 m
= gfc_match (" ( %e )", &expr
);
2879 m
= gfc_match_assignment ();
2882 if (m
== MATCH_ERROR
)
2885 if (gfc_match_eos () != MATCH_YES
)
2888 c
= gfc_get_code ();
2892 c
->next
= gfc_get_code ();
2895 gfc_clear_new_st ();
2897 new_st
.op
= EXEC_WHERE
;
2903 gfc_syntax_error (ST_WHERE
);
2906 gfc_free_expr (expr
);
2910 /* Match a WHERE statement. */
2913 gfc_match_where (gfc_statement
* st
)
2919 m0
= gfc_match_label ();
2920 if (m0
== MATCH_ERROR
)
2923 m
= gfc_match (" where ( %e )", &expr
);
2927 if (gfc_match_eos () == MATCH_YES
)
2929 *st
= ST_WHERE_BLOCK
;
2931 new_st
.op
= EXEC_WHERE
;
2936 m
= gfc_match_assignment ();
2938 gfc_syntax_error (ST_WHERE
);
2942 gfc_free_expr (expr
);
2946 /* We've got a simple WHERE statement. */
2948 c
= gfc_get_code ();
2952 c
->next
= gfc_get_code ();
2955 gfc_clear_new_st ();
2957 new_st
.op
= EXEC_WHERE
;
2964 /* Match an ELSEWHERE statement. We leave behind a WHERE node in
2965 new_st if successful. */
2968 gfc_match_elsewhere (void)
2970 char name
[GFC_MAX_SYMBOL_LEN
+ 1];
2974 if (gfc_current_state () != COMP_WHERE
)
2976 gfc_error ("ELSEWHERE statement at %C not enclosed in WHERE block");
2982 if (gfc_match_char ('(') == MATCH_YES
)
2984 m
= gfc_match_expr (&expr
);
2987 if (m
== MATCH_ERROR
)
2990 if (gfc_match_char (')') != MATCH_YES
)
2994 if (gfc_match_eos () != MATCH_YES
)
2995 { /* Better be a name at this point */
2996 m
= gfc_match_name (name
);
2999 if (m
== MATCH_ERROR
)
3002 if (gfc_match_eos () != MATCH_YES
)
3005 if (strcmp (name
, gfc_current_block ()->name
) != 0)
3007 gfc_error ("Label '%s' at %C doesn't match WHERE label '%s'",
3008 name
, gfc_current_block ()->name
);
3013 new_st
.op
= EXEC_WHERE
;
3018 gfc_syntax_error (ST_ELSEWHERE
);
3021 gfc_free_expr (expr
);
3026 /******************** FORALL subroutines ********************/
3028 /* Free a list of FORALL iterators. */
3031 gfc_free_forall_iterator (gfc_forall_iterator
* iter
)
3033 gfc_forall_iterator
*next
;
3039 gfc_free_expr (iter
->var
);
3040 gfc_free_expr (iter
->start
);
3041 gfc_free_expr (iter
->end
);
3042 gfc_free_expr (iter
->stride
);
3050 /* Match an iterator as part of a FORALL statement. The format is:
3052 <var> = <start>:<end>[:<stride>][, <scalar mask>] */
3055 match_forall_iterator (gfc_forall_iterator
** result
)
3057 gfc_forall_iterator
*iter
;
3061 where
= gfc_current_locus
;
3062 iter
= gfc_getmem (sizeof (gfc_forall_iterator
));
3064 m
= gfc_match_variable (&iter
->var
, 0);
3068 if (gfc_match_char ('=') != MATCH_YES
)
3074 m
= gfc_match_expr (&iter
->start
);
3077 if (m
== MATCH_ERROR
)
3080 if (gfc_match_char (':') != MATCH_YES
)
3083 m
= gfc_match_expr (&iter
->end
);
3086 if (m
== MATCH_ERROR
)
3089 if (gfc_match_char (':') == MATCH_NO
)
3090 iter
->stride
= gfc_int_expr (1);
3093 m
= gfc_match_expr (&iter
->stride
);
3096 if (m
== MATCH_ERROR
)
3104 gfc_error ("Syntax error in FORALL iterator at %C");
3108 gfc_current_locus
= where
;
3109 gfc_free_forall_iterator (iter
);
3114 /* Match the header of a FORALL statement. */
3117 match_forall_header (gfc_forall_iterator
** phead
, gfc_expr
** mask
)
3119 gfc_forall_iterator
*head
, *tail
, *new;
3122 gfc_gobble_whitespace ();
3127 if (gfc_match_char ('(') != MATCH_YES
)
3130 m
= match_forall_iterator (&new);
3131 if (m
== MATCH_ERROR
)
3140 if (gfc_match_char (',') != MATCH_YES
)
3143 m
= match_forall_iterator (&new);
3144 if (m
== MATCH_ERROR
)
3153 /* Have to have a mask expression */
3155 m
= gfc_match_expr (mask
);
3158 if (m
== MATCH_ERROR
)
3164 if (gfc_match_char (')') == MATCH_NO
)
3171 gfc_syntax_error (ST_FORALL
);
3174 gfc_free_expr (*mask
);
3175 gfc_free_forall_iterator (head
);
3180 /* Match the rest of a simple FORALL statement that follows an IF statement.
3184 match_simple_forall (void)
3186 gfc_forall_iterator
*head
;
3195 m
= match_forall_header (&head
, &mask
);
3202 m
= gfc_match_assignment ();
3204 if (m
== MATCH_ERROR
)
3208 m
= gfc_match_pointer_assignment ();
3209 if (m
== MATCH_ERROR
)
3215 c
= gfc_get_code ();
3217 c
->loc
= gfc_current_locus
;
3219 if (gfc_match_eos () != MATCH_YES
)
3222 gfc_clear_new_st ();
3223 new_st
.op
= EXEC_FORALL
;
3225 new_st
.ext
.forall_iterator
= head
;
3226 new_st
.block
= gfc_get_code ();
3228 new_st
.block
->op
= EXEC_FORALL
;
3229 new_st
.block
->next
= c
;
3234 gfc_syntax_error (ST_FORALL
);
3237 gfc_free_forall_iterator (head
);
3238 gfc_free_expr (mask
);
3244 /* Match a FORALL statement. */
3247 gfc_match_forall (gfc_statement
* st
)
3249 gfc_forall_iterator
*head
;
3258 m0
= gfc_match_label ();
3259 if (m0
== MATCH_ERROR
)
3262 m
= gfc_match (" forall");
3266 m
= match_forall_header (&head
, &mask
);
3267 if (m
== MATCH_ERROR
)
3272 if (gfc_match_eos () == MATCH_YES
)
3274 *st
= ST_FORALL_BLOCK
;
3276 new_st
.op
= EXEC_FORALL
;
3278 new_st
.ext
.forall_iterator
= head
;
3283 m
= gfc_match_assignment ();
3284 if (m
== MATCH_ERROR
)
3288 m
= gfc_match_pointer_assignment ();
3289 if (m
== MATCH_ERROR
)
3295 c
= gfc_get_code ();
3298 if (gfc_match_eos () != MATCH_YES
)
3301 gfc_clear_new_st ();
3302 new_st
.op
= EXEC_FORALL
;
3304 new_st
.ext
.forall_iterator
= head
;
3305 new_st
.block
= gfc_get_code ();
3307 new_st
.block
->op
= EXEC_FORALL
;
3308 new_st
.block
->next
= c
;
3314 gfc_syntax_error (ST_FORALL
);
3317 gfc_free_forall_iterator (head
);
3318 gfc_free_expr (mask
);
3319 gfc_free_statements (c
);