This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC 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]

Re: [fortran,patch] Full implementation of assign, assigned goto.


  Sorry for my carelessness. The last patch included three "Only in ..." and I
forgot to block the else branch in gfc_show_code_node dumping goto label list.
The patch attached is the newest. Pass the test in ia64-linux.
  More haste, less speed :-) In my Chinese that is "Yu su ze bu da".

  Best regards,
  Feng Wang

 --- Feng Wang <wf_cs@yahoo.com> 的正文:>   The new patch correctes the error
you pointed.
> 
>  --- Steven Bosscher <s.bosscher@student.tudelft.nl> 的正文:> On Friday 26
> December 2003 14:11, Feng Wang wrote:
> > > Hi, all
> > >   This patch implemented assign, assigned goto and related i/o
> statements,
> > > including assigned goto with a label list.
> > >   Steven, can you help me check them again? If it is Ok, please apply
> them.
> > > Thanks.
> > 
> > Sure.
> > 
> > 
> > > *************** gfc_get_symbol_decl (gfc_symbol * sym)
> > > *** 716,721 ****
> > > --- 715,732 ----
> > >
> > >     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)
> > >       {
> > 
> > I'm not quite sure I understand what you are doing here.  What is the
> > "-2" required for, you don't seem to use it anywhere.  Please explain,
> > this could use some comment for the ignorant reader ;-)
> > 
>    Yep, I should explain. STRING_LENGTH is also used as flag. Less than -1
> means that ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is
> the 
> target label's address. Other value is the length of format string and
> ASSIGN_ADDR is the address of format string. So STRING_LENGTH should be
> initialized an integer less than -1. The new patch adds the comment.
> 
>   r~
>   Feng Wang
> 
> 
> __________________________________________________
> Do You Yahoo!?
> Tired of spam?  Yahoo! Mail has the best spam protection around 
> http://mail.yahoo.com > Only in gcc/gcc/fortran/: assign.diff
> Only in gcc/gcc/fortran/: assign2.diff
> diff -c3p original/gcc/gcc/fortran/dump-parse-tree.c
> gcc/gcc/fortran/dump-parse-tree.c
> *** original/gcc/gcc/fortran/dump-parse-tree.c	Fri Aug  1 16:26:48 2003
> --- gcc/gcc/fortran/dump-parse-tree.c	Sun Dec 28 15:48:17 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,825 ----
>         break;
>   
>       case EXEC_GOTO:
> !       gfc_status ("GOTO ");
> !       if (c->label)
> !         gfc_status ("%d", c->label->value);
> !       else
> !         gfc_show_expr (c->expr);
> !         d = c->block;
> !         if (d != NULL)
> !           {
> !             gfc_status (", (");
> !             for (; d; d = d ->block)
> !               {
> !                 code_indent (level, d->label);
> !                 if (d->block != NULL)
> !                   gfc_status_char (',');
> !                 else
> !                   gfc_status_char (')');
> !               }
> !           }
>         break;
>   
>       case EXEC_CALL:
> diff -c3p original/gcc/gcc/fortran/gfortran.h gcc/gcc/fortran/gfortran.h
> *** original/gcc/gcc/fortran/gfortran.h	Fri Dec  5 02:29:27 2003
> --- gcc/gcc/fortran/gfortran.h	Fri Dec 26 20:29:33 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,1120 ****
>   /* 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,
>     EXEC_ALLOCATE, EXEC_DEALLOCATE,
> --- 1112,1119 ----
>   /* 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,
>     EXEC_ALLOCATE, EXEC_DEALLOCATE,
> diff -c3p original/gcc/gcc/fortran/intrinsic.c gcc/gcc/fortran/intrinsic.c
> *** original/gcc/gcc/fortran/intrinsic.c	Sat Oct 11 15:00:22 2003
> --- gcc/gcc/fortran/intrinsic.c	Sun Dec 28 14:13:28 2003
> *************** gfc_type_letter (bt type)
> *** 69,75 ****
>         c = 'l';
>         break;
>       case BT_CHARACTER:
> !       c = 'c';
>         break;
>       case BT_INTEGER:
>         c = 'i';
> --- 69,75 ----
>         c = 'l';
>         break;
>       case BT_CHARACTER:
> !       c = 's';
>         break;
>       case BT_INTEGER:
>         c = 'i';
> *************** gfc_type_letter (bt type)
> *** 78,84 ****
>         c = 'r';
>         break;
>       case BT_COMPLEX:
> !       c = 'z';
>         break;
>   
>       default:
> --- 78,84 ----
>         c = 'r';
>         break;
>       case BT_COMPLEX:
> !       c = 'c';
>         break;
>   
>       default:
> diff -c3p original/gcc/gcc/fortran/io.c gcc/gcc/fortran/io.c
> *** original/gcc/gcc/fortran/io.c	Mon Dec  1 15:23:57 2003
> --- gcc/gcc/fortran/io.c	Fri Dec 26 20:29:33 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 label can be integer varibale.  */
> !       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 original/gcc/gcc/fortran/match.c gcc/gcc/fortran/match.c
> *** original/gcc/gcc/fortran/match.c	Fri Nov 28 08:15:45 2003
> --- gcc/gcc/fortran/match.c	Fri Dec 26 20:29:33 2003
> *************** gfc_match_if (gfc_statement * if_type)
> 
=== message truncated === 

