/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000-2016 Free Software Foundation, Inc.
+ Copyright (C) 2000-2020 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
/* Stack of SELECT TYPE statements. */
gfc_select_type_stack *select_type_stack = NULL;
+/* List of type parameter expressions. */
+gfc_actual_arglist *type_param_spec_list;
+
/* For debugging and diagnostic purposes. Return the textual representation
of the intrinsic operator OP. */
const char *
case INTRINSIC_NONE:
return "none";
+ /* DTIO */
+ case INTRINSIC_FORMATTED:
+ return "formatted";
+ case INTRINSIC_UNFORMATTED:
+ return "unformatted";
+
default:
break;
}
/******************** Generic matching subroutines ************************/
+/* Matches a member separator. With standard FORTRAN this is '%', but with
+ DEC structures we must carefully match dot ('.').
+ Because operators are spelled ".op.", a dotted string such as "x.y.z..."
+ can be either a component reference chain or a combination of binary
+ operations.
+ There is no real way to win because the string may be grammatically
+ ambiguous. The following rules help avoid ambiguities - they match
+ some behavior of other (older) compilers. If the rules here are changed
+ the test cases should be updated. If the user has problems with these rules
+ they probably deserve the consequences. Consider "x.y.z":
+ (1) If any user defined operator ".y." exists, this is always y(x,z)
+ (even if ".y." is the wrong type and/or x has a member y).
+ (2) Otherwise if x has a member y, and y is itself a derived type,
+ this is (x->y)->z, even if an intrinsic operator exists which
+ can handle (x,z).
+ (3) If x has no member y or (x->y) is not a derived type but ".y."
+ is an intrinsic operator (such as ".eq."), this is y(x,z).
+ (4) Lastly if there is no operator ".y." and x has no member "y", it is an
+ error.
+ It is worth noting that the logic here does not support mixed use of member
+ accessors within a single string. That is, even if x has component y and y
+ has component z, the following are all syntax errors:
+ "x%y.z" "x.y%z" "(x.y).z" "(x%y)%z"
+ */
+
+match
+gfc_match_member_sep(gfc_symbol *sym)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus dot_loc, start_loc;
+ gfc_intrinsic_op iop;
+ match m;
+ gfc_symbol *tsym;
+ gfc_component *c = NULL;
+
+ /* What a relief: '%' is an unambiguous member separator. */
+ if (gfc_match_char ('%') == MATCH_YES)
+ return MATCH_YES;
+
+ /* Beware ye who enter here. */
+ if (!flag_dec_structure || !sym)
+ return MATCH_NO;
+
+ tsym = NULL;
+
+ /* We may be given either a derived type variable or the derived type
+ declaration itself (which actually contains the components);
+ we need the latter to search for components. */
+ if (gfc_fl_struct (sym->attr.flavor))
+ tsym = sym;
+ else if (gfc_bt_struct (sym->ts.type))
+ tsym = sym->ts.u.derived;
+
+ iop = INTRINSIC_NONE;
+ name[0] = '\0';
+ m = MATCH_NO;
+
+ /* If we have to reject come back here later. */
+ start_loc = gfc_current_locus;
+
+ /* Look for a component access next. */
+ if (gfc_match_char ('.') != MATCH_YES)
+ return MATCH_NO;
+
+ /* If we accept, come back here. */
+ dot_loc = gfc_current_locus;
+
+ /* Try to match a symbol name following the dot. */
+ if (gfc_match_name (name) != MATCH_YES)
+ {
+ gfc_error ("Expected structure component or operator name "
+ "after '.' at %C");
+ goto error;
+ }
+
+ /* If no dot follows we have "x.y" which should be a component access. */
+ if (gfc_match_char ('.') != MATCH_YES)
+ goto yes;
+
+ /* Now we have a string "x.y.z" which could be a nested member access
+ (x->y)->z or a binary operation y on x and z. */
+
+ /* First use any user-defined operators ".y." */
+ if (gfc_find_uop (name, sym->ns) != NULL)
+ goto no;
+
+ /* Match accesses to existing derived-type components for
+ derived-type vars: "x.y.z" = (x->y)->z */
+ c = gfc_find_component(tsym, name, false, true, NULL);
+ if (c && (gfc_bt_struct (c->ts.type) || c->ts.type == BT_CLASS))
+ goto yes;
+
+ /* If y is not a component or has no members, try intrinsic operators. */
+ gfc_current_locus = start_loc;
+ if (gfc_match_intrinsic_op (&iop) != MATCH_YES)
+ {
+ /* If ".y." is not an intrinsic operator but y was a valid non-
+ structure component, match and leave the trailing dot to be
+ dealt with later. */
+ if (c)
+ goto yes;
+
+ gfc_error ("%qs is neither a defined operator nor a "
+ "structure component in dotted string at %C", name);
+ goto error;
+ }
+
+ /* .y. is an intrinsic operator, overriding any possible member access. */
+ goto no;
+
+ /* Return keeping the current locus consistent with the match result. */
+error:
+ m = MATCH_ERROR;
+no:
+ gfc_current_locus = start_loc;
+ return m;
+yes:
+ gfc_current_locus = dot_loc;
+ return MATCH_YES;
+}
+
+
/* This function scans the current statement counting the opened and closed
parenthesis to make sure they are balanced. */
for (;;)
{
+ if (count > 0)
+ where = gfc_current_locus;
c = gfc_next_char_literal (instring);
if (c == '\n')
break;
if (c == '(' && quote == ' ')
{
count++;
- where = gfc_current_locus;
}
if (c == ')' && quote == ' ')
{
gfc_current_locus = old_loc;
- if (count > 0)
- {
- gfc_error ("Missing %<)%> in statement at or before %L", &where);
- return MATCH_ERROR;
- }
- if (count < 0)
+ if (count != 0)
{
- gfc_error ("Missing %<(%> in statement at or before %L", &where);
+ gfc_error ("Missing %qs in statement at or before %L",
+ count > 0? ")":"(", &where);
return MATCH_ERROR;
}
gfc_match_small_int (int *value)
{
gfc_expr *expr;
- const char *p;
match m;
int i;
if (m != MATCH_YES)
return m;
- p = gfc_extract_int (expr, &i);
+ if (gfc_extract_int (expr, &i, 1))
+ m = MATCH_ERROR;
gfc_free_expr (expr);
- if (p != NULL)
- {
- gfc_error (p);
- m = MATCH_ERROR;
- }
-
*value = i;
return m;
}
match
gfc_match_small_int_expr (int *value, gfc_expr **expr)
{
- const char *p;
match m;
int i;
if (m != MATCH_YES)
return m;
- p = gfc_extract_int (*expr, &i);
-
- if (p != NULL)
- {
- gfc_error (p);
- m = MATCH_ERROR;
- }
+ if (gfc_extract_int (*expr, &i, 1))
+ m = MATCH_ERROR;
*value = i;
return m;
return MATCH_ERROR;
}
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
+ if (!gfc_add_flavor (&gfc_new_block->attr, FL_LABEL,
gfc_new_block->name, NULL))
return MATCH_ERROR;
}
break;
+ case 'x':
+ if (gfc_next_ascii_char () == 'o'
+ && gfc_next_ascii_char () == 'r'
+ && gfc_next_ascii_char () == '.')
+ {
+ if (!gfc_notify_std (GFC_STD_LEGACY, ".XOR. operator at %C"))
+ return MATCH_ERROR;
+ /* Matched ".xor." - equivalent to ".neqv.". */
+ *result = INTRINSIC_NEQV;
+ return MATCH_YES;
+ }
+ break;
+
default:
break;
}
if (m != MATCH_YES)
return MATCH_NO;
+ if (var->symtree->n.sym->attr.dimension)
+ {
+ gfc_error ("Loop variable at %C cannot be an array");
+ goto cleanup;
+ }
+
/* F2008, C617 & C565. */
if (var->symtree->n.sym->attr.codimension)
{
default:
gfc_internal_error ("gfc_match(): Bad match code %c", c);
}
+ /* FALLTHRU */
default:
rvalue = NULL;
m = gfc_match (" %e%t", &rvalue);
+
+ if (m == MATCH_YES
+ && rvalue->ts.type == BT_BOZ
+ && lvalue->ts.type == BT_CLASS)
+ {
+ m = MATCH_ERROR;
+ gfc_error ("BOZ literal constant at %L is neither a DATA statement "
+ "value nor an actual argument of INT/REAL/DBLE/CMPLX "
+ "intrinsic subprogram", &rvalue->where);
+ }
+
+ if (lvalue->expr_type == EXPR_CONSTANT)
+ {
+ /* This clobbers %len and %kind. */
+ m = MATCH_ERROR;
+ gfc_error ("Assignment to a constant expression at %C");
+ }
+
if (m != MATCH_YES)
{
gfc_current_locus = old_loc;
gfc_check_do_variable (lvalue->symtree);
+ if (lvalue->ts.type == BT_CLASS)
+ gfc_find_vtab (&rvalue->ts);
+
return MATCH_YES;
}
return MATCH_ERROR;
}
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
+ if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
+ "Arithmetic IF statement at %C"))
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
old_loc = gfc_current_locus;
- m = gfc_match (" if ( %e", &expr);
+ m = gfc_match (" if ", &expr);
+ if (m != MATCH_YES)
+ return m;
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Missing %<(%> in IF-expression at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match ("%e", &expr);
if (m != MATCH_YES)
return m;
return MATCH_ERROR;
}
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF statement at %C"))
+ if (!gfc_notify_std (GFC_STD_F95_OBS | GFC_STD_F2018_DEL,
+ "Arithmetic IF statement at %C"))
return MATCH_ERROR;
new_st.op = EXEC_ARITHMETIC_IF;
match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
match ("backspace", gfc_match_backspace, ST_BACKSPACE)
match ("call", gfc_match_call, ST_CALL)
+ match ("change team", gfc_match_change_team, ST_CHANGE_TEAM)
match ("close", gfc_match_close, ST_CLOSE)
match ("continue", gfc_match_continue, ST_CONTINUE)
match ("cycle", gfc_match_cycle, ST_CYCLE)
match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
match ("end file", gfc_match_endfile, ST_END_FILE)
+ match ("end team", gfc_match_end_team, ST_END_TEAM)
match ("error stop", gfc_match_error_stop, ST_ERROR_STOP)
match ("event post", gfc_match_event_post, ST_EVENT_POST)
match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT)
match ("exit", gfc_match_exit, ST_EXIT)
+ match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE)
match ("flush", gfc_match_flush, ST_FLUSH)
match ("forall", match_simple_forall, ST_FORALL)
+ match ("form team", gfc_match_form_team, ST_FORM_TEAM)
match ("go to", gfc_match_goto, ST_GOTO)
match ("if", match_arithmetic_if, ST_ARITHMETIC_IF)
match ("inquire", gfc_match_inquire, ST_INQUIRE)
match ("sync all", gfc_match_sync_all, ST_SYNC_CALL);
match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
+ match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM)
match ("unlock", gfc_match_unlock, ST_UNLOCK)
match ("where", match_simple_where, ST_WHERE)
match ("write", gfc_match_write, ST_WRITE)
- /* The gfc_match_assignment() above may have returned a MATCH_NO
- where the assignment was to a named constant. Check that
- special case here. */
- m = gfc_match_assignment ();
- if (m == MATCH_NO)
- {
- gfc_error ("Cannot assign to a named constant at %C");
- gfc_free_expr (expr);
- gfc_undo_symbols ();
- gfc_current_locus = old_loc;
- return MATCH_ERROR;
- }
+ if (flag_dec)
+ match ("type", gfc_match_print, ST_WRITE)
/* All else has failed, so give up. See if any of the matchers has
stored an error message of some sort. */
if (!gfc_error_check ())
- gfc_error ("Unclassifiable statement in IF-clause at %C");
+ gfc_error ("Syntax error in IF-clause after %C");
gfc_free_expr (expr);
return MATCH_ERROR;
got_match:
if (m == MATCH_NO)
- gfc_error ("Syntax error in IF-clause at %C");
+ gfc_error ("Syntax error in IF-clause after %C");
if (m != MATCH_YES)
{
gfc_free_expr (expr);
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
- gfc_error ("Unexpected junk after ELSE statement at %C");
+ gfc_error ("Invalid character(s) in ELSE statement after %C");
return MATCH_ERROR;
}
gfc_match_elseif (void)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
- gfc_expr *expr;
+ gfc_expr *expr, *then;
+ locus where;
match m;
- m = gfc_match (" ( %e ) then", &expr);
+ if (gfc_match_char ('(') != MATCH_YES)
+ {
+ gfc_error ("Missing %<(%> in ELSE IF expression at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" %e ", &expr);
if (m != MATCH_YES)
return m;
- if (gfc_match_eos () == MATCH_YES)
+ if (gfc_match_char (')') != MATCH_YES)
+ {
+ gfc_error ("Missing %<)%> in ELSE IF expression at %C");
+ goto cleanup;
+ }
+
+ m = gfc_match (" then ", &then);
+
+ where = gfc_current_locus;
+
+ if (m == MATCH_YES && (gfc_match_eos () == MATCH_YES
+ || (gfc_current_block ()
+ && gfc_match_name (name) == MATCH_YES)))
goto done;
+ if (gfc_match_eos () == MATCH_YES)
+ {
+ gfc_error ("Missing THEN in ELSE IF statement after %L", &where);
+ goto cleanup;
+ }
+
if (gfc_match_name (name) != MATCH_YES
|| gfc_current_block () == NULL
|| gfc_match_eos () != MATCH_YES)
{
- gfc_error ("Unexpected junk after ELSE IF statement at %C");
+ gfc_error ("Syntax error in ELSE IF statement after %L", &where);
goto cleanup;
}
if (strcmp (name, gfc_current_block ()->name) != 0)
{
- gfc_error ("Label %qs at %C doesn't match IF label %qs",
- name, gfc_current_block ()->name);
+ gfc_error ("Label %qs after %L doesn't match IF label %qs",
+ name, &where, gfc_current_block ()->name);
goto cleanup;
}
+ if (m != MATCH_YES)
+ return m;
+
done:
new_st.op = EXEC_IF;
new_st.expr1 = expr;
gfc_association_list* a;
/* Match the next association. */
- if (gfc_match (" %n => %e", newAssoc->name, &newAssoc->target)
- != MATCH_YES)
+ if (gfc_match (" %n =>", newAssoc->name) != MATCH_YES)
{
gfc_error ("Expected association at %C");
goto assocListError;
}
+
+ if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+ {
+ /* Have another go, allowing for procedure pointer selectors. */
+ gfc_matching_procptr_assignment = 1;
+ if (gfc_match (" %e", &newAssoc->target) != MATCH_YES)
+ {
+ gfc_error ("Invalid association target at %C");
+ goto assocListError;
+ }
+ gfc_matching_procptr_assignment = 0;
+ }
newAssoc->where = gfc_current_locus;
/* Check that the current name is not yet in the list. */
goto assocListError;
}
+ /* The target expression cannot be a BOZ literal constant. */
+ if (newAssoc->target->ts.type == BT_BOZ)
+ {
+ gfc_error ("Association target at %L cannot be a BOZ literal "
+ "constant", &newAssoc->target->where);
+ goto assocListError;
+ }
+
/* The `variable' field is left blank for now; because the target is not
yet resolved, we can't use gfc_has_vector_subscript to determine it
for now. This is set during resolution. */
{
char name[GFC_MAX_SYMBOL_LEN + 1];
locus old_locus;
- gfc_symbol *derived;
+ gfc_symbol *derived, *der_type;
+ match m = MATCH_YES;
+ gfc_actual_arglist *decl_type_param_list = NULL;
+ bool is_pdt_template = false;
old_locus = gfc_current_locus;
gfc_find_symbol (name, NULL, 1, &derived);
+ /* Match the PDT spec list, if there. */
+ if (derived && derived->attr.flavor == FL_PROCEDURE)
+ {
+ gfc_find_symbol (gfc_dt_upper_string (name), NULL, 1, &der_type);
+ is_pdt_template = der_type
+ && der_type->attr.flavor == FL_DERIVED
+ && der_type->attr.pdt_template;
+ }
+
+ if (is_pdt_template)
+ m = gfc_match_actual_arglist (1, &decl_type_param_list, true);
+
+ if (m == MATCH_ERROR)
+ {
+ gfc_free_actual_arglist (decl_type_param_list);
+ return m;
+ }
+
if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
+ /* If this is a PDT, find the specific instance. */
+ if (m == MATCH_YES && is_pdt_template)
+ {
+ gfc_namespace *old_ns;
+
+ old_ns = gfc_current_ns;
+ while (gfc_current_ns && gfc_current_ns->parent)
+ gfc_current_ns = gfc_current_ns->parent;
+
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+ m = gfc_get_pdt_instance (decl_type_param_list, &der_type,
+ &type_param_spec_list);
+ gfc_free_actual_arglist (decl_type_param_list);
+
+ if (m != MATCH_YES)
+ return m;
+ derived = der_type;
+ gcc_assert (!derived->attr.pdt_template && derived->attr.pdt_type);
+ gfc_set_sym_referenced (derived);
+
+ gfc_current_ns = old_ns;
+ }
+
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
{
match m;
locus old_locus;
+ char c, name[GFC_MAX_SYMBOL_LEN + 1];
gfc_clear_ts (ts);
gfc_gobble_whitespace ();
old_locus = gfc_current_locus;
+ /* If c isn't [a-z], then return immediately. */
+ c = gfc_peek_ascii_char ();
+ if (!ISALPHA(c))
+ return MATCH_NO;
+
+ type_param_spec_list = NULL;
+
if (match_derived_type_spec (ts) == MATCH_YES)
{
/* Enforce F03:C401. */
goto kind_selector;
}
- if (gfc_match ("real") == MATCH_YES)
- {
- ts->type = BT_REAL;
- ts->kind = gfc_default_real_kind;
- goto kind_selector;
- }
-
if (gfc_match ("double precision") == MATCH_YES)
{
ts->type = BT_REAL;
return m;
}
- if (gfc_match ("logical") == MATCH_YES)
+ /* REAL is a real pain because it can be a type, intrinsic subprogram,
+ or list item in a type-list of an OpenMP reduction clause. Need to
+ differentiate REAL([KIND]=scalar-int-initialization-expr) from
+ REAL(A,[KIND]) and REAL(KIND,A). Logically, when this code was
+ written the use of LOGICAL as a type-spec or intrinsic subprogram
+ was overlooked. */
+
+ m = gfc_match (" %n", name);
+ if (m == MATCH_YES
+ && (strcmp (name, "real") == 0 || strcmp (name, "logical") == 0))
{
- ts->type = BT_LOGICAL;
- ts->kind = gfc_default_logical_kind;
- goto kind_selector;
+ char c;
+ gfc_expr *e;
+ locus where;
+
+ if (*name == 'r')
+ {
+ ts->type = BT_REAL;
+ ts->kind = gfc_default_real_kind;
+ }
+ else
+ {
+ ts->type = BT_LOGICAL;
+ ts->kind = gfc_default_logical_kind;
+ }
+
+ gfc_gobble_whitespace ();
+
+ /* Prevent REAL*4, etc. */
+ c = gfc_peek_ascii_char ();
+ if (c == '*')
+ {
+ gfc_error ("Invalid type-spec at %C");
+ return MATCH_ERROR;
+ }
+
+ /* Found leading colon in REAL::, a trailing ')' in for example
+ TYPE IS (REAL), or REAL, for an OpenMP list-item. */
+ if (c == ':' || c == ')' || (flag_openmp && c == ','))
+ return MATCH_YES;
+
+ /* Found something other than the opening '(' in REAL(... */
+ if (c != '(')
+ return MATCH_NO;
+ else
+ gfc_next_char (); /* Burn the '('. */
+
+ /* Look for the optional KIND=. */
+ where = gfc_current_locus;
+ m = gfc_match ("%n", name);
+ if (m == MATCH_YES)
+ {
+ gfc_gobble_whitespace ();
+ c = gfc_next_char ();
+ if (c == '=')
+ {
+ if (strcmp(name, "a") == 0 || strcmp(name, "l") == 0)
+ return MATCH_NO;
+ else if (strcmp(name, "kind") == 0)
+ goto found;
+ else
+ return MATCH_ERROR;
+ }
+ else
+ gfc_current_locus = where;
+ }
+ else
+ gfc_current_locus = where;
+
+found:
+
+ m = gfc_match_init_expr (&e);
+ if (m == MATCH_NO || m == MATCH_ERROR)
+ return MATCH_NO;
+
+ /* If a comma appears, it is an intrinsic subprogram. */
+ gfc_gobble_whitespace ();
+ c = gfc_peek_ascii_char ();
+ if (c == ',')
+ {
+ gfc_free_expr (e);
+ return MATCH_NO;
+ }
+
+ /* If ')' appears, we have REAL(initialization-expr), here check for
+ a scalar integer initialization-expr and valid kind parameter. */
+ if (c == ')')
+ {
+ if (e->ts.type != BT_INTEGER || e->rank > 0)
+ {
+ gfc_free_expr (e);
+ return MATCH_NO;
+ }
+
+ if (e->expr_type != EXPR_CONSTANT)
+ goto ohno;
+
+ gfc_next_char (); /* Burn the ')'. */
+ ts->kind = (int) mpz_get_si (e->value.integer);
+ if (gfc_validate_kind (ts->type, ts->kind , true) == -1)
+ {
+ gfc_error ("Invalid type-spec at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_free_expr (e);
+
+ return MATCH_YES;
+ }
}
+ohno:
+
/* If a type is not matched, simply return MATCH_NO. */
gfc_current_locus = old_locus;
return MATCH_NO;
kind_selector:
gfc_gobble_whitespace ();
+
+ /* This prevents INTEGER*4, etc. */
if (gfc_peek_ascii_char () == '*')
{
gfc_error ("Invalid type-spec at %C");
m = gfc_match_kind_spec (ts, false);
+ /* No kind specifier found. */
if (m == MATCH_NO)
- m = MATCH_YES; /* No kind specifier found. */
-
- /* gfortran may have matched REAL(a=1), which is the keyword form of the
- intrinsic procedure. */
- if (ts->type == BT_REAL && m == MATCH_ERROR)
- m = MATCH_NO;
+ m = MATCH_YES;
return m;
}
old_loc = gfc_current_locus;
+ memset (&iter, '\0', sizeof (gfc_iterator));
label = NULL;
- iter.var = iter.start = iter.end = iter.step = NULL;
m = gfc_match_label ();
if (m == MATCH_ERROR)
case COMP_IF:
case COMP_SELECT:
case COMP_SELECT_TYPE:
+ case COMP_SELECT_RANK:
gcc_assert (sym);
if (op == EXEC_CYCLE)
{
if (o != NULL)
{
gfc_error (is_oacc (p)
- ? "%s statement at %C leaving OpenACC structured block"
- : "%s statement at %C leaving OpenMP structured block",
+ ? G_("%s statement at %C leaving OpenACC structured block")
+ : G_("%s statement at %C leaving OpenMP structured block"),
gfc_ascii_statement (st));
return MATCH_ERROR;
}
&& o != NULL
&& o->state == COMP_OMP_STRUCTURED_BLOCK
&& (o->head->op == EXEC_OACC_LOOP
- || o->head->op == EXEC_OACC_PARALLEL_LOOP))
+ || o->head->op == EXEC_OACC_KERNELS_LOOP
+ || o->head->op == EXEC_OACC_PARALLEL_LOOP
+ || o->head->op == EXEC_OACC_SERIAL_LOOP))
{
int collapse = 1;
gcc_assert (o->head->next != NULL
|| o->head->next->op == EXEC_DO_WHILE)
&& o->previous != NULL
&& o->previous->tail->op == o->head->op);
- if (o->previous->tail->ext.omp_clauses != NULL
- && o->previous->tail->ext.omp_clauses->collapse > 1)
- collapse = o->previous->tail->ext.omp_clauses->collapse;
+ if (o->previous->tail->ext.omp_clauses != NULL)
+ {
+ /* Both collapsed and tiled loops are lowered the same way, but are not
+ compatible. In gfc_trans_omp_do, the tile is prioritized. */
+ if (o->previous->tail->ext.omp_clauses->tile_list)
+ {
+ collapse = 0;
+ gfc_expr_list *el = o->previous->tail->ext.omp_clauses->tile_list;
+ for ( ; el; el = el->next)
+ ++collapse;
+ }
+ else if (o->previous->tail->ext.omp_clauses->collapse > 1)
+ collapse = o->previous->tail->ext.omp_clauses->collapse;
+ }
if (st == ST_EXIT && cnt <= collapse)
{
gfc_error ("EXIT statement at %C terminating !$ACC LOOP loop");
}
if (st == ST_CYCLE && cnt < collapse)
{
- gfc_error ("CYCLE statement at %C to non-innermost collapsed"
- " !$ACC LOOP loop");
+ gfc_error (o->previous->tail->ext.omp_clauses->tile_list
+ ? G_("CYCLE statement at %C to non-innermost tiled"
+ " !$ACC LOOP loop")
+ : G_("CYCLE statement at %C to non-innermost collapsed"
+ " !$ACC LOOP loop"));
return MATCH_ERROR;
}
}
|| o->head->op == EXEC_OMP_DO_SIMD
|| o->head->op == EXEC_OMP_PARALLEL_DO_SIMD))
{
- int collapse = 1;
+ int count = 1;
gcc_assert (o->head->next != NULL
&& (o->head->next->op == EXEC_DO
|| o->head->next->op == EXEC_DO_WHILE)
&& o->previous != NULL
&& o->previous->tail->op == o->head->op);
- if (o->previous->tail->ext.omp_clauses != NULL
- && o->previous->tail->ext.omp_clauses->collapse > 1)
- collapse = o->previous->tail->ext.omp_clauses->collapse;
- if (st == ST_EXIT && cnt <= collapse)
+ if (o->previous->tail->ext.omp_clauses != NULL)
+ {
+ if (o->previous->tail->ext.omp_clauses->collapse > 1)
+ count = o->previous->tail->ext.omp_clauses->collapse;
+ if (o->previous->tail->ext.omp_clauses->orderedc)
+ count = o->previous->tail->ext.omp_clauses->orderedc;
+ }
+ if (st == ST_EXIT && cnt <= count)
{
gfc_error ("EXIT statement at %C terminating !$OMP DO loop");
return MATCH_ERROR;
}
- if (st == ST_CYCLE && cnt < collapse)
+ if (st == ST_CYCLE && cnt < count)
{
gfc_error ("CYCLE statement at %C to non-innermost collapsed"
" !$OMP DO loop");
}
-/* Match a number or character constant after an (ERROR) STOP or PAUSE
- statement. */
+/* Match a stop-code after an (ERROR) STOP or PAUSE statement. The
+ requirements for a stop-code differ in the standards.
+
+Fortran 95 has
+
+ R840 stop-stmt is STOP [ stop-code ]
+ R841 stop-code is scalar-char-constant
+ or digit [ digit [ digit [ digit [ digit ] ] ] ]
+
+Fortran 2003 matches Fortran 95 except R840 and R841 are now R849 and R850.
+Fortran 2008 has
+
+ R855 stop-stmt is STOP [ stop-code ]
+ R856 allstop-stmt is ALL STOP [ stop-code ]
+ R857 stop-code is scalar-default-char-constant-expr
+ or scalar-int-constant-expr
+
+For free-form source code, all standards contain a statement of the form:
+
+ A blank shall be used to separate names, constants, or labels from
+ adjacent keywords, names, constants, or labels.
+
+A stop-code is not a name, constant, or label. So, under Fortran 95 and 2003,
+
+ STOP123
+
+is valid, but it is invalid Fortran 2008. */
static match
gfc_match_stopcode (gfc_statement st)
{
- gfc_expr *e;
+ gfc_expr *e = NULL;
match m;
+ bool f95, f03, f08;
- e = NULL;
+ /* Set f95 for -std=f95. */
+ f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);
+
+ /* Set f03 for -std=f2003. */
+ f03 = (gfc_option.allow_std == GFC_STD_OPT_F03);
+
+ /* Set f08 for -std=f2008. */
+ f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);
+
+ /* Look for a blank between STOP and the stop-code for F2008 or later. */
+ if (gfc_current_form != FORM_FIXED && !(f95 || f03))
+ {
+ char c = gfc_peek_ascii_char ();
+
+ /* Look for end-of-statement. There is no stop-code. */
+ if (c == '\n' || c == '!' || c == ';')
+ goto done;
+
+ if (c != ' ')
+ {
+ gfc_error ("Blank required in %s statement near %C",
+ gfc_ascii_statement (st));
+ return MATCH_ERROR;
+ }
+ }
if (gfc_match_eos () != MATCH_YES)
{
- m = gfc_match_init_expr (&e);
+ int stopcode;
+ locus old_locus;
+
+ /* First look for the F95 or F2003 digit [...] construct. */
+ old_locus = gfc_current_locus;
+ m = gfc_match_small_int (&stopcode);
+ if (m == MATCH_YES && (f95 || f03))
+ {
+ if (stopcode < 0)
+ {
+ gfc_error ("STOP code at %C cannot be negative");
+ return MATCH_ERROR;
+ }
+
+ if (stopcode > 99999)
+ {
+ gfc_error ("STOP code at %C contains too many digits");
+ return MATCH_ERROR;
+ }
+ }
+
+ /* Reset the locus and now load gfc_expr. */
+ gfc_current_locus = old_locus;
+ m = gfc_match_expr (&e);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
{
if (st == ST_ERROR_STOP)
{
- if (!gfc_notify_std (GFC_STD_F2015, "%s statement at %C in PURE "
+ if (!gfc_notify_std (GFC_STD_F2018, "%s statement at %C in PURE "
"procedure", gfc_ascii_statement (st)))
goto cleanup;
}
if (e != NULL)
{
+ if (!gfc_simplify_expr (e, 0))
+ goto cleanup;
+
+ /* Test for F95 and F2003 style STOP stop-code. */
+ if (e->expr_type != EXPR_CONSTANT && (f95 || f03))
+ {
+ gfc_error ("STOP code at %L must be a scalar CHARACTER constant "
+ "or digit[digit[digit[digit[digit]]]]", &e->where);
+ goto cleanup;
+ }
+
+ /* Use the machinery for an initialization expression to reduce the
+ stop-code to a constant. */
+ gfc_reduce_init_expr (e);
+
+ /* Test for F2008 style STOP stop-code. */
+ if (e->expr_type != EXPR_CONSTANT && f08)
+ {
+ gfc_error ("STOP code at %L must be a scalar default CHARACTER or "
+ "INTEGER constant expression", &e->where);
+ goto cleanup;
+ }
+
if (!(e->ts.type == BT_CHARACTER || e->ts.type == BT_INTEGER))
{
gfc_error ("STOP code at %L must be either INTEGER or CHARACTER type",
if (e->rank != 0)
{
- gfc_error ("STOP code at %L must be scalar",
- &e->where);
+ gfc_error ("STOP code at %L must be scalar", &e->where);
goto cleanup;
}
goto cleanup;
}
- if (e->ts.type == BT_INTEGER
- && e->ts.kind != gfc_default_integer_kind)
+ if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind)
{
gfc_error ("STOP code at %L must be default integer KIND=%d",
&e->where, (int) gfc_default_integer_kind);
}
}
+done:
+
switch (st)
{
case ST_STOP:
{
if (saw_stat)
{
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
goto cleanup;
}
stat = tmp;
{
if (saw_errmsg)
{
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
goto cleanup;
}
errmsg = tmp;
{
if (saw_until_count)
{
- gfc_error ("Redundant UNTIL_COUNT tag found at %L ",
+ gfc_error ("Redundant UNTIL_COUNT tag found at %L",
&tmp->where);
goto cleanup;
}
match
gfc_match_event_post (void)
{
- if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT POST statement at %C"))
+ if (!gfc_notify_std (GFC_STD_F2018, "EVENT POST statement at %C"))
return MATCH_ERROR;
return event_statement (ST_EVENT_POST);
match
gfc_match_event_wait (void)
{
- if (!gfc_notify_std (GFC_STD_F2008_TS, "EVENT WAIT statement at %C"))
+ if (!gfc_notify_std (GFC_STD_F2018, "EVENT WAIT statement at %C"))
return MATCH_ERROR;
return event_statement (ST_EVENT_WAIT);
}
+/* Match a FAIL IMAGE statement. */
+
+match
+gfc_match_fail_image (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2018, "FAIL IMAGE statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_YES)
+ goto syntax;
+
+ new_st.op = EXEC_FAIL_IMAGE;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FAIL_IMAGE);
+
+ return MATCH_ERROR;
+}
+
+/* Match a FORM TEAM statement. */
+
+match
+gfc_match_form_team (void)
+{
+ match m;
+ gfc_expr *teamid,*team;
+
+ if (!gfc_notify_std (GFC_STD_F2018, "FORM TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_FORM_TEAM;
+
+ if (gfc_match ("%e", &teamid) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = teamid;
+ new_st.expr2 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_FORM_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a CHANGE TEAM statement. */
+
+match
+gfc_match_change_team (void)
+{
+ match m;
+ gfc_expr *team;
+
+ if (!gfc_notify_std (GFC_STD_F2018, "CHANGE TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_CHANGE_TEAM;
+
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_CHANGE_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a END TEAM statement. */
+
+match
+gfc_match_end_team (void)
+{
+ if (!gfc_notify_std (GFC_STD_F2018, "END TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_YES)
+ goto syntax;
+
+ new_st.op = EXEC_END_TEAM;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_END_TEAM);
+
+ return MATCH_ERROR;
+}
+
+/* Match a SYNC TEAM statement. */
+
+match
+gfc_match_sync_team (void)
+{
+ match m;
+ gfc_expr *team;
+
+ if (!gfc_notify_std (GFC_STD_F2018, "SYNC TEAM statement at %C"))
+ return MATCH_ERROR;
+
+ if (gfc_match_char ('(') == MATCH_NO)
+ goto syntax;
+
+ new_st.op = EXEC_SYNC_TEAM;
+
+ if (gfc_match ("%e", &team) != MATCH_YES)
+ goto syntax;
+
+ m = gfc_match_char (')');
+ if (m == MATCH_NO)
+ goto syntax;
+
+ new_st.expr1 = team;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (ST_SYNC_TEAM);
+
+ return MATCH_ERROR;
+}
+
/* Match LOCK/UNLOCK statement. Syntax:
LOCK ( lock-variable [ , lock-stat-list ] )
UNLOCK ( lock-variable [ , sync-stat-list ] )
{
if (saw_stat)
{
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
goto cleanup;
}
stat = tmp;
{
if (saw_errmsg)
{
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
goto cleanup;
}
errmsg = tmp;
{
if (saw_acq_lock)
{
- gfc_error ("Redundant ACQUIRED_LOCK tag found at %L ",
+ gfc_error ("Redundant ACQUIRED_LOCK tag found at %L",
&tmp->where);
goto cleanup;
}
{
if (saw_stat)
{
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
goto cleanup;
}
stat = tmp;
{
if (saw_errmsg)
{
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
goto cleanup;
}
errmsg = tmp;
gfc_typespec ts;
gfc_symbol *sym;
match m;
- locus old_locus, deferred_locus;
+ locus old_locus, deferred_locus, assumed_locus;
bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3;
- bool saw_unlimited = false;
+ bool saw_unlimited = false, saw_assumed = false;
head = tail = NULL;
stat = errmsg = source = mold = tmp = NULL;
saw_stat = saw_errmsg = saw_source = saw_mold = saw_deferred = false;
if (gfc_match_char ('(') != MATCH_YES)
- goto syntax;
+ {
+ gfc_syntax_error (ST_ALLOCATE);
+ return MATCH_ERROR;
+ }
/* Match an optional type-spec. */
old_locus = gfc_current_locus;
}
else
{
+ /* Needed for the F2008:C631 check below. */
+ assumed_locus = gfc_current_locus;
+
if (gfc_match (" :: ") == MATCH_YES)
{
- if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
+ if (!gfc_notify_std (GFC_STD_F2003, "typespec in ALLOCATE at %L",
&old_locus))
goto cleanup;
}
if (ts.type == BT_CHARACTER)
- ts.u.cl->length_from_typespec = true;
+ {
+ if (!ts.u.cl->length)
+ saw_assumed = true;
+ else
+ ts.u.cl->length_from_typespec = true;
+ }
+
+ if (type_param_spec_list
+ && gfc_spec_list_type (type_param_spec_list, NULL)
+ == SPEC_DEFERRED)
+ {
+ gfc_error ("The type parameter spec list in the type-spec at "
+ "%L cannot contain DEFERRED parameters", &old_locus);
+ goto cleanup;
+ }
}
else
{
if (m == MATCH_ERROR)
goto cleanup;
+ if (tail->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("Unexpected constant at %C");
+ goto cleanup;
+ }
+
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
if (impure)
gfc_unset_implicit_pure (NULL);
+ /* F2008:C631 (R626) A type-param-value in a type-spec shall be an
+ asterisk if and only if each allocate-object is a dummy argument
+ for which the corresponding type parameter is assumed. */
+ if (saw_assumed
+ && (tail->expr->ts.deferred
+ || (tail->expr->ts.u.cl && tail->expr->ts.u.cl->length)
+ || tail->expr->symtree->n.sym->attr.dummy == 0))
+ {
+ gfc_error ("Incompatible allocate-object at %C for CHARACTER "
+ "type-spec at %L", &assumed_locus);
+ goto cleanup;
+ }
+
if (tail->expr->ts.deferred)
{
saw_deferred = true;
if (tail->expr->ts.type == BT_DERIVED)
tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived);
+ if (type_param_spec_list)
+ tail->expr->param_list = gfc_copy_actual_arglist (type_param_spec_list);
+
saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr);
if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension)
/* Enforce C630. */
if (saw_stat)
{
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
goto cleanup;
}
tmp = NULL;
saw_stat = true;
+ if (stat->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("STAT tag at %L cannot be a constant", &stat->where);
+ goto cleanup;
+ }
+
if (gfc_check_do_variable (stat->symtree))
goto cleanup;
/* Enforce C630. */
if (saw_errmsg)
{
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
goto cleanup;
}
/* Enforce C630. */
if (saw_source)
{
- gfc_error ("Redundant SOURCE tag found at %L ", &tmp->where);
+ gfc_error ("Redundant SOURCE tag found at %L", &tmp->where);
goto cleanup;
}
if (head->next
&& !gfc_notify_std (GFC_STD_F2008, "SOURCE tag at %L"
- " with more than a single allocate object",
+ " with more than a single allocate object",
&tmp->where))
goto cleanup;
/* Check F08:C636. */
if (saw_mold)
{
- gfc_error ("Redundant MOLD tag found at %L ", &tmp->where);
+ gfc_error ("Redundant MOLD tag found at %L", &tmp->where);
goto cleanup;
}
new_st.ext.alloc.list = head;
new_st.ext.alloc.ts = ts;
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
+
return MATCH_YES;
syntax:
gfc_free_expr (mold);
if (tmp && tmp->expr_type) gfc_free_expr (tmp);
gfc_free_alloc_list (head);
+ if (type_param_spec_list)
+ gfc_free_actual_arglist (type_param_spec_list);
return MATCH_ERROR;
}
goto cleanup;
}
+ /* Check for valid array pointer object. Bounds remapping is not
+ allowed with NULLIFY. */
+ if (p->ref)
+ {
+ gfc_ref *remap = p->ref;
+ for (; remap; remap = remap->next)
+ if (!remap->next && remap->type == REF_ARRAY
+ && remap->u.ar.type != AR_FULL)
+ break;
+ if (remap)
+ {
+ gfc_error ("NULLIFY does not allow bounds remapping for "
+ "pointer object at %C");
+ goto cleanup;
+ }
+ }
+
/* build ' => NULL() '. */
e = gfc_get_null_expr (&gfc_current_locus);
if (m == MATCH_NO)
goto syntax;
+ if (tail->expr->expr_type == EXPR_CONSTANT)
+ {
+ gfc_error ("Unexpected constant at %C");
+ goto cleanup;
+ }
+
if (gfc_check_do_variable (tail->expr->symtree))
goto cleanup;
&& (tail->expr->ref->type == REF_COMPONENT
|| tail->expr->ref->type == REF_ARRAY));
if (sym && sym->ts.type == BT_CLASS)
- b2 = !(CLASS_DATA (sym)->attr.allocatable
- || CLASS_DATA (sym)->attr.class_pointer);
+ b2 = !(CLASS_DATA (sym) && (CLASS_DATA (sym)->attr.allocatable
+ || CLASS_DATA (sym)->attr.class_pointer));
else
b2 = sym && !(sym->attr.allocatable || sym->attr.pointer
|| sym->attr.proc_pointer);
{
if (saw_stat)
{
- gfc_error ("Redundant STAT tag found at %L ", &tmp->where);
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
gfc_free_expr (tmp);
goto cleanup;
}
if (saw_errmsg)
{
- gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where);
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
gfc_free_expr (tmp);
goto cleanup;
}
goto syntax;
}
+ /* Walk the argument list looking for invalid BOZ. */
+ for (a = arglist; a; a = a->next)
+ if (a->expr && a->expr->ts.type == BT_BOZ)
+ {
+ gfc_error ("A BOZ literal constant at %L cannot appear as an actual "
+ "argument in a subroutine reference", &a->expr->where);
+ goto cleanup;
+ }
+
+
/* If any alternate return labels were found, construct a SELECT
statement that will jump to the right place. */
gfc_array_spec *as;
gfc_equiv *e1, *e2;
match m;
+ char c;
+
+ /* COMMON has been matched. In free form source code, the next character
+ needs to be whitespace or '/'. Check that here. Fixed form source
+ code needs to be checked below. */
+ c = gfc_peek_ascii_char ();
+ if (gfc_current_form == FORM_FREE && !gfc_is_whitespace (c) && c != '/')
+ return MATCH_NO;
as = NULL;
}
if (sym->attr.is_bind_c == 1)
- gfc_error_now ("Variable %qs in common block %qs at %C can not "
+ gfc_error_now ("Variable %qs in common block %qs at %C cannot "
"be bind(c) since it is not global", sym->name,
t->name);
}
|| sym->attr.data) && gfc_current_state () != COMP_BLOCK_DATA)
{
if (!gfc_notify_std (GFC_STD_GNU, "Initialized symbol %qs at "
- "%C can only be COMMON in BLOCK DATA",
+ "%C can only be COMMON in BLOCK DATA",
sym->name))
goto cleanup;
}
gfc_gobble_whitespace ();
if (gfc_match_eos () == MATCH_YES)
goto done;
- if (gfc_peek_ascii_char () == '/')
+ c = gfc_peek_ascii_char ();
+ if (c == '/')
break;
- if (gfc_match_char (',') != MATCH_YES)
- goto syntax;
+ if (c != ',')
+ {
+ /* In Fixed form source code, gfortran can end up here for an
+ expression of the form COMMONI = RHS. This may not be an
+ error, so return MATCH_NO. */
+ if (gfc_current_form == FORM_FIXED && c == '=')
+ {
+ gfc_free_array_spec (as);
+ return MATCH_NO;
+ }
+ goto syntax;
+ }
+ else
+ gfc_match_char (',');
+
gfc_gobble_whitespace ();
if (gfc_peek_ascii_char () == '/')
break;
gfc_symbol *sym;
match m;
+ if (!gfc_notify_std (GFC_STD_F2018_OBS, "BLOCK DATA construct at %L",
+ &gfc_current_locus))
+ return MATCH_ERROR;
+
if (gfc_match_eos () == MATCH_YES)
{
gfc_new_block = NULL;
return MATCH_ERROR;
if (group_name->attr.flavor != FL_NAMELIST
- && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
+ && !gfc_add_flavor (&group_name->attr, FL_NAMELIST,
group_name->name, NULL))
return MATCH_ERROR;
if (m != MATCH_YES)
return m;
- if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
+ if (!gfc_add_flavor (&gfc_new_block->attr, FL_MODULE,
gfc_new_block->name, NULL))
return MATCH_ERROR;
gfc_common_head *common_head = NULL;
bool common_flag;
int cnt;
+ char c;
+
+ /* EQUIVALENCE has been matched. After gobbling any possible whitespace,
+ the next character needs to be '('. Check that here, and return
+ MATCH_NO for a variable of the form equivalencej. */
+ gfc_gobble_whitespace ();
+ c = gfc_peek_ascii_char ();
+ if (c != '(')
+ return MATCH_NO;
tail = NULL;
}
}
+ if (!gfc_notify_std (GFC_STD_F2018_OBS, "EQUIVALENCE statement at %C"))
+ return MATCH_ERROR;
+
return MATCH_YES;
syntax:
gfc_symbol *sym;
gfc_expr *expr;
match m;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+ locus old_locus;
+ bool fcn;
+ gfc_formal_arglist *ptr;
+
+ /* Read the possible statement function name, and then check to see if
+ a symbol is already present in the namespace. Record if it is a
+ function and whether it has been referenced. */
+ fcn = false;
+ ptr = NULL;
+ old_locus = gfc_current_locus;
+ m = gfc_match_name (name);
+ if (m == MATCH_YES)
+ {
+ gfc_find_symbol (name, NULL, 1, &sym);
+ if (sym && sym->attr.function && !sym->attr.referenced)
+ {
+ fcn = true;
+ ptr = sym->formal;
+ }
+ }
+ gfc_current_locus = old_locus;
m = gfc_match_symbol (&sym, 0);
if (m != MATCH_YES)
return m;
return MATCH_ERROR;
}
+ if (fcn && ptr != sym->formal)
+ {
+ gfc_error ("Statement function %qs at %L conflicts with function name",
+ sym->name, &expr->where);
+ return MATCH_ERROR;
+ }
+
sym->value = expr;
if ((gfc_current_state () == COMP_FUNCTION
{
gfc_ref *ref;
gfc_symbol *assoc_sym;
+ int rank = 0;
assoc_sym = associate->symtree->n.sym;
ref = ref->next;
if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
- && ref && ref->type == REF_ARRAY)
+ && CLASS_DATA (selector)->as->type == AS_ASSUMED_RANK)
+ {
+ assoc_sym->attr.dimension = 1;
+ assoc_sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
+ goto build_class_sym;
+ }
+ else if (selector->ts.type == BT_CLASS && CLASS_DATA (selector)->as
+ && ref && ref->type == REF_ARRAY)
{
/* Ensure that the array reference type is set. We cannot use
gfc_resolve_expr at this point, so the usable parts of
selector->rank = ref->u.ar.dimen;
else
selector->rank = 0;
+
+ rank = selector->rank;
}
- if (selector->rank)
+ if (rank)
{
- assoc_sym->attr.dimension = 1;
- assoc_sym->as = gfc_get_array_spec ();
- assoc_sym->as->rank = selector->rank;
- assoc_sym->as->type = AS_DEFERRED;
+ for (int i = 0; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_ELEMENT
+ || (ref->u.ar.dimen_type[i] == DIMEN_UNKNOWN
+ && ref->u.ar.end[i] == NULL
+ && ref->u.ar.stride[i] == NULL))
+ rank--;
+
+ if (rank)
+ {
+ assoc_sym->attr.dimension = 1;
+ assoc_sym->as = gfc_get_array_spec ();
+ assoc_sym->as->rank = rank;
+ assoc_sym->as->type = AS_DEFERRED;
+ }
+ else
+ assoc_sym->as = NULL;
}
else
assoc_sym->as = NULL;
+build_class_sym:
if (selector->ts.type == BT_CLASS)
{
/* The correct class container has to be available. */
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp;
- int charlen = 0;
+ HOST_WIDE_INT charlen = 0;
+ gfc_symbol *selector = select_type_stack->selector;
+ gfc_symbol *sym;
if (ts->type == BT_CLASS || ts->type == BT_DERIVED)
return NULL;
- if (select_type_stack->selector->ts.type == BT_CLASS
- && !select_type_stack->selector->attr.class_ok)
+ if (selector->ts.type == BT_CLASS && !selector->attr.class_ok)
return NULL;
+ /* Case value == NULL corresponds to SELECT TYPE cases otherwise
+ the values correspond to SELECT rank cases. */
if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT)
- charlen = mpz_get_si (ts->u.cl->length->value.integer);
+ charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
if (ts->type != BT_CHARACTER)
sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type),
ts->kind);
else
- sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type),
- charlen, ts->kind);
+ snprintf (name, sizeof (name),
+ "__tmp_%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ gfc_basic_typename (ts->type), charlen, ts->kind);
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- gfc_add_type (tmp->n.sym, ts, NULL);
+ sym = tmp->n.sym;
+ gfc_add_type (sym, ts, NULL);
/* Copy across the array spec to the selector. */
- if (select_type_stack->selector->ts.type == BT_CLASS
- && (CLASS_DATA (select_type_stack->selector)->attr.dimension
- || CLASS_DATA (select_type_stack->selector)->attr.codimension))
+ if (selector->ts.type == BT_CLASS
+ && (CLASS_DATA (selector)->attr.dimension
+ || CLASS_DATA (selector)->attr.codimension))
{
- tmp->n.sym->attr.pointer = 1;
- tmp->n.sym->attr.dimension
- = CLASS_DATA (select_type_stack->selector)->attr.dimension;
- tmp->n.sym->attr.codimension
- = CLASS_DATA (select_type_stack->selector)->attr.codimension;
- tmp->n.sym->as
- = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
+ sym->attr.pointer = 1;
+ sym->attr.dimension = CLASS_DATA (selector)->attr.dimension;
+ sym->attr.codimension = CLASS_DATA (selector)->attr.codimension;
+ sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
}
- gfc_set_sym_referenced (tmp->n.sym);
- gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
- tmp->n.sym->attr.select_type_temporary = 1;
+ gfc_set_sym_referenced (sym);
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
+ sym->attr.select_type_temporary = 1;
return tmp;
}
{
char name[GFC_MAX_SYMBOL_LEN];
gfc_symtree *tmp = NULL;
+ gfc_symbol *selector = select_type_stack->selector;
+ gfc_symbol *sym;
if (!ts)
{
sprintf (name, "__tmp_class_%s", ts->u.derived->name);
else
sprintf (name, "__tmp_type_%s", ts->u.derived->name);
+
gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
- gfc_add_type (tmp->n.sym, ts, NULL);
+ sym = tmp->n.sym;
+ gfc_add_type (sym, ts, NULL);
- if (select_type_stack->selector->ts.type == BT_CLASS
- && select_type_stack->selector->attr.class_ok)
+ if (selector->ts.type == BT_CLASS && selector->attr.class_ok)
{
- tmp->n.sym->attr.pointer
- = CLASS_DATA (select_type_stack->selector)->attr.class_pointer;
+ sym->attr.pointer
+ = CLASS_DATA (selector)->attr.class_pointer;
/* Copy across the array spec to the selector. */
- if (CLASS_DATA (select_type_stack->selector)->attr.dimension
- || CLASS_DATA (select_type_stack->selector)->attr.codimension)
+ if (CLASS_DATA (selector)->attr.dimension
+ || CLASS_DATA (selector)->attr.codimension)
{
- tmp->n.sym->attr.dimension
- = CLASS_DATA (select_type_stack->selector)->attr.dimension;
- tmp->n.sym->attr.codimension
- = CLASS_DATA (select_type_stack->selector)->attr.codimension;
- tmp->n.sym->as
- = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as);
+ sym->attr.dimension
+ = CLASS_DATA (selector)->attr.dimension;
+ sym->attr.codimension
+ = CLASS_DATA (selector)->attr.codimension;
+ sym->as
+ = gfc_copy_array_spec (CLASS_DATA (selector)->as);
}
- }
+ }
- gfc_set_sym_referenced (tmp->n.sym);
- gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL);
- tmp->n.sym->attr.select_type_temporary = 1;
+ gfc_set_sym_referenced (sym);
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
+ sym->attr.select_type_temporary = 1;
- if (ts->type == BT_CLASS)
- gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr,
- &tmp->n.sym->as);
+ if (ts->type == BT_CLASS)
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
+ else
+ sym = tmp->n.sym;
+
/* Add an association for it, so the rest of the parser knows it is
an associate-name. The target will be set during resolution. */
- tmp->n.sym->assoc = gfc_get_association_list ();
- tmp->n.sym->assoc->dangling = 1;
- tmp->n.sym->assoc->st = tmp;
+ sym->assoc = gfc_get_association_list ();
+ sym->assoc->dangling = 1;
+ sym->assoc->st = tmp;
select_type_stack->tmp = tmp;
}
char name[GFC_MAX_SYMBOL_LEN];
bool class_array;
gfc_symbol *sym;
+ gfc_namespace *ns = gfc_current_ns;
m = gfc_match_label ();
if (m == MATCH_ERROR)
if (m != MATCH_YES)
return m;
+ if (gfc_current_state() == COMP_MODULE
+ || gfc_current_state() == COMP_SUBMODULE)
+ {
+ gfc_error ("SELECT TYPE at %C cannot appear in this scope");
+ return MATCH_ERROR;
+ }
+
+ gfc_current_ns = gfc_build_block_ns (ns);
m = gfc_match (" %n => %e", name, &expr2);
if (m == MATCH_YES)
{
- expr1 = gfc_get_expr();
+ expr1 = gfc_get_expr ();
expr1->expr_type = EXPR_VARIABLE;
+ expr1->where = expr2->where;
if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
{
m = MATCH_ERROR;
{
m = gfc_match (" %e ", &expr1);
if (m != MATCH_YES)
- return m;
+ {
+ std::swap (ns, gfc_current_ns);
+ gfc_free_namespace (ns);
+ return m;
+ }
}
m = gfc_match (" )%t");
allowed by the standard.
TODO: see if it is sufficient to exclude component and substring
references. */
- class_array = expr1->expr_type == EXPR_VARIABLE
- && expr1->ts.type == BT_CLASS
- && CLASS_DATA (expr1)
- && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
- && (CLASS_DATA (expr1)->attr.dimension
- || CLASS_DATA (expr1)->attr.codimension)
- && expr1->ref
- && expr1->ref->type == REF_ARRAY
- && expr1->ref->next == NULL;
-
- /* Check for F03:C811. */
+ class_array = (expr1->expr_type == EXPR_VARIABLE
+ && expr1->ts.type == BT_CLASS
+ && CLASS_DATA (expr1)
+ && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0)
+ && (CLASS_DATA (expr1)->attr.dimension
+ || CLASS_DATA (expr1)->attr.codimension)
+ && expr1->ref
+ && expr1->ref->type == REF_ARRAY
+ && expr1->ref->u.ar.type == AR_FULL
+ && expr1->ref->next == NULL);
+
+ /* Check for F03:C811 (F08:C835). */
if (!expr2 && (expr1->expr_type != EXPR_VARIABLE
- || (!class_array && expr1->ref != NULL)))
+ || (!class_array && expr1->ref != NULL)))
{
gfc_error ("Selector in SELECT TYPE at %C is not a named variable; "
"use associate-name=>");
new_st.ext.block.ns = gfc_current_ns;
select_type_push (expr1->symtree->n.sym);
+ gfc_current_ns = ns;
return MATCH_YES;
cleanup:
gfc_free_expr (expr1);
gfc_free_expr (expr2);
+ gfc_undo_symbols ();
+ std::swap (ns, gfc_current_ns);
+ gfc_free_namespace (ns);
+ return m;
+}
+
+
+/* Set the temporary for the current intrinsic SELECT RANK selector. */
+
+static void
+select_rank_set_tmp (gfc_typespec *ts, int *case_value)
+{
+ char name[2 * GFC_MAX_SYMBOL_LEN];
+ char tname[GFC_MAX_SYMBOL_LEN];
+ gfc_symtree *tmp;
+ gfc_symbol *selector = select_type_stack->selector;
+ gfc_symbol *sym;
+ gfc_symtree *st;
+ HOST_WIDE_INT charlen = 0;
+
+ if (case_value == NULL)
+ return;
+
+ if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length
+ && ts->u.cl->length->expr_type == EXPR_CONSTANT)
+ charlen = gfc_mpz_get_hwi (ts->u.cl->length->value.integer);
+
+ if (ts->type == BT_CLASS)
+ sprintf (tname, "class_%s", ts->u.derived->name);
+ else if (ts->type == BT_DERIVED)
+ sprintf (tname, "type_%s", ts->u.derived->name);
+ else if (ts->type != BT_CHARACTER)
+ sprintf (tname, "%s_%d", gfc_basic_typename (ts->type), ts->kind);
+ else
+ sprintf (tname, "%s_" HOST_WIDE_INT_PRINT_DEC "_%d",
+ gfc_basic_typename (ts->type), charlen, ts->kind);
+
+ /* Case value == NULL corresponds to SELECT TYPE cases otherwise
+ the values correspond to SELECT rank cases. */
+ if (*case_value >=0)
+ sprintf (name, "__tmp_%s_rank_%d", tname, *case_value);
+ else
+ sprintf (name, "__tmp_%s_rank_m%d", tname, -*case_value);
+
+ gfc_find_sym_tree (name, gfc_current_ns, 0, &st);
+ if (st)
+ return;
+
+ gfc_get_sym_tree (name, gfc_current_ns, &tmp, false);
+ sym = tmp->n.sym;
+ gfc_add_type (sym, ts, NULL);
+
+ /* Copy across the array spec to the selector. */
+ if (selector->ts.type == BT_CLASS)
+ {
+ sym->ts.u.derived = CLASS_DATA (selector)->ts.u.derived;
+ sym->attr.pointer = CLASS_DATA (selector)->attr.pointer;
+ sym->attr.allocatable = CLASS_DATA (selector)->attr.allocatable;
+ sym->attr.target = CLASS_DATA (selector)->attr.target;
+ sym->attr.class_ok = 0;
+ if (case_value && *case_value != 0)
+ {
+ sym->attr.dimension = 1;
+ sym->as = gfc_copy_array_spec (CLASS_DATA (selector)->as);
+ if (*case_value > 0)
+ {
+ sym->as->type = AS_DEFERRED;
+ sym->as->rank = *case_value;
+ }
+ else if (*case_value == -1)
+ {
+ sym->as->type = AS_ASSUMED_SIZE;
+ sym->as->rank = 1;
+ }
+ }
+ }
+ else
+ {
+ sym->attr.pointer = selector->attr.pointer;
+ sym->attr.allocatable = selector->attr.allocatable;
+ sym->attr.target = selector->attr.target;
+ if (case_value && *case_value != 0)
+ {
+ sym->attr.dimension = 1;
+ sym->as = gfc_copy_array_spec (selector->as);
+ if (*case_value > 0)
+ {
+ sym->as->type = AS_DEFERRED;
+ sym->as->rank = *case_value;
+ }
+ else if (*case_value == -1)
+ {
+ sym->as->type = AS_ASSUMED_SIZE;
+ sym->as->rank = 1;
+ }
+ }
+ }
+
+ gfc_set_sym_referenced (sym);
+ gfc_add_flavor (&sym->attr, FL_VARIABLE, name, NULL);
+ sym->attr.select_type_temporary = 1;
+ if (case_value)
+ sym->attr.select_rank_temporary = 1;
+
+ if (ts->type == BT_CLASS)
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
+
+ /* Add an association for it, so the rest of the parser knows it is
+ an associate-name. The target will be set during resolution. */
+ sym->assoc = gfc_get_association_list ();
+ sym->assoc->dangling = 1;
+ sym->assoc->st = tmp;
+
+ select_type_stack->tmp = tmp;
+}
+
+
+/* Match a SELECT RANK statement. */
+
+match
+gfc_match_select_rank (void)
+{
+ gfc_expr *expr1, *expr2 = NULL;
+ match m;
+ char name[GFC_MAX_SYMBOL_LEN];
+ gfc_symbol *sym, *sym2;
+ gfc_namespace *ns = gfc_current_ns;
+ gfc_array_spec *as = NULL;
+
+ m = gfc_match_label ();
+ if (m == MATCH_ERROR)
+ return m;
+
+ m = gfc_match (" select rank ( ");
+ if (m != MATCH_YES)
+ return m;
+
+ if (!gfc_notify_std (GFC_STD_F2018, "SELECT RANK statement at %C"))
+ return MATCH_NO;
+
+ gfc_current_ns = gfc_build_block_ns (ns);
+ m = gfc_match (" %n => %e", name, &expr2);
+ if (m == MATCH_YES)
+ {
+ expr1 = gfc_get_expr ();
+ expr1->expr_type = EXPR_VARIABLE;
+ expr1->where = expr2->where;
+ expr1->ref = gfc_copy_ref (expr2->ref);
+ if (gfc_get_sym_tree (name, NULL, &expr1->symtree, false))
+ {
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ sym = expr1->symtree->n.sym;
+
+ if (expr2->symtree)
+ {
+ sym2 = expr2->symtree->n.sym;
+ as = sym2->ts.type == BT_CLASS ? CLASS_DATA (sym2)->as : sym2->as;
+ }
+
+ if (expr2->expr_type != EXPR_VARIABLE
+ || !(as && as->type == AS_ASSUMED_RANK))
+ {
+ gfc_error ("The SELECT RANK selector at %C must be an assumed "
+ "rank variable");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+
+ if (expr2->ts.type == BT_CLASS)
+ {
+ copy_ts_from_selector_to_associate (expr1, expr2);
+
+ sym->attr.flavor = FL_VARIABLE;
+ sym->attr.referenced = 1;
+ sym->attr.class_ok = 1;
+ CLASS_DATA (sym)->attr.allocatable = CLASS_DATA (sym2)->attr.allocatable;
+ CLASS_DATA (sym)->attr.pointer = CLASS_DATA (sym2)->attr.pointer;
+ CLASS_DATA (sym)->attr.target = CLASS_DATA (sym2)->attr.target;
+ sym->attr.pointer = 1;
+ }
+ else
+ {
+ sym->ts = sym2->ts;
+ sym->as = gfc_copy_array_spec (sym2->as);
+ sym->attr.dimension = 1;
+
+ sym->attr.flavor = FL_VARIABLE;
+ sym->attr.referenced = 1;
+ sym->attr.class_ok = sym2->attr.class_ok;
+ sym->attr.allocatable = sym2->attr.allocatable;
+ sym->attr.pointer = sym2->attr.pointer;
+ sym->attr.target = sym2->attr.target;
+ }
+ }
+ else
+ {
+ m = gfc_match (" %e ", &expr1);
+
+ if (m != MATCH_YES)
+ {
+ std::swap (ns, gfc_current_ns);
+ gfc_free_namespace (ns);
+ return m;
+ }
+
+ if (expr1->symtree)
+ {
+ sym = expr1->symtree->n.sym;
+ as = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as;
+ }
+
+ if (expr1->expr_type != EXPR_VARIABLE
+ || !(as && as->type == AS_ASSUMED_RANK))
+ {
+ gfc_error("The SELECT RANK selector at %C must be an assumed "
+ "rank variable");
+ m = MATCH_ERROR;
+ goto cleanup;
+ }
+ }
+
+ m = gfc_match (" )%t");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("parse error in SELECT RANK statement at %C");
+ goto cleanup;
+ }
+
+ new_st.op = EXEC_SELECT_RANK;
+ new_st.expr1 = expr1;
+ new_st.expr2 = expr2;
+ new_st.ext.block.ns = gfc_current_ns;
+
+ select_type_push (expr1->symtree->n.sym);
+ gfc_current_ns = ns;
+
+ return MATCH_YES;
+
+cleanup:
+ gfc_free_expr (expr1);
+ gfc_free_expr (expr2);
+ gfc_undo_symbols ();
+ std::swap (ns, gfc_current_ns);
+ gfc_free_namespace (ns);
return m;
}
return MATCH_ERROR;
}
+ if (c->ts.type == BT_DERIVED
+ && c->ts.u.derived && c->ts.u.derived->attr.pdt_type
+ && gfc_spec_list_type (type_param_spec_list, c->ts.u.derived)
+ != SPEC_ASSUMED)
+ {
+ gfc_error ("All the LEN type parameters in the TYPE IS statement "
+ "at %C must be ASSUMED");
+ return MATCH_ERROR;
+ }
+
/* Create temporary variable. */
select_type_set_tmp (&c->ts);
}
+/* Match a RANK statement. */
+
+match
+gfc_match_rank_is (void)
+{
+ gfc_case *c = NULL;
+ match m;
+ int case_value;
+
+ if (gfc_current_state () != COMP_SELECT_RANK)
+ {
+ gfc_error ("Unexpected RANK statement at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match ("% default") == MATCH_YES)
+ {
+ m = match_case_eos ();
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ new_st.op = EXEC_SELECT_RANK;
+ c = gfc_get_case ();
+ c->ts.type = BT_UNKNOWN;
+ c->where = gfc_current_locus;
+ new_st.ext.block.case_list = c;
+ select_type_stack->tmp = NULL;
+ return MATCH_YES;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ c = gfc_get_case ();
+ c->where = gfc_current_locus;
+ c->ts = select_type_stack->selector->ts;
+
+ m = gfc_match_expr (&c->low);
+ if (m == MATCH_NO)
+ {
+ if (gfc_match_char ('*') == MATCH_YES)
+ c->low = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, -1);
+ else
+ goto syntax;
+
+ case_value = -1;
+ }
+ else if (m == MATCH_YES)
+ {
+ /* F2018: R1150 */
+ if (c->low->expr_type != EXPR_CONSTANT
+ || c->low->ts.type != BT_INTEGER
+ || c->low->rank)
+ {
+ gfc_error ("The SELECT RANK CASE expression at %C must be a "
+ "scalar, integer constant");
+ goto cleanup;
+ }
+
+ case_value = (int) mpz_get_si (c->low->value.integer);
+ /* F2018: C1151 */
+ if ((case_value < 0) || (case_value > GFC_MAX_DIMENSIONS))
+ {
+ gfc_error ("The value of the SELECT RANK CASE expression at "
+ "%C must not be less than zero or greater than %d",
+ GFC_MAX_DIMENSIONS);
+ goto cleanup;
+ }
+ }
+ else
+ goto cleanup;
+
+ if (gfc_match_char (')') != MATCH_YES)
+ goto syntax;
+
+ m = match_case_eos ();
+ if (m == MATCH_NO)
+ goto syntax;
+ if (m == MATCH_ERROR)
+ goto cleanup;
+
+ new_st.op = EXEC_SELECT_RANK;
+ new_st.ext.block.case_list = c;
+
+ /* Create temporary variable. Recycle the select type code. */
+ select_rank_set_tmp (&c->ts, &case_value);
+
+ return MATCH_YES;
+
+syntax:
+ gfc_error ("Syntax error in RANK specification at %C");
+
+cleanup:
+ if (c != NULL)
+ gfc_free_case_list (c); /* new_st is cleaned up in parse.c. */
+ return MATCH_ERROR;
+}
+
/********************* WHERE subroutines ********************/
/* Match the rest of a simple WHERE statement that follows an IF statement.
c->next = XCNEW (gfc_code);
*c->next = new_st;
+ c->next->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;
c = gfc_get_code (EXEC_WHERE);
c->expr1 = expr;
+ /* Put in the assignment. It will not be processed by add_statement, so we
+ need to copy the location here. */
+
c->next = XCNEW (gfc_code);
*c->next = new_st;
+ c->next->loc = gfc_current_locus;
gfc_clear_new_st ();
new_st.op = EXEC_WHERE;