This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[gfortran,patch] Assign, assigned goto available.


Hi, all
  This patch implements the assign and related statemnets. I create two
variables. One holds the address of target label or the address of format
string. The other holds the length of format sting and is also used as flag to
distinguish the two kinds of label . Their decls are both putted into
lang_decl.
   Now the patch treats "goto label, (100,200,300)" as "goto label". I will
implement this later.
   assign.f90 is the simple test program.
   assign.diff is the gcc/gcc/fortran diff file.

   Could anyone help me check and apply them?
   The ChangeLog entry:

2003-12-09  Feng Wang <fengwang@nudt.edu.cn>

        * dump-parse-tree.c (gfc_show_code_node): Add ASSIGN and ASSIGNED GOTO
dumping.
        * gfortran.h (gfc_statement): New ST_LABEL_ASSIGNMENT.
        (gfc_exec_op): New EXEC_LABEL_ASSIGN.
        (symbol_attribute):New variable attribute: assign.
        * io.c (resolve_tag):Integer variable is allowed.
	(match_dt_format): Add ASSIGN statement. Set assign flag.
        * match.c (gfc_match_if): Change ST_NONE to ST_LABEL_ASSIGNMENT.
        (gfc_match_assign): Add ASSIGN statement. Set assign flag.
        (gfc_match_goto): Add ASSIGNED GOTO statement. Set assign flag.
        * parse.c (decode_statement): Add ST_LABEL_ASSIGNMENT.
        (next_statement): Add ST_LABEL_ASSIGNMENT.
        (gfc_ascii_statement): Add ST_LABEL_ASSIGNMENT.
        * resolve.c (resolve_code): Resolve ASSIGN and ASSIGNED GOTO statement.
        * st.c (gfc_free_statement): Add EXEC_LABEL_ASSIGN.
        * trans-decl.c (gfc_get_symbol_decl): Create the shadow variable for
assign.
        put them into the stuct lang_decl.
        * trans-io.c (set_string): Add the assign statement.
        * trans-stmt.c (gfc_trans_label_assign): New function.
        (gfc_trans_goto): Translate ASSIGNED GOTO statement.
        * trans-stmt.h (gfc_trans_label_assign): Added function prototype.
        * trans.c (gfc_trans_code): Add EXEC_LABEL_ASSIGN.
        * trans.h (lang_decl):Add shadow variable decl tree needed by assign.
        (GFC_DECL_ASSIGN_ADDR(node)): New macro to access this.
        (GFC_DECL_ASSIGN(node)): New macro to access flag.


__________________________________________________
Do You Yahoo!?
Tired of spam?  Yahoo! Mail has the best spam protection around 
http://mail.yahoo.com 
diff -c3p /home/wf/treessa/fortran/dump-parse-tree.c fortran/dump-parse-tree.c
*** /home/wf/treessa/fortran/dump-parse-tree.c	Tue Dec  9 09:11:34 2003
--- fortran/dump-parse-tree.c	Tue Dec  9 09:12:36 2003
*************** gfc_show_code_node (int level, gfc_code 
*** 788,793 ****
--- 788,798 ----
        gfc_status_char (' ');
        gfc_show_expr (c->expr2);
        break;
+     case EXEC_LABEL_ASSIGN:
+       gfc_status ("LABEL ASSIGN ");
+       gfc_show_expr (c->expr);
+       gfc_status (" %d", c->label->value);
+       break;
  
      case EXEC_POINTER_ASSIGN:
        gfc_status ("POINTER ASSIGN ");
*************** gfc_show_code_node (int level, gfc_code 
*** 797,803 ****
        break;
  
      case EXEC_GOTO:
!       gfc_status ("GOTO %d", c->label->value);
        break;
  
      case EXEC_CALL:
--- 802,812 ----
        break;
  
      case EXEC_GOTO:
!       gfc_status ("GOTO ");
!       if (c->label)
!         gfc_status ("%d", c->label->value);
!       else
!         gfc_show_expr (c->expr);
        break;
  
      case EXEC_CALL:
diff -c3p /home/wf/treessa/fortran/gfortran.h fortran/gfortran.h
*** /home/wf/treessa/fortran/gfortran.h	Tue Dec  9 09:11:34 2003
--- fortran/gfortran.h	Tue Dec  9 09:12:36 2003
*************** typedef enum
*** 198,204 ****
    ST_SUBROUTINE,
    ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, ST_ASSIGNMENT,
    ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
!   ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_NONE
  }
  gfc_statement;
  
--- 198,204 ----
    ST_SUBROUTINE,
    ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WRITE, ST_ASSIGNMENT,
    ST_POINTER_ASSIGNMENT, ST_SELECT_CASE, ST_SEQUENCE, ST_SIMPLE_IF,
!   ST_STATEMENT_FUNCTION, ST_DERIVED_DECL, ST_LABEL_ASSIGNMENT, ST_NONE
  }
  gfc_statement;
  