__________________________________________________
Do You Yahoo!?
Tired of spam?  Yahoo! Mail has the best spam protection around 
http://mail.yahoo.com 
diff -c3p original/gcc/gcc/fortran/dump-parse-tree.c gcc/gcc/fortran/dump-parse-tree.c
*** original/gcc/gcc/fortran/dump-parse-tree.c	Fri Aug  1 16:26:48 2003
--- gcc/gcc/fortran/dump-parse-tree.c	Mon Dec 29 11:08:24 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,827 ----
        break;
  
      case EXEC_GOTO:
!       gfc_status ("GOTO ");
!       if (c->label)
!         gfc_status ("%d", c->label->value);
!       else
!         {
!           gfc_show_expr (c->expr);
!           d = c->block;
!           if (d != NULL)
!             {
!               gfc_status (", (");
!               for (; d; d = d ->block)
!                 {
!                   code_indent (level, d->label);
!                   if (d->block != NULL)
!                     gfc_status_char (',');
!                   else
!                     gfc_status_char (')');
!                 }
!             }
!         }
        break;
  
      case EXEC_CALL:
diff -c3p original/gcc/gcc/fortran/gfortran.h gcc/gcc/fortran/gfortran.h
*** original/gcc/gcc/fortran/gfortran.h	Fri Dec  5 02:29:27 2003
--- gcc/gcc/fortran/gfortran.h	Fri Dec 26 20:29:33 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,1120 ****
  /* 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,
    EXEC_ALLOCATE, EXEC_DEALLOCATE,
--- 1112,1119 ----
  /* 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,
    EXEC_ALLOCATE, EXEC_DEALLOCATE,
diff -c3p original/gcc/gcc/fortran/intrinsic.c gcc/gcc/fortran/intrinsic.c
*** original/gcc/gcc/fortran/intrinsic.c	Sat Oct 11 15:00:22 2003
--- gcc/gcc/fortran/intrinsic.c	Sun Dec 28 14:13:28 2003
*************** gfc_type_letter (bt type)
*** 69,75 ****
        c = 'l';
        break;
      case BT_CHARACTER:
!       c = 'c';
        break;
      case BT_INTEGER:
        c = 'i';
--- 69,75 ----
        c = 'l';
        break;
      case BT_CHARACTER:
!       c = 's';
        break;
      case BT_INTEGER:
        c = 'i';
*************** gfc_type_letter (bt type)
*** 78,84 ****
        c = 'r';
        break;
      case BT_COMPLEX:
!       c = 'z';
        break;
  
      default:
--- 78,84 ----
        c = 'r';
        break;
      case BT_COMPLEX:
!       c = 'c';
        break;
  
      default:
diff -c3p original/gcc/gcc/fortran/io.c gcc/gcc/fortran/io.c
*** original/gcc/gcc/fortran/io.c	Mon Dec  1 15:23:57 2003
--- gcc/gcc/fortran/io.c	Fri Dec 26 20:29:33 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 label can be integer varibale.  */
!       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 original/gcc/gcc/fortran/match.c gcc/gcc/fortran/match.c
*** original/gcc/gcc/fortran/match.c	Fri Nov 28 08:15:45 2003
--- gcc/gcc/fortran/match.c	Fri Dec 26 20:29:33 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)
*** 1472,1484 ****
    gfc_expr *expr;
    gfc_st_label *label;
  
