This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[fortran, patch] Patch for PR18827
- From: Feng Wang <wf_cs at yahoo dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches at gcc dot gnu dot org
- Cc: Steven Bosscher <stevenb at suse dot de>
- Date: Tue, 22 Feb 2005 15:48:29 +0800 (CST)
- Subject: [fortran, patch] Patch for PR18827
This patch fix pr18827. Allows variables in a common block to be assigned a
label. And do not set symbol's assign attribute when match assigned goto
statement and i/o statements using label assigned variable. We should set it
only when match assign statment. And add checking this attribute when
resolving.
But this patch reveals another bug of the backend. The backend will remove the
label unless we set !DECL_ARTIFICIAL flag on assigned label, even we set
TREE_ADDRESSABLE flag and !DECL_IGNORED_P and FORCED_LABEL flag. After
discussion with Steven, we reserve the setting of !DECL_ARTIFICIAL on assigned
label to fix pr18827. And after committing this patch, I will file a BE bug
reporting.
Tested on i686 with no regression. If it is ok, please commit it.
Best Regards,
Feng Wang
fortran ChangeLog entry:
2005-02-22 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.
testsuite ChangeLog entry:
2005-02-22 Feng Wang <fengwang@nudt.edu.cn>
PR fortran/18827
* gfortran.dg/assign_2.f90: New test.
* gfortran.dg/assign_3.f90: New test.
* gfortran.fortran-torture/execute/assign.f90: New test.
_________________________________________________________
Do You Yahoo!?
150万曲MP3疯狂搜，带您闯入音乐殿堂
http://music.yisou.com/
美女明星应有尽有，搜遍美图、艳图和酷图
http://image.yisou.com
1G就是1000兆，雅虎电邮自助扩容！
http://cn.rd.yahoo.com/mail_cn/tag/1g/*http://cn.mail.yahoo.com/event/mail_1g/
*** io.c 2005/02/16 02:20:09 1.1
--- io.c 2005/02/16 02:38:07
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 981,986 ****
--- 981,994 ----
&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
{
*************** match_dt_format (gfc_dt * dt)
*** 1526,1534 ****
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;
}
--- 1534,1539 ----
*** match.c 2005/02/16 02:20:09 1.1
--- match.c 2005/02/16 02:38:07
*************** gfc_match_goto (void)
*** 1526,1532 ****
== FAILURE)
return MATCH_ERROR;
- expr->symtree->n.sym->attr.assign = 1;
new_st.op = EXEC_GOTO;
new_st.expr = expr;
--- 1526,1531 ----
*** resolve.c 2005/02/16 02:20:09 1.1
--- resolve.c 2005/02/16 02:38:07
*************** resolve_code (gfc_code * code, gfc_names
*** 3648,3657 ****
break;
case EXEC_GOTO:
! if (code->expr != NULL && code->expr->ts.type != BT_INTEGER)
! gfc_error ("ASSIGNED GOTO statement at %L requires an INTEGER "
"variable", &code->expr->where);
! else
resolve_branch (code->label, code);
break;
--- 3648,3664 ----
break;
case EXEC_GOTO:
! 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 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;
*** trans-common.c 2005/02/16 02:20:09 1.1
--- trans-common.c 2005/02/16 02:38:07
*************** build_field (segment_info *h, tree union
*** 242,247 ****
--- 242,268 ----
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;
}
*************** create_common (gfc_common_head *com, seg
*** 429,435 ****
for (s = head; s; s = next_s)
{
s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
! decl, s->field, NULL_TREE);
next_s = s->next;
gfc_free (s);
--- 450,456 ----
for (s = head; s; s = next_s)
{
s->sym->backend_decl = build3 (COMPONENT_REF, TREE_TYPE (s->field),
! decl, s->field, NULL_TREE);
next_s = s->next;
gfc_free (s);
*** trans.h 2005/02/16 02:20:09 1.1
--- trans.h 2005/02/16 02:38:07
*************** void gfc_conv_expr_lhs (gfc_se * se, gfc
*** 289,294 ****
--- 289,296 ----
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);
+ /* Converts a variable assigned a label. */
+ 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 *);
*** trans-io.c 2005/02/16 02:20:09 1.1
--- trans-io.c 2005/02/16 02:38:07
*************** set_string (stmtblock_t * block, stmtblo
*** 397,403 ****
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,
--- 397,402 ----
*************** set_string (stmtblock_t * block, stmtblo
*** 406,411 ****
--- 405,411 ----
/* 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);
*************** set_string (stmtblock_t * block, stmtblo
*** 417,422 ****
--- 417,423 ----
}
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);
*** trans-stmt.c 2005/02/16 02:20:09 1.1
--- trans-stmt.c 2005/02/16 02:50:52
*************** gfc_trans_label_here (gfc_code * code)
*** 80,85 ****
--- 80,99 ----
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)
*************** gfc_trans_label_assign (gfc_code * code)
*** 95,101 ****
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
! gfc_conv_expr (&se, code->expr);
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
--- 109,116 ----
/* Start a new block. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
! gfc_conv_label_variable (&se, code->expr);
!
len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
*************** gfc_trans_label_assign (gfc_code * code)
*** 103,108 ****
--- 118,124 ----
if (code->label->defined == ST_LABEL_TARGET)
{
+ DECL_ARTIFICIAL (label_tree) = 0;
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = integer_minus_one_node;
}
*************** gfc_trans_goto (gfc_code * code)
*** 140,146 ****
/* ASSIGNED GOTO. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
! gfc_conv_expr (&se, code->expr);
assign_error =
gfc_build_cstring_const ("Assigned label is not a target label");
tmp = GFC_DECL_STRING_LEN (se.expr);
--- 156,162 ----
/* ASSIGNED GOTO. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
! 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);
! Program to test ASSIGNing a label to common variable.
program test
integer i
common i
assign 2000 to i
2000 continue
end
! { dg-do compile }
! Option passed to avoid excess errors from obsolete warning
! { dg-options "-w" }
integer i,j
common /foo/ i,j
assign 1000 to j
j = 5
goto j
1000 continue
end
! { dg-do compile }
! Option passed to avoid excess errors from obsolete warning
! { dg-options "-w" }
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