*************** typedef struct
*** 373,379 ****
    /* Variable attributes.  */
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
      optional:1, pointer:1, save:1, target:1,
!     dummy:1, common:1, result:1, entry:1;
  
    unsigned data:1,		/* Symbol is named in a DATA statement.  */
      use_assoc:1;		/* Symbol has been use-associated.  */
--- 373,379 ----
    /* Variable attributes.  */
    unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
      optional:1, pointer:1, save:1, target:1,
!     dummy:1, common:1, result:1, entry:1, assign:1;
  
    unsigned data:1,		/* Symbol is named in a DATA statement.  */
      use_assoc:1;		/* Symbol has been use-associated.  */
*************** typedef struct
*** 599,605 ****
  }
  gfc_user_op;
  
- 
  /* Symbol nodes.  These are important things.  They are what the
     standard refers to as "entities".  The possibly multiple names that
     refer to the same entity are accomplished by a binary tree of
--- 599,604 ----
*************** gfc_forall_iterator;
*** 1113,1119 ****
  /* Executable statements that fill gfc_code structures.  */
  typedef enum
  {
!   EXEC_NOP = 1, EXEC_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_GOTO, EXEC_CALL,
    EXEC_RETURN, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
    EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
    EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
--- 1112,1118 ----
  /* Executable statements that fill gfc_code structures.  */
  typedef enum
  {
!   EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN, EXEC_GOTO, EXEC_CALL,
    EXEC_RETURN, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
    EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
    EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
diff -c3p /home/wf/treessa/fortran/io.c fortran/io.c
*** /home/wf/treessa/fortran/io.c	Tue Dec  9 09:11:34 2003
--- fortran/io.c	Tue Dec  9 10:43:55 2003
*************** resolve_tag (const io_tag * tag, gfc_exp
*** 913,921 ****
  
    if (e->ts.type != tag->type)
      {
!       gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where,
! 		 gfc_basic_typename (tag->type));
!       return FAILURE;
      }
  
    if (tag == &tag_format)
--- 913,925 ----
  
    if (e->ts.type != tag->type)
      {
!       /*Format string can be integer array!!!*/
!       if (tag != &tag_format)
!         {
!           gfc_error ("%s tag at %L must be of type %s", tag->name, &e->where,
!           gfc_basic_typename (tag->type));
!           return FAILURE;
!         }
      }
  
    if (tag == &tag_format)
*************** match_dt_format (gfc_dt * dt)
*** 1471,1476 ****
--- 1475,1482 ----
  	  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 -c3p /home/wf/treessa/fortran/match.c fortran/match.c
*** /home/wf/treessa/fortran/match.c	Tue Dec  9 09:11:34 2003
--- fortran/match.c	Tue Dec  9 10:00:14 2003
*************** gfc_match_if (gfc_statement * if_type)
*** 1036,1042 ****
      match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
      match ("end file", gfc_match_endfile, ST_END_FILE)
      match ("exit", gfc_match_exit, ST_EXIT)
!     match ("assign", gfc_match_assign, ST_NONE)
      match ("go to", gfc_match_goto, ST_GOTO)
      match ("inquire", gfc_match_inquire, ST_INQUIRE)
      match ("nullify", gfc_match_nullify, ST_NULLIFY)
--- 1036,1042 ----
      match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE)
      match ("end file", gfc_match_endfile, ST_END_FILE)
      match ("exit", gfc_match_exit, ST_EXIT)
!     match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT)
      match ("go to", gfc_match_goto, ST_GOTO)
      match ("inquire", gfc_match_inquire, ST_INQUIRE)
      match ("nullify", gfc_match_nullify, ST_NULLIFY)