!   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;
  }
  
--- 1472,1491 ----
    gfc_expr *expr;
    gfc_st_label *label;
  
!   if (gfc_match (" %l", &label) == MATCH_YES)
      {
!       if (gfc_reference_st_label (label, ST_LABEL_UNKNOWN) == FAILURE)
!         return MATCH_ERROR;
!       if (gfc_match (" to %v%t", &expr) == MATCH_YES)
!         {
!           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;
  }
  
*************** 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.  */
--- 1515,1572 ----
        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;
! 
!       if (gfc_match_eos () == MATCH_YES)
!         return MATCH_YES;
! 
!       /* Match label list.  */
!       gfc_match_char (',');
!       if (gfc_match_char ('(') != MATCH_YES)
!         {
!           gfc_syntax_error (ST_GOTO);
!           return MATCH_ERROR;
!         }
!       head = tail = NULL;
! 
!       do
!         {
!           m = gfc_match_st_label (&label, 0);
!           if (m != MATCH_YES)
!             goto syntax;
! 
!           if (gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
!             goto cleanup;
! 
!           if (head == NULL)
!             head = tail = gfc_get_code ();
!           else
! 	    {
!               tail->block = gfc_get_code ();
!               tail = tail->block;
!             }
! 
!           tail->label = label;
!           tail->op = EXEC_GOTO;
!         }
!       while (gfc_match_char (',') == MATCH_YES);
! 
!       if (gfc_match (")%t") != MATCH_YES)
!         goto syntax;
! 
!       if (head == NULL)
!         {
!            gfc_error ("Statement label list in GOTO at %C cannot be empty");
!            goto syntax;
!         }
!       new_st.block = head;
!       return MATCH_YES;
      }
  
    /* Last chance is a computed GO TO statement.  */
diff -c3p original/gcc/gcc/fortran/parse.c gcc/gcc/fortran/parse.c
*** original/gcc/gcc/fortran/parse.c	Fri Aug  1 16:26:48 2003
--- gcc/gcc/fortran/parse.c	Fri Dec 26 16:19:52 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 original/gcc/gcc/fortran/resolve.c gcc/gcc/fortran/resolve.c
*** original/gcc/gcc/fortran/resolve.c	Fri Nov 28 08:15:45 2003
--- gcc/gcc/fortran/resolve.c	Fri Dec 26 20:29:33 2003
*************** gfc_resolve_forall (gfc_code *code, gfc_
*** 3364,3371 ****
  }
  
  
! /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL and DO code
!    nodes.  */
  
  static void resolve_code (gfc_code *, gfc_namespace *);
  
--- 3364,3371 ----
  }
  
  
! /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL ,GOTO and
!    DO code nodes.  */
  
  static void resolve_code (gfc_code *, gfc_namespace *);
  
*************** resolve_blocks (gfc_code * b, gfc_namesp
*** 3400,3405 ****
--- 3400,3409 ----
  	       &b->expr->where);
  	  break;
  
+         case EXEC_GOTO:
+           resolve_branch (b->label, b);
+           break;
+ 
  	case EXEC_SELECT:
  	case EXEC_FORALL:
  	case EXEC_DO:
