* 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158253
138bc75d-0d04-0410-961f-
82ee72b054a4
+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.
+
2010-04-10 Tobias Burnus <burnus@net-b.de>
PR fortran/43591
# from the parse tree to GENERIC
F95_PARSER_OBJS = fortran/arith.o fortran/array.o fortran/bbt.o \
- fortran/check.o fortran/class.o fortran/constructor.o fortran/cpp.o \
- fortran/data.o fortran/decl.o fortran/dump-parse-tree.o fortran/error.o \
- fortran/expr.o fortran/interface.o fortran/intrinsic.o fortran/io.o \
- fortran/iresolve.o fortran/match.o fortran/matchexp.o fortran/misc.o \
- fortran/module.o fortran/openmp.o fortran/options.o fortran/parse.o \
- fortran/primary.o fortran/resolve.o fortran/scanner.o fortran/simplify.o \
- fortran/st.o fortran/symbol.o fortran/target-memory.o
+ fortran/check.o fortran/constructor.o fortran/cpp.o fortran/data.o \
+ fortran/decl.o fortran/dump-parse-tree.o fortran/error.o fortran/expr.o \
+ fortran/interface.o fortran/intrinsic.o fortran/io.o fortran/iresolve.o \
+ fortran/match.o fortran/matchexp.o fortran/misc.o fortran/module.o \
+ fortran/openmp.o fortran/options.o fortran/parse.o fortran/primary.o \
+ fortran/resolve.o fortran/scanner.o fortran/simplify.o fortran/st.o \
+ fortran/symbol.o fortran/target-memory.o
F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
fortran/convert.o fortran/dependency.o fortran/f95-lang.o \
$(TREE_DUMP_H) debug.h pointer-set.h
fortran/trans-types.o: $(GFORTRAN_TRANS_DEPS) gt-fortran-trans-types.h \
$(REAL_H) toplev.h $(TARGET_H) $(FLAGS_H) dwarf2out.h
-fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS) realmpfr.h
+fortran/trans-const.o: $(GFORTRAN_TRANS_DEPS)
fortran/trans-expr.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-stmt.o: $(GFORTRAN_TRANS_DEPS) fortran/dependency.h
fortran/trans-openmp.o: $(GFORTRAN_TRANS_DEPS)
#include "system.h"
#include "gfortran.h"
#include "match.h"
+#include "constructor.h"
/**************** Array reference matching subroutines *****************/
if (gfc_match_char ('*') == MATCH_YES)
{
- *lower = gfc_int_expr (1);
+ *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
return AS_ASSUMED_SIZE;
}
if (gfc_match_char (':') == MATCH_NO)
{
- *lower = gfc_int_expr (1);
+ *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
return AS_EXPLICIT;
}
for (i = 0; i < as->rank + as->corank; i++)
{
if (as->lower[i] == NULL)
- as->lower[i] = gfc_int_expr (1);
+ as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
}
}
/****************** Array constructor functions ******************/
-/* Start an array constructor. The constructor starts with zero
- elements and should be appended to by gfc_append_constructor(). */
-
-gfc_expr *
-gfc_start_constructor (bt type, int kind, locus *where)
-{
- gfc_expr *result;
-
- result = gfc_get_expr ();
-
- result->expr_type = EXPR_ARRAY;
- result->rank = 1;
-
- result->ts.type = type;
- result->ts.kind = kind;
- result->where = *where;
- return result;
-}
-
-
-/* Given an array constructor expression, append the new expression
- node onto the constructor. */
-
-void
-gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
-{
- gfc_constructor *c;
-
- if (base->value.constructor == NULL)
- base->value.constructor = c = gfc_get_constructor ();
- else
- {
- c = base->value.constructor;
- while (c->next)
- c = c->next;
-
- c->next = gfc_get_constructor ();
- c = c->next;
- }
-
- c->expr = new_expr;
-
- if (new_expr
- && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
- gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
-}
-
-
-/* Given an array constructor expression, insert the new expression's
- constructor onto the base's one according to the offset. */
-
-void
-gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
-{
- gfc_constructor *c, *pre;
- expr_t type;
- int t;
-
- type = base->expr_type;
-
- if (base->value.constructor == NULL)
- base->value.constructor = c1;
- else
- {
- c = pre = base->value.constructor;
- while (c)
- {
- if (type == EXPR_ARRAY)
- {
- t = mpz_cmp (c->n.offset, c1->n.offset);
- if (t < 0)
- {
- pre = c;
- c = c->next;
- }
- else if (t == 0)
- {
- gfc_error ("duplicated initializer");
- break;
- }
- else
- break;
- }
- else
- {
- pre = c;
- c = c->next;
- }
- }
-
- if (pre != c)
- {
- pre->next = c1;
- c1->next = c;
- }
- else
- {
- c1->next = c;
- base->value.constructor = c1;
- }
- }
-}
-
-
-/* Get a new constructor. */
-
-gfc_constructor *
-gfc_get_constructor (void)
-{
- gfc_constructor *c;
-
- c = XCNEW (gfc_constructor);
- c->expr = NULL;
- c->iterator = NULL;
- c->next = NULL;
- mpz_init_set_si (c->n.offset, 0);
- mpz_init_set_si (c->repeat, 0);
- return c;
-}
-
-
-/* Free chains of gfc_constructor structures. */
-
-void
-gfc_free_constructor (gfc_constructor *p)
-{
- gfc_constructor *next;
-
- if (p == NULL)
- return;
-
- for (; p; p = next)
- {
- next = p->next;
-
- if (p->expr)
- gfc_free_expr (p->expr);
- if (p->iterator != NULL)
- gfc_free_iterator (p->iterator, 1);
- mpz_clear (p->n.offset);
- mpz_clear (p->repeat);
- gfc_free (p);
- }
-}
-
/* Given an expression node that might be an array constructor and a
symbol, make sure that no iterators in this or child constructors
duplicate was found. */
static int
-check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
+check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
e = c->expr;
/* Forward declaration because these functions are mutually recursive. */
-static match match_array_cons_element (gfc_constructor **);
+static match match_array_cons_element (gfc_constructor_base *);
/* Match a list of array elements. */
static match
-match_array_list (gfc_constructor **result)
+match_array_list (gfc_constructor_base *result)
{
- gfc_constructor *p, *head, *tail, *new_cons;
+ gfc_constructor_base head;
+ gfc_constructor *p;
gfc_iterator iter;
locus old_loc;
gfc_expr *e;
if (m != MATCH_YES)
goto cleanup;
- tail = head;
-
if (gfc_match_char (',') != MATCH_YES)
{
m = MATCH_NO;
if (m == MATCH_ERROR)
goto cleanup;
- m = match_array_cons_element (&new_cons);
+ m = match_array_cons_element (&head);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto cleanup; /* Could be a complex constant */
}
- tail->next = new_cons;
- tail = new_cons;
-
if (gfc_match_char (',') != MATCH_YES)
{
if (n > 2)
goto cleanup;
}
- e = gfc_get_expr ();
- e->expr_type = EXPR_ARRAY;
- e->where = old_loc;
+ e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
e->value.constructor = head;
- p = gfc_get_constructor ();
- p->where = gfc_current_locus;
+ p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
p->iterator = gfc_get_iterator ();
*p->iterator = iter;
- p->expr = e;
- *result = p;
-
return MATCH_YES;
syntax:
m = MATCH_ERROR;
cleanup:
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
gfc_free_iterator (&iter, 0);
gfc_current_locus = old_loc;
return m;
single expression or a list of elements. */
static match
-match_array_cons_element (gfc_constructor **result)
+match_array_cons_element (gfc_constructor_base *result)
{
- gfc_constructor *p;
gfc_expr *expr;
match m;
if (m != MATCH_YES)
return m;
- p = gfc_get_constructor ();
- p->where = gfc_current_locus;
- p->expr = expr;
-
- *result = p;
+ gfc_constructor_append_expr (result, expr, &gfc_current_locus);
return MATCH_YES;
}
match
gfc_match_array_constructor (gfc_expr **result)
{
- gfc_constructor *head, *tail, *new_cons;
+ gfc_constructor_base head, new_cons;
gfc_expr *expr;
gfc_typespec ts;
locus where;
end_delim = " /)";
where = gfc_current_locus;
- head = tail = NULL;
+ head = new_cons = NULL;
seen_ts = false;
/* Try to match an optional "type-spec ::" */
for (;;)
{
- m = match_array_cons_element (&new_cons);
+ m = match_array_cons_element (&head);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
- if (head == NULL)
- head = new_cons;
- else
- tail->next = new_cons;
-
- tail = new_cons;
-
if (gfc_match_char (',') == MATCH_NO)
break;
}
goto syntax;
done:
- expr = gfc_get_expr ();
-
- expr->expr_type = EXPR_ARRAY;
-
- expr->value.constructor = head;
/* Size must be calculated at resolution time. */
-
if (seen_ts)
- expr->ts = ts;
+ {
+ expr = gfc_get_array_expr (ts.type, ts.kind, &where);
+ expr->ts = ts;
+ }
else
- expr->ts.type = BT_UNKNOWN;
-
+ expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
+
+ expr->value.constructor = head;
if (expr->ts.u.cl)
expr->ts.u.cl->length_from_typespec = seen_ts;
- expr->where = where;
- expr->rank = 1;
-
*result = expr;
return MATCH_YES;
gfc_error ("Syntax error in array constructor at %C");
cleanup:
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
return MATCH_ERROR;
}
/* Recursive work function for gfc_check_constructor_type(). */
static gfc_try
-check_constructor_type (gfc_constructor *c, bool convert)
+check_constructor_type (gfc_constructor_base base, bool convert)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
e = c->expr;
static cons_stack *base;
-static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
+static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
/* Check an EXPR_VARIABLE expression in a constructor to make sure
that that variable is an iteration variables. */
constructor, giving variables with the names of iterators a pass. */
static gfc_try
-check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
+check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
gfc_try t;
+ gfc_constructor *c;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
{
e = c->expr;
typedef struct
{
- gfc_constructor *new_head, *new_tail;
+ gfc_constructor_base base;
int extract_count, extract_n;
gfc_expr *extracted;
mpz_t *count;
static expand_info current_expand;
-static gfc_try expand_constructor (gfc_constructor *);
+static gfc_try expand_constructor (gfc_constructor_base);
/* Work function that counts the number of elements present in a
static gfc_try
expand (gfc_expr *e)
{
- if (current_expand.new_head == NULL)
- current_expand.new_head = current_expand.new_tail =
- gfc_get_constructor ();
- else
- {
- current_expand.new_tail->next = gfc_get_constructor ();
- current_expand.new_tail = current_expand.new_tail->next;
- }
+ gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
+ e, &e->where);
- current_expand.new_tail->where = e->where;
- current_expand.new_tail->expr = e;
-
- mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
- current_expand.new_tail->n.component = current_expand.component;
- mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
+ c->n.component = current_expand.component;
return SUCCESS;
}
if (p == NULL)
return; /* Variable not found */
- gfc_replace_expr (e, gfc_int_expr (0));
+ gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
mpz_set (e->value.integer, p->value);
passed expression. */
static gfc_try
-expand_constructor (gfc_constructor *c)
+expand_constructor (gfc_constructor_base base)
{
+ gfc_constructor *c;
gfc_expr *e;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
{
if (c->iterator != NULL)
{
gfc_free_expr (e);
return FAILURE;
}
- current_expand.offset = &c->n.offset;
- current_expand.component = c->n.component;
+ current_expand.offset = &c->offset;
current_expand.repeat = &c->repeat;
+ current_expand.component = c->n.component;
if (current_expand.expand_work_function (e) == FAILURE)
return FAILURE;
}
}
+/* Given an array expression and an element number (starting at zero),
+ return a pointer to the array element. NULL is returned if the
+ size of the array has been exceeded. The expression node returned
+ remains a part of the array and should not be freed. Access is not
+ efficient at all, but this is another place where things do not
+ have to be particularly fast. */
+
+static gfc_expr *
+gfc_get_array_element (gfc_expr *array, int element)
+{
+ expand_info expand_save;
+ gfc_expr *e;
+ gfc_try rc;
+
+ expand_save = current_expand;
+ current_expand.extract_n = element;
+ current_expand.expand_work_function = extract_element;
+ current_expand.extracted = NULL;
+ current_expand.extract_count = 0;
+
+ iter_stack = NULL;
+
+ rc = expand_constructor (array->value.constructor);
+ e = current_expand.extracted;
+ current_expand = expand_save;
+
+ if (rc == FAILURE)
+ return NULL;
+
+ return e;
+}
+
+
/* Top level subroutine for expanding constructors. We only expand
constructor if they are small enough. */
gfc_expr *f;
gfc_try rc;
+ /* If we can successfully get an array element at the max array size then
+ the array is too big to expand, so we just return. */
f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
if (f != NULL)
{
return SUCCESS;
}
+ /* We now know the array is not too big so go ahead and try to expand it. */
expand_save = current_expand;
- current_expand.new_head = current_expand.new_tail = NULL;
+ current_expand.base = NULL;
iter_stack = NULL;
if (expand_constructor (e->value.constructor) == FAILURE)
{
- gfc_free_constructor (current_expand.new_head);
+ gfc_constructor_free (current_expand.base);
rc = FAILURE;
goto done;
}
- gfc_free_constructor (e->value.constructor);
- e->value.constructor = current_expand.new_head;
+ gfc_constructor_free (e->value.constructor);
+ e->value.constructor = current_expand.base;
rc = SUCCESS;
{
expand_info expand_save;
gfc_try rc;
- gfc_constructor * con;
-
- rc = SUCCESS;
- if (e->value.constructor
- && e->value.constructor->expr->expr_type == EXPR_ARRAY)
- {
- /* Expand the constructor. */
- iter_stack = NULL;
- expand_save = current_expand;
- current_expand.expand_work_function = is_constant_element;
+ iter_stack = NULL;
+ expand_save = current_expand;
+ current_expand.expand_work_function = is_constant_element;
- rc = expand_constructor (e->value.constructor);
-
- current_expand = expand_save;
- }
- else
- {
- /* No need to expand this further. */
- for (con = e->value.constructor; con; con = con->next)
- {
- if (con->expr->expr_type == EXPR_CONSTANT)
- continue;
- else
- {
- if (!gfc_is_constant_expr (con->expr))
- rc = FAILURE;
- }
- }
- }
+ rc = expand_constructor (e->value.constructor);
+ current_expand = expand_save;
if (rc == FAILURE)
return 0;
int
gfc_expanded_ac (gfc_expr *e)
{
- gfc_constructor *p;
+ gfc_constructor *c;
if (e->expr_type == EXPR_ARRAY)
- for (p = e->value.constructor; p; p = p->next)
- if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
return 0;
return 1;
be of the same type. */
static gfc_try
-resolve_array_list (gfc_constructor *p)
+resolve_array_list (gfc_constructor_base base)
{
gfc_try t;
+ gfc_constructor *c;
t = SUCCESS;
- for (; p; p = p->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
- if (p->iterator != NULL
- && gfc_resolve_iterator (p->iterator, false) == FAILURE)
+ if (c->iterator != NULL
+ && gfc_resolve_iterator (c->iterator, false) == FAILURE)
t = FAILURE;
- if (gfc_resolve_expr (p->expr) == FAILURE)
+ if (gfc_resolve_expr (c->expr) == FAILURE)
t = FAILURE;
}
if (expr->ts.u.cl == NULL)
{
- for (p = expr->value.constructor; p; p = p->next)
+ for (p = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
if (p->expr->ts.u.cl != NULL)
{
/* Ensure that if there is a char_len around that it is
/* Check that all constant string elements have the same length until
we reach the end or find a variable-length one. */
- for (p = expr->value.constructor; p; p = p->next)
+ for (p = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
{
int current_length = -1;
gfc_ref *ref;
gcc_assert (found_length != -1);
/* Update the character length of the array constructor. */
- expr->ts.u.cl->length = gfc_int_expr (found_length);
+ expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, found_length);
}
else
{
(without typespec) all elements are verified to have the same length
anyway. */
if (found_length != -1)
- for (p = expr->value.constructor; p; p = p->next)
+ for (p = gfc_constructor_first (expr->value.constructor);
+ p; p = gfc_constructor_next (p))
if (p->expr->expr_type == EXPR_CONSTANT)
{
gfc_expr *cl = NULL;
/* Copy an iterator structure. */
-static gfc_iterator *
-copy_iterator (gfc_iterator *src)
+gfc_iterator *
+gfc_copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
}
-/* Copy a constructor structure. */
-
-gfc_constructor *
-gfc_copy_constructor (gfc_constructor *src)
-{
- gfc_constructor *dest;
- gfc_constructor *tail;
-
- if (src == NULL)
- return NULL;
-
- dest = tail = NULL;
- while (src)
- {
- if (dest == NULL)
- dest = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
- tail->where = src->where;
- tail->expr = gfc_copy_expr (src->expr);
- tail->iterator = copy_iterator (src->iterator);
- mpz_set (tail->n.offset, src->n.offset);
- tail->n.component = src->n.component;
- mpz_set (tail->repeat, src->repeat);
- src = src->next;
- }
-
- return dest;
-}
-
-
-/* Given an array expression and an element number (starting at zero),
- return a pointer to the array element. NULL is returned if the
- size of the array has been exceeded. The expression node returned
- remains a part of the array and should not be freed. Access is not
- efficient at all, but this is another place where things do not
- have to be particularly fast. */
-
-gfc_expr *
-gfc_get_array_element (gfc_expr *array, int element)
-{
- expand_info expand_save;
- gfc_expr *e;
- gfc_try rc;
-
- expand_save = current_expand;
- current_expand.extract_n = element;
- current_expand.expand_work_function = extract_element;
- current_expand.extracted = NULL;
- current_expand.extract_count = 0;
-
- iter_stack = NULL;
-
- rc = expand_constructor (array->value.constructor);
- e = current_expand.extracted;
- current_expand = expand_save;
-
- if (rc == FAILURE)
- return NULL;
-
- return e;
-}
-
-
/********* Subroutines for determining the size of an array *********/
/* These are needed just to accommodate RESHAPE(). There are no
gfc_free_iterator (c->iterator, 1);
mpz_clear (c->offset);
+ mpz_clear (c->repeat);
gfc_free (c);
}
c->n.component = src->n.component;
mpz_init_set (c->offset, src->offset);
+ mpz_init_set (c->repeat, src->repeat);
return c;
}
c->iterator = NULL;
mpz_init_set_si (c->offset, 0);
+ mpz_init_set_si (c->repeat, 0);
return c;
}
gfc_constructor *
gfc_constructor_lookup (gfc_constructor_base base, int offset)
{
+ gfc_constructor *c;
splay_tree_node node;
if (!base)
if (node)
return (gfc_constructor*) node->value;
- return NULL;
+ /* Check if the previous node as a repeat count big enough to
+ cover the offset looked for. */
+ node = splay_tree_predecessor (base, offset);
+ if (!node)
+ return NULL;
+
+ c = (gfc_constructor*) node->value;
+ if (mpz_cmp_si (c->repeat, 1) > 0)
+ {
+ if (mpz_get_si (c->offset) + mpz_get_si (c->repeat) <= offset)
+ c = NULL;
+ }
+ else
+ c = NULL;
+
+ return c;
}
if (len > end - start)
{
- gfc_warning_now ("Initialization string starting at %L was "
- "truncated to fit the variable (%d/%d)",
- &rvalue->where, end - start, len);
len = end - start;
+ gfc_warning_now ("initialization string truncated to match variable "
+ "at %L", &rvalue->where);
}
if (rvalue->ts.type == BT_HOLLERITH)
if (!con)
{
con = gfc_constructor_insert_expr (&expr->value.constructor,
- NULL, &rvalue->where,
+ NULL, NULL,
mpz_get_si (offset));
}
break;
expr = (LOCATION_LINE (init->where.lb->location)
> LOCATION_LINE (rvalue->where.lb->location))
? init : rvalue;
- if (gfc_notify_std (GFC_STD_GNU,"Extension: "
- "re-initialization of '%s' at %L",
- symbol->name, &expr->where) == FAILURE)
- return FAILURE;
+ gfc_notify_std (GFC_STD_GNU, "Extension: re-initialization "
+ "of '%s' at %L", symbol->name, &expr->where);
}
expr = gfc_copy_expr (rvalue);
/* Similarly, but initialize REPEAT consecutive values in LVALUE the same
- value in RVALUE. */
+ value in RVALUE. For the nonce, LVALUE must refer to a full array, not
+ an array section. */
-gfc_try
+void
gfc_assign_data_value_range (gfc_expr *lvalue, gfc_expr *rvalue,
mpz_t index, mpz_t repeat)
{
- mpz_t offset, last_offset;
- gfc_try t;
-
- mpz_init (offset);
- mpz_init (last_offset);
- mpz_add (last_offset, index, repeat);
-
- t = SUCCESS;
- for (mpz_set(offset, index) ; mpz_cmp(offset, last_offset) < 0;
- mpz_add_ui (offset, offset, 1))
- if (gfc_assign_data_value (lvalue, rvalue, offset) == FAILURE)
- {
- t = FAILURE;
- break;
- }
+ gfc_ref *ref;
+ gfc_expr *init, *expr;
+ gfc_constructor *con, *last_con;
+ gfc_symbol *symbol;
+ gfc_typespec *last_ts;
+ mpz_t offset;
- mpz_clear (offset);
- mpz_clear (last_offset);
+ symbol = lvalue->symtree->n.sym;
+ init = symbol->value;
+ last_ts = &symbol->ts;
+ last_con = NULL;
+ mpz_init_set_si (offset, 0);
- return t;
-}
+ /* Find/create the parent expressions for subobject references. */
+ for (ref = lvalue->ref; ref; ref = ref->next)
+ {
+ /* Use the existing initializer expression if it exists.
+ Otherwise create a new one. */
+ if (init == NULL)
+ expr = gfc_get_expr ();
+ else
+ expr = init;
+
+ /* Find or create this element. */
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ if (init == NULL)
+ {
+ /* The element typespec will be the same as the array
+ typespec. */
+ expr->ts = *last_ts;
+ /* Setup the expression to hold the constructor. */
+ expr->expr_type = EXPR_ARRAY;
+ expr->rank = ref->u.ar.as->rank;
+ }
+ else
+ gcc_assert (expr->expr_type == EXPR_ARRAY);
+
+ if (ref->u.ar.type == AR_ELEMENT)
+ {
+ get_array_index (&ref->u.ar, &offset);
+
+ /* This had better not be the bottom of the reference.
+ We can still get to a full array via a component. */
+ gcc_assert (ref->next != NULL);
+ }
+ else
+ {
+ mpz_set (offset, index);
+
+ /* We're at a full array or an array section. This means
+ that we've better have found a full array, and that we're
+ at the bottom of the reference. */
+ gcc_assert (ref->u.ar.type == AR_FULL);
+ gcc_assert (ref->next == NULL);
+ }
+
+ con = gfc_constructor_lookup (expr->value.constructor,
+ mpz_get_si (offset));
+ if (con == NULL)
+ {
+ con = gfc_constructor_insert_expr (&expr->value.constructor,
+ NULL, NULL,
+ mpz_get_si (offset));
+ if (ref->next == NULL)
+ mpz_set (con->repeat, repeat);
+ }
+ else
+ gcc_assert (ref->next != NULL);
+ break;
+ case REF_COMPONENT:
+ if (init == NULL)
+ {
+ /* Setup the expression to hold the constructor. */
+ expr->expr_type = EXPR_STRUCTURE;
+ expr->ts.type = BT_DERIVED;
+ expr->ts.u.derived = ref->u.c.sym;
+ }
+ else
+ gcc_assert (expr->expr_type == EXPR_STRUCTURE);
+ last_ts = &ref->u.c.component->ts;
+
+ /* Find the same element in the existing constructor. */
+ con = find_con_by_component (ref->u.c.component,
+ expr->value.constructor);
+
+ if (con == NULL)
+ {
+ /* Create a new constructor. */
+ con = gfc_constructor_append_expr (&expr->value.constructor,
+ NULL, NULL);
+ con->n.component = ref->u.c.component;
+ }
+
+ /* Since we're only intending to initialize arrays here,
+ there better be an inner reference. */
+ gcc_assert (ref->next != NULL);
+ break;
+
+ case REF_SUBSTRING:
+ default:
+ gcc_unreachable ();
+ }
+
+ if (init == NULL)
+ {
+ /* Point the container at the new expression. */
+ if (last_con == NULL)
+ symbol->value = expr;
+ else
+ last_con->expr = expr;
+ }
+ init = con->expr;
+ last_con = con;
+ }
+
+ if (last_ts->type == BT_CHARACTER)
+ expr = create_character_intializer (init, last_ts, NULL, rvalue);
+ else
+ {
+ /* We should never be overwriting an existing initializer. */
+ gcc_assert (!init);
+
+ expr = gfc_copy_expr (rvalue);
+ if (!gfc_compare_types (&lvalue->ts, &expr->ts))
+ gfc_convert_type (expr, &lvalue->ts, 0);
+ }
+
+ if (last_con == NULL)
+ symbol->value = expr;
+ else
+ last_con->expr = expr;
+}
/* Modify the index of array section and re-calculate the array offset. */
#include "match.h"
#include "parse.h"
#include "flags.h"
-
+#include "constructor.h"
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
- *expr = gfc_int_expr (length);
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
return m;
}
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
- gfc_expr *p = init->value.constructor->expr;
- clen = p->value.character.length;
- sym->ts.u.cl->length = gfc_int_expr (clen);
+ gfc_constructor *c;
+ c = gfc_constructor_first (init->value.constructor);
+ clen = c->expr->value.character.length;
+ sym->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, clen);
}
else if (init->ts.u.cl && init->ts.u.cl->length)
sym->ts.u.cl->length =
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
- gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
+ gfc_constructor *c;
+
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
- for (p = init->value.constructor; p; p = p->next)
- gfc_set_constant_character_len (len, p->expr, -1);
+ for (c = gfc_constructor_first (init->value.constructor);
+ c; c = gfc_constructor_next (c))
+ gfc_set_constant_character_len (len, c->expr, -1);
}
}
}
if (init->ts.is_iso_c)
sym->ts.f90_type = init->ts.f90_type;
}
-
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
mpz_t size;
gfc_expr *array;
- gfc_constructor *c;
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
&& spec_size (sym->as, &size) == SUCCESS
&& mpz_cmp_si (size, 0) > 0)
{
- array = gfc_start_constructor (init->ts.type, init->ts.kind,
- &init->where);
-
- array->value.constructor = c = NULL;
+ array = gfc_get_array_expr (init->ts.type, init->ts.kind,
+ &init->where);
for (n = 0; n < (int)mpz_get_si (size); n++)
- {
- if (array->value.constructor == NULL)
- {
- array->value.constructor = c = gfc_get_constructor ();
- c->expr = init;
- }
- else
- {
- c->next = gfc_get_constructor ();
- c = c->next;
- c->expr = gfc_copy_expr (init);
- }
- }
-
+ gfc_constructor_append_expr (&array->value.constructor,
+ n == 0
+ ? init
+ : gfc_copy_expr (init),
+ &init->where);
+
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
- bool has_ts;
- gfc_constructor *ctor = c->initializer->value.constructor;
-
- has_ts = (c->initializer->ts.u.cl
- && c->initializer->ts.u.cl->length_from_typespec);
+ gfc_constructor *ctor;
+ ctor = gfc_constructor_first (c->initializer->value.constructor);
if (ctor)
{
int first_len;
+ bool has_ts = (c->initializer->ts.u.cl
+ && c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
- for (; ctor; ctor = ctor->next)
+ for ( ; ctor; ctor = gfc_constructor_next (ctor))
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
{
- if (ctor->expr->expr_type == EXPR_CONSTANT)
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
+ gfc_set_constant_character_len (len, ctor->expr,
+ has_ts ? -1 : first_len);
+ ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
}
}
}
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
- gfc_expr *e;
match m;
m = gfc_match (" null ( )");
|| gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
- e = gfc_get_expr ();
- e->where = gfc_current_locus;
- e->expr_type = EXPR_NULL;
- e->ts.type = BT_UNKNOWN;
-
- *result = e;
+ *result = gfc_get_null_expr (&gfc_current_locus);
return MATCH_YES;
}
cl = gfc_new_charlen (gfc_current_ns, NULL);
if (seen_length == 0)
- cl->length = gfc_int_expr (1);
+ cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
else
cl->length = len;
{
ts.kind = gfc_default_character_kind;
ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- ts.u.cl->length = gfc_int_expr (1);
+ ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
/* Record the Successful match. */
enum_initializer (gfc_expr *last_initializer, locus where)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = gfc_c_int_kind;
- result->where = where;
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
mpz_init (result->value.integer);
}
+/* Insert a reference to the component of the given name.
+ Only to be used with CLASS containers. */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+ gfc_ref **tail = &(e->ref);
+ gfc_ref *next = NULL;
+ gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+ while (*tail != NULL)
+ {
+ if ((*tail)->type == REF_COMPONENT)
+ derived = (*tail)->u.c.component->ts.u.derived;
+ if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+ break;
+ tail = &((*tail)->next);
+ }
+ if (*tail != NULL && strcmp (name, "$data") == 0)
+ next = *tail;
+ (*tail) = gfc_get_ref();
+ (*tail)->next = next;
+ (*tail)->type = REF_COMPONENT;
+ (*tail)->u.c.sym = derived;
+ (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+ gcc_assert((*tail)->u.c.component);
+ if (!next)
+ e->ts = (*tail)->u.c.component->ts;
+}
+
+
/* Copy a shape array. */
mpz_t *
int rank;
int d;
int shape_i;
- int limit;
long unsigned one = 1;
bool incr_ctr;
mpz_t start[GFC_MAX_DIMENSIONS];
}
}
- limit = mpz_get_ui (ptr);
- if (limit >= gfc_option.flag_max_array_constructor)
- {
- gfc_error ("The number of elements in the array constructor "
- "at %L requires an increase of the allowed %d "
- "upper limit. See -fmax-array-constructor "
- "option", &expr->where,
- gfc_option.flag_max_array_constructor);
- return FAILURE;
- }
-
- cons = gfc_constructor_lookup (base, limit);
+ 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);
/* Only substitute array parameter variables if we are in an
initialization expression, or we want a subsection. */
if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
- && (gfc_init_expr_flag || p->ref
+ && (gfc_init_expr || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
{
if (simplify_parameter_variable (p, type) == FAILURE)
{
gfc_try t;
- gfc_init_expr_flag = true;
+ gfc_init_expr = 1;
t = gfc_resolve_expr (expr);
if (t == SUCCESS)
t = check_init_expr (expr);
- gfc_init_expr_flag = false;
+ gfc_init_expr = 0;
if (t == FAILURE)
return FAILURE;
/* Match an initialization expression. We work by first matching an
- expression, then reducing it to a constant. */
+ expression, then reducing it to a constant. The reducing it to
+ constant part requires a global variable to flag the prohibition
+ of a non-integer exponent in -std=f95 mode. */
+
+bool init_flag = false;
match
gfc_match_init_expr (gfc_expr **result)
expr = NULL;
- gfc_init_expr_flag = true;
+ init_flag = true;
m = gfc_match_expr (&expr);
if (m != MATCH_YES)
{
- gfc_init_expr_flag = false;
+ init_flag = false;
return m;
}
if (t != SUCCESS)
{
gfc_free_expr (expr);
- gfc_init_expr_flag = false;
+ init_flag = false;
return MATCH_ERROR;
}
*result = expr;
- gfc_init_expr_flag = false;
+ init_flag = false;
return MATCH_YES;
}
}
-/* Check for default initializer; sym->value is not enough
- as it is also set for EXPR_NULL of allocatables. */
-
-bool
-gfc_has_default_initializer (gfc_symbol *der)
-{
- gfc_component *c;
-
- gcc_assert (der->attr.flavor == FL_DERIVED);
- for (c = der->components; c; c = c->next)
- if (c->ts.type == BT_DERIVED)
- {
- if (!c->attr.pointer
- && gfc_has_default_initializer (c->ts.u.derived))
- return true;
- }
- else
- {
- if (c->initializer)
- return true;
- }
-
- return false;
-}
-
/* Get an expression for a default initializer. */
gfc_expr *
gfc_expr *init;
gfc_component *comp;
- /* See if we have a default initializer in this, but not in nested
- types (otherwise we could use gfc_has_default_initializer()). */
+ /* See if we have a default initializer. */
for (comp = ts->u.derived->components; comp; comp = comp->next)
if (comp->initializer || comp->attr.allocatable)
break;
#define GFC_RND_MODE GMP_RNDN
#define GFC_MPC_RND_MODE MPC_RNDNN
+typedef splay_tree gfc_constructor_base;
+
typedef struct gfc_expr
{
expr_t expr_type;
a function call in interface.c(gfc_extend_expr). */
unsigned int user_operator : 1;
- /* Used to quickly find a given constructor by its offset. */
- splay_tree con_by_offset;
-
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
}
character;
- struct gfc_constructor *constructor;
+ gfc_constructor_base constructor;
}
value;
/* Constructor nodes for array and structure constructors. */
typedef struct gfc_constructor
{
+ gfc_constructor_base base;
+ mpz_t offset; /* Offset within a constructor, used as
+ key within base. */
+
gfc_expr *expr;
gfc_iterator *iterator;
locus where;
- struct gfc_constructor *next;
- struct
+
+ union
{
- mpz_t offset; /* Record the offset of array element which appears in
- data statement like "data a(5)/4/". */
- gfc_component *component; /* Record the component being initialized. */
+ gfc_component *component; /* Record the component being initialized. */
}
n;
mpz_t repeat; /* Record the repeat number of initial values in data
- statement like "data a/5*10/". */
+ statement like "data a/5*10/". */
}
gfc_constructor;
int gfc_has_vector_index (gfc_expr *);
gfc_expr *gfc_get_expr (void);
+gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
+gfc_expr *gfc_get_null_expr (locus *);
+gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *);
+gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
+gfc_expr *gfc_get_constant_expr (bt, int, locus *);
+gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len);
+gfc_expr *gfc_get_int_expr (int, locus *, int);
+gfc_expr *gfc_get_logical_expr (int, locus *, bool);
+gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
+
void gfc_free_expr (gfc_expr *);
void gfc_replace_expr (gfc_expr *, gfc_expr *);
-gfc_expr *gfc_int_expr (int);
-gfc_expr *gfc_logical_expr (int, locus *);
mpz_t *gfc_copy_shape (mpz_t *, int);
mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
gfc_expr *gfc_copy_expr (gfc_expr *);
/* array.c */
+gfc_iterator *gfc_copy_iterator (gfc_iterator *);
+
void gfc_free_array_spec (gfc_array_spec *);
gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *);
int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *);
-gfc_expr *gfc_start_constructor (bt, int, locus *);
-void gfc_append_constructor (gfc_expr *, gfc_expr *);
-void gfc_free_constructor (gfc_constructor *);
void gfc_simplify_iterator_var (gfc_expr *);
gfc_try gfc_expand_constructor (gfc_expr *);
int gfc_constant_ac (gfc_expr *);
gfc_try gfc_check_constructor_type (gfc_expr *);
gfc_try gfc_check_iter_variable (gfc_expr *);
gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *));
-gfc_constructor *gfc_copy_constructor (gfc_constructor *);
-gfc_expr *gfc_get_array_element (gfc_expr *, int);
gfc_try gfc_array_size (gfc_expr *, mpz_t *);
gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
gfc_array_ref *gfc_find_array_ref (gfc_expr *);
-void gfc_insert_constructor (gfc_expr *, gfc_constructor *);
-gfc_constructor *gfc_get_constructor (void);
tree gfc_conv_array_initializer (tree type, gfc_expr *);
gfc_try spec_size (gfc_array_spec *, mpz_t *);
gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *);
/* Matching subroutines in all sizes, shapes and colors.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
2010 Free Software Foundation, Inc.
Contributed by Andy Vaught
if (gfc_match_char (',') != MATCH_YES)
{
- e3 = gfc_int_expr (1);
+ e3 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
goto done;
}
if (gfc_match_eos () == MATCH_YES)
{
- iter.end = gfc_logical_expr (1, NULL);
+ iter.end = gfc_get_logical_expr (gfc_default_logical_kind, NULL, true);
new_st.op = EXEC_DO_WHILE;
goto done;
}
}
cp = gfc_get_case ();
- cp->low = cp->high = gfc_int_expr (i++);
+ cp->low = cp->high = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, i++);
tail->op = EXEC_SELECT;
tail->ext.case_list = cp;
}
/* build ' => NULL() '. */
- e = gfc_get_expr ();
- e->where = gfc_current_locus;
- e->expr_type = EXPR_NULL;
- e->ts.type = BT_UNKNOWN;
+ e = gfc_get_null_expr (&gfc_current_locus);
/* Chain to list. */
if (tail == NULL)
c->op = EXEC_SELECT;
new_case = gfc_get_case ();
- new_case->high = new_case->low = gfc_int_expr (i);
+ new_case->high = gfc_get_int_expr (gfc_default_integer_kind, NULL, i);
+ new_case->low = new_case->high;
c->ext.case_list = new_case;
c->next = gfc_get_code ();
goto cleanup;
if (gfc_match_char (':') == MATCH_NO)
- iter->stride = gfc_int_expr (1);
+ iter->stride = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
else
{
m = gfc_match_expr (&iter->stride);
#include "match.h"
#include "parse.h" /* FIXME */
#include "md5.h"
+#include "constructor.h"
#define MODULE_EXTENSION ".mod"
static void
-mio_constructor (gfc_constructor **cp)
+mio_constructor (gfc_constructor_base *cp)
{
- gfc_constructor *c, *tail;
+ gfc_constructor *c;
mio_lparen ();
if (iomode == IO_OUTPUT)
{
- for (c = *cp; c; c = c->next)
+ for (c = gfc_constructor_first (*cp); c; c = gfc_constructor_next (c))
{
mio_lparen ();
mio_expr (&c->expr);
}
else
{
- *cp = NULL;
- tail = NULL;
-
while (peek_atom () != ATOM_RPAREN)
{
- c = gfc_get_constructor ();
-
- if (tail == NULL)
- *cp = c;
- else
- tail->next = c;
-
- tail = c;
+ c = gfc_constructor_append_expr (cp, NULL, NULL);
mio_lparen ();
mio_expr (&c->expr);
sym->attr.flavor = FL_PARAMETER;
sym->ts.type = BT_INTEGER;
sym->ts.kind = gfc_default_integer_kind;
- sym->value = gfc_int_expr (value);
+ sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL, value);
sym->attr.use_assoc = 1;
sym->from_intmod = module;
sym->intmod_sym_id = id;
#include "dependency.h"
#include "data.h"
#include "target-memory.h" /* for gfc_simplify_transfer */
+#include "constructor.h"
/* Types used in equivalence statements. */
{
sym->as->type = AS_ASSUMED_SHAPE;
for (i = 0; i < sym->as->rank; i++)
- sym->as->lower[i] = gfc_int_expr (1);
+ sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
}
if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
symbol_attribute a;
t = SUCCESS;
- cons = expr->value.constructor;
+ cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
- for (; comp; comp = comp->next, cons = cons->next)
+ for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
if (char_ref->u.ss.start)
start = gfc_copy_expr (char_ref->u.ss.start);
else
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
if (char_ref->u.ss.end)
end = gfc_copy_expr (char_ref->u.ss.end);
/* Length = (end - start +1). */
e->ts.u.cl->length = gfc_subtract (end, start);
- e->ts.u.cl->length = gfc_add (e->ts.u.cl->length, gfc_int_expr (1));
+ e->ts.u.cl->length = gfc_add (e->ts.u.cl->length,
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
e->ts.u.cl->length->ts.type = BT_INTEGER;
e->ts.u.cl->length->ts.kind = gfc_charlen_int_kind;
if (op1->ts.u.cl && op1->ts.u.cl->length)
e1 = gfc_copy_expr (op1->ts.u.cl->length);
else if (op1->expr_type == EXPR_CONSTANT)
- e1 = gfc_int_expr (op1->value.character.length);
+ e1 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op1->value.character.length);
if (op2->ts.u.cl && op2->ts.u.cl->length)
e2 = gfc_copy_expr (op2->ts.u.cl->length);
else if (op2->expr_type == EXPR_CONSTANT)
- e2 = gfc_int_expr (op2->value.character.length);
+ e2 = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ op2->value.character.length);
e->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
/* Traverse the constructor looking for variables that are flavor
parameter. Parameters must be expanded since they are fully used at
compile time. */
- for (con = e->value.constructor; con; con = con->next)
+ con = gfc_constructor_first (e->value.constructor);
+ for (; con; con = gfc_constructor_next (con))
{
if (con->expr->expr_type == EXPR_VARIABLE
- && con->expr->symtree
- && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
+ && con->expr->symtree
+ && (con->expr->symtree->n.sym->attr.flavor == FL_PARAMETER
|| con->expr->symtree->n.sym->attr.flavor == FL_VARIABLE))
return true;
if (con->expr->expr_type == EXPR_ARRAY
- && gfc_is_expandable_expr (con->expr))
+ && gfc_is_expandable_expr (con->expr))
return true;
}
}
for (body = code->block; body; body = body->block)
{
c = body->ext.case_list;
-
+
if (c->ts.type == BT_DERIVED)
- c->low = c->high = gfc_int_expr (c->ts.u.derived->hash_value);
+ c->low = c->high = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->ts.u.derived->hash_value);
+
else if (c->ts.type == BT_UNKNOWN)
continue;
-
+
/* Assign temporary to selector. */
if (c->ts.type == BT_CLASS)
sprintf (name, "tmp$class$%s", c->ts.u.derived->name);
&& gfc_simplify_expr (code->expr1, 0) == SUCCESS)
{
gfc_constructor *cons;
- for (cons = code->expr1->value.constructor; cons; cons = cons->next)
+ cons = gfc_constructor_first (code->expr1->value.constructor);
+ for (; cons; cons = gfc_constructor_next (cons))
if (cons->expr->expr_type == EXPR_CONSTANT
&& mpz_cmp_si (cons->expr->value.integer, 1) < 0)
gfc_error ("Imageset argument at %L must between 1 and "
gfc_warning_now ("CHARACTER variable at %L has negative length %d,"
" the length has been set to zero",
&cl->length->where, i);
- gfc_replace_expr (cl->length, gfc_int_expr (0));
+ gfc_replace_expr (cl->length,
+ gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
}
/* Check that the character length is not too large. */
return NULL;
/* Now we'll try to build an initializer expression. */
- init_expr = gfc_get_expr ();
- init_expr->expr_type = EXPR_CONSTANT;
- init_expr->ts.type = sym->ts.type;
- init_expr->ts.kind = sym->ts.kind;
- init_expr->where = sym->declared_at;
-
+ init_expr = gfc_get_constant_expr (sym->ts.type, sym->ts.kind,
+ &sym->declared_at);
+
/* We will only initialize integers, reals, complex, logicals, and
characters, and only if the corresponding command-line flags
were set. Otherwise, we free init_expr and return null. */
{
ref->type = REF_SUBSTRING;
if (start == NULL)
- start = gfc_int_expr (1);
+ start = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
ref->u.ss.start = start;
if (end == NULL && e->ts.u.cl)
end = gfc_copy_expr (e->ts.u.cl->length);
static gfc_expr *
simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
- gfc_array_spec *as, gfc_ref *ref, bool coarray)
+ gfc_array_spec *as, gfc_ref *ref)
{
gfc_expr *l, *u, *result;
int k;
/* The last dimension of an assumed-size array is special. */
- if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
- || (coarray && d == as->rank + as->corank))
+ if (d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
return gfc_copy_expr (as->lower[d-1]);
/* Then, we need to know the extent of the given dimension. */
- if (coarray || ref->u.ar.type == AR_FULL)
+ if (ref->u.ar.type == AR_FULL)
{
l = as->lower[d-1];
u = as->upper[d-1];
- if (l->expr_type != EXPR_CONSTANT || u == NULL
- || u->expr_type != EXPR_CONSTANT)
+ if (l->expr_type != EXPR_CONSTANT || u->expr_type != EXPR_CONSTANT)
return NULL;
if (mpz_cmp (l->value.integer, u->value.integer) > 0)
/* Simplify the bounds for each dimension. */
for (d = 0; d < array->rank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
- false);
+ bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
int j;
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, kind, d, upper, as, ref, false);
- }
-}
-
-
-static gfc_expr *
-simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
-{
- gfc_ref *ref;
- gfc_array_spec *as;
- int d;
-
- if (array->expr_type != EXPR_VARIABLE)
- return NULL;
-
- /* Follow any component references. */
- as = array->symtree->n.sym->as;
- for (ref = array->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_ARRAY:
- switch (ref->u.ar.type)
- {
- case AR_ELEMENT:
- if (ref->next == NULL)
- {
- gcc_assert (ref->u.ar.as->corank > 0
- && ref->u.ar.as->rank == 0);
- as = ref->u.ar.as;
- goto done;
- }
- as = NULL;
- continue;
-
- case AR_FULL:
- /* We're done because 'as' has already been set in the
- previous iteration. */
- if (!ref->next)
- goto done;
-
- /* Fall through. */
-
- case AR_UNKNOWN:
- return NULL;
-
- case AR_SECTION:
- as = ref->u.ar.as;
- goto done;
- }
-
- gcc_unreachable ();
-
- case REF_COMPONENT:
- as = ref->u.c.component->as;
- continue;
-
- case REF_SUBSTRING:
- continue;
- }
- }
-
- gcc_unreachable ();
-
- done:
-
- if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
- return NULL;
-
- if (dim == NULL)
- {
- /* Multi-dimensional cobounds. */
- gfc_expr *bounds[GFC_MAX_DIMENSIONS];
- gfc_expr *e;
- int k;
-
- /* Simplify the cobounds for each dimension. */
- for (d = 0; d < as->corank; d++)
- {
- bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
- upper, as, ref, true);
- if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
- {
- int j;
-
- for (j = 0; j < d; j++)
- gfc_free_expr (bounds[j]);
- return bounds[d];
- }
- }
-
- /* Allocate the result expression. */
- e = gfc_get_expr ();
- e->where = array->where;
- e->expr_type = EXPR_ARRAY;
- e->ts.type = BT_INTEGER;
- k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
- gfc_default_integer_kind);
- if (k == -1)
- {
- gfc_free_expr (e);
- return &gfc_bad_expr;
- }
- e->ts.kind = k;
-
- /* The result is a rank 1 array; its size is the rank of the first
- argument to {L,U}COBOUND. */
- e->rank = 1;
- e->shape = gfc_get_shape (1);
- mpz_init_set_ui (e->shape[0], as->corank);
-
- /* Create the constructor for this array. */
- for (d = 0; d < as->corank; d++)
- gfc_constructor_append_expr (&e->value.constructor,
- bounds[d], &e->where);
- return e;
- }
- else
- {
- /* A DIM argument is specified. */
- if (dim->expr_type != EXPR_CONSTANT)
- return NULL;
-
- d = mpz_get_si (dim->value.integer);
-
- if (d < 1 || d > as->corank)
- {
- gfc_error ("DIM argument at %L is out of bounds", &dim->where);
- return &gfc_bad_expr;
- }
-
- return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
+ return simplify_bound_dim (array, kind, d, upper, as, ref);
}
}
gfc_expr *
-gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- gfc_expr *e;
- /* return simplify_cobound (array, dim, kind, 0);*/
-
- e = simplify_cobound (array, dim, kind, 0);
- if (e != NULL)
- return e;
-
- gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
- "cobounds at %L", &array->where);
- return &gfc_bad_expr;
-}
-
-gfc_expr *
gfc_simplify_leadz (gfc_expr *e)
{
unsigned long lz, bs;
gfc_simplify_num_images (void)
{
gfc_expr *result;
-
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return &gfc_bad_expr;
- }
-
/* FIXME: gfc_current_locus is wrong. */
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
gfc_expr *
-gfc_simplify_num_images (void)
-{
- gfc_expr *result;
- /* FIXME: gfc_current_locus is wrong. */
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
- mpz_set_si (result->value.integer, 1);
- return result;
-}
-
-
-gfc_expr *
gfc_simplify_or (gfc_expr *x, gfc_expr *y)
{
gfc_expr *result;
unsigned char *buffer;
if (!gfc_is_constant_expr (source)
- || (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
+ || (gfc_init_expr && !gfc_is_constant_expr (mold))
|| !gfc_is_constant_expr (size))
return NULL;
gfc_expr *
-gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
-{
- gfc_expr *result;
- gfc_ref *ref;
- gfc_array_spec *as;
- gfc_constructor *sub_cons;
- bool first_image;
- int d;
-
- if (!is_constant_array_expr (sub))
- goto not_implemented; /* return NULL;*/
-
- /* Follow any component references. */
- as = coarray->symtree->n.sym->as;
- for (ref = coarray->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- as = ref->u.ar.as;
-
- if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
-
- /* "valid sequence of cosubscripts" are required; thus, return 0 unless
- the cosubscript addresses the first image. */
-
- sub_cons = gfc_constructor_first (sub->value.constructor);
- first_image = true;
-
- for (d = 1; d <= as->corank; d++)
- {
- gfc_expr *ca_bound;
- int cmp;
-
- if (sub_cons == NULL)
- {
- gfc_error ("Too few elements in expression for SUB= argument at %L",
- &sub->where);
- return &gfc_bad_expr;
- }
-
- ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
- NULL, true);
- if (ca_bound == NULL)
- goto not_implemented; /* return NULL */
-
- if (ca_bound == &gfc_bad_expr)
- return ca_bound;
-
- cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
-
- if (cmp == 0)
- {
- gfc_free_expr (ca_bound);
- sub_cons = gfc_constructor_next (sub_cons);
- continue;
- }
-
- first_image = false;
-
- if (cmp > 0)
- {
- gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
- "SUB has %ld and COARRAY lower bound is %ld)",
- &coarray->where, d,
- mpz_get_si (sub_cons->expr->value.integer),
- mpz_get_si (ca_bound->value.integer));
- gfc_free_expr (ca_bound);
- return &gfc_bad_expr;
- }
-
- gfc_free_expr (ca_bound);
-
- /* Check whether upperbound is valid for the multi-images case. */
- if (d < as->corank)
- {
- ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
- NULL, true);
- if (ca_bound == &gfc_bad_expr)
- return ca_bound;
-
- if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
- && mpz_cmp (ca_bound->value.integer,
- sub_cons->expr->value.integer) < 0)
- {
- gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
- "SUB has %ld and COARRAY upper bound is %ld)",
- &coarray->where, d,
- mpz_get_si (sub_cons->expr->value.integer),
- mpz_get_si (ca_bound->value.integer));
- gfc_free_expr (ca_bound);
- return &gfc_bad_expr;
- }
-
- if (ca_bound)
- gfc_free_expr (ca_bound);
- }
-
- sub_cons = gfc_constructor_next (sub_cons);
- }
-
- if (sub_cons != NULL)
- {
- gfc_error ("Too many elements in expression for SUB= argument at %L",
- &sub->where);
- return &gfc_bad_expr;
- }
-
- result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &gfc_current_locus);
- if (first_image)
- mpz_set_si (result->value.integer, 1);
- else
- mpz_set_si (result->value.integer, 0);
-
- return result;
-
-not_implemented:
- gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
-}
-
-
-gfc_expr *
-gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
-{
- gfc_ref *ref;
- gfc_array_spec *as;
- int d;
-
- if (coarray == NULL)
- {
- gfc_expr *result;
- /* FIXME: gfc_current_locus is wrong. */
- result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &gfc_current_locus);
- mpz_set_si (result->value.integer, 1);
- return result;
- }
-
- gcc_assert (coarray->expr_type == EXPR_VARIABLE);
-
- /* Follow any component references. */
- as = coarray->symtree->n.sym->as;
- for (ref = coarray->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- as = ref->u.ar.as;
-
- if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
-
- if (dim == NULL)
- {
- /* Multi-dimensional bounds. */
- gfc_expr *bounds[GFC_MAX_DIMENSIONS];
- gfc_expr *e;
-
- /* Simplify the bounds for each dimension. */
- for (d = 0; d < as->corank; d++)
- {
- bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
- as, NULL, true);
- if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
- {
- int j;
-
- for (j = 0; j < d; j++)
- gfc_free_expr (bounds[j]);
- if (bounds[d] == NULL)
- goto not_implemented;
- return bounds[d];
- }
- }
-
- /* Allocate the result expression. */
- e = gfc_get_expr ();
- e->where = coarray->where;
- e->expr_type = EXPR_ARRAY;
- e->ts.type = BT_INTEGER;
- e->ts.kind = gfc_default_integer_kind;
-
- e->rank = 1;
- e->shape = gfc_get_shape (1);
- mpz_init_set_ui (e->shape[0], as->corank);
-
- /* Create the constructor for this array. */
- for (d = 0; d < as->corank; d++)
- gfc_constructor_append_expr (&e->value.constructor,
- bounds[d], &e->where);
-
- return e;
- }
- else
- {
- gfc_expr *e;
- /* A DIM argument is specified. */
- if (dim->expr_type != EXPR_CONSTANT)
- goto not_implemented; /*return NULL;*/
-
- d = mpz_get_si (dim->value.integer);
-
- if (d < 1 || d > as->corank)
- {
- gfc_error ("DIM argument at %L is out of bounds", &dim->where);
- return &gfc_bad_expr;
- }
-
- /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
- e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
- if (e != NULL)
- return e;
- else
- goto not_implemented;
- }
-
-not_implemented:
- gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
-}
-
-
-gfc_expr *
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
return simplify_bound (array, dim, kind, 1);
}
-gfc_expr *
-gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
-{
- gfc_expr *e;
- /* return simplify_cobound (array, dim, kind, 1);*/
-
- e = simplify_cobound (array, dim, kind, 1);
- if (e != NULL)
- return e;
-
- gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
- "cobounds at %L", &array->where);
- return &gfc_bad_expr;
-}
-
gfc_expr *
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
#include "gfortran.h"
#include "parse.h"
#include "match.h"
+#include "constructor.h"
/* Strings for all symbol attributes. We use these for dumping the
{
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
+ gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
- tmp_sym->value->value.constructor = gfc_get_constructor ();
- tmp_sym->value->value.constructor->expr = gfc_get_expr ();
- tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
- tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
+ gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
+ c = gfc_constructor_first (tmp_sym->value->value.constructor);
+ c->expr = gfc_get_expr ();
+ c->expr->expr_type = EXPR_NULL;
+ c->expr->ts.is_iso_c = 1;
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
param_sym->as->upper[i] = NULL;
}
param_sym->as->rank = 1;
- param_sym->as->lower[0] = gfc_int_expr (1);
+ param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* The extent is unknown until we get it. The length give us
the rank the incoming pointer. */
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
- tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
+ tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c_interop_kinds_table[s].value);
/* Initialize an integer constant expression node. */
tmp_sym->attr.flavor = FL_PARAMETER;
/* Initialize an integer constant expression node for the
length of the character. */
- tmp_sym->value = gfc_get_expr ();
- tmp_sym->value->expr_type = EXPR_CONSTANT;
- tmp_sym->value->ts.type = BT_CHARACTER;
- tmp_sym->value->ts.kind = gfc_default_character_kind;
- tmp_sym->value->where = gfc_current_locus;
+ tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, NULL, 1);
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
- tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
= (gfc_char_t) c_interop_kinds_table[s].value;
- tmp_sym->value->value.character.string[1] = '\0';
tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- tmp_sym->ts.u.cl->length = gfc_int_expr (1);
+ tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
c->attr.codimension = attr->codimension;
c->attr.abstract = ts->u.derived->attr.abstract;
c->as = (*as);
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
+ c->initializer = gfc_get_null_expr (NULL);
/* Add component '$vptr'. */
if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
gcc_assert (vtab);
c->ts.u.derived = vtab->ts.u.derived;
c->attr.pointer = 1;
- c->initializer = gfc_get_expr ();
- c->initializer->expr_type = EXPR_NULL;
}
/* Since the extension field is 8 bit wide, we can only have
c->ts.type = BT_INTEGER;
c->ts.kind = 4;
c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_int_expr (derived->hash_value);
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, derived->hash_value);
/* Add component '$size'. */
if (gfc_add_component (vtype, "$size", &c) == FAILURE)
so that the correct initializer can be set later on
(in gfc_conv_structure). */
c->ts.u.derived = derived;
- c->initializer = gfc_int_expr (0);
+ c->initializer = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 0);
/* Add component $extends. */
if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
return NULL;
c->attr.pointer = 1;
c->attr.access = ACCESS_PRIVATE;
- c->initializer = gfc_get_expr ();
parent = gfc_get_derived_super_type (derived);
if (parent)
{
parent_vtab = gfc_find_derived_vtab (parent);
c->ts.type = BT_DERIVED;
c->ts.u.derived = parent_vtab->ts.u.derived;
+ c->initializer = gfc_get_expr ();
c->initializer->expr_type = EXPR_VARIABLE;
gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
&c->initializer->symtree);
{
c->ts.type = BT_DERIVED;
c->ts.u.derived = vtype;
- c->initializer->expr_type = EXPR_NULL;
+ c->initializer = gfc_get_null_expr (NULL);
}
}
vtab->ts.u.derived = vtype;
#include "real.h"
#include "flags.h"
#include "gfortran.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-stmt.h"
#include "trans-types.h"
#include "dependency.h"
static gfc_ss *gfc_walk_subexpr (gfc_ss *, gfc_expr *);
-static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor *);
+static bool gfc_get_array_constructor_size (mpz_t *, gfc_constructor_base);
/* The contents of this structure aren't actually used, just the address. */
static gfc_ss gfc_ss_terminator_var;
of array constructor C. */
static bool
-gfc_get_array_constructor_size (mpz_t * size, gfc_constructor * c)
+gfc_get_array_constructor_size (mpz_t * size, gfc_constructor_base base)
{
+ gfc_constructor *c;
gfc_iterator *i;
mpz_t val;
mpz_t len;
mpz_init (val);
dynamic = false;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
i = c->iterator;
if (i && gfc_iterator_has_dynamic_bounds (i))
static void
gfc_trans_array_constructor_value (stmtblock_t * pblock, tree type,
- tree desc, gfc_constructor * c,
+ tree desc, gfc_constructor_base base,
tree * poffset, tree * offsetvar,
bool dynamic)
{
stmtblock_t body;
gfc_se se;
mpz_t size;
+ gfc_constructor *c;
tree shadow_loopvar = NULL_TREE;
gfc_saved_var saved_loopvar;
mpz_init (size);
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
/* If this is an iterator or an array, the offset must be a variable. */
if ((c->iterator || c->expr->rank > 0) && INTEGER_CST_P (*poffset))
n = 0;
while (p && !(p->iterator || p->expr->expr_type != EXPR_CONSTANT))
{
- p = p->next;
+ p = gfc_constructor_next (p);
n++;
}
if (n < 4)
list = tree_cons (build_int_cst (gfc_array_index_type,
idx++), se.expr, list);
c = p;
- p = p->next;
+ p = gfc_constructor_next (p);
}
bound = build_int_cst (NULL_TREE, n - 1);
Returns TRUE if all elements are character constants. */
bool
-get_array_ctor_strlen (stmtblock_t *block, gfc_constructor * c, tree * len)
+get_array_ctor_strlen (stmtblock_t *block, gfc_constructor_base base, tree * len)
{
+ gfc_constructor *c;
bool is_const;
-
+
is_const = TRUE;
- if (c == NULL)
+ if (gfc_constructor_first (base) == NULL)
{
if (len)
*len = build_int_cstu (gfc_charlen_type_node, 0);
/* Loop over all constructor elements to find out is_const, but in len we
want to store the length of the first, not the last, element. We can
of course exit the loop as soon as is_const is found to be false. */
- for (; c && is_const; c = c->next)
+ for (c = gfc_constructor_first (base);
+ c && is_const; c = gfc_constructor_next (c))
{
switch (c->expr->expr_type)
{
return zero. Note, an empty or NULL array constructor returns zero. */
unsigned HOST_WIDE_INT
-gfc_constant_array_constructor_p (gfc_constructor * c)
+gfc_constant_array_constructor_p (gfc_constructor_base base)
{
unsigned HOST_WIDE_INT nelem = 0;
+ gfc_constructor *c = gfc_constructor_first (base);
while (c)
{
if (c->iterator
|| c->expr->rank > 0
|| c->expr->expr_type != EXPR_CONSTANT)
return 0;
- c = c->next;
+ c = gfc_constructor_next (c);
nelem++;
}
return nelem;
to tree to build an initializer. */
nelem = 0;
list = NULL_TREE;
- c = expr->value.constructor;
+ c = gfc_constructor_first (expr->value.constructor);
while (c)
{
gfc_init_se (&se, NULL);
se.expr);
list = tree_cons (build_int_cst (gfc_array_index_type, nelem),
se.expr, list);
- c = c->next;
+ c = gfc_constructor_next (c);
nelem++;
}
as.type = AS_EXPLICIT;
if (!expr->shape)
{
- as.lower[0] = gfc_int_expr (0);
- as.upper[0] = gfc_int_expr (nelem - 1);
+ as.lower[0] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[0] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, nelem - 1);
}
else
for (i = 0; i < expr->rank; i++)
{
int tmp = (int) mpz_get_si (expr->shape[i]);
- as.lower[i] = gfc_int_expr (0);
- as.upper[i] = gfc_int_expr (tmp - 1);
+ as.lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
+ as.upper[i] = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, tmp - 1);
}
tmptype = gfc_get_nodesc_array_type (type, &as, PACKED_STATIC, true);
static void
gfc_trans_array_constructor (gfc_loopinfo * loop, gfc_ss * ss, locus * where)
{
- gfc_constructor *c;
+ gfc_constructor_base c;
tree offset;
tree offsetvar;
tree desc;
tree tmp;
gfc_ss *loopspec[GFC_MAX_DIMENSIONS];
bool dynamic[GFC_MAX_DIMENSIONS];
- gfc_constructor *c;
mpz_t *cshape;
mpz_t i;
if (ss->type == GFC_SS_CONSTRUCTOR)
{
+ gfc_constructor_base base;
/* An unknown size constructor will always be rank one.
Higher rank constructors will either have known shape,
or still be wrapped in a call to reshape. */
can be determined at compile time. Prefer not to otherwise,
since the general case involves realloc, and it's better to
avoid that overhead if possible. */
- c = ss->expr->value.constructor;
- dynamic[n] = gfc_get_array_constructor_size (&i, c);
+ base = ss->expr->value.constructor;
+ dynamic[n] = gfc_get_array_constructor_size (&i, base);
if (!dynamic[n] || !loopspec[n])
loopspec[n] = ss;
continue;
case EXPR_ARRAY:
/* Create a vector of all the elements. */
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (c->iterator)
{
gfc_option.flag_max_array_constructor);
return NULL_TREE;
}
- if (mpz_cmp_si (c->n.offset, 0) != 0)
- index = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ if (mpz_cmp_si (c->offset, 0) != 0)
+ index = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
else
index = NULL_TREE;
mpz_init (maxval);
tree tmp1, tmp2;
mpz_set (maxval, c->repeat);
- mpz_add (maxval, c->n.offset, maxval);
+ mpz_add (maxval, c->offset, maxval);
mpz_sub_ui (maxval, maxval, 1);
tmp2 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
- if (mpz_cmp_si (c->n.offset, 0) != 0)
+ if (mpz_cmp_si (c->offset, 0) != 0)
{
- mpz_add_ui (maxval, c->n.offset, 1);
+ mpz_add_ui (maxval, c->offset, 1);
tmp1 = gfc_conv_mpz_to_tree (maxval, gfc_index_integer_kind);
}
else
- tmp1 = gfc_conv_mpz_to_tree (c->n.offset, gfc_index_integer_kind);
+ tmp1 = gfc_conv_mpz_to_tree (c->offset, gfc_index_integer_kind);
range = fold_build2 (RANGE_EXPR, integer_type_node, tmp1, tmp2);
}
#include "debug.h"
#include "gfortran.h"
#include "pointer-set.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
return check_constant_initializer (expr, ts, false, false);
else if (expr->expr_type != EXPR_ARRAY)
return false;
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (c->iterator)
return false;
if (expr->expr_type != EXPR_STRUCTURE)
return false;
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
if (!c->expr || cm->attr.allocatable)
continue;
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
/* We've found what we're looking for. */
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
{
+ gfc_constructor *c;
gfc_expr* new_expr;
+
gcc_assert (e->value.constructor);
- new_expr = e->value.constructor->expr;
- e->value.constructor->expr = NULL;
+ c = gfc_constructor_first (e->value.constructor);
+ new_expr = c->expr;
+ c->expr = NULL;
flatten_array_ctors_without_strlen (new_expr);
gfc_replace_expr (e, new_expr);
/* Otherwise, fall through to handle constructor elements. */
case EXPR_STRUCTURE:
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
flatten_array_ctors_without_strlen (c->expr);
break;
gfc_typespec ts;
gfc_clear_ts (&ts);
- *expr = gfc_int_expr ((int)(*expr)->value.character.string[0]);
+ *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ (int)(*expr)->value.character.string[0]);
if ((*expr)->ts.kind != gfc_c_int_kind)
{
/* The expr needs to be compatible with a C int. If the
static void
gfc_apply_interface_mapping_to_cons (gfc_interface_mapping * mapping,
- gfc_constructor * c)
+ gfc_constructor_base base)
{
- for (; c; c = c->next)
+ gfc_constructor *c;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
gfc_apply_interface_mapping_to_expr (mapping, c->expr);
if (c->iterator)
return false;
}
- tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]), gfc_int_expr (1));
+ tmp = gfc_add (gfc_copy_expr (sym->as->upper[d]),
+ gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, 1));
tmp = gfc_subtract (tmp, gfc_copy_expr (sym->as->lower[d]));
if (new_expr)
new_expr = gfc_multiply (new_expr, tmp);
{
gfc_symbol *derived = expr->ts.u.derived;
- expr = gfc_int_expr (0);
-
/* The derived symbol has already been converted to a (void *). Use
its kind. */
+ expr = gfc_get_int_expr (derived->ts.kind, NULL, 0);
expr->ts.f90_type = derived->ts.f90_type;
- expr->ts.kind = derived->ts.kind;
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, expr);
gfc_start_block (&block);
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers. */
if (!c->expr)
cm = expr->ts.u.derived->components;
- for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c), cm = cm->next)
{
/* Skip absent members in default initializers and allocatable
components. Although the latter have a default initializer
rhs->ts = vtab->ts;
}
else if (code->expr2->expr_type == EXPR_NULL)
- rhs = gfc_int_expr (0);
+ rhs = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
else
gcc_unreachable ();
void gfc_generate_constructors (void);
/* Get the string length of an array constructor. */
-bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *);
+bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
/* Generate a runtime error call. */
tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
OSDN Git Service
