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] | |
The attached patch is a reworking of how character variables are handled. There are still a few bits missing, but most things (including arrays) should now work. Tested on i686-linux. Applied to tree-ssa branch. Paul 2003-04-04 Paul Brook <paul@codesourcery.com> PR 13252 PR 14081 * f95-lang.c (gfc_init_builtin_functions): Add stack_alloc, stack_save and stack_restore. * gfortran.h (struct gfc_charlen): Add backend_decl. * trans-array.c (gfc_trans_allocate_temp_array, gfc_conv_temp_array_ref, gfc_conv_resolve_dependencies, (gfc_conv_loop_setup, gfc_array_allocate, gfc_conv_array_init_size): Remove old, broken string handling. (gfc_trans_auto_array_allocation, gfc_trans_g77_array, gfc_trans_dummy_array_bias, gfc_conv_expr_descriptor, gfc_trans_deferred_array): Handle character arrays. * trans-const.c (gfc_conv_const_charlen): New function. * trans-const.h (gfc_conv_const_charlen): Add prototype. * trans-decl.c (gfc_finish_var_decl): Don't mark automatic variables as static. (gfc_build_dummy_array_decl): Handle arrays with unknown element size. (gfc_create_string_length): New function. (gfc_get_symbol_decl): Create lengths for character variables. (gfc_get_fake_result_decl): Ditto. (gfc_build_function_decl): Only set length for assumed length character arguments. (gfc_trans_dummy_character): New function. (gfc_trans_auto_character_variable): Rewrite. (gfc_trans_deferred_vars): Handle more types of character variable. (gfc_create_module_variable): String lengths have moved. (gfc_generate_function_code): Initialize deferred var chain earlier. * trans-expr.c (gfc_conv_init_string_length): Rename ... (gfc_trans_init_string_length): ... to this. (gfc_conv_component_ref, gfc_conv_variable, gfc_conv_concat_op, gfc_conv_function_call): Update to new format for character variables. (gfc_conv_string_length): Remove. (gfc_conv_string_parameter): Update assertion. * trans-intrinsic.c (gfc_conv_intrinsic_len): Use new location. * trans-io.c (set_string): Use new macro names. * trans-stmt.c (gfc_trans_label_assign. gfc_trans_goto): Ditto. * trans-types.c (gfc_get_character_type): Use existing length expr. (gfc_is_nodesc_array): Make public. (gfc_get_dtype_cst): Rename ... (gfc_get_dtype): ... to this. Handle unknown size arrays. (gfc_get_nodesc_array_type): Use new name. (gfc_sym_type): New character variable code. (gfc_get_derived_type): Ditto. (gfc_get_function_type): Evaluate character variable lengths. * trans-types.h (gfc_strlen_kind): Define. (gfc_is_nodesc_array): Add prototype. * trans.h: Update prototypes. (struct lang_type): Update comments. (GFC_DECL_STRING_LEN): New name for GFC_DECL_STRING_LENGTH. (GFC_KNOWN_SIZE_STRING_TYPE): Remove. testsuite * gfortran.fortran-torture/execute/strarray_1.f90: New test. * gfortran.fortran-torture/execute/strarray_2.f90: New test. * gfortran.fortran-torture/execute/strarray_3.f90: New test. * gfortran.fortran-torture/execute/strarray_4.f90: New test. * gfortran.fortran-torture/execute/strcommon_1.f90: New test.
Index: f95-lang.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/f95-lang.c,v
retrieving revision 1.1.2.18
diff -u -p -r1.1.2.18 f95-lang.c
--- a/f95-lang.c 16 Feb 2004 12:36:08 -0000 1.1.2.18
+++ b/f95-lang.c 4 Apr 2004 15:39:12 -0000
@@ -826,6 +826,22 @@ gfc_init_builtin_functions (void)
ftype = build_function_type (pvoid_type_node, tmp);
gfc_define_builtin ("__builtin_adjust_trampoline", ftype,
BUILT_IN_ADJUST_TRAMPOLINE, "adjust_trampoline", true);
+
+ tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
+ tmp = tree_cons (NULL_TREE, size_type_node, voidchain);
+ ftype = build_function_type (pvoid_type_node, tmp);
+ gfc_define_builtin ("__builtin_stack_alloc", ftype, BUILT_IN_STACK_ALLOC,
+ "stack_alloc", false);
+
+ /* The stack_save and stack_restore builtins aren't used directly. They
+ are inserted during gimplification to implement stack_alloc calls. */
+ ftype = build_function_type (pvoid_type_node, voidchain);
+ gfc_define_builtin ("__builtin_stack_save", ftype, BUILT_IN_STACK_SAVE,
+ "stack_save", false);
+ tmp = tree_cons (NULL_TREE, pvoid_type_node, voidchain);
+ ftype = build_function_type (void_type_node, tmp);
+ gfc_define_builtin ("__builtin_stack_restore", ftype, BUILT_IN_STACK_RESTORE,
+ "stack_restore", false);
}
#undef DEFINE_MATH_BUILTIN
Index: gfortran.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/gfortran.h,v
retrieving revision 1.1.2.11
diff -u -p -r1.1.2.11 gfortran.h
--- a/gfortran.h 4 Apr 2004 15:33:41 -0000 1.1.2.11
+++ b/gfortran.h 4 Apr 2004 15:39:12 -0000
@@ -480,6 +480,7 @@ typedef struct gfc_charlen
{
struct gfc_expr *length;
struct gfc_charlen *next;
+ tree backend_decl;
}
gfc_charlen;
Index: trans-array.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-array.c,v
retrieving revision 1.1.2.18
diff -u -p -r1.1.2.18 trans-array.c
--- a/trans-array.c 4 Apr 2004 11:50:00 -0000 1.1.2.18
+++ b/trans-array.c 4 Apr 2004 21:34:24 -0000
@@ -530,11 +530,7 @@ gfc_trans_allocate_temp_array (gfc_loopi
desc = gfc_create_var (type, "atmp");
GFC_DECL_PACKED_ARRAY (desc) = 1;
if (string_length)
- {
- gfc_allocate_lang_decl (desc);
- GFC_DECL_STRING (desc) = 1;
- GFC_DECL_STRING_LENGTH (desc) = string_length;
- }
+ GFC_DECL_STRING (desc) = 1;
info->descriptor = desc;
size = integer_one_node;
@@ -572,8 +568,9 @@ gfc_trans_allocate_temp_array (gfc_loopi
size = gfc_evaluate_now (size, &loop->pre);
}
+ /* TODO: Where does the string length go? */
if (string_length)
- gfc_todo_error ("Arrays of strings");
+ gfc_todo_error ("temporary arrays of strings");
/* Get the size of the array. */
nelem = size;
@@ -1442,8 +1439,9 @@ gfc_conv_tmp_array_ref (gfc_se * se)
tree desc;
desc = se->ss->data.info.descriptor;
+ /* TODO: We need the string length. */
if (GFC_DECL_STRING (desc))
- se->string_length = GFC_DECL_STRING_LENGTH (desc);
+ gfc_todo_error ("temporary arrays of strings");
gfc_conv_scalarized_array_ref (se, NULL);
}
@@ -2183,8 +2181,7 @@ gfc_conv_resolve_dependencies (gfc_loopi
loop->temp_ss->type = GFC_SS_TEMP;
loop->temp_ss->data.temp.type =
gfc_get_element_type (TREE_TYPE (dest->data.info.descriptor));
- loop->temp_ss->data.temp.string_length =
- gfc_conv_string_length (dest->data.info.descriptor);
+ loop->temp_ss->data.temp.string_length = NULL_TREE;
loop->temp_ss->data.temp.dimen = loop->dimen;
loop->temp_ss->next = gfc_ss_terminator;
gfc_add_ss_to_loop (loop, loop->temp_ss);
@@ -2429,14 +2426,13 @@ gfc_conv_loop_setup (gfc_loopinfo * loop
static tree
gfc_array_init_size (tree descriptor, int rank, tree * poffset,
gfc_expr ** lower, gfc_expr ** upper,
- stmtblock_t * pblock, tree * pstring)
+ stmtblock_t * pblock)
{
tree type;
tree tmp;
tree size;
tree offset;
tree stride;
- tree string_len;
gfc_expr *ubound;
gfc_se se;
int n;
@@ -2509,23 +2505,11 @@ gfc_array_init_size (tree descriptor, in
stride = gfc_evaluate_now (stride, pblock);
}
- if (pstring && *pstring)
- {
- string_len = *pstring;
- string_len = fold (build (MULT_EXPR, gfc_array_index_type, stride,
- string_len));
- }
- else
- string_len = NULL_TREE;
-
/* The stride is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold (build (MULT_EXPR, gfc_array_index_type, stride, tmp));
- if (string_len)
- size = fold (build (PLUS_EXPR, gfc_array_index_type, size, string_len));
-
if (poffset != NULL)
{
offset = gfc_evaluate_now (offset, pblock);
@@ -2549,7 +2533,6 @@ gfc_array_allocate (gfc_se * se, gfc_ref
tree allocate;
tree offset;
tree size;
- tree len;
gfc_expr **lower;
gfc_expr **upper;
@@ -2578,9 +2561,8 @@ gfc_array_allocate (gfc_se * se, gfc_ref
break;
}
- len = se->string_length;
size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, &offset,
- lower, upper, &se->pre, &len);
+ lower, upper, &se->pre);
/* Allocate memory to store the data. */
tmp = gfc_conv_descriptor_data (se->expr);
@@ -2604,12 +2586,6 @@ gfc_array_allocate (gfc_se * se, gfc_ref
tmp = gfc_conv_descriptor_offset (se->expr);
gfc_add_modify_expr (&se->pre, tmp, offset);
-
- /* Initialize the pointers for a character array. */
- if (len)
- {
- gfc_todo_error ("arrays of strings");
- }
}
@@ -2845,37 +2821,74 @@ gfc_trans_auto_array_allocation (tree de
tree fndecl;
tree size;
tree offset;
+ tree args;
+ bool onstack;
assert (!(sym->attr.pointer || sym->attr.allocatable));
- if (sym->ts.type == BT_CHARACTER)
- gfc_todo_error ("arrays of strings");
+ /* Do nothing for USEd variables. */
+ if (sym->attr.use_assoc)
+ return fnbody;
type = TREE_TYPE (decl);
assert (GFC_ARRAY_TYPE_P (type));
- if (TREE_CODE (type) != POINTER_TYPE)
+ onstack = TREE_CODE (type) != POINTER_TYPE;
+
+ /* We never generate initialization code of module variables. */
+ if (fnbody == NULL_TREE)
{
- /* TODO: Put large arrays on the heap. */
- if (sym->value && !sym->attr.use_assoc)
+ assert (onstack);
+
+ /* Generate static initializer. */
+ if (sym->value)
{
DECL_INITIAL (decl) =
gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
}
-
return fnbody;
}
- /* Module variables are always static because there's nowhere to put the
- initialization code. */
- assert (fnbody != NULL_TREE);
-
+ gfc_start_block (&block);
+
+ /* Evaluate character string length. */
+ if (sym->ts.type == BT_CHARACTER
+ && onstack && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ {
+ gfc_trans_init_string_length (sym->ts.cl, &block);
+
+ DECL_DEFER_OUTPUT (decl) = 1;
+
+ /* Generate code to allocate the automatic variable. It will be
+ freed automatically. */
+ tmp = gfc_build_addr_expr (NULL, decl);
+ args = gfc_chainon_list (NULL_TREE, tmp);
+ args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
+ tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC],
+ args);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ if (onstack)
+ {
+ if (sym->value)
+ {
+ DECL_INITIAL (decl) =
+ gfc_conv_array_initializer (TREE_TYPE (decl), sym->value);
+ }
+
+ gfc_add_expr_to_block (&block, fnbody);
+ return gfc_finish_block (&block);
+ }
+
type = TREE_TYPE (type);
assert (!sym->attr.use_assoc);
assert (!TREE_STATIC (decl));
assert (!sym->module[0]);
- gfc_start_block (&block);
+ if (sym->ts.type == BT_CHARACTER
+ && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ gfc_trans_init_string_length (sym->ts.cl, &block);
size = gfc_trans_array_bounds (type, sym, &offset, &block);
@@ -2898,7 +2911,7 @@ gfc_trans_auto_array_allocation (tree de
gfc_add_modify_expr (&block, decl, tmp);
/* Set offset of the array. */
- if (!INTEGER_CST_P (GFC_TYPE_ARRAY_OFFSET (type)))
+ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
@@ -2939,13 +2952,23 @@ gfc_trans_g77_array (gfc_symbol * sym, t
gfc_start_block (&block);
+ if (sym->ts.type == BT_CHARACTER
+ && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ gfc_trans_init_string_length (sym->ts.cl, &block);
+
/* Evaluate the bounds of the array. */
gfc_trans_array_bounds (type, sym, &offset, &block);
/* Set the offset. */
- if (!INTEGER_CST_P (GFC_TYPE_ARRAY_OFFSET (type)))
+ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ /* Set the pointer itself if we aren't using the parameter dirtectly. */
+ if (TREE_CODE (parm) != PARM_DECL)
+ {
+ tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
+ gfc_add_modify_expr (&block, parm, tmp);
+ }
tmp = gfc_finish_block (&block);
gfc_set_backend_locus (&loc);
@@ -2995,7 +3018,7 @@ gfc_trans_dummy_array_bias (gfc_symbol *
int checkparm;
int no_repack;
- if (sym->attr.dummy && TREE_CODE (tmpdesc) == PARM_DECL)
+ if (sym->attr.dummy && gfc_is_nodesc_array (sym))
return gfc_trans_g77_array (sym, body);
gfc_get_backend_locus (&loc);
@@ -3008,6 +3031,10 @@ gfc_trans_dummy_array_bias (gfc_symbol *
dumdesc = gfc_build_indirect_ref (dumdesc);
gfc_start_block (&block);
+ if (sym->ts.type == BT_CHARACTER
+ && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ gfc_trans_init_string_length (sym->ts.cl, &block);
+
checkparm = (sym->as->type == AS_EXPLICIT && flag_bounds_check);
no_repack = !(GFC_DECL_PACKED_ARRAY (tmpdesc)
@@ -3184,7 +3211,8 @@ gfc_trans_dummy_array_bias (gfc_symbol *
}
/* Set the offset. */
- gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
+ if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
+ gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
stmt = gfc_finish_block (&block);
@@ -3265,9 +3293,6 @@ gfc_conv_expr_descriptor (gfc_se * se, g
assert (ss != gfc_ss_terminator);
- if (expr->ts.type == BT_CHARACTER)
- gfc_todo_error ("Character string array actual parameters");
-
/* TODO: Pass constant array constructors without a temporary. */
/* If we have a linear array section, we can pass it directly. Otherwise
we need to copy it into a temporary. */
@@ -3367,8 +3392,6 @@ gfc_conv_expr_descriptor (gfc_se * se, g
if (need_tmp)
{
/* Tell the scalarizer to make a temporary. */
- if (expr->ts.type == BT_CHARACTER)
- gfc_todo_error ("Passing character string expressions");
loop.temp_ss = gfc_get_ss ();
loop.temp_ss->type = GFC_SS_TEMP;
loop.temp_ss->next = gfc_ss_terminator;
@@ -3689,13 +3712,9 @@ gfc_trans_deferred_array (gfc_symbol * s
gfc_init_block (&fnblock);
assert (TREE_CODE (sym->backend_decl) == VAR_DECL);
- if (GFC_DECL_STRING (sym->backend_decl))
- {
- tmp = GFC_DECL_STRING_LENGTH (sym->backend_decl);
- if (!INTEGER_CST_P (tmp))
- gfc_conv_init_string_length (sym, &fnblock);
- }
-
+ if (sym->ts.type == BT_CHARACTER
+ && !INTEGER_CST_P (sym->ts.cl->backend_decl))
+ gfc_trans_init_string_length (sym->ts.cl, &fnblock);
/* Parameter variables don't need anything special. */
if (sym->attr.dummy)
Index: trans-common.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-common.c,v
retrieving revision 1.1.2.4
diff -u -p -r1.1.2.4 trans-common.c
--- a/trans-common.c 5 Dec 2003 10:29:26 -0000 1.1.2.4
+++ b/trans-common.c 4 Apr 2004 22:58:52 -0000
@@ -95,6 +95,7 @@ Boston, MA 02111-1307, USA. */
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
+#include "trans-const.h"
typedef struct segment_info
@@ -312,8 +313,6 @@ create_common (gfc_symbol *sym)
{
h->sym->backend_decl = build (COMPONENT_REF, TREE_TYPE (h->field),
decl, h->field);
- if (h->sym->ts.type == BT_CHARACTER)
- gfc_todo_error ("CHARACTER inside COMMON block or EQUIVALENCE list");
next_s = h->next;
gfc_free (h);
@@ -345,6 +344,8 @@ calculate_length (gfc_symbol *symbol)
int j, element_size;
mpz_t elements;
+ if (symbol->ts.type == BT_CHARACTER)
+ gfc_conv_const_charlen (symbol->ts.cl);
element_size = int_size_in_bytes (gfc_typenode_for_spec (&symbol->ts));
if (symbol->as == NULL)
return element_size;
@@ -448,6 +449,8 @@ calculate_offset (gfc_expr *s)
case AR_ELEMENT:
a = element_number (&reference->u.ar);
+ if (element_type->type == BT_CHARACTER)
+ gfc_conv_const_charlen (element_type->cl);
element_size =
int_size_in_bytes (gfc_typenode_for_spec (element_type));
offset += a * element_size;
Index: trans-const.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-const.c,v
retrieving revision 1.1.2.5
diff -u -p -r1.1.2.5 trans-const.c
--- a/trans-const.c 4 Apr 2004 11:50:00 -0000 1.1.2.5
+++ b/trans-const.c 4 Apr 2004 17:52:22 -0000
@@ -121,6 +121,22 @@ gfc_conv_string_init (tree length, gfc_e
return str;
}
+
+/* Create a tree node for the string length if it is constant. */
+
+void
+gfc_conv_const_charlen (gfc_charlen * cl)
+{
+ if (cl->backend_decl)
+ return;
+
+ if (cl->length && cl->length->expr_type == EXPR_CONSTANT)
+ {
+ cl->backend_decl = gfc_conv_mpz_to_tree (cl->length->value.integer,
+ cl->length->ts.kind);
+ }
+}
+
void
gfc_init_constants (void)
{
Index: trans-const.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-const.h,v
retrieving revision 1.1.2.3
diff -u -p -r1.1.2.3 trans-const.h
--- a/trans-const.h 4 Apr 2004 11:50:00 -0000 1.1.2.3
+++ b/trans-const.h 4 Apr 2004 17:35:40 -0000
@@ -39,6 +39,9 @@ tree gfc_build_string_const (int, const
/* Translate a string constant for a static initializer. */
tree gfc_conv_string_init (tree, gfc_expr *);
+/* Create a tree node for the string length if it is constant. */
+void gfc_conv_const_charlen (gfc_charlen *);
+
/* Initialise the nodes for constants. */
void gfc_init_constants (void);
Index: trans-decl.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-decl.c,v
retrieving revision 1.1.2.34
diff -u -p -r1.1.2.34 trans-decl.c
--- a/trans-decl.c 4 Apr 2004 11:50:00 -0000 1.1.2.34
+++ b/trans-decl.c 4 Apr 2004 22:19:38 -0000
@@ -420,6 +420,7 @@ gfc_finish_var_decl (tree decl, gfc_symb
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
+ && INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
TREE_STATIC (decl) = 1;
}
@@ -532,7 +533,9 @@ gfc_build_qualified_array (tree decl, gf
}
-/* Get a temporary decl for a dummy array parameter. */
+/* For some dummy arguments we don't use the actual argument directly.
+ Instead we create a local decl and use that. This allows us to preform
+ initialization, and construct full type information. */
static tree
gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
@@ -543,6 +546,7 @@ gfc_build_dummy_array_decl (gfc_symbol *
char *name;
int packed;
int n;
+ bool known_size;
if (sym->attr.pointer || sym->attr.allocatable)
return dummy;
@@ -553,45 +557,63 @@ gfc_build_dummy_array_decl (gfc_symbol *
type = TREE_TYPE (dummy);
assert (TREE_CODE (dummy) == PARM_DECL
- && POINTER_TYPE_P (type));
+ && POINTER_TYPE_P (type));
- if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
+ /* Do we know the element size. */
+ known_size = sym->ts.type != BT_CHARACTER
+ || INTEGER_CST_P (sym->ts.cl->backend_decl);
+
+ if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
+ /* For descriptorless arrays with known element size the actual
+ argument is sufficient. */
assert (GFC_ARRAY_TYPE_P (type));
gfc_build_qualified_array (dummy, sym);
return dummy;
}
type = TREE_TYPE (type);
-
- as = sym->as;
- packed = 0;
- if (!gfc_option.flag_repack_arrays)
+ if (GFC_DESCRIPTOR_TYPE_P (type))
{
- if (as->type == AS_ASSUMED_SIZE)
- packed = 2;
+ /* Create a decriptorless array pointer. */
+ as = sym->as;
+ packed = 0;
+ if (!gfc_option.flag_repack_arrays)
+ {
+ if (as->type == AS_ASSUMED_SIZE)
+ packed = 2;
+ }
+ else
+ {
+ if (as->type == AS_EXPLICIT)
+ {
+ packed = 2;
+ for (n = 0; n < as->rank; n++)
+ {
+ if (!(as->upper[n]
+ && as->lower[n]
+ && as->upper[n]->expr_type == EXPR_CONSTANT
+ && as->lower[n]->expr_type == EXPR_CONSTANT))
+ packed = 1;
+ }
+ }
+ else
+ packed = 1;
+ }
+
+ type = gfc_typenode_for_spec (&sym->ts);
+ type = gfc_get_nodesc_array_type (type, sym->as, packed);
}
else
{
- if (as->type == AS_EXPLICIT)
- {
- packed = 2;
- for (n = 0; n < as->rank; n++)
- {
- if (!(as->upper[n]
- && as->lower[n]
- && as->upper[n]->expr_type == EXPR_CONSTANT
- && as->lower[n]->expr_type == EXPR_CONSTANT))
- packed = 1;
- }
- }
- else
- packed = 1;
+ /* We now have an expression for the element size, so create a fully
+ qualified type. Reset sym->backend decl or this will just return the
+ old type. */
+ sym->backend_decl = NULL_TREE;
+ type = gfc_sym_type (sym);
+ packed = 2;
}
- type = gfc_get_nodesc_array_type (gfc_get_element_type (type), sym->as,
- packed);
-
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
decl = build_decl (VAR_DECL, get_identifier (name), type);
@@ -600,8 +622,9 @@ gfc_build_dummy_array_decl (gfc_symbol *
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
- if (sym->as->type == AS_DEFERRED)
- internal_error ("possible gfortran frontend bug: deferred shape dummy array");
+ /* We should never get deferred shape arrays here. We used to because of
+ frontend bugs. */
+ assert (sym->as->type != AS_DEFERRED);
switch (packed)
{
@@ -634,6 +657,36 @@ gfc_build_dummy_array_decl (gfc_symbol *
}
+/* Return a constant or a variable to use as a string length. Does not
+ add the decl to the current scope. */
+
+static tree
+gfc_create_string_length (gfc_symbol * sym)
+{
+ tree length;
+
+ assert (sym->ts.cl);
+ gfc_conv_const_charlen (sym->ts.cl);
+
+ if (sym->ts.cl->backend_decl == NULL_TREE)
+ {
+ char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
+
+ /* Also prefix the mangled name. */
+ strcpy (&name[1], sym->name);
+ name[0] = '.';
+ length = build_decl (VAR_DECL, get_identifier (name),
+ gfc_strlen_type_node);
+ DECL_ARTIFICIAL (length) = 1;
+ TREE_USED (length) = 1;
+ gfc_defer_symbol_init (sym);
+ sym->ts.cl->backend_decl = length;
+ }
+
+ return sym->ts.cl->backend_decl;
+}
+
+
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
@@ -641,7 +694,7 @@ tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
tree decl;
- tree length;
+ tree length = NULL_TREE;
gfc_se se;
int byref;
@@ -665,12 +718,27 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* Dummy variables should already have been created. */
assert (sym->backend_decl);
+ /* Create a character length variable. */
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ if (sym->ts.cl->backend_decl == NULL_TREE)
+ {
+ length = gfc_create_string_length (sym);
+ if (TREE_CODE (length) != INTEGER_CST)
+ {
+ gfc_finish_var_decl (length, sym);
+ gfc_defer_symbol_init (sym);
+ }
+ }
+ }
+
/* Use a copy of the descriptor for dummy arrays. */
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
sym->backend_decl =
gfc_build_dummy_array_decl (sym, sym->backend_decl);
}
+
TREE_USED (sym->backend_decl) = 1;
return sym->backend_decl;
}
@@ -691,6 +759,12 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (sym->attr.intrinsic)
internal_error ("intrinsic variable which isn't a procedure");
+ /* Create string length decl first so that they can be used in the
+ type declaration. */
+ if (sym->ts.type == BT_CHARACTER)
+ length = gfc_create_string_length (sym);
+
+ /* Create the decl for the variable. */
decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
/* Symbols from modules have its assembler name should be mangled.
@@ -717,16 +791,16 @@ gfc_get_symbol_decl (gfc_symbol * sym)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_ASSIGN (decl) = 1;
- GFC_DECL_STRING_LENGTH (decl) =
- gfc_create_var (gfc_strlen_type_node, sym->name);
+ length = gfc_create_var (gfc_strlen_type_node, sym->name);
+ GFC_DECL_STRING_LEN (decl) = length;
GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
- TREE_STATIC (GFC_DECL_STRING_LENGTH (decl)) = 1;
+ /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
+ TREE_STATIC (length) = TREE_STATIC (decl);
/* 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);
+ DECL_INITIAL (length) = build_int_2 (-2, -1);
}
/* TODO: Initialization of pointer variables. */
@@ -734,22 +808,19 @@ gfc_get_symbol_decl (gfc_symbol * sym)
{
case BT_CHARACTER:
/* Character variables need special handling. */
- /* Character lengths are common for a whole array. */
gfc_allocate_lang_decl (decl);
GFC_DECL_STRING (decl) = 1;
- if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
+ if (TREE_CODE (length) == INTEGER_CST)
{
- length =
- gfc_conv_mpz_to_tree (sym->ts.cl->length->value.integer, 4);
-
- /* Static initializer. */
- if (sym->value)
+ /* Static initializer for string scalars.
+ Initialization of string arrays is handled elsewhere. */
+ if (sym->value && sym->attr.dimension == 0)
{
assert (TREE_STATIC (decl));
if (sym->attr.pointer)
- gfc_todo_error ("initialization of pointers");
+ gfc_todo_error ("initialization of character pointers");
DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
}
}
@@ -757,28 +828,18 @@ gfc_get_symbol_decl (gfc_symbol * sym)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
- /* Create annother variable to hold the length. Prefix the name
- to avoid conflicts. */
- strcpy (&name[1], sym->name);
- name[0] = '.';
- length = build_decl (VAR_DECL, get_identifier (name),
- gfc_strlen_type_node);
-
- DECL_ARTIFICIAL (decl) = 1;
- /* Also prefix the mangled name for symbols from modules. */
if (sym->module[0])
{
+ /* Also prefix the mangled name for symbols from modules. */
+ strcpy (&name[1], sym->name);
+ name[0] = '.';
strcpy (&name[1],
IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
}
gfc_finish_var_decl (length, sym);
- /* Remember this variable for allocation/cleanup. */
- gfc_defer_symbol_init (sym);
assert (!sym->value);
}
-
- GFC_DECL_STRING_LENGTH (decl) = length;
break;
case BT_DERIVED:
@@ -922,7 +983,7 @@ gfc_build_function_decl (gfc_symbol * sy
assert (!sym->backend_decl);
assert (!sym->attr.external);
- /* Allow only one nesting level. Allow external declarations. */
+ /* Allow only one nesting level. Allow public declarations. */
assert (current_function_decl == NULL_TREE
|| DECL_CONTEXT (current_function_decl) == NULL_TREE);
@@ -939,6 +1000,7 @@ gfc_build_function_decl (gfc_symbol * sy
attr = sym->attr;
result_decl = NULL_TREE;
+ /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */
if (attr.function)
{
if (gfc_return_by_reference (sym))
@@ -953,7 +1015,7 @@ gfc_build_function_decl (gfc_symbol * sy
}
else
{
- /* Look for an alternate return placeholders. */
+ /* Look for alternate return placeholders. */
int has_alternate_returns = 0;
for (f = sym->formal; f; f = f->next)
{
@@ -1039,27 +1101,22 @@ gfc_build_function_decl (gfc_symbol * sy
/* Length of character result */
type = TREE_VALUE (typelist);
assert (type == gfc_strlen_type_node);
+
length = build_decl (PARM_DECL,
get_identifier (".__result"),
type);
+ if (!sym->ts.cl->length)
+ {
+ sym->ts.cl->backend_decl = length;
+ TREE_USED (length) = 1;
+ }
+ assert (TREE_CODE (length) == PARM_DECL);
arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
DECL_CONTEXT (length) = fndecl;
DECL_ARG_TYPE (length) = type;
TREE_READONLY (length) = 1;
gfc_finish_decl (length, NULL_TREE);
-
- if (sym->ts.cl
- && sym->ts.cl->length
- && sym->ts.cl->length->expr_type == EXPR_CONSTANT)
- {
- length = gfc_conv_mpz_to_tree
- (sym->ts.cl->length->value.integer, 4);
- }
- else
- TREE_USED (length) = 1;
-
- GFC_DECL_STRING_LENGTH (parm) = length;
}
}
@@ -1108,7 +1165,7 @@ gfc_build_function_decl (gfc_symbol * sy
assert (type == gfc_strlen_type_node);
strcpy (&name[1], f->sym->name);
- name[0] = '.';
+ name[0] = '_';
length = build_decl (PARM_DECL, get_identifier (name), type);
arglist = chainon (arglist, length);
@@ -1117,18 +1174,15 @@ gfc_build_function_decl (gfc_symbol * sy
TREE_READONLY (length) = 1;
gfc_finish_decl (length, NULL_TREE);
- gfc_allocate_lang_decl (parm);
GFC_DECL_STRING (parm) = 1;
- if (f->sym->ts.cl
- && f->sym->ts.cl->length
- && f->sym->ts.cl->length->expr_type == EXPR_CONSTANT)
- {
- length = gfc_conv_mpz_to_tree (
- f->sym->ts.cl->length->value.integer, 4);
- }
- else
- TREE_USED (length) = 1;
- GFC_DECL_STRING_LENGTH (parm) = length;
+ /* TODO: Check string lengths when -fbounds-check. */
+
+ /* Use the passed value for assumed length variables. */
+ if (!f->sym->ts.cl->length)
+ {
+ TREE_USED (length) = 1;
+ f->sym->ts.cl->backend_decl = length;
+ }
parm = TREE_CHAIN (parm);
typelist = TREE_CHAIN (typelist);
@@ -1150,6 +1204,8 @@ tree
gfc_get_fake_result_decl (gfc_symbol * sym)
{
tree decl;
+ tree length;
+
char name[GFC_MAX_SYMBOL_LEN + 10];
if (current_fake_result_decl != NULL_TREE)
@@ -1160,6 +1216,13 @@ gfc_get_fake_result_decl (gfc_symbol * s
if (!sym)
return NULL_TREE;
+ if (sym->ts.type == BT_CHARACTER
+ && !sym->ts.cl->backend_decl)
+ {
+ length = gfc_create_string_length (sym);
+ gfc_finish_var_decl (length, sym);
+ }
+
if (gfc_return_by_reference (sym))
{
decl = DECL_ARGUMENTS (sym->backend_decl);
@@ -1487,44 +1550,55 @@ gfc_build_builtin_function_decls (void)
}
+/* Exaluate the length of dummy character variables. */
+
+static tree
+gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
+{
+ stmtblock_t body;
+
+ gfc_finish_decl (cl->backend_decl, NULL_TREE);
+
+ gfc_start_block (&body);
+
+ /* Evaluate the string length expression. */
+ gfc_trans_init_string_length (cl, &body);
+
+ gfc_add_expr_to_block (&body, fnbody);
+ return gfc_finish_block (&body);
+}
+
+
/* Allocate and cleanup an automatic character variable. */
static tree
gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
{
- tree tmp;
- tree args;
- tree len;
- stmtblock_t block;
stmtblock_t body;
+ tree decl;
+ tree args;
+ tree tmp;
+ assert (sym->backend_decl);
assert (sym->ts.cl && sym->ts.cl->length);
- assert (sym->backend_decl != NULL_TREE);
gfc_start_block (&body);
- gfc_start_block (&block);
- len = gfc_conv_init_string_length (sym, &block);
- args = gfc_chainon_list (NULL_TREE, len);
- tmp = gfc_build_function_call (gfor_fndecl_internal_malloc, args);
- tmp = convert (TREE_TYPE (sym->backend_decl), tmp);
- gfc_add_modify_expr (&block, sym->backend_decl, tmp);
+ /* Evaluate the string length expression. */
+ gfc_trans_init_string_length (sym->ts.cl, &body);
- tmp = gfc_finish_block (&block);
- gfc_add_expr_to_block (&body, tmp);
+ decl = sym->backend_decl;
- gfc_add_expr_to_block (&body, fnbody);
-
- gfc_start_block (&block);
+ DECL_DEFER_OUTPUT (decl) = 1;
- tmp = convert (pvoid_type_node, sym->backend_decl);
+ /* Generate code to allocate the automatic variable. It will be freed
+ automatically. */
+ tmp = gfc_build_addr_expr (NULL, decl);
args = gfc_chainon_list (NULL_TREE, tmp);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
- gfc_add_expr_to_block (&block, tmp);
-
- tmp = gfc_finish_block (&block);
+ args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
+ tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
gfc_add_expr_to_block (&body, tmp);
-
+ gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
@@ -1557,14 +1631,17 @@ gfc_trans_deferred_vars (gfc_symbol * pr
current_fake_result_decl,
fnbody);
}
- else if (proc_sym->ts.type != BT_CHARACTER)
+ else if (proc_sym->ts.type == BT_CHARACTER)
+ {
+ if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
+ }
+ else
gfc_todo_error ("Deferred non-array return by reference");
}
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
- /* For now this is only array variables, but may get extended to
- derived types. */
if (sym->attr.dimension)
{
switch (sym->as->type)
@@ -1619,7 +1696,10 @@ gfc_trans_deferred_vars (gfc_symbol * pr
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
- fnbody = gfc_trans_auto_character_variable (sym, fnbody);
+ if (sym->attr.dummy || sym->attr.result)
+ fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
+ else
+ fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
}
else
@@ -1703,7 +1783,7 @@ gfc_create_module_variable (gfc_symbol *
{
tree length;
- length = GFC_DECL_STRING_LENGTH (decl);
+ length = sym->ts.cl->backend_decl;
if (!INTEGER_CST_P (length))
{
pushdecl (length);
@@ -1820,10 +1900,17 @@ gfc_generate_function_code (gfc_namespac
tree result;
gfc_symbol *sym;
+ sym = ns->proc_name;
+ /* Check that the frontend isn't still using this. */
+ assert (sym->tlink == NULL);
+
+ sym->tlink = sym;
+
/* Create the declaration for functions with global scope. */
- if (!ns->proc_name->backend_decl)
+ if (!sym->backend_decl)
gfc_build_function_decl (ns->proc_name);
+ fndecl = sym->backend_decl;
old_context = current_function_decl;
if (old_context)
@@ -1833,10 +1920,6 @@ gfc_generate_function_code (gfc_namespac
saved_function_decls = NULL_TREE;
}
- sym = ns->proc_name;
-
- fndecl = sym->backend_decl;
-
/* let GCC know the current scope is this function */
current_function_decl = fndecl;
@@ -1876,10 +1959,6 @@ gfc_generate_function_code (gfc_namespac
/* function.c requires a push at the start of the function */
pushlevel (0);
- /* Check that the frontend isn't still using this. */
- assert (sym->tlink == NULL);
- sym->tlink = sym;
-
gfc_start_block (&block);
gfc_generate_contained_functions (ns);
Index: trans-expr.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-expr.c,v
retrieving revision 1.1.2.20
diff -u -p -r1.1.2.20 trans-expr.c
--- a/trans-expr.c 4 Apr 2004 15:33:41 -0000 1.1.2.20
+++ b/trans-expr.c 4 Apr 2004 23:03:42 -0000
@@ -142,20 +142,18 @@ gfc_conv_expr_present (gfc_symbol * sym)
/* Generate code to initialize a string length variable. Returns the
value. */
-tree
-gfc_conv_init_string_length (gfc_symbol * sym, stmtblock_t * pblock)
+void
+gfc_trans_init_string_length (gfc_charlen * cl, stmtblock_t * pblock)
{
gfc_se se;
tree tmp;
gfc_init_se (&se, NULL);
- gfc_conv_expr_type (&se, sym->ts.cl->length, gfc_strlen_type_node);
+ gfc_conv_expr_type (&se, cl->length, gfc_strlen_type_node);
gfc_add_block_to_block (pblock, &se.pre);
- tmp = GFC_DECL_STRING_LENGTH (sym->backend_decl);
+ tmp = cl->backend_decl;
gfc_add_modify_expr (pblock, tmp, se.expr);
-
- return se.expr;
}
static void
@@ -229,7 +227,7 @@ gfc_conv_component_ref (gfc_se * se, gfc
if (c->ts.type == BT_CHARACTER)
{
- tmp = GFC_DECL_STRING_LENGTH (field);
+ tmp = c->ts.cl->backend_decl;
assert (tmp);
if (!INTEGER_CST_P (tmp))
gfc_todo_error ("Unknown length character component");
@@ -306,8 +304,8 @@ gfc_conv_variable (gfc_se * se, gfc_expr
/* For character variables, also get the length. */
if (sym->ts.type == BT_CHARACTER)
{
- assert (GFC_DECL_STRING (se->expr));
- se->string_length = GFC_DECL_STRING_LENGTH (se->expr);
+ assert (sym->attr.in_common || GFC_DECL_STRING (se->expr));
+ se->string_length = sym->ts.cl->backend_decl;
assert (se->string_length);
}
@@ -691,11 +689,8 @@ gfc_conv_concat_op (gfc_se * se, gfc_exp
gfc_add_block_to_block (&se->pre, &rse.pre);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
- if (GFC_KNOWN_SIZE_STRING_TYPE (type))
- {
- len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
- }
- else
+ len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
+ if (len == NULL_TREE)
{
len = fold (build (PLUS_EXPR, TREE_TYPE (lse.string_length),
lse.string_length, rse.string_length));
@@ -1000,9 +995,12 @@ gfc_conv_function_call (gfc_se * se, gfc
}
else if (sym->ts.type == BT_CHARACTER)
{
+ assert (sym->ts.cl && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type == EXPR_CONSTANT);
+ len = gfc_conv_mpz_to_tree
+ (sym->ts.cl->length->value.integer, sym->ts.cl->length->ts.kind);
+ sym->ts.cl->backend_decl = len;
type = gfc_get_character_type (sym->ts.kind, sym->ts.cl);
- assert (GFC_KNOWN_SIZE_STRING_TYPE (type));
- len = TYPE_MAX_VALUE (TYPE_DOMAIN (type));
type = build_pointer_type (type);
var = gfc_conv_string_tmp (se, type, len);
@@ -1549,23 +1547,8 @@ gfc_trans_pointer_assignment (gfc_expr *
}
-/* Get the decl for the length of a string from an expression. */
-
-tree
-gfc_conv_string_length (tree expr)
-{
- /* TODO: string lengths of components. */
- while (TREE_CODE (expr) == INDIRECT_REF)
- expr = TREE_OPERAND (expr, 0);
-
- if (!(DECL_P (expr) && GFC_DECL_STRING (expr)))
- return NULL_TREE;
-
- return GFC_DECL_STRING_LENGTH (expr);
-}
-
-
/* Makes sure se is suitable for passing as a function string parameter. */
+/* TODO: Need to check all callers fo this function. It may be abused. */
void
gfc_conv_string_parameter (gfc_se * se)
@@ -1581,9 +1564,7 @@ gfc_conv_string_parameter (gfc_se * se)
type = TREE_TYPE (se->expr);
if (TYPE_STRING_FLAG (type))
{
- assert (TREE_CODE (se->expr) == VAR_DECL
- || TREE_CODE (se->expr) == COMPONENT_REF
- || TREE_CODE (se->expr) == PARM_DECL);
+ assert (TREE_CODE (se->expr) != INDIRECT_REF);
se->expr = gfc_build_addr_expr (pchar_type_node, se->expr);
}
Index: trans-intrinsic.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-intrinsic.c,v
retrieving revision 1.1.2.26
diff -u -p -r1.1.2.26 trans-intrinsic.c
--- a/trans-intrinsic.c 10 Jan 2004 21:09:18 -0000 1.1.2.26
+++ b/trans-intrinsic.c 4 Apr 2004 15:39:12 -0000
@@ -1878,7 +1878,7 @@ gfc_conv_intrinsic_len (gfc_se * se, gfc
decl = gfc_get_fake_result_decl (sym);
assert (GFC_DECL_STRING (decl));
- len = GFC_DECL_STRING_LENGTH (decl);
+ len = sym->ts.cl->backend_decl;
assert (len);
}
else
Index: trans-io.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-io.c,v
retrieving revision 1.1.2.8
diff -u -p -r1.1.2.8 trans-io.c
--- a/trans-io.c 24 Mar 2004 10:52:54 -0000 1.1.2.8
+++ b/trans-io.c 4 Apr 2004 15:39:12 -0000
@@ -394,11 +394,11 @@ set_string (stmtblock_t * block, stmtblo
{
msg =
gfc_build_string_const (37, "Assigned label is not a format label");
- tmp = GFC_DECL_STRING_LENGTH (se.expr);
+ tmp = GFC_DECL_STRING_LEN (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));
+ gfc_add_modify_expr (&se.pre, len, GFC_DECL_STRING_LEN (se.expr));
}
else
{
Index: trans-stmt.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-stmt.c,v
retrieving revision 1.1.2.15
diff -u -p -r1.1.2.15 trans-stmt.c
--- a/trans-stmt.c 11 Jan 2004 23:28:53 -0000 1.1.2.15
+++ b/trans-stmt.c 4 Apr 2004 15:39:12 -0000
@@ -99,7 +99,7 @@ gfc_trans_label_assign (gfc_code * code)
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
gfc_conv_expr (&se, code->expr);
- len = GFC_DECL_STRING_LENGTH (se.expr);
+ len = GFC_DECL_STRING_LEN (se.expr);
addr = GFC_DECL_ASSIGN_ADDR (se.expr);
label_tree = gfc_get_label_decl (code->label);
@@ -146,7 +146,7 @@ gfc_trans_goto (gfc_code * code)
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 = GFC_DECL_STRING_LEN (se.expr);
tmp = build (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
gfc_trans_runtime_check (tmp, assign_error, &se.pre);
Index: trans-types.c
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-types.c,v
retrieving revision 1.1.2.13
diff -u -p -r1.1.2.13 trans-types.c
--- a/trans-types.c 4 Apr 2004 15:33:41 -0000 1.1.2.13
+++ b/trans-types.c 4 Apr 2004 22:36:56 -0000
@@ -282,19 +282,11 @@ gfc_get_character_type (int kind, gfc_ch
fatal_error ("character kind=%d not available", kind);
}
- if (cl && cl->length && cl->length->expr_type == EXPR_CONSTANT)
- {
- len = gfc_conv_mpz_to_tree (cl->length->value.integer,
- cl->length->ts.kind);
- }
- else
- len = NULL_TREE;
+ len = (cl == 0) ? NULL_TREE : cl->backend_decl;
bounds = build_range_type (gfc_array_index_type, integer_one_node, len);
type = build_array_type (base, bounds);
TYPE_STRING_FLAG (type) = 1;
- if (len != NULL_TREE)
- GFC_KNOWN_SIZE_STRING_TYPE (type) = 1;
return type;
}
@@ -454,7 +446,7 @@ gfc_get_element_type (tree type)
/* Returns true if the array sym does not require a descriptor. */
-static int
+int
gfc_is_nodesc_array (gfc_symbol * sym)
{
assert (sym->attr.dimension);
@@ -545,12 +537,13 @@ gfc_get_desc_dim_type (void)
}
static tree
-gfc_get_dtype_cst (tree type, int rank)
+gfc_get_dtype (tree type, int rank)
{
tree size;
int n;
- unsigned HOST_WIDE_INT lo;
- unsigned HOST_WIDE_INT hi;
+ HOST_WIDE_INT i;
+ tree tmp;
+ tree dtype;
if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
return (GFC_TYPE_ARRAY_DTYPE (type));
@@ -574,32 +567,46 @@ gfc_get_dtype_cst (tree type, int rank)
n = GFC_DTYPE_COMPLEX;
break;
- /* Arrays have already been dealt with. */
+ /* Arrays have already been dealt with. */
case RECORD_TYPE:
n = GFC_DTYPE_DERIVED;
break;
-/* Arrays of strings are currently broken. */
-#if 0
+
case ARRAY_TYPE:
n = GFC_DTYPE_CHARACTER;
break;
-#endif
+
default:
abort ();
}
assert (rank <= GFC_DTYPE_RANK_MASK);
size = TYPE_SIZE_UNIT (type);
- assert (INTEGER_CST_P (size));
- if (tree_int_cst_lt (gfc_max_array_element_size, size))
- internal_error ("Array element size too big");
-
- lo = TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
- hi = TREE_INT_CST_HIGH (size) << GFC_DTYPE_SIZE_SHIFT
- | (lo >> (sizeof (HOST_WIDE_INT) * 8 - GFC_DTYPE_SIZE_SHIFT));
- lo |= rank | (n << GFC_DTYPE_TYPE_SHIFT);
+
+ i = rank | (n << GFC_DTYPE_TYPE_SHIFT);
+ if (size && INTEGER_CST_P (size))
+ {
+ if (tree_int_cst_lt (gfc_max_array_element_size, size))
+ internal_error ("Array element size too big");
+
+ i += TREE_INT_CST_LOW (size) << GFC_DTYPE_SIZE_SHIFT;
+ }
+ dtype = build_int_2 (i, 0);
+ TREE_TYPE (dtype) = gfc_array_index_type;
- return build_int_2 (lo, hi);
+ if (size && !INTEGER_CST_P (size))
+ {
+ tmp = build_int_2 (GFC_DTYPE_SIZE_SHIFT, 0);
+ TREE_TYPE (tmp) = gfc_array_index_type;
+ tmp = fold (build (LSHIFT_EXPR, gfc_array_index_type, size, tmp));
+ dtype = fold (build (PLUS_EXPR, gfc_array_index_type, tmp, dtype));
+ }
+ /* If we don't know the size we leave it as zero. This should never happen
+ for anything that is actually used. */
+ /* TODO: Check this is actually true, particularly when repacking
+ assumed size parameters. */
+
+ return dtype;
}
@@ -709,7 +716,7 @@ gfc_get_nodesc_array_type (tree etype, g
else
GFC_TYPE_ARRAY_SIZE (type) = NULL_TREE;
- GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype_cst (etype, as->rank);
+ GFC_TYPE_ARRAY_DTYPE (type) = gfc_get_dtype (etype, as->rank);
GFC_TYPE_ARRAY_RANK (type) = as->rank;
range = build_range_type (gfc_array_index_type, integer_zero_node,
NULL_TREE);
@@ -771,7 +778,7 @@ gfc_get_array_type_bounds (tree etype, i
TYPE_LANG_SPECIFIC (fat_type) = (struct lang_type *)
ggc_alloc_cleared (sizeof (struct lang_type));
GFC_TYPE_ARRAY_RANK (fat_type) = dimen;
- GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype_cst (etype, dimen);
+ GFC_TYPE_ARRAY_DTYPE (fat_type) = gfc_get_dtype (etype, dimen);
tmp = TYPE_NAME (etype);
if (tmp && TREE_CODE (tmp) == TYPE_DECL)
@@ -905,7 +912,6 @@ tree
gfc_sym_type (gfc_symbol * sym)
{
tree type;
- tree base_type;
int byref;
if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function)
@@ -924,46 +930,36 @@ gfc_sym_type (gfc_symbol * sym)
if (sym->attr.function && sym->result)
sym = sym->result;
- base_type = type = gfc_typenode_for_spec (&sym->ts);
+ type = gfc_typenode_for_spec (&sym->ts);
if (sym->attr.dummy && !sym->attr.function)
byref = 1;
else
byref = 0;
- if (sym->ts.type == BT_CHARACTER)
- {
- if (sym->attr.dimension
- || sym->attr.pointer || sym->attr.allocatable
- || sym->attr.function || sym->attr.result)
- type = build_pointer_type (type);
- }
-
if (sym->attr.dimension)
{
- /* The string code is currently very broken. I need to figure out a way
- of doing it that works with descriptorless arrays. */
- if (sym->ts.type == BT_CHARACTER)
- gfc_todo_error ("arrays of strings");
-
if (gfc_is_nodesc_array (sym))
{
- type = gfc_get_nodesc_array_type (type, sym->as,
- byref ? 2 : 3);
- byref = 0;
+ /* If this is a character argument of unknown length, just use the
+ base type. */
+ if (sym->ts.type != BT_CHARACTER
+ || !(sym->attr.dummy || sym->attr.function || sym->attr.result)
+ || sym->ts.cl->backend_decl)
+ {
+ type = gfc_get_nodesc_array_type (type, sym->as,
+ byref ? 2 : 3);
+ byref = 0;
+ }
}
else
type = gfc_build_array_type (type, sym->as);
}
- else if (sym->ts.type != BT_CHARACTER)
+ else
{
if (sym->attr.allocatable || sym->attr.pointer)
type = gfc_build_pointer_type (sym, type);
}
- else if (!(GFC_KNOWN_SIZE_STRING_TYPE (base_type) || sym->attr.dummy))
- {
- type = build_pointer_type (type);
- }
/* We currently pass all parameters by reference.
See f95_get_function_decl. For dummy function parameters return the
@@ -1016,7 +1012,6 @@ static tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode, field, field_type, fieldlist;
- tree tmp;
gfc_component *c;
assert (derived && derived->attr.flavor == FL_DERIVED);
@@ -1059,7 +1054,16 @@ gfc_get_derived_type (gfc_symbol * deriv
}
}
else
- field_type = gfc_typenode_for_spec (&c->ts);
+ {
+ if (c->ts.type == BT_CHARACTER)
+ {
+ /* Evaluate the string length. */
+ gfc_conv_const_charlen (c->ts.cl);
+ assert (c->ts.cl->backend_decl);
+ }
+
+ field_type = gfc_typenode_for_spec (&c->ts);
+ }
/* This returns an array descriptor type. Initialisation may be
required. */
@@ -1083,16 +1087,6 @@ gfc_get_derived_type (gfc_symbol * deriv
DECL_PACKED (field) |= TYPE_PACKED (typenode);
- if (c->ts.type == BT_CHARACTER)
- {
- gfc_allocate_lang_decl (field);
- tmp = TREE_TYPE (field);
- assert (TREE_CODE (tmp) == ARRAY_TYPE);
- tmp = TYPE_MAX_VALUE (TYPE_DOMAIN (tmp));
- assert (INTEGER_CST_P (tmp));
- GFC_DECL_STRING_LENGTH (field) = tmp;
- }
-
assert (!c->backend_decl);
c->backend_decl = field;
}
@@ -1157,9 +1151,16 @@ gfc_get_function_type (gfc_symbol * sym)
arg = sym->result;
else
arg = sym;
+
+ if (arg->ts.type == BT_CHARACTER)
+ gfc_conv_const_charlen (arg->ts.cl);
+
type = gfc_sym_type (arg);
- if (arg->ts.type == BT_DERIVED || arg->attr.dimension)
+ if (arg->ts.type == BT_DERIVED
+ || arg->attr.dimension
+ || arg->ts.type == BT_CHARACTER)
type = build_reference_type (type);
+
typelist = gfc_chainon_list (typelist, type);
if (arg->ts.type == BT_CHARACTER)
typelist = gfc_chainon_list (typelist, gfc_strlen_type_node);
@@ -1171,6 +1172,11 @@ gfc_get_function_type (gfc_symbol * sym)
arg = f->sym;
if (arg)
{
+ /* Evaluate constant character lengths here so that they can be
+ included in the type. */
+ if (arg->ts.type == BT_CHARACTER)
+ gfc_conv_const_charlen (arg->ts.cl);
+
if (arg->attr.flavor == FL_PROCEDURE)
{
type = gfc_get_function_type (arg);
Index: trans-types.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans-types.h,v
retrieving revision 1.1.2.2
diff -u -p -r1.1.2.2 trans-types.h
--- a/trans-types.h 2 Aug 2003 00:26:48 -0000 1.1.2.2
+++ b/trans-types.h 4 Apr 2004 16:23:13 -0000
@@ -91,6 +91,7 @@ extern GTY(()) tree pchar_type_node;
#define gfc_character1_type_node gfc_type_nodes[F95_CHARACTER1_TYPE]
+#define gfc_strlen_kind 4
#define gfc_strlen_type_node gfc_int4_type_node
/* These C-specific types are used while building builtin function decls.
@@ -136,4 +137,7 @@ void gfc_finish_type (tree);
/* Some functions have an extra parameter for the return value. */
int gfc_return_by_reference (gfc_symbol *);
+/* Returns true if the array sym does not require a descriptor. */
+int gfc_is_nodesc_array (gfc_symbol *);
+
#endif
Index: trans.h
===================================================================
RCS file: /var/cvsroot/gcc-cvs/gcc/gcc/fortran/Attic/trans.h,v
retrieving revision 1.1.2.14
diff -u -p -r1.1.2.14 trans.h
--- a/trans.h 16 Feb 2004 12:36:08 -0000 1.1.2.14
+++ b/trans.h 4 Apr 2004 22:20:08 -0000
@@ -303,10 +303,8 @@ tree gfc_conv_expr_present (gfc_symbol *
/* Generate code to allocate a string temporary. */
tree gfc_conv_string_tmp (gfc_se *, tree, tree);
-/* Get the length of a string. */
-tree gfc_conv_string_length (tree);
/* Initialize a string length variable. */
-tree gfc_conv_init_string_length (gfc_symbol *, stmtblock_t *);
+void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
/* Add an expression to the end of a block. */
void gfc_add_expr_to_block (stmtblock_t *, tree);
@@ -485,19 +483,19 @@ struct lang_type GTY(())
struct lang_decl GTY(())
{
- /* String nodes. */
- tree stringlength;
+ /* Dummy variables. */
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 stringlen;
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_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
#define GFC_DECL_SAVED_DESCRIPTOR(node) \
(DECL_LANG_SPECIFIC(node)->saved_descriptor)
#define GFC_DECL_STRING(node) DECL_LANG_FLAG_0(node)
@@ -505,7 +503,6 @@ struct lang_decl GTY(())
#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. */
#define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node)
/* An array without a descriptor. */
Attachment:
strarray_3.f90
Description: Text document
Attachment:
strarray_1.f90
Description: Text document
Attachment:
strcommon_1.f90
Description: Text document
Attachment:
strarray_2.f90
Description: Text document
Attachment:
strarray_4.f90
Description: Text document
| Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
|---|---|---|
| Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |