diff options
Diffstat (limited to 'gcc/fortran/trans.c')
| -rw-r--r-- | gcc/fortran/trans.c | 40 |
1 files changed, 23 insertions, 17 deletions
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6365213..70f06ff 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1,6 +1,6 @@ /* Code translation -- generate GCC trees from gfc_code. - Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2012 - Free Software Foundation, Inc. + Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, + 2012 Free Software Foundation, Inc. Contributed by Paul Brook This file is part of GCC. @@ -87,7 +87,7 @@ tree gfc_create_var_np (tree type, const char *prefix) { tree t; - + t = create_tmp_var_raw (type, prefix); /* No warnings for anonymous variables. */ @@ -139,7 +139,7 @@ gfc_evaluate_now (tree expr, stmtblock_t * pblock) } -/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. +/* Build a MODIFY_EXPR node and add it to a given statement block PBLOCK. A MODIFY_EXPR is an assignment: LHS <- RHS. */ @@ -428,7 +428,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid, arg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); free (message); - + asprintf (&message, "%s", _(msgid)); arg2 = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const (message)); @@ -440,7 +440,7 @@ trans_runtime_error_vararg (bool error, locus* where, const char* msgid, argarray[1] = arg2; for (i = 0; i < nargs; i++) argarray[2 + i] = va_arg (ap, tree); - + /* Build the function call to runtime_(warning,error)_at; because of the variable number of arguments, we can't use build_call_expr_loc dinput_location, irectly. */ @@ -591,14 +591,14 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) /* Allocate memory, using an optional status argument. - + This function follows the following pseudo-code: void * allocate (size_t size, integer_type stat) { void *newmem; - + if (stat requested) stat = 0; @@ -661,7 +661,7 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, /* Allocate memory, using an optional status argument. - + This function follows the following pseudo-code: void * @@ -717,9 +717,9 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, /* Generate code for an ALLOCATE statement when the argument is an allocatable variable. If the variable is currently allocated, it is an error to allocate it again. - + This function follows the following pseudo-code: - + void * allocate_allocatable (void *mem, size_t size, integer_type stat) { @@ -733,7 +733,7 @@ gfc_allocate_using_lib (stmtblock_t * block, tree pointer, tree size, runtime_error ("Attempting to allocate already allocated variable"); } } - + expr must be set to the original expression being allocated for its locus and variable name in case a runtime error has to be printed. */ void @@ -866,7 +866,7 @@ gfc_call_free (tree var) even when no status variable is passed to us (this is used for unconditional deallocation generated by the front-end at end of each procedure). - + If a runtime-message is possible, `expr' must point to the original expression being deallocated for its locus and variable name. @@ -1075,7 +1075,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, /* When POINTER is not NULL, we free it. */ gfc_start_block (&non_null); - + /* Free allocatable components. */ if (ts.type == BT_DERIVED && ts.u.derived->attr.alloc_comp) { @@ -1091,7 +1091,7 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, bool can_fail, tmp, 0); gfc_add_expr_to_block (&non_null, tmp); } - + tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); @@ -1320,6 +1320,12 @@ trans_code (gfc_code * code, tree cond) case EXEC_POINTER_ASSIGN: if (code->expr1->ts.type == BT_CLASS) res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); + else if (UNLIMITED_POLY (code->expr2) + && code->expr1->ts.type == BT_DERIVED + && (code->expr1->ts.u.derived->attr.sequence + || code->expr1->ts.u.derived->attr.is_bind_c)) + /* F2003: C717 */ + res = gfc_trans_class_assign (code->expr1, code->expr2, code->op); else res = gfc_trans_pointer_assign (code); break; @@ -1544,7 +1550,7 @@ trans_code (gfc_code * code, tree cond) { if (TREE_CODE (res) != STATEMENT_LIST) SET_EXPR_LOCATION (res, input_location); - + /* Add the new statement to the block. */ gfc_add_expr_to_block (&block, res); } @@ -1686,7 +1692,7 @@ gfc_finish_wrapped_block (gfc_wrapped_block* block) if (block->cleanup) result = build2_loc (input_location, TRY_FINALLY_EXPR, void_type_node, result, block->cleanup); - + /* Clear the block. */ block->init = NULL_TREE; block->code = NULL_TREE; |