*************** gfc_match_assign (void)
*** 1474,1485 ****
  
    if (gfc_match (" %l to %v%t", &label, &expr) == MATCH_YES)
      {
!       gfc_free_expr (expr);
!       gfc_error ("The ASSIGN statement at %C is not allowed in Fortran 95");
!       return MATCH_ERROR;
!     }
  
    return MATCH_NO;
  }
  
  
--- 1474,1493 ----
  
    if (gfc_match (" %l to %v%t", &label, &expr) == MATCH_YES)
      {
!       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
!         goto cleanup;
!       expr->symtree->n.sym->attr.assign = 1;
  
+       new_st.op = EXEC_LABEL_ASSIGN;
+       new_st.label = label;
+       new_st.expr = expr;
+       return MATCH_YES;
+     }
    return MATCH_NO;
+ 
+ cleanup:
+   gfc_free_expr (expr);
+   return MATCH_ERROR;
  }
  
  
*************** gfc_match_goto (void)
*** 1508,1521 ****
        return MATCH_YES;
      }
  
!   /* The assigned GO TO statement is not allowed in Fortran 95, but a
!      compiler is required to flag it.  */
    if (gfc_match_variable (&expr, 0) == MATCH_YES)
      {
!       gfc_free_expr (expr);
!       gfc_error ("The assigned GO TO statement at %C is not allowed in "
! 		 "Fortran 95");
!       return MATCH_ERROR;
      }
  
    /* Last chance is a computed GO TO statement.  */
--- 1516,1534 ----
        return MATCH_YES;
      }
  
!   /* The assigned GO TO statement.  */ 
! 
    if (gfc_match_variable (&expr, 0) == MATCH_YES)
      {
!       expr->symtree->n.sym->attr.assign = 1;
!       new_st.op = EXEC_GOTO;
!       new_st.expr = expr;
! 
!       /* Leave the left of this statement.  */
!       while (gfc_match_eos () != MATCH_YES)
!         gfc_next_char();
! 
!       return MATCH_YES;
      }
  
    /* Last chance is a computed GO TO statement.  */
diff -c3p /home/wf/treessa/fortran/parse.c fortran/parse.c
*** /home/wf/treessa/fortran/parse.c	Tue Dec  9 09:11:34 2003
--- fortran/parse.c	Tue Dec  9 09:12:36 2003
*************** decode_statement (void)
*** 172,178 ****
      case 'a':
        match ("allocate", gfc_match_allocate, ST_ALLOCATE);
        match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
!       match ("assign", gfc_match_assign, ST_NONE);
        break;
  
      case 'b':
--- 172,178 ----
      case 'a':
        match ("allocate", gfc_match_allocate, ST_ALLOCATE);
        match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
!       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
        break;
  
      case 'b':
*************** next_statement (void)
*** 520,526 ****
    case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
    case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
    case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
!   case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL
  
  /* Statements that mark other executable statements.  */
  
--- 520,526 ----
    case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
    case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \
    case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
!   case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: case ST_LABEL_ASSIGNMENT
  
  /* Statements that mark other executable statements.  */
  
*************** gfc_ascii_statement (gfc_statement st)
*** 933,938 ****
--- 933,941 ----
      case ST_STATEMENT_FUNCTION:
        p = "STATEMENT FUNCTION";
        break;
+     case ST_LABEL_ASSIGNMENT:
+       p = "LABEL ASSIGNMENT";
+       break;
      default:
        gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
      }
