re PR fortran/18827 (ICE on assign to common variable)

fortran/
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.
testsuite/
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.

From-SVN: r96467

gcc/fortran/ChangeLog

+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

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;
     }

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;
 

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;
 

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);

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);

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);

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 *);
 

gcc/testsuite/ChangeLog

+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,

gcc/testsuite/gfortran.dg/assign.f90

+! { 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

gcc/testsuite/gfortran.dg/assign_2.f90

+! { 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

gcc/testsuite/gfortran.dg/assign_3.f90

+! { 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