aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog15
-rw-r--r--gcc/fortran/io.c11
-rw-r--r--gcc/fortran/match.c1
-rw-r--r--gcc/fortran/resolve.c13
-rw-r--r--gcc/fortran/trans-common.c23
-rw-r--r--gcc/fortran/trans-io.c3
-rw-r--r--gcc/fortran/trans-stmt.c23
-rw-r--r--gcc/fortran/trans.h2
-rw-r--r--gcc/testsuite/ChangeLog7
-rw-r--r--gcc/testsuite/gfortran.dg/assign.f908
-rw-r--r--gcc/testsuite/gfortran.dg/assign_2.f9011
-rw-r--r--gcc/testsuite/gfortran.dg/assign_3.f9011
12 files changed, 117 insertions, 11 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 819442c..415af9d 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,18 @@
+2005-03-15 Feng Wang <fengwang@nudt.edu.cn>
+
+ PR fortran/18827
+ * io.c (resolve_tag): Add checking on assigned label.
+ (match_dt_format): Does not set symbol assign attribute.
+ * match.c (gfc_match_goto):Does not set symbol assign attribute.
+ * resolve.c (resolve_code): Add checking on assigned label.
+ * trans-common.c (build_field): Deals with common variable assigned
+ a label.
+ * trans-stmt.c (gfc_conv_label_variable): New function.
+ (gfc_trans_label_assign): Use it.
+ (gfc_trans_goto): Ditto.
+ * trans-io.c (set_string): Ditto.
+ * trans.h (gfc_conv_label_variable): Add prototype.
+
2005-03-14 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
PR fortran/20467
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 8230fa9..12650f9 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -981,6 +981,14 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
&e->where);
return FAILURE;
}
+ /* Check assigned label. */
+ if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_INTEGER
+ && e->symtree->n.sym->attr.assign != 1)
+ {
+ gfc_error ("Variable '%s' has not been assigned a format label at %L",
+ e->symtree->n.sym->name, &e->where);
+ return FAILURE;
+ }
}
else
{
@@ -1526,9 +1534,6 @@ match_dt_format (gfc_dt * dt)
gfc_free_expr (e);
goto conflict;
}
- if (e->ts.type == BT_INTEGER && e->rank == 0)
- e->symtree->n.sym->attr.assign = 1;
-
dt->format_expr = e;
return MATCH_YES;
}
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 2a36447..f433db5 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1526,7 +1526,6 @@ gfc_match_goto (void)
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 35795c3..730f4fb 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3695,10 +3695,17 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
break;
case EXEC_GOTO:
- if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
- gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
+ if (code->expr != NULL)
+ {
+ if (code->expr->ts.type != BT_INTEGER)
+ gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
- else
+ else if (code->expr->symtree->n.sym->attr.assign != 1)
+ gfc_error ("Variable '%s' has not been assigned a target label "
+ "at %L", code->expr->symtree->n.sym->name,
+ &code->expr->where);
+ }
+ else
resolve_branch (code->label, code);
break;
diff --git a/gcc/fortran/trans-common.c b/gcc/fortran/trans-common.c
index c62d68d..c8db6e7 100644
--- a/gcc/fortran/trans-common.c
+++ b/gcc/fortran/trans-common.c
@@ -242,6 +242,27 @@ build_field (segment_info *h, tree union_type, record_layout_info rli)
size_binop (PLUS_EXPR,
DECL_FIELD_OFFSET (field),
DECL_SIZE_UNIT (field)));
+ /* If this field is assigned to a label, we create another two variables.
+ One will hold the address of taget label or format label. The other will
+ hold the length of format label string. */
+ if (h->sym->attr.assign)
+ {
+ tree len;
+ tree addr;
+
+ gfc_allocate_lang_decl (field);
+ GFC_DECL_ASSIGN (field) = 1;
+ len = gfc_create_var_np (gfc_charlen_type_node,h->sym->name);
+ addr = gfc_create_var_np (pvoid_type_node, h->sym->name);
+ TREE_STATIC (len) = 1;
+ TREE_STATIC (addr) = 1;
+ DECL_INITIAL (len) = build_int_cst (NULL_TREE, -2);
+ gfc_set_decl_location (len, &h->sym->declared_at);
+ gfc_set_decl_location (addr, &h->sym->declared_at);
+ GFC_DECL_STRING_LEN (field) = pushdecl_top_level (len);
+ GFC_DECL_ASSIGN_ADDR (field) = pushdecl_top_level (addr);
+ }
+
h->field = field;
}
@@ -434,7 +455,7 @@ create_common (gfc_common_head *com, segment_info * head)
for (s = head; s; s = next_s)
{
s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
- decl, s->field, NULL_TREE);
+ decl, s->field, NULL_TREE);
next_s = s->next;
gfc_free (s);
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 26f05f1..4169321 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -397,7 +397,6 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
tree len;
gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e);
io = build3 (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var, NULL_TREE);
len = build3 (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len,
@@ -406,6 +405,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
/* Integer variable assigned a format label. */
if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
{
+ gfc_conv_label_variable (&se, e);
msg =
gfc_build_cstring_const ("Assigned label is not a format label");
tmp = GFC_DECL_STRING_LEN (se.expr);
@@ -417,6 +417,7 @@ set_string (stmtblock_t * block, stmtblock_t * postblock, tree var,
}
else
{
+ gfc_conv_expr (&se, e);
gfc_conv_string_parameter (&se);
gfc_add_modify_expr (&se.pre, io, fold_convert (TREE_TYPE (io), se.expr));
gfc_add_modify_expr (&se.pre, len, se.string_length);
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index da074c8..ea5da88 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -80,7 +80,23 @@ gfc_trans_label_here (gfc_code * code)
return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
}
+
+/* Given a variable expression which has been ASSIGNed to, find the decl
+ containing the auxiliary variables. For variables in common blocks this
+ is a field_decl. */
+
+void
+gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
+{
+ gcc_assert (expr->symtree->n.sym->attr.assign == 1);
+ gfc_conv_expr (se, expr);
+ /* Deals with variable in common block. Get the field declaration. */
+ if (TREE_CODE (se->expr) == COMPONENT_REF)
+ se->expr = TREE_OPERAND (se->expr, 1);
+}
+
/* Translate a label assignment statement. */
+
tree
gfc_trans_label_assign (gfc_code * code)
{
@@ -95,7 +111,8 @@ gfc_trans_label_assign (gfc_code * code)
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
- gfc_conv_expr (&se, code->expr);
+ gfc_conv_label_variable (&se, code->expr);
+
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
@@ -103,6 +120,8 @@ gfc_trans_label_assign (gfc_code * code)
if (code->label->defined == ST_LABEL_TARGET)
{
+ /* Shouldn't need to set this flag. Reserve for optimization bug. */
+ DECL_ARTIFICIAL (label_tree) = 0;
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = integer_minus_one_node;
}
@@ -140,7 +159,7 @@ gfc_trans_goto (gfc_code * code)
/* ASSIGNED GOTO. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
- gfc_conv_expr (&se, code->expr);
+ gfc_conv_label_variable (&se, code->expr);
assign_error =
gfc_build_cstring_const ("Assigned label is not a target label");
tmp = GFC_DECL_STRING_LEN (se.expr);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index aad878f..712c530 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -289,6 +289,8 @@ void gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr);
void gfc_conv_expr_reference (gfc_se * se, gfc_expr *);
/* Equivalent to convert(type, gfc_conv_expr_val(se, expr)). */
void gfc_conv_expr_type (gfc_se * se, gfc_expr *, tree);
+/* Find the decl containing the auxiliary variables for assigned variables. */
+void gfc_conv_label_variable (gfc_se * se, gfc_expr * expr);
/* If the value is not constant, Create a temporary and copy the value. */
tree gfc_evaluate_now (tree, stmtblock_t *);
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6d39769..765cc43 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2005-03-15 Feng Wang <fengwang@nudt.edu.cn>
+
+ PR fortran/18827
+ * gfortran.dg/assign_2.f90: New test.
+ * gfortran.dg/assign_3.f90: New test.
+ * gfortran.dg/assign.f90: New test.
+
2005-03-15 Joseph S. Myers <joseph@codesourcery.com>
* g++.dg/other/cv_func.C, g++.dg/other/offsetof3.C,
diff --git a/gcc/testsuite/gfortran.dg/assign.f90 b/gcc/testsuite/gfortran.dg/assign.f90
new file mode 100644
index 0000000..516a3d7
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assign.f90
@@ -0,0 +1,8 @@
+! { dg-do run }
+! Program to test ASSIGNing a label to common variable. PR18827.
+ program test
+ integer i
+ common i
+ assign 2000 to i ! { dg-warning "Obsolete: ASSIGN statement" }
+2000 continue
+ end
diff --git a/gcc/testsuite/gfortran.dg/assign_2.f90 b/gcc/testsuite/gfortran.dg/assign_2.f90
new file mode 100644
index 0000000..4119cd9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assign_2.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Option passed to avoid excess errors from obsolete warning
+! { dg-options "-w" }
+! PR18827
+ integer i,j
+ common /foo/ i,j
+ assign 1000 to j
+ j = 5
+ goto j
+ 1000 continue
+ end
diff --git a/gcc/testsuite/gfortran.dg/assign_3.f90 b/gcc/testsuite/gfortran.dg/assign_3.f90
new file mode 100644
index 0000000..a43b10c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assign_3.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Option passed to avoid excess errors from obsolete warning
+! { dg-options "-w" }
+! PR18827
+ integer i,j
+ equivalence (i,j)
+ assign 1000 to i
+ write (*, j) ! { dg-error "not been assigned a format label" }
+ goto j ! { dg-error "not been assigned a target label" }
+ 1000 continue
+ end
generated by cgit v1.1 at 2024-11-05 13:22:06 +0000