diff -c3p /home/wf/treessa/fortran/resolve.c fortran/resolve.c
*** /home/wf/treessa/fortran/resolve.c	Tue Dec  9 09:11:34 2003
--- fortran/resolve.c	Tue Dec  9 15:33:27 2003
*************** resolve_code (gfc_code * code, gfc_names
*** 3468,3474 ****
  	  break;
  
  	case EXEC_GOTO:
! 	  resolve_branch (code->label, code);
  	  break;
  
  	case EXEC_RETURN:
--- 3468,3478 ----
  	  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;
  
  	case EXEC_RETURN:
*************** resolve_code (gfc_code * code, gfc_names
*** 3508,3513 ****
--- 3512,3523 ----
  	  gfc_check_assign (code->expr, code->expr2, 1);
  	  break;
  
+ 	case EXEC_LABEL_ASSIGN:
+ 	  if (t == SUCCESS && code->expr->ts.type != BT_INTEGER)
+ 	    gfc_error ("ASSIGN statement at %L requires an INTEGER "
+ 		       "variable", &code->expr->where);
+ 	  break;
+ 
  	case EXEC_POINTER_ASSIGN:
  	  if (t == FAILURE)
  	    break;
diff -c3p /home/wf/treessa/fortran/st.c fortran/st.c
*** /home/wf/treessa/fortran/st.c	Tue Dec  9 09:11:34 2003
--- fortran/st.c	Tue Dec  9 09:12:36 2003
*************** gfc_free_statement (gfc_code * p)
*** 105,110 ****
--- 105,111 ----
      case EXEC_DO_WHILE:
      case EXEC_CONTINUE:
      case EXEC_TRANSFER:
+     case EXEC_LABEL_ASSIGN:
  
      case EXEC_ARITHMETIC_IF:
        break;
diff -c3p /home/wf/treessa/fortran/trans-decl.c fortran/trans-decl.c
*** /home/wf/treessa/fortran/trans-decl.c	Tue Dec  9 09:11:34 2003
--- fortran/trans-decl.c	Tue Dec  9 15:07:03 2003
*************** gfc_allocate_lang_decl (tree decl)
*** 434,440 ****
      ggc_alloc_cleared (sizeof (struct lang_decl));
  }
  
- 
  /* Remember a symbol to generate initialization/cleanup code at function
     entry/exit.  */
  
--- 434,439 ----
*************** gfc_get_symbol_decl (gfc_symbol * sym)
*** 716,721 ****
--- 715,731 ----
  
    gfc_finish_var_decl (decl, sym);
  
+   if (sym->attr.assign)
+     {
+       gfc_allocate_lang_decl (decl);
+       GFC_DECL_ASSIGN (decl) = 1;
+       GFC_DECL_STRING_LENGTH (decl) = gfc_create_var (gfc_strlen_type_node, sym->name);
+       GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
+       TREE_STATIC (GFC_DECL_STRING_LENGTH (decl)) = 1;
+       DECL_INITIAL (GFC_DECL_STRING_LENGTH (decl)) =
+         build_int_2 (-2, -1);
+     }
+ 
    /* TODO: Initialization of pointer variables.  */
    switch (sym->ts.type)
      {
diff -c3p /home/wf/treessa/fortran/trans-io.c fortran/trans-io.c
*** /home/wf/treessa/fortran/trans-io.c	Tue Dec  9 09:11:34 2003
--- fortran/trans-io.c	Tue Dec  9 11:48:43 2003
*************** set_string (stmtblock_t * block, stmtblo
*** 379,397 ****
  {
    gfc_se se;
    tree tmp;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr (&se, e);
!   gfc_conv_string_parameter (&se);
  
    gfc_add_block_to_block (block, &se.pre);
    gfc_add_block_to_block (postblock, &se.post);
  
-   tmp = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var);
-   gfc_add_modify_expr (block, tmp, se.expr);
- 
-   tmp = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len);
-   gfc_add_modify_expr (block, tmp, se.string_length);
  }
  
  
--- 379,414 ----
  {
    gfc_se se;
    tree tmp;
+   tree error;
+   tree io;
+   tree len;
  
    gfc_init_se (&se, NULL);
    gfc_conv_expr (&se, e);
! 
!   io = build (COMPONENT_REF, TREE_TYPE (var), ioparm_var, var);
!   len = build (COMPONENT_REF, TREE_TYPE (var_len), ioparm_var, var_len);
! 
!   /*  Integer variable assigned a format label.  */
!   if (e->ts.type == BT_INTEGER && e->symtree->n.sym->attr.assign == 1)
!     {
!       error = gfc_build_string_const (37, "Assigned label is not a format label");
!       tmp = GFC_DECL_STRING_LENGTH (se.expr);
!       tmp = build (LE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
!       gfc_trans_runtime_check (tmp, error, &se.pre);
!       gfc_add_modify_expr (&se.pre, io, GFC_DECL_ASSIGN_ADDR (se.expr));
!       gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LENGTH (se.expr));
!     }
!   else
!     {
!       gfc_conv_string_parameter (&se);
!       gfc_add_modify_expr (&se.pre, io, se.expr);
!       gfc_add_modify_expr (&se.pre, len, se.string_length);
!     }
  
    gfc_add_block_to_block (block, &se.pre);
    gfc_add_block_to_block (postblock, &se.post);
  
  }
  
  
diff -c3p /home/wf/treessa/fortran/trans-stmt.c fortran/trans-stmt.c
*** /home/wf/treessa/fortran/trans-stmt.c	Tue Dec  9 09:11:34 2003
--- fortran/trans-stmt.c	Tue Dec  9 15:22:47 2003
*************** gfc_trans_label_here (gfc_code * code)
*** 83,95 ****
    return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
  }
  
  