*************** resolve_code (gfc_code * code, gfc_names
*** 3468,3474 ****
  	  break;
  
  	case EXEC_GOTO:
! 	  resolve_branch (code->label, code);
  	  break;
  
  	case EXEC_RETURN:
--- 3472,3482 ----
  	  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 ****
--- 3516,3530 ----
  	  gfc_check_assign (code->expr, code->expr2, 1);
  	  break;
  
+ 	case EXEC_LABEL_ASSIGN:
+           if (code->label->defined == ST_LABEL_UNKNOWN)
+             gfc_error ("Label %d referenced at %L is never defined",
+                        code->label->value, &code->label->where);
+           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 original/gcc/gcc/fortran/st.c gcc/gcc/fortran/st.c
*** original/gcc/gcc/fortran/st.c	Sat Jul 26 08:27:46 2003
--- gcc/gcc/fortran/st.c	Fri Dec 26 16:19:52 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 original/gcc/gcc/fortran/trans-decl.c gcc/gcc/fortran/trans-decl.c
*** original/gcc/gcc/fortran/trans-decl.c	Fri Dec  5 02:29:26 2003
--- gcc/gcc/fortran/trans-decl.c	Sun Dec 28 16:07:39 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,736 ----
  
    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;
+       /*  STRING_LENGTH is also used as flag. Less than -1 means that
+           ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
+           target label's address. Other value is the length of format string
+           and ASSIGN_ADDR is the address of format string.  */
+       DECL_INITIAL (GFC_DECL_STRING_LENGTH (decl)) =
+         build_int_2 (-2, -1);
+     }
+ 
    /* TODO: Initialization of pointer variables.  */
    switch (sym->ts.type)
      {
diff -c3p original/gcc/gcc/fortran/trans-io.c gcc/gcc/fortran/trans-io.c
*** original/gcc/gcc/fortran/trans-io.c	Fri Dec  5 01:16:09 2003
--- gcc/gcc/fortran/trans-io.c	Sun Dec 28 16:13:35 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,415 ----
  {
    gfc_se se;
    tree tmp;
+   tree msg;
+   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)
!     {
!       msg =
!         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, msg, &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 original/gcc/gcc/fortran/trans-stmt.c gcc/gcc/fortran/trans-stmt.c
*** original/gcc/gcc/fortran/trans-stmt.c	Fri Dec  5 01:16:09 2003
--- gcc/gcc/fortran/trans-stmt.c	Fri Dec 26 20:29:33 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,181 ----
    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);
+     }
+ 
+   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 target;
!   tree tmp;
!   tree assign_error;
!   tree range_error;
!   gfc_se se;
! 
! 
!   if (code->label != NULL)
!     return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
! 
!   /* ASSIGNED GOTO.  */
!   gfc_init_se (&se, NULL);
!   gfc_start_block (&se.pre);
!   gfc_conv_expr (&se, code->expr);
!   assign_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, assign_error, &se.pre);
! 
!   assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
!   target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
! 
!   code = code->block;
!   if (code == NULL)
!     {
!       gfc_add_expr_to_block (&se.pre, target);
!       return gfc_finish_block (&se.pre);
!     }
! 
!   /* Check the label list.  */
!   range_error =
!     gfc_build_string_const (34, "Assigned label is not in the list");
! 
!   do
!     {
!       tmp = gfc_get_label_decl (code->label);
!       tmp = gfc_build_addr_expr (pvoid_type_node, tmp);
!       tmp = build (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
!       tmp = build_v (COND_EXPR, tmp, target, build_empty_stmt ());
!       gfc_add_expr_to_block (&se.pre, tmp);
!       code = code->block;
!     }
!   while (code != NULL);
!   gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
!   return gfc_finish_block (&se.pre); 
  }
  
  
diff -c3p original/gcc/gcc/fortran/trans-stmt.h gcc/gcc/fortran/trans-stmt.h
*** original/gcc/gcc/fortran/trans-stmt.h	Sat Jul 26 08:27:46 2003
--- gcc/gcc/fortran/trans-stmt.h	Fri Dec 26 16:19:52 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 original/gcc/gcc/fortran/trans.c gcc/gcc/fortran/trans.c
*** original/gcc/gcc/fortran/trans.c	Fri Dec 19 16:15:13 2003
--- gcc/gcc/fortran/trans.c	Fri Dec 26 16:19:52 2003
*************** gfc_trans_code (gfc_code * code)
*** 465,470 ****
--- 465,474 ----
  	  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 original/gcc/gcc/fortran/trans.h gcc/gcc/fortran/trans.h
*** original/gcc/gcc/fortran/trans.h	Fri Dec  5 02:29:27 2003
--- gcc/gcc/fortran/trans.h	Fri Dec 26 16:19:52 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.  */

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