diff options
author | Jerry DeLisle <jvdelisle@gcc.gnu.org> | 2010-04-13 01:59:35 +0000 |
---|---|---|
committer | Jerry DeLisle <jvdelisle@gcc.gnu.org> | 2010-04-13 01:59:35 +0000 |
commit | b7e757713c17d27acbce6bb2d2dd19f226e2e552 (patch) | |
tree | 918735c4a29176e24e41c0c81fa94027f00f96f3 /gcc/fortran/expr.c | |
parent | 57408aaf2ba396a43394465e549f157d8fbfb173 (diff) | |
download | gcc-b7e757713c17d27acbce6bb2d2dd19f226e2e552.zip gcc-b7e757713c17d27acbce6bb2d2dd19f226e2e552.tar.gz gcc-b7e757713c17d27acbce6bb2d2dd19f226e2e552.tar.bz2 |
[multiple changes]
2010-04-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
* array.c (extract_element): Restore function from trunk.
(gfc_get_array_element): Restore function from trunk.
(gfc_expand_constructor): Restore check against
flag_max_array_constructor.
* constructor.c (node_copy_and_append): Delete unused.
* gfortran.h: Delete comment and extra include.
* constructor.h: Bump copyright and clean up TODO comments.
* resolve.c: Whitespace.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* simplify.c (compute_dot_product): Replaced usage of ADVANCE macro
with direct access access to elements. Adjusted prototype, fixed all
callers.
(gfc_simplify_dot_product): Removed duplicate check for zero-sized
array.
(gfc_simplify_matmul): Removed usage of ADVANCE macro.
(gfc_simplify_spread): Removed workaround, directly insert elements
at a given array position.
(gfc_simplify_transpose): Likewise.
(gfc_simplify_pack): Replaced usage of ADVANCE macro with corresponding
function calls.
(gfc_simplify_unpack): Likewise.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* simplify.c (only_convert_cmplx_boz): Renamed to ...
(convert_boz): ... this and moved to start of file.
(gfc_simplify_abs): Whitespace fix.
(gfc_simplify_acos): Whitespace fix.
(gfc_simplify_acosh): Whitespace fix.
(gfc_simplify_aint): Whitespace fix.
(gfc_simplify_dint): Whitespace fix.
(gfc_simplify_anint): Whitespace fix.
(gfc_simplify_and): Replaced if-gate by more common switch-over-type.
(gfc_simplify_dnint): Whitespace fix.
(gfc_simplify_asin): Whitespace fix.
(gfc_simplify_asinh): Moved creation of result-expr out of switch.
(gfc_simplify_atan): Likewise.
(gfc_simplify_atanh): Whitespace fix.
(gfc_simplify_atan2): Whitespace fix.
(gfc_simplify_bessel_j0): Removed ATTRIBUTE_UNUSED.
(gfc_simplify_bessel_j1): Likewise.
(gfc_simplify_bessel_jn): Likewise.
(gfc_simplify_bessel_y0): Likewise.
(gfc_simplify_bessel_y1): Likewise.
(gfc_simplify_bessel_yn): Likewise.
(gfc_simplify_ceiling): Reorderd statements.
(simplify_cmplx): Use convert_boz(), check for constant arguments.
Whitespace fix.
(gfc_simplify_cmplx): Use correct default kind. Removed check for
constant arguments.
(gfc_simplify_complex): Replaced if-gate. Removed check for
constant arguments.
(gfc_simplify_conjg): Whitespace fix.
(gfc_simplify_cos): Whitespace fix.
(gfc_simplify_cosh): Replaced if-gate by more common switch-over-type.
(gfc_simplify_dcmplx): Removed check for constant arguments.
(gfc_simplify_dble): Use convert_boz() and gfc_convert_constant().
(gfc_simplify_digits): Whitespace fix.
(gfc_simplify_dim): Whitespace fix.
(gfc_simplify_dprod): Reordered statements.
(gfc_simplify_erf): Whitespace fix.
(gfc_simplify_erfc): Whitespace fix.
(gfc_simplify_epsilon): Whitespace fix.
(gfc_simplify_exp): Whitespace fix.
(gfc_simplify_exponent): Use convert_boz().
(gfc_simplify_floor): Reorderd statements.
(gfc_simplify_gamma): Whitespace fix.
(gfc_simplify_huge): Whitespace fix.
(gfc_simplify_iand): Whitespace fix.
(gfc_simplify_ieor): Whitespace fix.
(simplify_intconv): Use gfc_convert_constant().
(gfc_simplify_int): Use simplify_intconv().
(gfc_simplify_int2): Reorderd statements.
(gfc_simplify_idint): Reorderd statements.
(gfc_simplify_ior): Whitespace fix.
(gfc_simplify_ishftc): Removed duplicate type check.
(gfc_simplify_len): Use range_check() instead of manual range check.
(gfc_simplify_lgamma): Removed ATTRIBUTE_UNUSED. Whitespace fix.
(gfc_simplify_log): Whitespace fix.
(gfc_simplify_log10): Whitespace fix.
(gfc_simplify_minval): Whitespace fix.
(gfc_simplify_maxval): Whitespace fix.
(gfc_simplify_mod): Whitespace fix.
(gfc_simplify_modulo): Whitespace fix.
(simplify_nint): Reorderd statements.
(gfc_simplify_not): Whitespace fix.
(gfc_simplify_or): Replaced if-gate by more common switch-over-type.
(gfc_simplify_radix): Removed unused result-variable. Whitespace fix.
(gfc_simplify_range): Removed unused result-variable. Whitespace fix.
(gfc_simplify_real): Use convert_boz() and gfc_convert_constant().
(gfc_simplify_realpart): Whitespace fix.
(gfc_simplify_selected_char_kind): Removed unused result-variable.
(gfc_simplify_selected_int_kind): Removed unused result-variable.
(gfc_simplify_selected_real_kind): Removed unused result-variable.
(gfc_simplify_sign): Whitespace fix.
(gfc_simplify_sin): Whitespace fix.
(gfc_simplify_sinh): Replaced if-gate by more common switch-over-type.
(gfc_simplify_sqrt): Avoided goto by inlining check. Whitespace fix.
(gfc_simplify_tan): Replaced if-gate by more common switch-over-type.
(gfc_simplify_tanh): Replaced if-gate by more common switch-over-type.
(gfc_simplify_xor): Replaced if-gate by more common switch-over-type.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* gfortran.h (gfc_start_constructor): Removed.
(gfc_get_array_element): Removed.
* array.c (gfc_start_constructor): Removed, use gfc_get_array_expr
instead. Fixed all callers.
(extract_element): Removed.
(gfc_expand_constructor): Temporarily removed check for
max-array-constructor. Will be re-introduced later if still required.
(gfc_get_array_element): Removed, use gfc_constructor_lookup_expr
instead. Fixed all callers.
* expr.c (find_array_section): Replaced manual lookup of elements
by gfc_constructor_lookup.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* gfortran.h (gfc_get_null_expr): New prototype.
(gfc_get_operator_expr): New prototype.
(gfc_get_character_expr): New prototype.
(gfc_get_iokind_expr): New prototype.
* expr.c (gfc_get_null_expr): New.
(gfc_get_character_expr): New.
(gfc_get_iokind_expr): New.
(gfc_get_operator_expr): Moved here from matchexp.c (build_node).
* matchexp.c (build_node): Renamed and moved to
expr.c (gfc_get_operator_expr). Reordered arguments to match
other functions. Fixed all callers.
(gfc_get_parentheses): Use specific function to build expr.
* array.c (gfc_match_array_constructor): Likewise.
* arith.c (eval_intrinsic): Likewise.
(gfc_hollerith2int): Likewise.
(gfc_hollerith2real): Likewise.
(gfc_hollerith2complex): Likewise.
(gfc_hollerith2logical): Likewise.
* data.c (create_character_intializer): Likewise.
* decl.c (gfc_match_null): Likewise.
(enum_initializer): Likewise.
* io.c (gfc_match_format): Likewise.
(match_io): Likewise.
* match.c (gfc_match_nullify): Likewise.
* primary.c (match_string_constant): Likewise.
(match_logical_constant): Likewise.
(build_actual_constructor): Likewise.
* resolve.c (build_default_init_expr): Likewise.
* symbol.c (generate_isocbinding_symbol): Likewise.
(gfc_build_class_symbol): Likewise.
(gfc_find_derived_vtab): Likewise.
* simplify.c (simplify_achar_char): Likewise.
(gfc_simplify_adjustl): Likewise.
(gfc_simplify_adjustr): Likewise.
(gfc_simplify_and): Likewise.
(gfc_simplify_bit_size): Likewise.
(gfc_simplify_is_iostat_end): Likewise.
(gfc_simplify_is_iostat_eor): Likewise.
(gfc_simplify_isnan): Likewise.
(simplify_bound): Likewise.
(gfc_simplify_leadz): Likewise.
(gfc_simplify_len_trim): Likewise.
(gfc_simplify_logical): Likewise.
(gfc_simplify_maxexponent): Likewise.
(gfc_simplify_minexponent): Likewise.
(gfc_simplify_new_line): Likewise.
(gfc_simplify_null): Likewise.
(gfc_simplify_or): Likewise.
(gfc_simplify_precision): Likewise.
(gfc_simplify_repeat): Likewise.
(gfc_simplify_scan): Likewise.
(gfc_simplify_size): Likewise.
(gfc_simplify_trailz): Likewise.
(gfc_simplify_trim): Likewise.
(gfc_simplify_verify): Likewise.
(gfc_simplify_xor): Likewise.
* trans-io.c (build_dt): Likewise.
(gfc_new_nml_name_expr): Removed.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* arith.h (gfc_constant_result): Removed prototype.
* constructor.h (gfc_build_array_expr): Removed prototype.
(gfc_build_structure_constructor_expr): Removed prototype.
* gfortran.h (gfc_int_expr): Removed prototype.
(gfc_logical_expr): Removed prototype.
(gfc_get_array_expr): New prototype.
(gfc_get_structure_constructor_expr): New prototype.
(gfc_get_constant_expr): New prototype.
(gfc_get_int_expr): New prototype.
(gfc_get_logical_expr): New prototype.
* arith.c (gfc_constant_result): Moved and renamed to
expr.c (gfc_get_constant_expr). Fixed all callers.
* constructor.c (gfc_build_array_expr): Moved and renamed to
expr.c (gfc_get_array_expr). Split gfc_typespec argument to type
and kind. Fixed all callers.
(gfc_build_structure_constructor_expr): Moved and renamed to
expr.c (gfc_get_structure_constructor_expr). Split gfc_typespec argument
to type and kind. Fixed all callers.
* expr.c (gfc_logical_expr): Renamed to ...
(gfc_get_logical_expr): ... this. Added kind argument. Fixed all callers.
(gfc_int_expr): Renamed to ...
(gfc_get_int_expr): ... this. Added kind and where arguments. Fixed all
callers.
(gfc_get_constant_expr): New.
(gfc_get_array_expr): New.
(gfc_get_structure_constructor_expr): New.
* simplify.c (int_expr_with_kind): Removed, callers use gfc_get_int_expr
instead.
2010-04-12 Daniel Franke <franke.daniel@gmail.com>
* constructor.h: New.
* constructor.c: New.
* Make-lang.in: Add new files to F95_PARSER_OBJS.
* arith.c (reducy_unary): Use constructor API.
(reduce_binary_ac): Likewise.
(reduce_binary_ca): Likewise.
(reduce_binary_aa): Likewise.
* check.c (gfc_check_pack): Likewise.
(gfc_check_reshape): Likewise.
(gfc_check_unpack): Likewise.
* decl.c (add_init_expr_to_sym): Likewise.
(build_struct): Likewise.
* dependency.c (gfc_check_dependency): Likewise.
(contains_forall_index_p): Likewise.
* dump-parse-tree.c (show_constructor): Likewise.
* expr.c (free_expr0): Likewise.
(gfc_copy_expr): Likewise.
(gfc_is_constant_expr): Likewise.
(simplify_constructor): Likewise.
(find_array_element): Likewise.
(find_component_ref): Likewise.
(find_array_section): Likewise.
(find_substring_ref): Likewise.
(simplify_const_ref): Likewise.
(scalarize_intrinsic_call): Likewise.
(check_alloc_comp_init): Likewise.
(gfc_default_initializer): Likewise.
(gfc_traverse_expr): Likewise.
* iresolve.c (check_charlen_present): Likewise.
(gfc_resolve_reshape): Likewise.
(gfc_resolve_transfer): Likewise.
* module.c (mio_constructor): Likewise.
* primary.c (build_actual_constructor): Likewise.
(gfc_match_structure_constructor): Likewise.
* resolve.c (resolve_structure_cons): Likewise.
* simplify.c (is_constant_array_expr): Likewise.
(init_result_expr): Likewise.
(transformational_result): Likewise.
(simplify_transformation_to_scalar): Likewise.
(simplify_transformation_to_array): Likewise.
(gfc_simplify_dot_product): Likewise.
(simplify_bound): Likewise.
(simplify_matmul): Likewise.
(simplify_minval_maxval): Likewise.
(gfc_simplify_pack): Likewise.
(gfc_simplify_reshape): Likewise.
(gfc_simplify_shape): Likewise.
(gfc_simplify_spread): Likewise.
(gfc_simplify_transpose): Likewise.
(gfc_simplify_unpack): Likewise.q
(gfc_convert_constant): Likewise.
(gfc_convert_char_constant): Likewise.
* target-memory.c (size_array): Likewise.
(encode_array): Likewise.
(encode_derived): Likewise.
(interpret_array): Likewise.
(gfc_interpret_derived): Likewise.
(expr_to_char): Likewise.
(gfc_merge_initializers): Likewise.
* trans-array.c (gfc_get_array_constructor_size): Likewise.
(gfc_trans_array_constructor_value): Likewise.
(get_array_ctor_strlen): Likewise.
(gfc_constant_array_constructor_p): Likewise.
(gfc_build_constant_array_constructor): Likewise.
(gfc_trans_array_constructor): Likewise.
(gfc_conv_array_initializer): Likewise.
* trans-decl.c (check_constant_initializer): Likewise.
* trans-expr.c (flatten_array_ctors_without_strlen): Likewise.
(gfc_apply_interface_mapping_to_cons): Likewise.
(gfc_trans_structure_assign): Likewise.
(gfc_conv_structure): Likewise.
* array.c (check_duplicate_iterator): Likewise.
(match_array_list): Likewise.
(match_array_cons_element): Likewise.
(gfc_match_array_constructor): Likewise.
(check_constructor_type): Likewise.
(check_constructor): Likewise.
(expand): Likewise.
(expand_constructor): Likewise.
(extract_element): Likewise.
(gfc_expanded_ac): Likewise.
(resolve_array_list): Likewise.
(gfc_resolve_character_array_constructor): Likewise.
(copy_iterator): Renamed to ...
(gfc_copy_iterator): ... this.
(gfc_append_constructor): Removed.
(gfc_insert_constructor): Removed unused function.
(gfc_get_constructor): Removed.
(gfc_free_constructor): Removed.
(qgfc_copy_constructor): Removed.
* gfortran.h (struct gfc_expr): Removed member 'con_by_offset'.
Removed all references. Replaced constructor list by splay-tree.
(struct gfc_constructor): Removed member 'next', moved 'offset' from
the inner struct, added member 'base'.
(gfc_append_constructor): Removed prototype.
(gfc_insert_constructor): Removed prototype.
(gfc_get_constructor): Removed prototype.
(gfc_free_constructor): Removed prototype.
(qgfc_copy_constructor): Removed prototype.
(gfc_copy_iterator): New prototype.
* trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype.
From-SVN: r158253
Diffstat (limited to 'gcc/fortran/expr.c')
-rw-r--r-- | gcc/fortran/expr.c | 930 |
1 files changed, 532 insertions, 398 deletions
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 9e2beb6..700fd10 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -26,8 +26,19 @@ along with GCC; see the file COPYING3. If not see #include "arith.h" #include "match.h" #include "target-memory.h" /* for gfc_convert_boz */ +#include "constructor.h" -/* Get a new expr node. */ + +/* The following set of functions provide access to gfc_expr* of + various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE. + + There are two functions available elsewhere that provide + slightly different flavours of variables. Namely: + expr.c (gfc_get_variable_expr) + symbol.c (gfc_lval_expr_from_sym) + TODO: Merge these functions, if possible. */ + +/* Get a new expression node. */ gfc_expr * gfc_get_expr (void) @@ -39,92 +50,349 @@ gfc_get_expr (void) e->shape = NULL; e->ref = NULL; e->symtree = NULL; - e->con_by_offset = NULL; return e; } -/* Free an argument list and everything below it. */ +/* Get a new expression node that is an array constructor + of given type and kind. */ -void -gfc_free_actual_arglist (gfc_actual_arglist *a1) +gfc_expr * +gfc_get_array_expr (bt type, int kind, locus *where) { - gfc_actual_arglist *a2; + gfc_expr *e; - while (a1) - { - a2 = a1->next; - gfc_free_expr (a1->expr); - gfc_free (a1); - a1 = a2; - } + e = gfc_get_expr (); + e->expr_type = EXPR_ARRAY; + e->value.constructor = NULL; + e->rank = 1; + e->shape = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; } -/* Copy an arglist structure and all of the arguments. */ +/* Get a new expression node that is the NULL expression. */ -gfc_actual_arglist * -gfc_copy_actual_arglist (gfc_actual_arglist *p) +gfc_expr * +gfc_get_null_expr (locus *where) { - gfc_actual_arglist *head, *tail, *new_arg; + gfc_expr *e; - head = tail = NULL; + e = gfc_get_expr (); + e->expr_type = EXPR_NULL; + e->ts.type = BT_UNKNOWN; - for (; p; p = p->next) + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an operator expression node. */ + +gfc_expr * +gfc_get_operator_expr (locus *where, gfc_intrinsic_op op, + gfc_expr *op1, gfc_expr *op2) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_OP; + e->value.op.op = op; + e->value.op.op1 = op1; + e->value.op.op2 = op2; + + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an structure constructor + of given type and kind. */ + +gfc_expr * +gfc_get_structure_constructor_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + e = gfc_get_expr (); + e->expr_type = EXPR_STRUCTURE; + e->value.constructor = NULL; + + e->ts.type = type; + e->ts.kind = kind; + if (where) + e->where = *where; + + return e; +} + + +/* Get a new expression node that is an constant of given type and kind. */ + +gfc_expr * +gfc_get_constant_expr (bt type, int kind, locus *where) +{ + gfc_expr *e; + + if (!where) + gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL"); + + e = gfc_get_expr (); + + e->expr_type = EXPR_CONSTANT; + e->ts.type = type; + e->ts.kind = kind; + e->where = *where; + + switch (type) { - new_arg = gfc_get_actual_arglist (); - *new_arg = *p; + case BT_INTEGER: + mpz_init (e->value.integer); + break; - new_arg->expr = gfc_copy_expr (p->expr); - new_arg->next = NULL; + case BT_REAL: + gfc_set_model_kind (kind); + mpfr_init (e->value.real); + break; - if (head == NULL) - head = new_arg; - else - tail->next = new_arg; + case BT_COMPLEX: + gfc_set_model_kind (kind); + mpc_init2 (e->value.complex, mpfr_get_default_prec()); + break; - tail = new_arg; + default: + break; } - return head; + return e; } -/* Free a list of reference structures. */ +/* Get a new expression node that is an string constant. + If no string is passed, a string of len is allocated, + blanked and null-terminated. */ -void -gfc_free_ref_list (gfc_ref *p) +gfc_expr * +gfc_get_character_expr (int kind, locus *where, const char *src, int len) { - gfc_ref *q; - int i; + gfc_expr *e; + gfc_char_t *dest; - for (; p; p = q) + if (!src) { - q = p->next; + dest = gfc_get_wide_string (len + 1); + gfc_wide_memset (dest, ' ', len); + dest[len] = '\0'; + } + else + dest = gfc_char_to_widechar (src); - switch (p->type) + e = gfc_get_constant_expr (BT_CHARACTER, kind, + where ? where : &gfc_current_locus); + e->value.character.string = dest; + e->value.character.length = len; + + return e; +} + + +/* Get a new expression node that is an integer constant. */ + +gfc_expr * +gfc_get_int_expr (int kind, locus *where, int value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_INTEGER, kind, + where ? where : &gfc_current_locus); + + mpz_init_set_si (p->value.integer, value); + + return p; +} + + +/* Get a new expression node that is a logical constant. */ + +gfc_expr * +gfc_get_logical_expr (int kind, locus *where, bool value) +{ + gfc_expr *p; + p = gfc_get_constant_expr (BT_LOGICAL, kind, + where ? where : &gfc_current_locus); + + p->value.logical = value; + + return p; +} + + +gfc_expr * +gfc_get_iokind_expr (locus *where, io_kind k) +{ + gfc_expr *e; + + /* Set the types to something compatible with iokind. This is needed to + get through gfc_free_expr later since iokind really has no Basic Type, + BT, of its own. */ + + e = gfc_get_expr (); + e->expr_type = EXPR_CONSTANT; + e->ts.type = BT_LOGICAL; + e->value.iokind = k; + e->where = *where; + + return e; +} + + +/* Given an expression pointer, return a copy of the expression. This + subroutine is recursive. */ + +gfc_expr * +gfc_copy_expr (gfc_expr *p) +{ + gfc_expr *q; + gfc_char_t *s; + char *c; + + if (p == NULL) + return NULL; + + q = gfc_get_expr (); + *q = *p; + + switch (q->expr_type) + { + case EXPR_SUBSTRING: + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + break; + + case EXPR_CONSTANT: + /* Copy target representation, if it exists. */ + if (p->representation.string) { - case REF_ARRAY: - for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + c = XCNEWVEC (char, p->representation.length + 1); + q->representation.string = c; + memcpy (c, p->representation.string, (p->representation.length + 1)); + } + + /* Copy the values of any pointer components of p->value. */ + switch (q->ts.type) + { + case BT_INTEGER: + mpz_init_set (q->value.integer, p->value.integer); + break; + + case BT_REAL: + gfc_set_model_kind (q->ts.kind); + mpfr_init (q->value.real); + mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); + break; + + case BT_COMPLEX: + gfc_set_model_kind (q->ts.kind); + mpc_init2 (q->value.complex, mpfr_get_default_prec()); + mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); + break; + + case BT_CHARACTER: + if (p->representation.string) + q->value.character.string + = gfc_char_to_widechar (q->representation.string); + else { - gfc_free_expr (p->u.ar.start[i]); - gfc_free_expr (p->u.ar.end[i]); - gfc_free_expr (p->u.ar.stride[i]); - } + s = gfc_get_wide_string (p->value.character.length + 1); + q->value.character.string = s; + /* This is the case for the C_NULL_CHAR named constant. */ + if (p->value.character.length == 0 + && (p->ts.is_c_interop || p->ts.is_iso_c)) + { + *s = '\0'; + /* Need to set the length to 1 to make sure the NUL + terminator is copied. */ + q->value.character.length = 1; + } + else + memcpy (s, p->value.character.string, + (p->value.character.length + 1) * sizeof (gfc_char_t)); + } break; - case REF_SUBSTRING: - gfc_free_expr (p->u.ss.start); - gfc_free_expr (p->u.ss.end); + case BT_HOLLERITH: + case BT_LOGICAL: + case BT_DERIVED: + case BT_CLASS: + break; /* Already done. */ + + case BT_PROCEDURE: + case BT_VOID: + /* Should never be reached. */ + case BT_UNKNOWN: + gfc_internal_error ("gfc_copy_expr(): Bad expr node"); + /* Not reached. */ + } + + break; + + case EXPR_OP: + switch (q->value.op.op) + { + case INTRINSIC_NOT: + case INTRINSIC_PARENTHESES: + case INTRINSIC_UPLUS: + case INTRINSIC_UMINUS: + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); break; - case REF_COMPONENT: + default: /* Binary operators. */ + q->value.op.op1 = gfc_copy_expr (p->value.op.op1); + q->value.op.op2 = gfc_copy_expr (p->value.op.op2); break; } - gfc_free (p); + break; + + case EXPR_FUNCTION: + q->value.function.actual = + gfc_copy_actual_arglist (p->value.function.actual); + break; + + case EXPR_COMPCALL: + case EXPR_PPC: + q->value.compcall.actual = + gfc_copy_actual_arglist (p->value.compcall.actual); + q->value.compcall.tbp = p->value.compcall.tbp; + break; + + case EXPR_STRUCTURE: + case EXPR_ARRAY: + q->value.constructor = gfc_constructor_copy (p->value.constructor); + break; + + case EXPR_VARIABLE: + case EXPR_NULL: + break; } + + q->shape = gfc_copy_shape (p->shape, p->rank); + + q->ref = gfc_copy_ref (p->ref); + + return q; } @@ -191,7 +459,7 @@ free_expr0 (gfc_expr *e) case EXPR_ARRAY: case EXPR_STRUCTURE: - gfc_free_constructor (e->value.constructor); + gfc_constructor_free (e->value.constructor); break; case EXPR_SUBSTRING: @@ -227,13 +495,95 @@ gfc_free_expr (gfc_expr *e) { if (e == NULL) return; - if (e->con_by_offset) - splay_tree_delete (e->con_by_offset); free_expr0 (e); gfc_free (e); } +/* Free an argument list and everything below it. */ + +void +gfc_free_actual_arglist (gfc_actual_arglist *a1) +{ + gfc_actual_arglist *a2; + + while (a1) + { + a2 = a1->next; + gfc_free_expr (a1->expr); + gfc_free (a1); + a1 = a2; + } +} + + +/* Copy an arglist structure and all of the arguments. */ + +gfc_actual_arglist * +gfc_copy_actual_arglist (gfc_actual_arglist *p) +{ + gfc_actual_arglist *head, *tail, *new_arg; + + head = tail = NULL; + + for (; p; p = p->next) + { + new_arg = gfc_get_actual_arglist (); + *new_arg = *p; + + new_arg->expr = gfc_copy_expr (p->expr); + new_arg->next = NULL; + + if (head == NULL) + head = new_arg; + else + tail->next = new_arg; + + tail = new_arg; + } + + return head; +} + + +/* Free a list of reference structures. */ + +void +gfc_free_ref_list (gfc_ref *p) +{ + gfc_ref *q; + int i; + + for (; p; p = q) + { + q = p->next; + + switch (p->type) + { + case REF_ARRAY: + for (i = 0; i < GFC_MAX_DIMENSIONS; i++) + { + gfc_free_expr (p->u.ar.start[i]); + gfc_free_expr (p->u.ar.end[i]); + gfc_free_expr (p->u.ar.stride[i]); + } + + break; + + case REF_SUBSTRING: + gfc_free_expr (p->u.ss.start); + gfc_free_expr (p->u.ss.end); + break; + + case REF_COMPONENT: + break; + } + + gfc_free (p); + } +} + + /* Graft the *src expression onto the *dest subexpression. */ void @@ -420,147 +770,6 @@ gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim) } -/* Given an expression pointer, return a copy of the expression. This - subroutine is recursive. */ - -gfc_expr * -gfc_copy_expr (gfc_expr *p) -{ - gfc_expr *q; - gfc_char_t *s; - char *c; - - if (p == NULL) - return NULL; - - q = gfc_get_expr (); - *q = *p; - - switch (q->expr_type) - { - case EXPR_SUBSTRING: - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - break; - - case EXPR_CONSTANT: - /* Copy target representation, if it exists. */ - if (p->representation.string) - { - c = XCNEWVEC (char, p->representation.length + 1); - q->representation.string = c; - memcpy (c, p->representation.string, (p->representation.length + 1)); - } - - /* Copy the values of any pointer components of p->value. */ - switch (q->ts.type) - { - case BT_INTEGER: - mpz_init_set (q->value.integer, p->value.integer); - break; - - case BT_REAL: - gfc_set_model_kind (q->ts.kind); - mpfr_init (q->value.real); - mpfr_set (q->value.real, p->value.real, GFC_RND_MODE); - break; - - case BT_COMPLEX: - gfc_set_model_kind (q->ts.kind); - mpc_init2 (q->value.complex, mpfr_get_default_prec()); - mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE); - break; - - case BT_CHARACTER: - if (p->representation.string) - q->value.character.string - = gfc_char_to_widechar (q->representation.string); - else - { - s = gfc_get_wide_string (p->value.character.length + 1); - q->value.character.string = s; - - /* This is the case for the C_NULL_CHAR named constant. */ - if (p->value.character.length == 0 - && (p->ts.is_c_interop || p->ts.is_iso_c)) - { - *s = '\0'; - /* Need to set the length to 1 to make sure the NUL - terminator is copied. */ - q->value.character.length = 1; - } - else - memcpy (s, p->value.character.string, - (p->value.character.length + 1) * sizeof (gfc_char_t)); - } - break; - - case BT_HOLLERITH: - case BT_LOGICAL: - case BT_DERIVED: - case BT_CLASS: - break; /* Already done. */ - - case BT_PROCEDURE: - case BT_VOID: - /* Should never be reached. */ - case BT_UNKNOWN: - gfc_internal_error ("gfc_copy_expr(): Bad expr node"); - /* Not reached. */ - } - - break; - - case EXPR_OP: - switch (q->value.op.op) - { - case INTRINSIC_NOT: - case INTRINSIC_PARENTHESES: - case INTRINSIC_UPLUS: - case INTRINSIC_UMINUS: - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - break; - - default: /* Binary operators. */ - q->value.op.op1 = gfc_copy_expr (p->value.op.op1); - q->value.op.op2 = gfc_copy_expr (p->value.op.op2); - break; - } - - break; - - case EXPR_FUNCTION: - q->value.function.actual = - gfc_copy_actual_arglist (p->value.function.actual); - break; - - case EXPR_COMPCALL: - case EXPR_PPC: - q->value.compcall.actual = - gfc_copy_actual_arglist (p->value.compcall.actual); - q->value.compcall.tbp = p->value.compcall.tbp; - break; - - case EXPR_STRUCTURE: - case EXPR_ARRAY: - q->value.constructor = gfc_copy_constructor (p->value.constructor); - break; - - case EXPR_VARIABLE: - case EXPR_NULL: - break; - } - - q->shape = gfc_copy_shape (p->shape, p->rank); - - q->ref = gfc_copy_ref (p->ref); - - return q; -} - - /* Return the maximum kind of two expressions. In general, higher kind numbers mean more precision for numeric types. */ @@ -589,48 +798,6 @@ gfc_numeric_ts (gfc_typespec *ts) } -/* Returns an expression node that is an integer constant. */ - -gfc_expr * -gfc_int_expr (int i) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_INTEGER; - p->ts.kind = gfc_default_integer_kind; - - p->where = gfc_current_locus; - mpz_init_set_si (p->value.integer, i); - - return p; -} - - -/* Returns an expression node that is a logical constant. */ - -gfc_expr * -gfc_logical_expr (int i, locus *where) -{ - gfc_expr *p; - - p = gfc_get_expr (); - - p->expr_type = EXPR_CONSTANT; - p->ts.type = BT_LOGICAL; - p->ts.kind = gfc_default_logical_kind; - - if (where == NULL) - where = &gfc_current_locus; - p->where = *where; - p->value.logical = i; - - return p; -} - - /* Return an expression node with an optional argument list attached. A variable number of gfc_expr pointers are strung together in an argument list with a NULL pointer terminating the list. */ @@ -764,7 +931,6 @@ gfc_is_constant_expr (gfc_expr *e) { gfc_constructor *c; gfc_actual_arglist *arg; - int rv; if (e == NULL) return 1; @@ -772,68 +938,55 @@ gfc_is_constant_expr (gfc_expr *e) switch (e->expr_type) { case EXPR_OP: - rv = (gfc_is_constant_expr (e->value.op.op1) - && (e->value.op.op2 == NULL - || gfc_is_constant_expr (e->value.op.op2))); - break; + return (gfc_is_constant_expr (e->value.op.op1) + && (e->value.op.op2 == NULL + || gfc_is_constant_expr (e->value.op.op2))); case EXPR_VARIABLE: - rv = 0; - break; + return 0; case EXPR_FUNCTION: case EXPR_PPC: case EXPR_COMPCALL: /* Specification functions are constant. */ if (check_specification_function (e) == MATCH_YES) - { - rv = 1; - break; - } + return 1; /* Call to intrinsic with at least one argument. */ - rv = 0; if (e->value.function.isym && e->value.function.actual) { for (arg = e->value.function.actual; arg; arg = arg->next) - { - if (!gfc_is_constant_expr (arg->expr)) - break; - } - if (arg == NULL) - rv = 1; + if (!gfc_is_constant_expr (arg->expr)) + return 0; + + return 1; } - break; + else + return 0; case EXPR_CONSTANT: case EXPR_NULL: - rv = 1; - break; + return 1; case EXPR_SUBSTRING: - rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) - && gfc_is_constant_expr (e->ref->u.ss.end)); - break; + return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start) + && gfc_is_constant_expr (e->ref->u.ss.end)); case EXPR_STRUCTURE: - rv = 0; - for (c = e->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) if (!gfc_is_constant_expr (c->expr)) - break; + return 0; - if (c == NULL) - rv = 1; - break; + return 1; case EXPR_ARRAY: - rv = gfc_constant_ac (e); - break; + return gfc_constant_ac (e); default: gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type"); + return 0; } - - return rv; } @@ -1005,11 +1158,12 @@ simplify_intrinsic_op (gfc_expr *p, int type) with gfc_simplify_expr(). */ static gfc_try -simplify_constructor (gfc_constructor *c, int type) +simplify_constructor (gfc_constructor_base base, int type) { + gfc_constructor *c; gfc_expr *p; - for (; c; c = c->next) + for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c)) { if (c->iterator && (gfc_simplify_expr (c->iterator->start, type) == FAILURE @@ -1041,7 +1195,7 @@ simplify_constructor (gfc_constructor *c, int type) /* Pull a single array element out of an array constructor. */ static gfc_try -find_array_element (gfc_constructor *cons, gfc_array_ref *ar, +find_array_element (gfc_constructor_base base, gfc_array_ref *ar, gfc_constructor **rval) { unsigned long nelemen; @@ -1050,6 +1204,7 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_t offset; mpz_t span; mpz_t tmp; + gfc_constructor *cons; gfc_expr *e; gfc_try t; @@ -1104,16 +1259,13 @@ find_array_element (gfc_constructor *cons, gfc_array_ref *ar, mpz_mul (span, span, tmp); } - for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--) + for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset); + cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--) { - if (cons) + if (cons->iterator) { - if (cons->iterator) - { - cons = NULL; - goto depart; - } - cons = cons->next; + cons = NULL; + goto depart; } } @@ -1132,20 +1284,21 @@ depart: /* Find a component of a structure constructor. */ static gfc_constructor * -find_component_ref (gfc_constructor *cons, gfc_ref *ref) +find_component_ref (gfc_constructor_base base, gfc_ref *ref) { gfc_component *comp; gfc_component *pick; + gfc_constructor *c = gfc_constructor_first (base); comp = ref->u.c.sym->components; pick = ref->u.c.component; while (comp != pick) { comp = comp->next; - cons = cons->next; + c = gfc_constructor_next (c); } - return cons; + return c; } @@ -1190,15 +1343,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_t tmp_mpz; mpz_t nelts; mpz_t ptr; - mpz_t index; - gfc_constructor *cons; - gfc_constructor *base; + gfc_constructor_base base; + gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS]; gfc_expr *begin; gfc_expr *finish; gfc_expr *step; gfc_expr *upper; gfc_expr *lower; - gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c; gfc_try t; t = SUCCESS; @@ -1240,6 +1391,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */ { + gfc_constructor *ci; gcc_assert (begin); if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin)) @@ -1256,16 +1408,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) break; } - vecsub[d] = begin->value.constructor; + vecsub[d] = gfc_constructor_first (begin->value.constructor); mpz_set (ctr[d], vecsub[d]->expr->value.integer); mpz_mul (nelts, nelts, begin->shape[0]); mpz_set (expr->shape[shape_i++], begin->shape[0]); /* Check bounds. */ - for (c = vecsub[d]; c; c = c->next) + for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci)) { - if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0 - || mpz_cmp (c->expr->value.integer, + if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0 + || mpz_cmp (ci->expr->value.integer, lower->value.integer) < 0) { gfc_error ("index in dimension %d is out of bounds " @@ -1346,9 +1498,8 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) mpz_mul (delta_mpz, delta_mpz, tmp_mpz); } - mpz_init (index); mpz_init (ptr); - cons = base; + cons = gfc_constructor_first (base); /* Now clock through the array reference, calculating the index in the source constructor and transferring the elements to the new @@ -1374,11 +1525,11 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) { gcc_assert(vecsub[d]); - if (!vecsub[d]->next) - vecsub[d] = ref->u.ar.start[d]->value.constructor; + if (!gfc_constructor_next (vecsub[d])) + vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor); else { - vecsub[d] = vecsub[d]->next; + vecsub[d] = gfc_constructor_next (vecsub[d]); incr_ctr = false; } mpz_set (ctr[d], vecsub[d]->expr->value.integer); @@ -1396,25 +1547,13 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) } } - /* There must be a better way of dealing with negative strides - than resetting the index and the constructor pointer! */ - if (mpz_cmp (ptr, index) < 0) - { - mpz_set_ui (index, 0); - cons = base; - } - - while (cons && cons->next && mpz_cmp (ptr, index) > 0) - { - mpz_add_ui (index, index, one); - cons = cons->next; - } - - gfc_append_constructor (expr, gfc_copy_expr (cons->expr)); + cons = gfc_constructor_lookup (base, mpz_get_ui (ptr)); + gcc_assert (cons); + gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (cons->expr), NULL); } mpz_clear (ptr); - mpz_clear (index); cleanup: @@ -1429,7 +1568,7 @@ cleanup: mpz_clear (ctr[d]); mpz_clear (stride[d]); } - gfc_free_constructor (base); + gfc_constructor_free (base); return t; } @@ -1470,7 +1609,7 @@ find_substring_ref (gfc_expr *p, gfc_expr **newp) static gfc_try simplify_const_ref (gfc_expr *p) { - gfc_constructor *cons; + gfc_constructor *cons, *c; gfc_expr *newp; gfc_ref *last_ref; @@ -1510,20 +1649,20 @@ simplify_const_ref (gfc_expr *p) if (p->ref->next != NULL && (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED)) { - cons = p->value.constructor; - for (; cons; cons = cons->next) + for (c = gfc_constructor_first (p->value.constructor); + c; c = gfc_constructor_next (c)) { - cons->expr->ref = gfc_copy_ref (p->ref->next); - if (simplify_const_ref (cons->expr) == FAILURE) + c->expr->ref = gfc_copy_ref (p->ref->next); + if (simplify_const_ref (c->expr) == FAILURE) return FAILURE; } if (p->ts.type == BT_DERIVED && p->ref->next - && p->value.constructor) + && (c = gfc_constructor_first (p->value.constructor))) { /* There may have been component references. */ - p->ts = p->value.constructor->expr->ts; + p->ts = c->expr->ts; } last_ref = p->ref; @@ -1537,9 +1676,9 @@ simplify_const_ref (gfc_expr *p) character length according to the first element (as all should have the same length). */ int string_len; - if (p->value.constructor) + if ((c = gfc_constructor_first (p->value.constructor))) { - const gfc_expr* first = p->value.constructor->expr; + const gfc_expr* first = c->expr; gcc_assert (first->expr_type == EXPR_CONSTANT); gcc_assert (first->ts.type == BT_CHARACTER); string_len = first->value.character.length; @@ -1553,7 +1692,9 @@ simplify_const_ref (gfc_expr *p) else gfc_free_expr (p->ts.u.cl->length); - p->ts.u.cl->length = gfc_int_expr (string_len); + p->ts.u.cl->length + = gfc_get_int_expr (gfc_default_integer_kind, + NULL, string_len); } } gfc_free_ref_list (p->ref); @@ -1724,7 +1865,9 @@ gfc_simplify_expr (gfc_expr *p, int type) p->value.character.string = s; p->value.character.length = end - start; p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); - p->ts.u.cl->length = gfc_int_expr (p->value.character.length); + p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, + NULL, + p->value.character.length); gfc_free_ref_list (p->ref); p->ref = NULL; p->expr_type = EXPR_CONSTANT; @@ -1812,10 +1955,12 @@ static gfc_try scalarize_intrinsic_call (gfc_expr *e) { gfc_actual_arglist *a, *b; - gfc_constructor *args[5], *ctor, *new_ctor; + gfc_constructor_base ctor; + gfc_constructor *args[5]; + gfc_constructor *ci, *new_ctor; gfc_expr *expr, *old; int n, i, rank[5], array_arg; - + /* Find which, if any, arguments are arrays. Assume that the old expression carries the type information and that the first arg that is an array expression carries all the shape information.*/ @@ -1836,9 +1981,8 @@ scalarize_intrinsic_call (gfc_expr *e) old = gfc_copy_expr (e); - gfc_free_constructor (expr->value.constructor); + gfc_constructor_free (expr->value.constructor); expr->value.constructor = NULL; - expr->ts = old->ts; expr->where = old->where; expr->expr_type = EXPR_ARRAY; @@ -1858,7 +2002,7 @@ scalarize_intrinsic_call (gfc_expr *e) { rank[n] = a->expr->rank; ctor = a->expr->symtree->n.sym->value->value.constructor; - args[n] = gfc_copy_constructor (ctor); + args[n] = gfc_constructor_first (ctor); } else if (a->expr && a->expr->expr_type == EXPR_ARRAY) { @@ -1866,10 +2010,12 @@ scalarize_intrinsic_call (gfc_expr *e) rank[n] = a->expr->rank; else rank[n] = 1; - args[n] = gfc_copy_constructor (a->expr->value.constructor); + ctor = gfc_constructor_copy (a->expr->value.constructor); + args[n] = gfc_constructor_first (ctor); } else args[n] = NULL; + n++; } @@ -1877,53 +2023,46 @@ scalarize_intrinsic_call (gfc_expr *e) /* Using the array argument as the master, step through the array calling the function for each element and advancing the array constructors together. */ - ctor = args[array_arg - 1]; - new_ctor = NULL; - for (; ctor; ctor = ctor->next) + for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci)) { - if (expr->value.constructor == NULL) - expr->value.constructor - = new_ctor = gfc_get_constructor (); + new_ctor = gfc_constructor_append_expr (&expr->value.constructor, + gfc_copy_expr (old), NULL); + + gfc_free_actual_arglist (new_ctor->expr->value.function.actual); + a = NULL; + b = old->value.function.actual; + for (i = 0; i < n; i++) + { + if (a == NULL) + new_ctor->expr->value.function.actual + = a = gfc_get_actual_arglist (); else { - new_ctor->next = gfc_get_constructor (); - new_ctor = new_ctor->next; + a->next = gfc_get_actual_arglist (); + a = a->next; } - new_ctor->expr = gfc_copy_expr (old); - gfc_free_actual_arglist (new_ctor->expr->value.function.actual); - a = NULL; - b = old->value.function.actual; - for (i = 0; i < n; i++) - { - if (a == NULL) - new_ctor->expr->value.function.actual - = a = gfc_get_actual_arglist (); - else - { - a->next = gfc_get_actual_arglist (); - a = a->next; - } - if (args[i]) - a->expr = gfc_copy_expr (args[i]->expr); - else - a->expr = gfc_copy_expr (b->expr); - b = b->next; - } + if (args[i]) + a->expr = gfc_copy_expr (args[i]->expr); + else + a->expr = gfc_copy_expr (b->expr); - /* Simplify the function calls. If the simplification fails, the - error will be flagged up down-stream or the library will deal - with it. */ - gfc_simplify_expr (new_ctor->expr, 0); + b = b->next; + } - for (i = 0; i < n; i++) - if (args[i]) - args[i] = args[i]->next; + /* Simplify the function calls. If the simplification fails, the + error will be flagged up down-stream or the library will deal + with it. */ + gfc_simplify_expr (new_ctor->expr, 0); - for (i = 1; i < n; i++) - if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) - || (args[i] == NULL && args[array_arg - 1] != NULL))) - goto compliance; + for (i = 0; i < n; i++) + if (args[i]) + args[i] = gfc_constructor_next (args[i]); + + for (i = 1; i < n; i++) + if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL) + || (args[i] == NULL && args[array_arg - 1] != NULL))) + goto compliance; } free_expr0 (e); @@ -2063,21 +2202,22 @@ not_numeric: static gfc_try check_alloc_comp_init (gfc_expr *e) { - gfc_component *c; + gfc_component *comp; gfc_constructor *ctor; gcc_assert (e->expr_type == EXPR_STRUCTURE); gcc_assert (e->ts.type == BT_DERIVED); - for (c = e->ts.u.derived->components, ctor = e->value.constructor; - c; c = c->next, ctor = ctor->next) + for (comp = e->ts.u.derived->components, + ctor = gfc_constructor_first (e->value.constructor); + comp; comp = comp->next, ctor = gfc_constructor_next (ctor)) { - if (c->attr.allocatable + if (comp->attr.allocatable && ctor->expr->expr_type != EXPR_NULL) { gfc_error("Invalid initialization expression for ALLOCATABLE " "component '%s' in structure constructor at %L", - c->name, &ctor->expr->where); + comp->name, &ctor->expr->where); return FAILURE; } } @@ -3444,45 +3584,38 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue) gfc_expr * gfc_default_initializer (gfc_typespec *ts) { - gfc_constructor *tail; gfc_expr *init; - gfc_component *c; + gfc_component *comp; /* See if we have a default initializer. */ - for (c = ts->u.derived->components; c; c = c->next) - if (c->initializer || c->attr.allocatable) + for (comp = ts->u.derived->components; comp; comp = comp->next) + if (comp->initializer || comp->attr.allocatable) break; - if (!c) + if (!comp) return NULL; - /* Build the constructor. */ - init = gfc_get_expr (); - init->expr_type = EXPR_STRUCTURE; + init = gfc_get_structure_constructor_expr (ts->type, ts->kind, + &ts->u.derived->declared_at); init->ts = *ts; - init->where = ts->u.derived->declared_at; - tail = NULL; - for (c = ts->u.derived->components; c; c = c->next) + for (comp = ts->u.derived->components; comp; comp = comp->next) { - if (tail == NULL) - init->value.constructor = tail = gfc_get_constructor (); - else - { - tail->next = gfc_get_constructor (); - tail = tail->next; - } + gfc_constructor *ctor = gfc_constructor_get(); - if (c->initializer) - tail->expr = gfc_copy_expr (c->initializer); + if (comp->initializer) + ctor->expr = gfc_copy_expr (comp->initializer); - if (c->attr.allocatable) + if (comp->attr.allocatable) { - tail->expr = gfc_get_expr (); - tail->expr->expr_type = EXPR_NULL; - tail->expr->ts = c->ts; + ctor->expr = gfc_get_expr (); + ctor->expr->expr_type = EXPR_NULL; + ctor->expr->ts = comp->ts; } + + gfc_constructor_append (&init->value.constructor, ctor); } + return init; } @@ -3611,7 +3744,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, case EXPR_STRUCTURE: case EXPR_ARRAY: - for (c = expr->value.constructor; c; c = c->next) + for (c = gfc_constructor_first (expr->value.constructor); + c; c = gfc_constructor_next (c)) { if (gfc_traverse_expr (c->expr, sym, func, f)) return true; |