This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
Re: [fortran,patch] Full implementation of assign, assigned goto.
- From: Feng Wang <wf_cs at yahoo dot com>
- To: Steven Bosscher <s dot bosscher at student dot tudelft dot nl>, fortran <fortran at gcc dot gnu dot org>, patch <gcc-patches at gcc dot gnu dot org>
- Date: Sun, 28 Dec 2003 16:39:26 +0800 (CST)
- Subject: Re: [fortran,patch] Full implementation of assign, assigned goto.
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)
*** 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;
Only in gcc/gcc/fortran/: trans.c.orig
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. */