/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000-2015 Free Software Foundation, Inc.
+ Copyright (C) 2000-2020 Free Software Foundation, Inc.
Contributed by Andy Vaught
This file is part of GCC.
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "flags.h"
+#include "options.h"
#include "gfortran.h"
#include "match.h"
#include "parse.h"
-#include "alias.h"
-#include "symtab.h"
-#include "tree.h"
-#include "stringpool.h"
int gfc_matching_ptr_assignment = 0;
int gfc_matching_procptr_assignment = 0;
/* 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;
c = gfc_next_ascii_char ();
if (!(ISALPHA (c) || (c == '_' && flag_allow_leading_underscore)))
{
- if (!gfc_error_flag_test () && c != '(')
+ /* Special cases for unary minus and plus, which allows for a sensible
+ error message for code of the form 'c = exp(-a*b) )' where an
+ extra ')' appears at the end of statement. */
+ if (!gfc_error_flag_test () && c != '(' && c != '-' && c != '+')
gfc_error ("Invalid character in name at %C");
gfc_current_locus = old_loc;
return MATCH_NO;
}
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. */
+ 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);
}
}
- switch (st)
+done:
+
+ switch (st)
{
case ST_STOP:
new_st.op = EXEC_STOP;
return gfc_match_stopcode (ST_ERROR_STOP);
}
+/* Match EVENT POST/WAIT statement. Syntax:
+ EVENT POST ( event-variable [, sync-stat-list] )
+ EVENT WAIT ( event-variable [, wait-spec-list] )
+ with
+ wait-spec-list is sync-stat-list or until-spec
+ until-spec is UNTIL_COUNT = scalar-int-expr
+ sync-stat is STAT= or ERRMSG=. */
+
+static match
+event_statement (gfc_statement st)
+{
+ match m;
+ gfc_expr *tmp, *eventvar, *until_count, *stat, *errmsg;
+ bool saw_until_count, saw_stat, saw_errmsg;
+
+ tmp = eventvar = until_count = stat = errmsg = NULL;
+ saw_until_count = saw_stat = saw_errmsg = false;
+
+ if (gfc_pure (NULL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in PURE procedure",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ gfc_unset_implicit_pure (NULL);
+
+ if (flag_coarray == GFC_FCOARRAY_NONE)
+ {
+ gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_CRITICAL))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in CRITICAL block",
+ st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_find_state (COMP_DO_CONCURRENT))
+ {
+ gfc_error ("Image control statement EVENT %s at %C in DO CONCURRENT "
+ "block", st == ST_EVENT_POST ? "POST" : "WAIT");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_char ('(') != MATCH_YES)
+ goto syntax;
+
+ if (gfc_match ("%e", &eventvar) != MATCH_YES)
+ goto syntax;
+ m = gfc_match_char (',');
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_NO)
+ {
+ m = gfc_match_char (')');
+ if (m == MATCH_YES)
+ goto done;
+ goto syntax;
+ }
+
+ for (;;)
+ {
+ m = gfc_match (" stat = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_stat)
+ {
+ gfc_error ("Redundant STAT tag found at %L", &tmp->where);
+ goto cleanup;
+ }
+ stat = tmp;
+ saw_stat = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" errmsg = %v", &tmp);
+ if (m == MATCH_ERROR)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_errmsg)
+ {
+ gfc_error ("Redundant ERRMSG tag found at %L", &tmp->where);
+ goto cleanup;
+ }
+ errmsg = tmp;
+ saw_errmsg = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ m = gfc_match (" until_count = %e", &tmp);
+ if (m == MATCH_ERROR || st == ST_EVENT_POST)
+ goto syntax;
+ if (m == MATCH_YES)
+ {
+ if (saw_until_count)
+ {
+ gfc_error ("Redundant UNTIL_COUNT tag found at %L",
+ &tmp->where);
+ goto cleanup;
+ }
+ until_count = tmp;
+ saw_until_count = true;
+
+ m = gfc_match_char (',');
+ if (m == MATCH_YES)
+ continue;
+
+ tmp = NULL;
+ break;
+ }
+
+ break;
+ }
+
+ if (m == MATCH_ERROR)
+ goto syntax;
+
+ if (gfc_match (" )%t") != MATCH_YES)
+ goto syntax;
+
+done:
+ switch (st)
+ {
+ case ST_EVENT_POST:
+ new_st.op = EXEC_EVENT_POST;
+ break;
+ case ST_EVENT_WAIT:
+ new_st.op = EXEC_EVENT_WAIT;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+
+ new_st.expr1 = eventvar;
+ new_st.expr2 = stat;
+ new_st.expr3 = errmsg;
+ new_st.expr4 = until_count;
+
+ return MATCH_YES;
+
+syntax:
+ gfc_syntax_error (st);
+
+cleanup:
+ if (until_count != tmp)
+ gfc_free_expr (until_count);
+ if (errmsg != tmp)
+ gfc_free_expr (errmsg);
+ if (stat != tmp)
+ gfc_free_expr (stat);
+
+ gfc_free_expr (tmp);
+ gfc_free_expr (eventvar);
+
+ return MATCH_ERROR;
+
+}
+
+
+match
+gfc_match_event_post (void)
+{
+ 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_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 ] )
{
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. */
match
gfc_match_common (void)
{
- gfc_symbol *sym, **head, *tail, *other, *old_blank_common;
+ gfc_symbol *sym, **head, *tail, *other;
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_common_head *t;
gfc_array_spec *as;
gfc_equiv *e1, *e2;
match m;
+ char c;
- old_blank_common = gfc_current_ns->blank_common.head;
- if (old_blank_common)
- {
- while (old_blank_common->common_next)
- old_blank_common = old_blank_common->common_next;
- }
+ /* 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 (m == MATCH_NO)
goto syntax;
- /* Store a ref to the common block for error checking. */
- sym->common_block = t;
- sym->common_block->refs++;
-
/* See if we know the current common block is bind(c), and if
so, then see if we can check if the symbol is (which it'll
need to be). This can happen if the bind(c) attr stmt was
}
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;
}
- if (!gfc_add_in_common (&sym->attr, sym->name, NULL))
- goto cleanup;
-
- if (tail != NULL)
- tail->common_next = sym;
- else
- *head = sym;
-
- tail = sym;
-
/* Deal with an optional array specification after the
symbol name. */
m = gfc_match_array_spec (&as, true, true);
}
+ /* Add the in_common attribute, but ignore the reported errors
+ if any, and continue matching. */
+ gfc_add_in_common (&sym->attr, sym->name, NULL);
+
+ sym->common_block = t;
+ sym->common_block->refs++;
+
+ if (tail != NULL)
+ tail->common_next = sym;
+ else
+ *head = sym;
+
+ tail = sym;
+
sym->common_head = t;
/* Check to see if the symbol is already in an equivalence group.
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_match_st_function (void)
{
gfc_error_buffer old_error;
-
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;
}
- sym->value = expr;
+ 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_current_state () == COMP_SUBROUTINE)
+ && gfc_state_stack->previous->state == COMP_INTERFACE)
+ {
+ gfc_error ("Statement function at %L cannot appear within an INTERFACE",
+ &expr->where);
+ return MATCH_ERROR;
+ }
+
+ if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
+ return MATCH_ERROR;
+
+ return MATCH_YES;
+
+undo_error:
+ gfc_pop_error (&old_error);
+ return MATCH_NO;
+}
+
+
+/* Match an assignment to a pointer function (F2008). This could, in
+ general be ambiguous with a statement function. In this implementation
+ it remains so if it is the first statement after the specification
+ block. */
+
+match
+gfc_match_ptr_fcn_assign (void)
+{
+ gfc_error_buffer old_error;
+ locus old_loc;
+ gfc_symbol *sym;
+ gfc_expr *expr;
+ match m;
+ char name[GFC_MAX_SYMBOL_LEN + 1];
+
+ old_loc = gfc_current_locus;
+ m = gfc_match_name (name);
+ if (m != MATCH_YES)
+ return m;
+
+ gfc_find_symbol (name, NULL, 1, &sym);
+ if (sym && sym->attr.flavor != FL_PROCEDURE)
+ return MATCH_NO;
+
+ gfc_push_error (&old_error);
+
+ if (sym && sym->attr.function)
+ goto match_actual_arglist;
+
+ gfc_current_locus = old_loc;
+ m = gfc_match_symbol (&sym, 0);
+ if (m != MATCH_YES)
+ return m;
+
+ if (!gfc_add_procedure (&sym->attr, PROC_UNKNOWN, sym->name, NULL))
+ goto undo_error;
+
+match_actual_arglist:
+ gfc_current_locus = old_loc;
+ m = gfc_match (" %e", &expr);
+ if (m != MATCH_YES)
+ goto undo_error;
+
+ new_st.op = EXEC_ASSIGN;
+ new_st.expr1 = expr;
+ expr = NULL;
- if (!gfc_notify_std (GFC_STD_F95_OBS, "Statement function at %C"))
- return MATCH_ERROR;
+ m = gfc_match (" = %e%t", &expr);
+ if (m != MATCH_YES)
+ goto undo_error;
+ new_st.expr2 = expr;
return MATCH_YES;
undo_error:
}
-/* Match a single case selector. */
+/* Match a single case selector. Combining the requirements of F08:C830
+ and F08:C832 (R838) means that the case-value must have either CHARACTER,
+ INTEGER, or LOGICAL type. */
static match
match_case_selector (gfc_case **cp)
goto need_expr;
if (m == MATCH_ERROR)
goto cleanup;
+
+ if (c->high->ts.type != BT_LOGICAL && c->high->ts.type != BT_INTEGER
+ && c->high->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("Expression in CASE selector at %L cannot be %s",
+ &c->high->where, gfc_typename (&c->high->ts));
+ goto cleanup;
+ }
}
else
{
if (m == MATCH_NO)
goto need_expr;
+ if (c->low->ts.type != BT_LOGICAL && c->low->ts.type != BT_INTEGER
+ && c->low->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("Expression in CASE selector at %L cannot be %s",
+ &c->low->where, gfc_typename (&c->low->ts));
+ goto cleanup;
+ }
+
/* If we're not looking at a ':' now, make a range out of a single
target. Else get the upper bound for the case range. */
if (gfc_match_char (':') != MATCH_YES)
{
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;
projects / gcc.git / blobdiff