! /* Translate a normal GOTO statement.  */
  
  tree
  gfc_trans_goto (gfc_code * code)
  {
!   return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
  }
  
  
--- 83,162 ----
    return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
  }
  
+ /* Translate a label assignment statement.  */
+ tree
+ gfc_trans_label_assign (gfc_code * code)
+ {
+   tree label_tree;
+   gfc_se se;
+   tree len;
+   tree addr;
+   tree len_tree;
+   char *label_str;
+   int label_len;
+ 
+   /* Start a new block.  */
+   gfc_init_se (&se, NULL);
+   gfc_start_block (&se.pre);
+   gfc_conv_expr (&se, code->expr);
+   len = GFC_DECL_STRING_LENGTH (se.expr);
+   addr = GFC_DECL_ASSIGN_ADDR (se.expr);
+ 
+   label_tree = gfc_get_label_decl (code->label);
+ 
+   if (code->label->defined == ST_LABEL_TARGET)
+     {
+       label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
+       len_tree = integer_minus_one_node;
+     }
+   else
+     {
+       label_str = code->label->format->value.character.string;
+       label_len = code->label->format->value.character.length;
+       len_tree = build_int_2 (label_len, 0);
+       label_tree = gfc_build_string_const (label_len + 1, label_str);
+       label_tree = gfc_build_addr_expr (pchar_type_node, label_tree);
+     }
+ 
+   if (GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (addr)))
+       < GET_MODE_SIZE (TYPE_MODE (TREE_TYPE (label_tree))))
+     gfc_error ("The size of variable assigned is too small");
+ 
+   gfc_add_modify_expr (&se.pre, len, len_tree);
+   gfc_add_modify_expr (&se.pre, addr, label_tree);
  
