declarations. Therefore, check which is the most
recent. */
gfc_expr *exprd;
- exprd = (LOCATION_LINE (con->expr->where.lb->location)
- > LOCATION_LINE (rvalue->where.lb->location))
- ? con->expr : rvalue;
+ exprd = (linemap_location_before_p (line_table,
+ gfc_get_location (&con->expr->where),
+ gfc_get_location (&rvalue->where))
+ ? rvalue : con->expr);
if (gfc_notify_std (GFC_STD_GNU,
"re-initialization of %qs at %L",
symbol->name, &exprd->where) == false)
/* Overwriting an existing initializer is non-standard but usually only
provokes a warning from other compilers. */
- if (init != NULL && init->where.lb && rvalue->where.lb)
+ if (init != NULL
+ && GFC_LOCUS_IS_SET (init->where)
+ && GFC_LOCUS_IS_SET (rvalue->where))
{
/* Order in which the expressions arrive here depends on whether
they are from data statements or F95 style declarations.
Therefore, check which is the most recent. */
- expr = (LOCATION_LINE (init->where.lb->location)
- > LOCATION_LINE (rvalue->where.lb->location))
- ? init : rvalue;
+ expr = (linemap_location_before_p (line_table,
+ gfc_get_location (&init->where),
+ gfc_get_location (&rvalue->where))
+ ? rvalue : init);
if (gfc_notify_std (GFC_STD_GNU, "re-initialization of %qs at %L",
symbol->name, &expr->where) == false)
return false;
&& sym->ts.type == BT_DERIVED
&& gfc_has_default_initializer (sym->ts.u.derived))
{
- gfc_error ("Default-initialized %s dummy argument %qs "
- "at %L is not permitted in BIND(C) procedure %qs",
- (sym->attr.pointer ? "pointer" : "allocatable"),
- sym->name, &sym->declared_at,
- sym->ns->proc_name->name);
+ gfc_error ("Default-initialized dummy argument %qs with %s "
+ "attribute at %L is not permitted in BIND(C) "
+ "procedure %qs", sym->name,
+ (sym->attr.pointer ? "POINTER" : "ALLOCATABLE"),
+ &sym->declared_at, sym->ns->proc_name->name);
retval = false;
}
{
gfc_symtree *s = gfc_get_unique_symtree (gfc_current_ns);
s->n.sym = st->n.sym;
- sym = gfc_new_symbol (name, gfc_current_ns);
-
+ sym = gfc_new_symbol (name, gfc_current_ns, var_locus);
st->n.sym = sym;
sym->refs++;
gfc_set_sym_referenced (sym);
}
/* ...Otherwise generate a new symtree and new symbol. */
- else if (gfc_get_symbol (name, NULL, &sym))
+ else if (gfc_get_symbol (name, NULL, &sym, var_locus))
return false;
/* Check if the name has already been defined as a type. The
name to be '%FILL' which gives it an anonymous (inaccessible) name. */
m = MATCH_NO;
gfc_gobble_whitespace ();
+ var_locus = gfc_current_locus;
c = gfc_peek_ascii_char ();
if (c == '%')
{
goto cleanup;
}
- var_locus = gfc_current_locus;
-
/* Now we could see the optional array spec. or character length. */
m = gfc_match_array_spec (&as, true, true);
if (m == MATCH_ERROR)
goto cleanup;
}
+ var_locus = gfc_get_location_range (NULL, 0, &var_locus, 1,
+ &gfc_current_locus);
if (flag_cray_pointer)
cp_as = gfc_copy_array_spec (as);
if (sym != NULL && (sym->attr.dummy || sym->attr.result))
{
m = MATCH_ERROR;
- gfc_error ("%qs at %C is a redefinition of the declaration "
+ gfc_error ("%qs at %L is a redefinition of the declaration "
"in the corresponding interface for MODULE "
- "PROCEDURE %qs", sym->name,
+ "PROCEDURE %qs", sym->name, &var_locus,
gfc_current_ns->proc_name->name);
goto cleanup;
}
/* %FILL components may not have initializers. */
if (startswith (name, "%FILL") && gfc_match_eos () != MATCH_YES)
{
- gfc_error ("%qs entity cannot have an initializer at %C", "%FILL");
+ gfc_error ("%qs entity cannot have an initializer at %L", "%FILL",
+ &var_locus);
m = MATCH_ERROR;
goto cleanup;
}
{
if (sym->as != NULL)
{
- gfc_error ("Duplicate array spec for Cray pointee at %C");
+ gfc_error ("Duplicate array spec for Cray pointee at %L", &var_locus);
gfc_free_array_spec (cp_as);
m = MATCH_ERROR;
goto cleanup;
for (;;)
{
+ gfc_gobble_whitespace ();
if (gfc_match_char ('*') == MATCH_YES)
{
sym = NULL;
}
else
{
+ locus loc = gfc_current_locus;
m = gfc_match_name (name);
if (m != MATCH_YES)
{
gfc_error_now ("A parameter name is required at %C");
goto cleanup;
}
+ loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
- if (!typeparam && gfc_get_symbol (name, NULL, &sym))
+ if (!typeparam && gfc_get_symbol (name, NULL, &sym, &loc))
goto cleanup;
else if (typeparam
- && gfc_get_symbol (name, progname->f2k_derived, &sym))
+ && gfc_get_symbol (name, progname->f2k_derived, &sym, &loc))
goto cleanup;
}
if (m != MATCH_YES)
return m;
+ loc = gfc_current_locus;
m = gfc_match ("subroutine% %n", name);
if (m != MATCH_YES)
return m;
/* Set declared_at as it might point to, e.g., a PUBLIC statement, if
the symbol existed before. */
- sym->declared_at = gfc_current_locus;
+ sym->declared_at = gfc_get_location_range (NULL, 0, &loc, 1,
+ &gfc_current_locus);
if (current_attr.module_procedure)
sym->attr.module_procedure = 1;
/* Return a location_t suitable for 'tree' for a gfortran locus. During
- parsing in gfortran, loc->lb->location contains only the line number
+ parsing in gfortran, loc->u.lb->location contains only the line number
and LOCATION_COLUMN is 0; hence, the column has to be added when generating
- locations for 'tree'. */
+ locations for 'tree'. If available, return location_t directly, which
+ might be a range. */
location_t
gfc_get_location_with_offset (locus *loc, unsigned offset)
{
- gcc_checking_assert (loc->nextc >= loc->lb->line);
- return linemap_position_for_loc_and_offset (line_table, loc->lb->location,
- loc->nextc - loc->lb->line
+ if (loc->nextc == (gfc_char_t *) -1)
+ {
+ gcc_checking_assert (offset == 0);
+ return loc->u.location;
+ }
+ gcc_checking_assert (loc->nextc >= loc->u.lb->line);
+ return linemap_position_for_loc_and_offset (line_table, loc->u.lb->location,
+ loc->nextc - loc->u.lb->line
+ offset);
}
+/* Convert a locus to a range. */
+
+locus
+gfc_get_location_range (locus *caret_loc, unsigned caret_offset,
+ locus *start_loc, unsigned start_offset,
+ locus *end_loc)
+{
+ location_t caret;
+ location_t start = gfc_get_location_with_offset (start_loc, start_offset);
+ location_t end = gfc_get_location_with_offset (end_loc, 0);
+
+ if (caret_loc)
+ caret = gfc_get_location_with_offset (caret_loc, caret_offset);
+
+ locus range;
+ range.nextc = (gfc_char_t *) -1;
+ range.u.location = make_location (caret_loc ? caret : start, start, end);
+ return range;
+}
+
/* Return buffered_p. */
bool
gfc_buffered_p (void)
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
return true;
- where = lvalue->where.lb ? &lvalue->where : &rvalue->where;
+ where = (GFC_LOCUS_IS_SET (lvalue->where)
+ ? &lvalue->where : &rvalue->where);
gfc_error ("Incompatible types in DATA statement at %L; attempted "
"conversion of %s to %s", where,
gfc_typename (rvalue), gfc_typename (lvalue));
void *data ATTRIBUTE_UNUSED)
{
current_code = c;
- if (c && *c && (((*c)->loc.nextc == NULL) || ((*c)->loc.lb == NULL)))
+ if (c
+ && *c
+ && (((*c)->loc.nextc == NULL)
+ || ((*c)->loc.nextc == (gfc_char_t *) -1
+ && (*c)->loc.u.location == UNKNOWN_LOCATION)
+ || ((*c)->loc.nextc != (gfc_char_t *) -1
+ && ((*c)->loc.u.lb == NULL))))
+
gfc_warning_internal (0, "Inconsistent internal state: "
"No location in statement");
void *data ATTRIBUTE_UNUSED)
{
- if (e && *e && (((*e)->where.nextc == NULL || (*e)->where.lb == NULL)))
+ if (e
+ && *e
+ && (((*e)->where.nextc == NULL)
+ || ((*e)->where.nextc == (gfc_char_t *) -1
+ && (*e)->where.u.location == UNKNOWN_LOCATION)
+ || ((*e)->where.nextc != (gfc_char_t *) -1
+ && ((*e)->where.u.lb == NULL))))
gfc_warning_internal (0, "Inconsistent internal state: "
"No location in expression near %L",
&((*current_code)->loc));
gfc_code *c;
gfc_actual_arglist *a1, *a2, *a3;
- gcc_assert (e1->where.lb);
+ gcc_assert (GFC_LOCUS_IS_SET (e1->where));
/* Build the call to runtime_error. */
c = XCNEW (gfc_code);
c->op = EXEC_CALL;
#define gfc_linebuf_linenum(LBUF) (LOCATION_LINE ((LBUF)->location))
+/* If nextc = (gfc_char_t*) -1, 'location' is used. */
typedef struct
{
gfc_char_t *nextc;
- gfc_linebuf *lb;
+ union
+ {
+ gfc_linebuf *lb;
+ location_t location;
+ } u;
} locus;
+#define GFC_LOCUS_IS_SET(loc) \
+ ((loc).nextc == (gfc_char_t *) -1 || (loc).u.lb != NULL)
+
/* In order for the "gfc" format checking to work correctly, you must
have declared a typedef locus first. */
#if GCC_VERSION >= 4001
bool gfc_find_sym_in_expr (gfc_symbol *, gfc_expr *);
/* error.cc */
+locus gfc_get_location_range (locus *, unsigned, locus *, unsigned, locus *);
location_t gfc_get_location_with_offset (locus *, unsigned);
inline location_t
gfc_get_location (locus *loc)
gfc_user_op *gfc_find_uop (const char *, gfc_namespace *);
void gfc_free_symbol (gfc_symbol *&);
bool gfc_release_symbol (gfc_symbol *&);
-gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *);
+gfc_symbol *gfc_new_symbol (const char *, gfc_namespace *, locus * = NULL);
gfc_symtree* gfc_find_symtree_in_proc (const char *, gfc_namespace *);
int gfc_find_symbol (const char *, gfc_namespace *, int, gfc_symbol **);
bool gfc_find_sym_tree (const char *, gfc_namespace *, int, gfc_symtree **);
-int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **);
+int gfc_get_symbol (const char *, gfc_namespace *, gfc_symbol **,
+ locus * = NULL);
bool gfc_verify_c_interop (gfc_typespec *);
bool gfc_verify_c_interop_param (gfc_symbol *);
bool verify_bind_c_sym (gfc_symbol *, gfc_typespec *, int, gfc_common_head *);
gfc_symtree *generate_isocbinding_symbol (const char *, iso_c_binding_symbol,
const char *, gfc_symtree *, bool);
void gfc_save_symbol_data (gfc_symbol *);
-int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool);
-int gfc_get_ha_symbol (const char *, gfc_symbol **);
-int gfc_get_ha_sym_tree (const char *, gfc_symtree **);
+int gfc_get_sym_tree (const char *, gfc_namespace *, gfc_symtree **, bool,
+ locus * = NULL);
+int gfc_get_ha_symbol (const char *, gfc_symbol **, locus * = NULL);
+int gfc_get_ha_sym_tree (const char *, gfc_symtree **, locus * = NULL);
void gfc_drop_last_undo_checkpoint (void);
void gfc_restore_last_undo_checkpoint (void);
check_io_constraints (io_kind k, gfc_dt *dt, gfc_code *io_code,
locus *spec_end)
{
-#define io_constraint(condition, msg, arg)\
+#define io_constraint(condition, msg, where)\
if (condition) \
{\
- if ((arg)->lb != NULL)\
- gfc_error ((msg), (arg));\
+ if (GFC_LOCUS_IS_SET (*where))\
+ gfc_error ((msg), (where));\
else\
gfc_error ((msg), spec_end);\
return false;\
{
char buffer[GFC_MAX_SYMBOL_LEN + 1];
match m;
+ int ret;
+ locus loc = gfc_current_locus;
m = gfc_match_name (buffer);
if (m != MATCH_YES)
return m;
-
+ loc = gfc_get_location_range (NULL, 0, &loc, 1, &gfc_current_locus);
if (host_assoc)
- return (gfc_get_ha_sym_tree (buffer, matched_symbol))
- ? MATCH_ERROR : MATCH_YES;
+ {
+ ret = gfc_get_ha_sym_tree (buffer, matched_symbol, &loc);
+ return ret ? MATCH_ERROR : MATCH_YES;
+ }
- if (gfc_get_sym_tree (buffer, NULL, matched_symbol, false))
+ ret = gfc_get_sym_tree (buffer, NULL, matched_symbol, false, &loc);
+ if (ret)
return MATCH_ERROR;
return MATCH_YES;
for (;;)
{
+ gfc_gobble_whitespace ();
cur_loc = gfc_current_locus;
m = gfc_match_name (n);
if (m == MATCH_YES && strcmp (n, "omp_all_memory") == 0)
{
+ locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+ &gfc_current_locus);
if (!has_all_memory)
{
- gfc_error ("%<omp_all_memory%> at %C not permitted in this "
- "clause");
+ gfc_error ("%<omp_all_memory%> at %L not permitted in this "
+ "clause", &loc);
goto cleanup;
}
*has_all_memory = true;
tail->next = p;
tail = tail->next;
}
- tail->where = cur_loc;
+ tail->where = loc;
goto next_item;
}
if (m == MATCH_YES)
}
if (gfc_is_coindexed (expr))
{
- gfc_error ("List item shall not be coindexed at %C");
+ gfc_error ("List item shall not be coindexed at %L",
+ &expr->where);
goto cleanup;
}
}
}
tail->sym = sym;
tail->expr = expr;
- tail->where = cur_loc;
+ tail->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+ &gfc_current_locus);
if (reject_common_vars && sym->attr.in_common)
{
gcc_assert (allow_common);
if (!allow_common)
goto syntax;
- m = gfc_match (" / %n /", n);
+ m = gfc_match ("/ %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
+ cur_loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+ &gfc_current_locus);
st = gfc_find_symtree (gfc_current_ns->common_root, n);
if (st == NULL)
{
- gfc_error ("COMMON block /%s/ not found at %C", n);
+ gfc_error ("COMMON block %</%s/%> not found at %L", n, &cur_loc);
goto cleanup;
}
for (sym = st->n.common->head; sym; sym = sym->common_next)
for (;;)
{
+ gfc_gobble_whitespace ();
cur_loc = gfc_current_locus;
if (gfc_match_name (n) != MATCH_YES)
goto syntax;
+ locus loc = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+ &gfc_current_locus);
if (UNLIKELY (strcmp (n, "omp_all_memory") == 0))
{
gfc_error ("%<omp_all_memory%> used with dependence-type "
- "other than OUT or INOUT at %C");
+ "other than OUT or INOUT at %L", &loc);
goto cleanup;
}
sym = NULL;
}
tail->sym = sym;
tail->expr = NULL;
- tail->where = cur_loc;
+ tail->where = loc;
if (gfc_match_char ('+') == MATCH_YES)
{
if (gfc_match_literal_constant (&tail->expr, 0) != MATCH_YES)
if (digit_flag)
gfc_error_now ("Statement label without statement at %L", &label_locus);
- gfc_current_locus.lb->truncated = 0;
+ gfc_current_locus.u.lb->truncated = 0;
gfc_advance_line ();
return ST_NONE;
}
if (tmp && tmp->type == REF_INQUIRY)
{
- if (!primary->where.lb || !primary->where.nextc)
+ if (!primary->where.u.lb || !primary->where.nextc)
primary->where = gfc_current_locus;
gfc_simplify_expr (primary, 0);
expr->expr_type = EXPR_VARIABLE;
expr->symtree = st;
expr->ts = sym->ts;
- expr->where = where;
/* Now see if we have to do more. */
m = gfc_match_varspec (expr, equiv_flag, false, false);
return m;
}
+ expr->where = gfc_get_location_range (NULL, 0, &where, 1, &gfc_current_locus);
*result = expr;
return MATCH_YES;
}
case REF_ARRAY:
if (as == NULL)
{
- locus loc = ref->u.ar.where.lb ? ref->u.ar.where : e->where;
+ locus loc = (GFC_LOCUS_IS_SET (ref->u.ar.where)
+ ? ref->u.ar.where : e->where);
gfc_error ("Invalid array reference of a non-array entity at %L",
&loc);
return false;
if (line_head == NULL)
return 1; /* Null file */
- if (gfc_current_locus.lb == NULL)
+ if (gfc_current_locus.u.lb == NULL)
return 1;
return 0;
if (gfc_at_eof ())
return 1;
- return (gfc_current_locus.nextc == gfc_current_locus.lb->line);
+ return (gfc_current_locus.nextc == gfc_current_locus.u.lb->line);
}
(*debug_hooks->start_source_file) (0, gfc_source_file);
file_changes_cur = 0;
- report_file_change (gfc_current_locus.lb);
+ report_file_change (gfc_current_locus.u.lb);
}
void
if (gfc_at_end ())
return;
- if (gfc_current_locus.lb == NULL)
+ if (gfc_current_locus.u.lb == NULL)
{
end_flag = 1;
return;
}
- if (gfc_current_locus.lb->next
- && !gfc_current_locus.lb->next->dbg_emitted)
+ if (gfc_current_locus.u.lb->next
+ && !gfc_current_locus.u.lb->next->dbg_emitted)
{
- report_file_change (gfc_current_locus.lb->next);
- gfc_current_locus.lb->next->dbg_emitted = true;
+ report_file_change (gfc_current_locus.u.lb->next);
+ gfc_current_locus.u.lb->next->dbg_emitted = true;
}
- gfc_current_locus.lb = gfc_current_locus.lb->next;
+ gfc_current_locus.u.lb = gfc_current_locus.u.lb->next;
- if (gfc_current_locus.lb != NULL)
- gfc_current_locus.nextc = gfc_current_locus.lb->line;
+ if (gfc_current_locus.u.lb != NULL)
+ gfc_current_locus.nextc = gfc_current_locus.u.lb->line;
else
{
gfc_current_locus.nextc = NULL;
if (wide_strncmp (gfc_current_locus.nextc, "#define ", 8) == 0)
{
tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[8], -1);
- (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.lb),
+ (*debug_hooks->define) (gfc_linebuf_linenum (gfc_current_locus.u.lb),
tmp);
free (tmp);
}
if (wide_strncmp (gfc_current_locus.nextc, "#undef ", 7) == 0)
{
tmp = gfc_widechar_to_char (&gfc_current_locus.nextc[7], -1);
- (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.lb),
+ (*debug_hooks->undef) (gfc_linebuf_linenum (gfc_current_locus.u.lb),
tmp);
free (tmp);
}
return;
}
- if (gfc_current_locus.lb != NULL
- && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+ if (gfc_current_locus.u.lb != NULL
+ && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb);
/* If -fopenmp/-fopenacc, we need to handle here 2 things:
1) don't treat !$omp/!$acc|c$omp/c$acc|*$omp / *$acc as comments,
if (col != 6 && c == '!')
{
- if (gfc_current_locus.lb != NULL
- && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+ if (gfc_current_locus.u.lb != NULL
+ && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb);
skip_comment_line ();
continue;
}
while (c != '\n');
/* Avoid truncation warnings for comment ending lines. */
- gfc_current_locus.lb->truncated = 0;
+ gfc_current_locus.u.lb->truncated = 0;
goto done;
}
/* Check to see if the continuation line was truncated. */
- if (warn_line_truncation && gfc_current_locus.lb != NULL
- && gfc_current_locus.lb->truncated)
+ if (warn_line_truncation && gfc_current_locus.u.lb != NULL
+ && gfc_current_locus.u.lb->truncated)
{
int maxlen = flag_free_line_length;
gfc_char_t *current_nextc = gfc_current_locus.nextc;
- gfc_current_locus.lb->truncated = 0;
- gfc_current_locus.nextc = gfc_current_locus.lb->line + maxlen;
+ gfc_current_locus.u.lb->truncated = 0;
+ gfc_current_locus.nextc = gfc_current_locus.u.lb->line + maxlen;
gfc_warning_now (OPT_Wline_truncation,
"Line truncated at %L", &gfc_current_locus);
gfc_current_locus.nextc = current_nextc;
without getting reset (e.g. via input_stmt). It also happens
when pre-including files via -fpre-include=. */
if (continue_count == 0
- && gfc_current_locus.lb
- && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
+ && gfc_current_locus.u.lb
+ && continue_line > gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1)
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1;
continue_flag = 1;
if (c == '!')
/* We've got a continuation line. If we are on the very next line after
the last continuation, increment the continuation line count and
check whether the limit has been exceeded. */
- if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
+ if (gfc_linebuf_linenum (gfc_current_locus.u.lb) == continue_line + 1)
{
if (++continue_count == gfc_option.max_continue_free)
{
/* Now find where it continues. First eat any comment lines. */
openmp_cond_flag = skip_free_comments ();
- if (gfc_current_locus.lb != NULL
- && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+ if (gfc_current_locus.u.lb != NULL
+ && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb);
if (flag_openmp)
if (prev_openmp_flag != openmp_flag && !openacc_flag)
is_openmp = 1;
}
if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
- || omp_acc_err_loc.lb != gfc_current_locus.lb)
+ || omp_acc_err_loc.u.lb != gfc_current_locus.u.lb)
gfc_error_now (is_openmp
? G_("Wrong OpenACC continuation at %C: "
"expected !$ACC, got !$OMP")
while (c != '\n');
/* Avoid truncation warnings for comment ending lines. */
- gfc_current_locus.lb->truncated = 0;
+ gfc_current_locus.u.lb->truncated = 0;
}
if (c != '\n')
goto done;
/* Check to see if the continuation line was truncated. */
- if (warn_line_truncation && gfc_current_locus.lb != NULL
- && gfc_current_locus.lb->truncated)
+ if (warn_line_truncation && gfc_current_locus.u.lb != NULL
+ && gfc_current_locus.u.lb->truncated)
{
- gfc_current_locus.lb->truncated = 0;
+ gfc_current_locus.u.lb->truncated = 0;
gfc_warning_now (OPT_Wline_truncation,
"Line truncated at %L", &gfc_current_locus);
}
without getting reset (e.g. via input_stmt). It also happens
when pre-including files via -fpre-include=. */
if (continue_count == 0
- && gfc_current_locus.lb
- && continue_line > gfc_linebuf_linenum (gfc_current_locus.lb) + 1)
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb) + 1;
+ && gfc_current_locus.u.lb
+ && continue_line > gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1)
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb) + 1;
continue_flag = 1;
old_loc = gfc_current_locus;
is_openmp = 1;
}
if (omp_acc_err_loc.nextc != gfc_current_locus.nextc
- || omp_acc_err_loc.lb != gfc_current_locus.lb)
+ || omp_acc_err_loc.u.lb != gfc_current_locus.u.lb)
gfc_error_now (is_openmp
? G_("Wrong OpenACC continuation at %C: "
"expected !$ACC, got !$OMP")
/* We've got a continuation line. If we are on the very next line after
the last continuation, increment the continuation line count and
check whether the limit has been exceeded. */
- if (gfc_linebuf_linenum (gfc_current_locus.lb) == continue_line + 1)
+ if (gfc_linebuf_linenum (gfc_current_locus.u.lb) == continue_line + 1)
{
if (++continue_count == gfc_option.max_continue_fixed)
{
}
}
- if (gfc_current_locus.lb != NULL
- && continue_line < gfc_linebuf_linenum (gfc_current_locus.lb))
- continue_line = gfc_linebuf_linenum (gfc_current_locus.lb);
+ if (gfc_current_locus.u.lb != NULL
+ && continue_line < gfc_linebuf_linenum (gfc_current_locus.u.lb))
+ continue_line = gfc_linebuf_linenum (gfc_current_locus.u.lb);
}
/* Ready to read first character of continuation line, which might
line will be scanned multiple times. */
if (warn_tabs && c == '\t')
{
- int cur_linenum = LOCATION_LINE (gfc_current_locus.lb->location);
+ int cur_linenum = LOCATION_LINE (gfc_current_locus.u.lb->location);
if (cur_linenum != linenum)
{
linenum = cur_linenum;
openacc_flag = 0;
continue_count = 0;
continue_line = 0;
- gfc_current_locus.lb = b;
+ gfc_current_locus.u.lb = b;
gfc_current_locus.nextc = b->line;
gfc_skip_comments ();
else
load_file (gfc_source_file, NULL, true);
- gfc_current_locus.lb = line_head;
+ gfc_current_locus.u.lb = line_head;
gfc_current_locus.nextc = (line_head == NULL) ? NULL : line_head->line;
#if 0 /* Debugging aid. */
/* Allocate and initialize a new symbol node. */
gfc_symbol *
-gfc_new_symbol (const char *name, gfc_namespace *ns)
+gfc_new_symbol (const char *name, gfc_namespace *ns, locus *where)
{
gfc_symbol *p;
gfc_clear_ts (&p->ts);
gfc_clear_attr (&p->attr);
p->ns = ns;
- p->declared_at = gfc_current_locus;
+ p->declared_at = where ? *where : gfc_current_locus;
p->name = gfc_get_string ("%s", name);
return p;
int
gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result,
- bool allow_subroutine)
+ bool allow_subroutine, locus *where)
{
gfc_symtree *st;
gfc_symbol *p;
if (st == NULL)
{
/* If not there, create a new symbol. */
- p = gfc_new_symbol (name, ns);
+ p = gfc_new_symbol (name, ns, where);
/* Add to the list of tentative symbols. */
p->old_symbol = NULL;
int
-gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result)
+gfc_get_symbol (const char *name, gfc_namespace *ns, gfc_symbol **result,
+ locus *where)
{
gfc_symtree *st;
int i;
- i = gfc_get_sym_tree (name, ns, &st, false);
+ i = gfc_get_sym_tree (name, ns, &st, false, where);
if (i != 0)
return i;
exist, but tries to host-associate the symbol if possible. */
int
-gfc_get_ha_sym_tree (const char *name, gfc_symtree **result)
+gfc_get_ha_sym_tree (const char *name, gfc_symtree **result, locus *where)
{
gfc_symtree *st;
int i;
return 0;
}
- return gfc_get_sym_tree (name, gfc_current_ns, result, false);
+ return gfc_get_sym_tree (name, gfc_current_ns, result, false, where);
}
int
-gfc_get_ha_symbol (const char *name, gfc_symbol **result)
+gfc_get_ha_symbol (const char *name, gfc_symbol **result, locus *where)
{
int i;
gfc_symtree *st = NULL;
- i = gfc_get_ha_sym_tree (name, &st);
+ i = gfc_get_ha_sym_tree (name, &st, where);
if (st)
*result = st->n.sym;
{
symbol_attribute attr;
gfc_se fse;
- gfc_warning (0, "The structure constructor at %C has been"
+ locus loc;
+ gfc_locus_from_location (&loc, input_location);
+ gfc_warning (0, "The structure constructor at %L has been"
" finalized. This feature was removed by f08/0011."
" Use -std=f2018 or -std=gnu to eliminate the"
- " finalization.");
+ " finalization.", &loc);
attr.pointer = attr.allocatable = 0;
gfc_init_se (&fse, NULL);
fse.expr = desc;
{
tree parm;
tree type;
- locus loc;
tree offset;
tree tmp;
tree stmt;
stmtblock_t init;
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ location_t loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
/* Descriptor type. */
parm = sym->backend_decl;
}
stmt = gfc_finish_block (&init);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
/* Add the initialization code to the start of the function. */
tree size;
tree type;
tree offset;
- locus loc;
stmtblock_t init;
tree stmtInit, stmtCleanup;
tree lbound;
return;
}
- loc.nextc = NULL;
- gfc_save_backend_locus (&loc);
- /* loc.nextc is not set by save_backend_locus but the location routines
- depend on it. */
- if (loc.nextc == NULL)
- loc.nextc = loc.lb->line;
- gfc_set_backend_locus (&sym->declared_at);
+ location_t loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
/* Descriptor type. */
type = TREE_TYPE (tmpdesc);
stride = gfc_index_one_node;
if (warn_array_temporaries)
- gfc_warning (OPT_Warray_temporaries,
- "Creating array temporary at %L", &loc);
+ {
+ locus where;
+ gfc_locus_from_location (&where, loc);
+ gfc_warning (OPT_Warray_temporaries,
+ "Creating array temporary at %L", &where);
+ }
}
/* This is for the case where the array data is used directly without
/* Check (ubound(a) - lbound(a) == ubound(b) - lbound(b)). */
char * msg;
tree temp;
+ locus where;
+ gfc_locus_from_location (&where, loc);
temp = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type, ubound, lbound);
temp = fold_build2_loc (input_location, PLUS_EXPR,
msg = xasprintf ("Dimension %d of array '%s' has extent "
"%%ld instead of %%ld", n+1, sym->name);
- gfc_trans_runtime_check (true, false, tmp, &init, &loc, msg,
+ gfc_trans_runtime_check (true, false, tmp, &init, &where, msg,
fold_convert (long_integer_type_node, temp),
fold_convert (long_integer_type_node, stride2));
be freed at the end of the function by pop_context. */
gfc_add_init_cleanup (block, stmtInit, stmtCleanup);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
tree tmp;
tree descriptor;
stmtblock_t init;
- locus loc;
int rank;
/* Make sure the frontend gets these right. */
if (type == NULL || !GFC_DESCRIPTOR_TYPE_P (type))
return;
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ location_t loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
gfc_init_block (&init);
rank = CLASS_DATA (sym)->as ? (CLASS_DATA (sym)->as->rank) : (0);
gfc_add_expr_to_block (&init, tmp);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
tree descriptor;
stmtblock_t init;
stmtblock_t cleanup;
- locus loc;
int rank;
bool sym_has_alloc_comp, has_finalizer;
|| has_finalizer
|| (sym->as->type == AS_ASSUMED_RANK && sym->attr.dummy));
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ location_t loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
gfc_init_block (&init);
gcc_assert (VAR_P (sym->backend_decl)
if (sym->attr.dummy || sym->attr.use_assoc || sym->attr.result)
{
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
return;
}
gfc_trans_static_array_pointer (sym);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
return;
}
gfc_get_dtype_rank_type (sym->as->rank, etype));
gfc_add_expr_to_block (&init, tmp);
}
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
gfc_init_block (&cleanup);
/* Allocatable arrays need to be freed when they go out of scope.
/* The source location has been lost, and doesn't really matter.
We need to set it to something though. */
- gfc_set_decl_location (decl, &gfc_current_locus);
+ DECL_SOURCE_LOCATION (decl) = input_location;
gfc_add_decl_to_function (decl);
tmp = build_range_type (gfc_array_index_type,
gfc_index_zero_node, tmp);
tmp = build_array_type (type, tmp);
- field = build_decl (gfc_get_location (&gfc_current_locus),
- FIELD_DECL, NULL_TREE, tmp);
+ field = build_decl (input_location, FIELD_DECL, NULL_TREE, tmp);
known_align = BIGGEST_ALIGNMENT;
{
/* By construction, the external function cannot be
a contained procedure. */
- locus old_loc;
-
- gfc_save_backend_locus (&old_loc);
+ location_t old_loc = input_location;
push_cfun (NULL);
gfc_create_function_decl (gsym->ns, true);
pop_cfun ();
- gfc_restore_backend_locus (&old_loc);
+ input_location = old_loc;
}
/* If the namespace has entries, the proc_name is the
/* Set the line and filename. sym->declared_at seems to point to the
last statement for subroutines, but it'll do for now. */
- gfc_set_backend_locus (&sym->declared_at);
+ input_location = gfc_get_location (&sym->declared_at);
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
stmtblock_t body;
tree thunk_fndecl;
tree tmp;
- locus old_loc;
+ location_t old_loc;
/* This should always be a toplevel function. */
gcc_assert (current_function_decl == NULL_TREE);
- gfc_save_backend_locus (&old_loc);
+ old_loc = input_location;
for (el = ns->entries; el; el = el->next)
{
vec<tree, va_gc> *args = NULL;
}
}
- gfc_restore_backend_locus (&old_loc);
+ input_location = old_loc;
}
static tree
gfc_null_and_pass_deferred_len (gfc_symbol *sym, stmtblock_t *init,
- locus *loc)
+ location_t loc)
{
tree tmp;
gfc_add_expr_to_block (init, tmp2);
}
- gfc_restore_backend_locus (loc);
+ input_location = loc;
/* Pass the final character length back. */
if (sym->attr.intent != INTENT_IN)
void
gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
{
- locus loc;
+ location_t loc;
gfc_symbol *sym;
gfc_formal_arglist *f;
stmtblock_t tmpblock;
else if (proc_sym->as)
{
tree result = TREE_VALUE (current_fake_result_decl);
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&proc_sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&proc_sym->declared_at);
gfc_trans_dummy_array_bias (proc_sym, result, block);
/* An automatic character length, pointer array result. */
if (proc_sym->ts.deferred)
{
gfc_start_block (&init);
- tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, &loc);
+ tmp = gfc_null_and_pass_deferred_len (proc_sym, &init, loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
else
if (proc_sym->ts.deferred)
{
tmp = NULL;
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&proc_sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&proc_sym->declared_at);
gfc_start_block (&init);
/* Zero the string length on entry. */
gfc_add_modify (&init, proc_sym->ts.u.cl->backend_decl,
gfc_add_modify (&init, tmp,
fold_convert (TREE_TYPE (se.expr),
null_pointer_node));
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
/* Pass back the string length on exit. */
tmp = proc_sym->ts.u.cl->backend_decl;
/* Initialize the INTENT(OUT) derived type dummy arguments. This
should be done here so that the offsets and lbounds of arrays
are available. */
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&proc_sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&proc_sym->declared_at);
init_intent_out_dt (proc_sym, block);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
/* For some reasons, internal procedures point to the parent's
namespace. Top-level procedure and variables inside BLOCK are fine. */
{
if (TREE_STATIC (sym->backend_decl))
{
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
gfc_trans_static_array_pointer (sym);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
else
{
}
else
{
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
if (alloc_comp_or_fini)
{
gfc_trans_auto_array_allocation (sym->backend_decl,
sym, block);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
break;
&& sym->attr.result)
{
gfc_start_block (&init);
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
- tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
+ tmp = gfc_null_and_pass_deferred_len (sym, &init, loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
break;
{
tree descriptor = NULL_TREE;
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
gfc_start_block (&init);
if (sym->ts.type == BT_CHARACTER
&& sym->ts.type == BT_CHARACTER
&& sym->ts.deferred
&& sym->ts.u.cl->passed_length)
- tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
+ tmp = gfc_null_and_pass_deferred_len (sym, &init, loc);
else
{
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
tmp = NULL_TREE;
}
if (sym->ts.type == BT_CLASS)
{
/* Initialize _vptr to declared type. */
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
+
e = gfc_lval_expr_from_sym (sym);
gfc_reset_vptr (&init, e);
gfc_free_expr (e);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
if (sym->attr.dummy)
{
gfc_start_block (&init);
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
- tmp = gfc_null_and_pass_deferred_len (sym, &init, &loc);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
+ tmp = gfc_null_and_pass_deferred_len (sym, &init, loc);
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
else
gfc_trans_auto_character_variable (sym, block);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
else if (sym->attr.assign)
{
- gfc_save_backend_locus (&loc);
- gfc_set_backend_locus (&sym->declared_at);
+ loc = input_location;
+ input_location = gfc_get_location (&sym->declared_at);
gfc_trans_assign_aux_var (sym, block);
- gfc_restore_backend_locus (&loc);
+ input_location = loc;
}
else if (sym->ts.type == BT_DERIVED
&& sym->value
void_type_node);
DECL_EXTERNAL (entry->namespace_decl) = 1;
}
- gfc_set_backend_locus (&use_stmt->where);
+ input_location = gfc_get_location (&use_stmt->where);
if (!use_stmt->only_flag)
(*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
NULL_TREE,
local_name = get_identifier (rent->local_name);
else
local_name = NULL_TREE;
- gfc_set_backend_locus (&rent->where);
+ input_location = gfc_get_location (&rent->where);
(*debug_hooks->imported_module_or_decl) (decl, local_name,
ns->proc_name->backend_decl,
!use_stmt->only_flag,
{
gfc_code *code;
gfc_oacc_declare *oc;
- locus where = gfc_current_locus;
+ locus where;
gfc_omp_clauses *omp_clauses = NULL;
gfc_omp_namelist *n, *p;
-
module_oacc_clauses = NULL;
+
+ gfc_locus_from_location (&where, input_location);
gfc_traverse_ns (ns, find_module_oacc_declare_clauses);
if (module_oacc_clauses && sym->attr.flavor == FL_PROGRAM)
/* Tell the backend the source location of the block data. */
if (ns->proc_name)
- gfc_set_backend_locus (&ns->proc_name->declared_at);
+ input_location = gfc_get_location (&ns->proc_name->declared_at);
else
- gfc_set_backend_locus (&gfc_current_locus);
+ input_location = gfc_get_location (&gfc_current_locus);
/* Process the DATA statements. */
gfc_trans_common (ns);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, from_len, to_len);
gfc_trans_runtime_check (true, false, cond, &body,
- &gfc_current_locus, msg,
- to_len, from_len);
+ NULL, msg, to_len, from_len);
free (msg);
}
}
&& expr->must_finalize
&& gfc_may_be_finalized (expr->ts))
{
- gfc_warning (0, "The structure constructor at %C has been"
+ locus loc;
+ gfc_locus_from_location (&loc, input_location);
+ gfc_warning (0, "The structure constructor at %L has been"
" finalized. This feature was removed by f08/0011."
" Use -std=f2018 or -std=gnu to eliminate the"
- " finalization.");
+ " finalization.", &loc);
symbol_attribute attr;
attr.allocatable = attr.pointer = 0;
gfc_finalize_tree_expr (se, expr->ts.u.derived, attr, 0);
static void
set_error_locus (stmtblock_t * block, tree var, locus * where)
{
- gfc_file *f;
tree str, locus_file;
- int line;
gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_filename];
locus_file = fold_build3_loc (input_location, COMPONENT_REF,
locus_file = fold_build3_loc (input_location, COMPONENT_REF,
TREE_TYPE (p->field), locus_file,
p->field, NULL_TREE);
- f = where->lb->file;
- str = gfc_build_cstring_const (f->filename);
-
+ location_t loc = gfc_get_location (where);
+ str = gfc_build_cstring_const (LOCATION_FILE (loc));
str = gfc_build_addr_expr (pchar_type_node, str);
gfc_add_modify (block, locus_file, str);
- line = LOCATION_LINE (where->lb->location);
- set_parameter_const (block, var, IOPARM_common_line, line);
+ set_parameter_const (block, var, IOPARM_common_line, LOCATION_LINE (loc));
}
gfc_internal_error ("gfc_trans_omp_workshare(): Bad statement code");
}
- gfc_set_backend_locus (&code->loc);
+ input_location = gfc_get_location (&code->loc);
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
{
gfc_se if_se;
tree stmt, elsestmt;
- locus saved_loc;
- location_t loc;
+ location_t loc, saved_loc = UNKNOWN_LOCATION;
/* Check for an unconditional ELSE clause. */
if (!code->expr1)
gfc_start_block (&if_se.pre);
/* Calculate the IF condition expression. */
- if (code->expr1->where.lb)
+ if (GFC_LOCUS_IS_SET (code->expr1->where))
{
- gfc_save_backend_locus (&saved_loc);
- gfc_set_backend_locus (&code->expr1->where);
+ saved_loc = input_location;
+ input_location = gfc_get_location (&code->expr1->where);
}
gfc_conv_expr_val (&if_se, code->expr1);
- if (code->expr1->where.lb)
- gfc_restore_backend_locus (&saved_loc);
+ if (saved_loc != UNKNOWN_LOCATION)
+ input_location = saved_loc;
/* Translate the THEN clause. */
stmt = gfc_trans_code (code->next);
elsestmt = build_empty_stmt (input_location);
/* Build the condition expression and add it to the condition block. */
- loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where)
- : input_location;
+ loc = (GFC_LOCUS_IS_SET (code->expr1->where)
+ ? gfc_get_location (&code->expr1->where) : input_location);
stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt,
elsestmt);
/* The map field's declaration. */
map_field = gfc_add_field_to_struct(typenode, get_identifier(map->name),
map_type, &chain);
- if (map->loc.lb)
- gfc_set_decl_location (map_field, &map->loc);
- else if (un->declared_at.lb)
- gfc_set_decl_location (map_field, &un->declared_at);
+ if (GFC_LOCUS_IS_SET (map->loc))
+ gfc_set_decl_location (map_field, &map->loc);
+ else if (GFC_LOCUS_IS_SET (un->declared_at))
+ gfc_set_decl_location (map_field, &un->declared_at);
DECL_PACKED (map_field) |= TYPE_PACKED (typenode);
DECL_NAMELESS(map_field) = true;
field = gfc_add_field_to_struct (typenode,
get_identifier (c->name),
field_type, &chain);
- if (c->loc.lb)
+ if (GFC_LOCUS_IS_SET (c->loc))
gfc_set_decl_location (field, &c->loc);
- else if (derived->declared_at.lb)
+ else if (GFC_LOCUS_IS_SET (derived->declared_at))
gfc_set_decl_location (field, &derived->declared_at);
gfc_finish_decl_attrs (field, &c->attr);
gfc_get_* get a backend tree representation of a decl or type */
-static gfc_file *gfc_current_backend_file;
-
const char gfc_msg_fault[] = N_("Array reference out of bounds");
return t;
}
+void
+gfc_locus_from_location (locus *where, location_t loc)
+{
+ where->nextc = (gfc_char_t *) -1;
+ where->u.location = loc;
+}
+
+
static int num_var;
#define MAX_PREFIX_LEN 20
tree fntype;
char *message;
const char *p;
- int line, nargs, i;
+ int nargs, i;
location_t loc;
/* Compute the number of extra arguments from the format string. */
if (where)
{
- line = LOCATION_LINE (where->lb->location);
- message = xasprintf ("At line %d of file %s", line,
- where->lb->file->filename);
+ location_t loc = gfc_get_location (where);
+ message = xasprintf ("At line %d of file %s", LOCATION_LINE (loc),
+ LOCATION_FILE (loc));
}
else
message = xasprintf ("In file '%s', around line %d",
- gfc_source_file, LOCATION_LINE (input_location) + 1);
+ gfc_source_file, LOCATION_LINE (input_location));
arg = gfc_build_addr_expr (pchar_type_node,
gfc_build_localized_cstring_const (message));
}
else
{
+ location_t loc = where ? gfc_get_location (where) : input_location;
if (once)
- cond = fold_build2_loc (gfc_get_location (where), TRUTH_AND_EXPR,
- boolean_type_node, tmpvar,
+ cond = fold_build2_loc (loc, TRUTH_AND_EXPR, boolean_type_node, tmpvar,
fold_convert (boolean_type_node, cond));
- tmp = fold_build3_loc (gfc_get_location (where), COND_EXPR, void_type_node,
- cond, body,
- build_empty_stmt (gfc_get_location (where)));
+ tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, body,
+ build_empty_stmt (loc));
gfc_add_expr_to_block (pblock, tmp);
}
}
}
-/* Save the current locus. The structure may not be complete, and should
- only be used with gfc_restore_backend_locus. */
-
-void
-gfc_save_backend_locus (locus * loc)
-{
- loc->lb = XCNEW (gfc_linebuf);
- loc->lb->location = input_location;
- loc->lb->file = gfc_current_backend_file;
-}
-
-
-/* Set the current locus. */
-
-void
-gfc_set_backend_locus (locus * loc)
-{
- gfc_current_backend_file = loc->lb->file;
- input_location = gfc_get_location (loc);
-}
-
-
-/* Restore the saved locus. Only used in conjunction with
- gfc_save_backend_locus, to free the memory when we are done. */
-
-void
-gfc_restore_backend_locus (locus * loc)
-{
- /* This only restores the information captured by gfc_save_backend_locus,
- intentionally does not use gfc_get_location. */
- input_location = loc->lb->location;
- gfc_current_backend_file = loc->lb->file;
- free (loc->lb);
-}
-
-
/* Translate an executable statement. The tree cond is used by gfc_trans_do.
This static function is wrapped by gfc_trans_code_cond and
gfc_trans_code. */
gfc_add_expr_to_block (&block, res);
}
- gfc_current_locus = code->loc;
- gfc_set_backend_locus (&code->loc);
+ input_location = gfc_get_location (&code->loc);
switch (code->op)
{
gfc_internal_error ("gfc_trans_code(): Bad statement code");
}
- gfc_set_backend_locus (&code->loc);
+ input_location = gfc_get_location (&code->loc);
if (res != NULL_TREE && ! IS_EMPTY_STMT (res))
{
struct module_htab_entry *gfc_find_module (const char *);
void gfc_module_add_decl (struct module_htab_entry *, tree);
-/* Get and set the current location. */
-void gfc_save_backend_locus (locus *);
-void gfc_set_backend_locus (locus *);
-void gfc_restore_backend_locus (locus *);
+void gfc_locus_from_location (locus *, location_t);
/* Handle static constructor functions. */
extern GTY(()) tree gfc_static_ctors;
end subroutine bla
end
-! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 1 of array .'.*.'" 1 "original" } }
-! { dg-final { scan-tree-dump-times "line 15 .* bound mismatch for dimension 2 of array .'.*.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "around line 15.* bound mismatch for dimension 1 of array .'.*.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "around line 15.* bound mismatch for dimension 2 of array .'.*.'" 1 "original" } }
-! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 1 of array .'d%%m.'" 1 "original" } }
-! { dg-final { scan-tree-dump-times "line 24 .* bound mismatch for dimension 2 of array .'d%%m.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "At line 24 .* bound mismatch for dimension 1 of array .'d%%m.'" 1 "original" } }
+! { dg-final { scan-tree-dump-times "At line 24 .* bound mismatch for dimension 2 of array .'d%%m.'" 1 "original" } }
!$acc & & ! { dg-final { scan-tree-dump-times "pr92793-1\\\.f90:26:22\\\] #pragma acc loop" 1 "original" } }
!$acc & & ! { dg-final { scan-tree-dump-times "pr92793-1\\\.f90:26:22\\\] #pragma acc loop" 1 "gimple" } }
!$acc& reduction ( + : sum ) & ! { dg-line sum1 }
- !$acc && ! Fortran location information points to the ':' in 'reduction(+:sum)'.
- !$acc & & ! { dg-message "36: location of the previous reduction for 'sum'" "" { target *-*-* } sum1 }
+ !$acc && ! Fortran location information points to the 's' in 'reduction(+:sum)'.
+ !$acc & & ! { dg-message "38: location of the previous reduction for 'sum'" "" { target *-*-* } sum1 }
!$acc& independent
do i = 1, 10
!$acc loop &
!$acc & reduction(-: diff ) &
!$acc&reduction(- : sum) & ! { dg-line sum2 }
!$acc & & ! Fortran location information points to the ':' in 'reduction(-:sum)'.
- !$acc& & ! { dg-warning "32: conflicting reduction operations for 'sum'" "" { target *-*-* } sum2 }
+ !$acc& & ! { dg-warning "37: conflicting reduction operations for 'sum'" "" { target *-*-* } sum2 }
!$acc &independent
do j = 1, 10
sum &
!$acc end serial
end subroutine gwv_s_l
-subroutine gwv_r () ! { dg-message "16: enclosing routine" }
+subroutine gwv_r () ! { dg-message "1: enclosing routine" }
implicit none (type, external)
integer :: i, j, k
!$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" }
- !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." }
+ !$omp allocators allocate(y) ! { dg-error "29:Unexpected coarray 'y' in 'allocate' at .1." }
allocate(y[*])
- !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." }
+ !$omp allocate(z) ! { dg-error "18:Unexpected coarray 'z' in 'allocate' at .1." }
allocate(z(5)[*])
x = 5
end
! 11111111112222222222333333333344
!2345678901234567890123456789012345678901
!$omp target enter data map(c, ca, p, pa)
-! { dg-warning "28:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
-! { dg-warning "30:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
-! { dg-warning "34:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
-! { dg-warning "37:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
+! { dg-warning "29:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
+! { dg-warning "32:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+! { dg-warning "39:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
! 11111111112222222222333333333344
!2345678901234567890123456789012345678901
-!$omp target firstprivate(ca) ! { dg-warning "26:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
+!$omp target firstprivate(ca) ! { dg-warning "27:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
!$omp end target
-!$omp target parallel do firstprivate(ca) ! { dg-warning "38:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
+!$omp target parallel do firstprivate(ca) ! { dg-warning "39:FIRSTPRIVATE with polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" }
do x = 0, 5
end do
! 11111111112222222222333333333344
!2345678901234567890123456789012345678901
!$omp target update from(c,ca), to(p,pa)
-! { dg-warning "25:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
-! { dg-warning "27:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
-! { dg-warning "35:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
-! { dg-warning "37:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
+! { dg-warning "26:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-1 }
+! { dg-warning "28:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-2 }
+! { dg-warning "36:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-3 }
+! { dg-warning "38:Mapping polymorphic list item at .1. is unspecified behavior \\\[-Wopenmp\\\]" "" { target *-*-* } .-4 }
! -------------------------
-!$omp target parallel map(release: x) ! { dg-error "35:TARGET with map-type other than TO, FROM, TOFROM, or ALLOC on MAP clause" }
+!$omp target parallel map(release: x) ! { dg-error "36:TARGET with map-type other than TO, FROM, TOFROM, or ALLOC on MAP clause" }
block
end block
!$omp end task ! { dg-error "Unexpected !.OMP END TASK statement" }
!$omp taskloop reduction(inscan,+:a) in_reduction(+:b) ! { dg-error "'inscan' REDUCTION clause on construct other than DO, SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD" }
- ! { dg-error "34: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 }
+ ! { dg-error "35: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" "" { target *-*-* } .-1 }
! { dg-error "'inscan' and non-'inscan' 'reduction' clauses on the same construct" "" { target *-*-* } .-2 }
do i=1,10
a = a + 1
end do
-!$omp taskloop reduction(task,+:a) in_reduction(+:b) ! { dg-error "32: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" }
+!$omp taskloop reduction(task,+:a) in_reduction(+:b) ! { dg-error "33: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" }
do i=1,10
a = a + 1
end do
a = a + 1
!$omp end teams
-!$omp teams reduction(task, +:b) ! { dg-error "30: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" }
+!$omp teams reduction(task, +:b) ! { dg-error "31: Only DEFAULT permitted as reduction-modifier in REDUCTION clause" }
a = a + 1
!$omp end teams
integer :: a, b, i
a = 0
-!$omp simd reduction(inscan,+:a) ! { dg-error "30: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" }
+!$omp simd reduction(inscan,+:a) ! { dg-error "31: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" }
do i=1,10
a = a + 1
end do
!$omp parallel
-!$omp do reduction(inscan,+:a) ! { dg-error "28: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" }
+!$omp do reduction(inscan,+:a) ! { dg-error "29: With INSCAN at .1., expected loop body with ..OMP SCAN between two structured block sequences" }
do i=1,10
a = a + 1
end do
projects / thirdparty / gcc.git / commitdiff