!   return gfc_finish_block (&se.pre);
! }
! 
! /* Translate a GOTO statement.  */
  
  tree
  gfc_trans_goto (gfc_code * code)
  {
!   tree assigned_goto;
!   tree tmp;
!   tree error;
!   gfc_se se;
! 
! 
!   if (code->label != NULL)
!     return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
! 
!   /* ASSIGNED GOTO.  */
!   /* Start a new block.  */
!   gfc_init_se (&se, NULL);
!   gfc_start_block (&se.pre);
!   gfc_conv_expr (&se, code->expr);
!   error = gfc_build_string_const (37, "Assigned label is not a target label");
!   tmp = GFC_DECL_STRING_LENGTH (se.expr);
!   tmp = build (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
!   gfc_trans_runtime_check (tmp, error, &se.pre);
! 
!   assigned_goto = build1 (GOTO_EXPR, void_type_node, GFC_DECL_ASSIGN_ADDR (se.expr));
!   gfc_add_expr_to_block (&se.pre, assigned_goto);
! 
!   return gfc_finish_block (&se.pre);
!  
  }
  
  
diff -c3p /home/wf/treessa/fortran/trans-stmt.h fortran/trans-stmt.h
*** /home/wf/treessa/fortran/trans-stmt.h	Tue Dec  9 09:11:34 2003
--- fortran/trans-stmt.h	Tue Dec  9 09:12:36 2003
*************** tree gfc_trans_pointer_assign (gfc_code 
*** 32,37 ****
--- 32,38 ----
  /* trans-stmt.c */
  tree gfc_trans_cycle (gfc_code *);
  tree gfc_trans_exit (gfc_code *);
+ tree gfc_trans_label_assign (gfc_code *);
  tree gfc_trans_label_here (gfc_code *);
  tree gfc_trans_goto (gfc_code *);
  tree gfc_trans_pause (gfc_code *);
diff -c3p /home/wf/treessa/fortran/trans.c fortran/trans.c
*** /home/wf/treessa/fortran/trans.c	Tue Dec  9 09:11:34 2003
--- fortran/trans.c	Tue Dec  9 09:12:36 2003
*************** gfc_trans_code (gfc_code * code)
*** 464,469 ****
--- 464,473 ----
  	  res = gfc_trans_assign (code);
  	  break;
  
+         case EXEC_LABEL_ASSIGN:
+           res = gfc_trans_label_assign (code);
+           break;
+ 
  	case EXEC_POINTER_ASSIGN:
  	  res = gfc_trans_pointer_assign (code);
  	  break;
diff -c3p /home/wf/treessa/fortran/trans.h fortran/trans.h
*** /home/wf/treessa/fortran/trans.h	Tue Dec  9 09:11:34 2003
--- fortran/trans.h	Tue Dec  9 09:12:36 2003
*************** struct lang_type		GTY(())
*** 484,502 ****
    tree dataptr_type;
  };
  
- /* String nodes only.  */
  struct lang_decl		GTY(())
  {
    tree stringlength;
    tree saved_descriptor;
  };
  
  #define GFC_DECL_STRING_LENGTH(node) (DECL_LANG_SPECIFIC(node)->stringlength)
  #define GFC_DECL_SAVED_DESCRIPTOR(node) \
    (DECL_LANG_SPECIFIC(node)->saved_descriptor)
  #define GFC_DECL_STRING(node) DECL_LANG_FLAG_0(node)
  #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
  #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_2(node)
  
  #define GFC_KNOWN_SIZE_STRING_TYPE(node) TYPE_LANG_FLAG_0(node)
  /* An array descriptor.  */
--- 484,510 ----
    tree dataptr_type;
  };
  
  struct lang_decl		GTY(())
  {
+   /* String nodes.  */
    tree stringlength;
    tree saved_descriptor;
+   /* Assigned integer nodes.  Stringlength is the IO format string's length.
+      Addr is the address of the string or the target label. Stringlength is
+      initialized to -2 and assiged to -1 when addr is assigned to the
+      address of target label.  */
+   tree addr;
  };
  
+ 
+ #define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
  #define GFC_DECL_STRING_LENGTH(node) (DECL_LANG_SPECIFIC(node)->stringlength)
  #define GFC_DECL_SAVED_DESCRIPTOR(node) \
    (DECL_LANG_SPECIFIC(node)->saved_descriptor)
  #define GFC_DECL_STRING(node) DECL_LANG_FLAG_0(node)
  #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_1(node)
  #define GFC_DECL_PARTIAL_PACKED_ARRAY(node) DECL_LANG_FLAG_2(node)
+ #define GFC_DECL_ASSIGN(node) DECL_LANG_FLAG_3(node)
  
  #define GFC_KNOWN_SIZE_STRING_TYPE(node) TYPE_LANG_FLAG_0(node)
  /* An array descriptor.  */
      ! Program to test ASSIGN statement
      Program assign_test
      implicit none
      integer r,ass
      r = 1
      if (r .ne. ass (r)) call abort
      r = 2 
      if (r .ne. ass (r)) call abort
      r = 3
      if (r .ne. ass (r)) call abort
      end

      integer function ass (i)
      implicit none
      integer i, label
      if (i .eq. 1) assign 1 to label
      if (i .eq. 2) assign 2 to label
      if (i .eq. 3) assign 3 to label
      go to label
   1  ass = 1
      go to 4
   2  ass = 2
      go to 4
   3  ass = 3
   4  continue
      end

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]