+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/cpp.o fortran/data.o fortran/decl.o \
- fortran/dump-parse-tree.o fortran/error.o fortran/expr.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 \
# TODO: Add dependencies on the backend/tree header files
$(F95_PARSER_OBJS): fortran/gfortran.h fortran/libgfortran.h \
- fortran/intrinsic.h fortran/match.h \
+ fortran/intrinsic.h fortran/match.h fortran/constructor.h \
fortran/parse.h fortran/arith.h fortran/target-memory.h \
$(CONFIG_H) $(SYSTEM_H) $(TM_H) $(TM_P_H) coretypes.h \
$(RTL_H) $(TREE_H) $(TREE_DUMP_H) $(GGC_H) $(EXPR_H) \
/* Compiler arithmetic
- 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
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "gfortran.h"
#include "arith.h"
#include "target-memory.h"
+#include "constructor.h"
/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
It's easily implemented with a few calls though. */
}
-/* Function to return a constant expression node of a given type and kind. */
-
-gfc_expr *
-gfc_constant_result (bt type, int kind, locus *where)
-{
- gfc_expr *result;
-
- if (!where)
- gfc_internal_error ("gfc_constant_result(): locus 'where' cannot be NULL");
-
- result = gfc_get_expr ();
-
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = type;
- result->ts.kind = kind;
- result->where = *where;
-
- switch (type)
- {
- case BT_INTEGER:
- mpz_init (result->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (kind);
- mpfr_init (result->value.real);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (kind);
- mpc_init2 (result->value.complex, mpfr_get_default_prec());
- break;
-
- default:
- break;
- }
-
- return result;
-}
-
-
/* Low-level arithmetic functions. All of these subroutines assume
that all operands are of the same type and return an operand of the
same type. The other thing about these subroutines is that they
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
result->value.logical = !op1->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical && op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical || op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical == op2->value.logical;
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_kind_max (op1, op2),
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
+ &op1->where);
result->value.logical = op1->value.logical != op2->value.logical;
*resultp = result;
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
gfc_expr *result;
arith rc;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
rc = ARITH_OK;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op1->ts.type)
{
extern bool init_flag;
rc = ARITH_OK;
- result = gfc_constant_result (op1->ts.type, op1->ts.kind, &op1->where);
+ result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
switch (op2->ts.type)
{
int len;
gcc_assert (op1->ts.kind == op2->ts.kind);
- result = gfc_constant_result (BT_CHARACTER, op1->ts.kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
+ &op1->where);
len = op1->value.character.length + op2->value.character.length;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
? !compare_complex (op1, op2)
: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &op1->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+ &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;
reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
arith rc;
return eval (op, result);
rc = ARITH_OK;
- head = gfc_copy_constructor (op->value.constructor);
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
rc = reduce_unary (eval, c->expr, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op->where);
r->shape = gfc_copy_shape (op->shape, op->rank);
-
- r->ts = head->expr->ts;
- r->where = op->where;
r->rank = op->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op1->value.constructor);
- rc = ARITH_OK;
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op1->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (c->expr, op2, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op2->value.constructor);
- rc = ARITH_OK;
-
- for (c = head; c; c = c->next)
+ head = gfc_constructor_copy (op2->value.constructor);
+ for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
{
if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (op1, c->expr, &r);
}
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op2->where);
r->shape = gfc_copy_shape (op2->shape, op2->rank);
-
- r->ts = head->expr->ts;
- r->where = op2->where;
r->rank = op2->rank;
-
+ r->value.constructor = head;
*result = r;
}
reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
{
- gfc_constructor *c, *d, *head;
+ gfc_constructor_base head;
+ gfc_constructor *c, *d;
gfc_expr *r;
- arith rc;
+ arith rc = ARITH_OK;
- head = gfc_copy_constructor (op1->value.constructor);
+ if (gfc_check_conformance (op1, op2,
+ "elemental binary operation") != SUCCESS)
+ return ARITH_INCOMMENSURATE;
- rc = ARITH_OK;
- d = op2->value.constructor;
-
- if (gfc_check_conformance (op1, op2, "elemental binary operation")
- != SUCCESS)
- rc = ARITH_INCOMMENSURATE;
- else
+ head = gfc_constructor_copy (op1->value.constructor);
+ for (c = gfc_constructor_first (head),
+ d = gfc_constructor_first (op2->value.constructor);
+ c && d;
+ c = gfc_constructor_next (c), d = gfc_constructor_next (d))
{
- for (c = head; c; c = c->next, d = d->next)
- {
- if (d == NULL)
- {
- rc = ARITH_INCOMMENSURATE;
- break;
- }
-
- rc = reduce_binary (eval, c->expr, d->expr, &r);
- if (rc != ARITH_OK)
- break;
-
- gfc_replace_expr (c->expr, r);
- }
+ rc = reduce_binary (eval, c->expr, d->expr, &r);
+ if (rc != ARITH_OK)
+ break;
- if (d != NULL)
- rc = ARITH_INCOMMENSURATE;
+ gfc_replace_expr (c->expr, r);
}
+ if (c || d)
+ rc = ARITH_INCOMMENSURATE;
+
if (rc != ARITH_OK)
- gfc_free_constructor (head);
+ gfc_constructor_free (head);
else
{
- r = gfc_get_expr ();
- r->expr_type = EXPR_ARRAY;
- r->value.constructor = head;
+ gfc_constructor *c = gfc_constructor_first (head);
+ r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
+ &op1->where);
r->shape = gfc_copy_shape (op1->shape, op1->rank);
-
- r->ts = head->expr->ts;
- r->where = op1->where;
r->rank = op1->rank;
-
+ r->value.constructor = head;
*result = r;
}
runtime:
/* Create a run-time expression. */
- result = gfc_get_expr ();
+ result = gfc_get_operator_expr (&op1->where, op, op1, op2);
result->ts = temp.ts;
- result->expr_type = EXPR_OP;
- result->value.op.op = op;
-
- result->value.op.op1 = op1;
- result->value.op.op2 = op2;
-
- result->where = op1->where;
-
return result;
}
gfc_expr *e;
const char *t;
- e = gfc_constant_result (BT_INTEGER, kind, where);
+ e = gfc_get_constant_expr (BT_INTEGER, kind, where);
/* A leading plus is allowed, but not by mpz_set_str. */
if (buffer[0] == '+')
t = buffer + 1;
{
gfc_expr *e;
- e = gfc_constant_result (BT_REAL, kind, where);
+ e = gfc_get_constant_expr (BT_REAL, kind, where);
mpfr_set_str (e->value.real, buffer, 10, GFC_RND_MODE);
return e;
{
gfc_expr *e;
- e = gfc_constant_result (BT_COMPLEX, kind, &real->where);
+ e = gfc_get_constant_expr (BT_COMPLEX, kind, &real->where);
mpc_set_fr_fr (e->value.complex, real->value.real, imag->value.real,
GFC_MPC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
mpz_set (result->value.integer, src->value.integer);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
&src->where);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_REAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
gfc_expr *result;
arith rc;
- result = gfc_constant_result (BT_COMPLEX, kind, &src->where);
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = src->value.logical;
return result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_INTEGER, kind, &src->where);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
mpz_set_si (result->value.integer, src->value.logical);
return result;
{
gfc_expr *result;
- result = gfc_constant_result (BT_LOGICAL, kind, &src->where);
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
return result;
gfc_hollerith2int (gfc_expr *src, int kind)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_INTEGER;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
gfc_hollerith2real (gfc_expr *src, int kind)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_REAL;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
gfc_hollerith2complex (gfc_expr *src, int kind)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_COMPLEX;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
gfc_hollerith2logical (gfc_expr *src, int kind)
{
gfc_expr *result;
-
- result = gfc_get_expr ();
- result->expr_type = EXPR_CONSTANT;
- result->ts.type = BT_LOGICAL;
- result->ts.kind = kind;
- result->where = src->where;
+ result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
hollerith2representation (result, src);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
void gfc_set_model_kind (int);
void gfc_set_model (mpfr_t);
-/* Return a constant result of a given type and kind, with locus. */
-gfc_expr *gfc_constant_result (bt, int, locus *);
-
/* Make sure a gfc_expr expression is within its allowed range. Checks
for overflow and underflow. */
arith gfc_range_check (gfc_expr *);
#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
#include "flags.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
/* Make sure an expression is a scalar. */
if (mask->expr_type == EXPR_ARRAY)
{
- gfc_constructor *mask_ctor = mask->value.constructor;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
if (mask_ctor->expr->value.logical)
mask_true_values++;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
else if (mask->expr_type == EXPR_CONSTANT && mask->value.logical)
int i, extent;
for (i = 0; i < shape_size; ++i)
{
- e = gfc_get_array_element (shape, i);
+ e = gfc_constructor_lookup_expr (shape->value.constructor, i);
if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_free_expr (e);
- continue;
- }
+ continue;
gfc_extract_int (e, &extent);
if (extent < 0)
gfc_current_intrinsic, &e->where, extent);
return FAILURE;
}
-
- gfc_free_expr (e);
}
}
for (i = 1; i <= order_size; ++i)
{
- e = gfc_get_array_element (order, i-1);
+ e = gfc_constructor_lookup_expr (order->value.constructor, i-1);
if (e->expr_type != EXPR_CONSTANT)
- {
- gfc_free_expr (e);
- continue;
- }
+ continue;
gfc_extract_int (e, &dim);
}
perm[dim-1] = 1;
- gfc_free_expr (e);
}
}
}
gfc_constructor *c;
bool test;
- c = shape->value.constructor;
+
mpz_init_set_ui (size, 1);
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (shape->value.constructor);
+ c; c = gfc_constructor_next (c))
mpz_mul (size, size, c->expr->value.integer);
test = mpz_cmp (nelems, size) < 0 && mpz_cmp_ui (size, 0) > 0;
&& gfc_array_size (vector, &vector_size) == SUCCESS)
{
int mask_true_count = 0;
- gfc_constructor *mask_ctor = mask->value.constructor;
+ gfc_constructor *mask_ctor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->expr_type != EXPR_CONSTANT)
if (mask_ctor->expr->value.logical)
mask_true_count++;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
if (mpz_get_si (vector_size) < mask_true_count)
--- /dev/null
+/* Array and structure constructors
+ Copyright (C) 2009, 2010
+ Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#include "config.h"
+#include "system.h"
+#include "gfortran.h"
+#include "constructor.h"
+
+
+static void
+node_free (splay_tree_value value)
+{
+ gfc_constructor *c = (gfc_constructor*)value;
+
+ if (c->expr)
+ gfc_free_expr (c->expr);
+
+ if (c->iterator)
+ gfc_free_iterator (c->iterator, 1);
+
+ mpz_clear (c->offset);
+ mpz_clear (c->repeat);
+
+ gfc_free (c);
+}
+
+
+static gfc_constructor *
+node_copy (splay_tree_node node, void *base)
+{
+ gfc_constructor *c, *src = (gfc_constructor*)node->value;
+
+ c = XCNEW (gfc_constructor);
+ c->base = (gfc_constructor_base)base;
+ c->expr = gfc_copy_expr (src->expr);
+ c->iterator = gfc_copy_iterator (src->iterator);
+ c->where = src->where;
+ c->n.component = src->n.component;
+
+ mpz_init_set (c->offset, src->offset);
+ mpz_init_set (c->repeat, src->repeat);
+
+ return c;
+}
+
+
+static int
+node_copy_and_insert (splay_tree_node node, void *base)
+{
+ int n = mpz_get_si (((gfc_constructor*)node->value)->offset);
+ gfc_constructor_insert ((gfc_constructor_base*)base,
+ node_copy (node, base), n);
+ return 0;
+}
+
+
+gfc_constructor *
+gfc_constructor_get (void)
+{
+ gfc_constructor *c = XCNEW (gfc_constructor);
+ c->base = NULL;
+ c->expr = NULL;
+ c->iterator = NULL;
+
+ mpz_init_set_si (c->offset, 0);
+ mpz_init_set_si (c->repeat, 0);
+
+ return c;
+}
+
+gfc_constructor_base gfc_constructor_get_base (void)
+{
+ return splay_tree_new (splay_tree_compare_ints, NULL, node_free);
+}
+
+
+gfc_constructor_base
+gfc_constructor_copy (gfc_constructor_base base)
+{
+ gfc_constructor_base new_base;
+
+ if (!base)
+ return NULL;
+
+ new_base = gfc_constructor_get_base ();
+ splay_tree_foreach (base, node_copy_and_insert, &new_base);
+
+ return new_base;
+}
+
+
+void
+gfc_constructor_free (gfc_constructor_base base)
+{
+ if (base)
+ splay_tree_delete (base);
+}
+
+
+gfc_constructor *
+gfc_constructor_append (gfc_constructor_base *base, gfc_constructor *c)
+{
+ int offset = 0;
+ if (*base)
+ offset = (int)(splay_tree_max (*base)->key) + 1;
+
+ return gfc_constructor_insert (base, c, offset);
+}
+
+
+gfc_constructor *
+gfc_constructor_append_expr (gfc_constructor_base *base,
+ gfc_expr *e, locus *where)
+{
+ gfc_constructor *c = gfc_constructor_get ();
+ c->expr = e;
+ if (where)
+ c->where = *where;
+
+ return gfc_constructor_append (base, c);
+}
+
+
+gfc_constructor *
+gfc_constructor_insert (gfc_constructor_base *base, gfc_constructor *c, int n)
+{
+ splay_tree_node node;
+
+ if (*base == NULL)
+ *base = splay_tree_new (splay_tree_compare_ints, NULL, node_free);
+
+ c->base = *base;
+ mpz_set_si (c->offset, n);
+
+ node = splay_tree_insert (*base, (splay_tree_key) n, (splay_tree_value) c);
+ gcc_assert (node);
+
+ return (gfc_constructor*)node->value;
+}
+
+
+gfc_constructor *
+gfc_constructor_insert_expr (gfc_constructor_base *base,
+ gfc_expr *e, locus *where, int n)
+{
+ gfc_constructor *c = gfc_constructor_get ();
+ c->expr = e;
+ if (where)
+ c->where = *where;
+
+ return gfc_constructor_insert (base, c, n);
+}
+
+
+gfc_constructor *
+gfc_constructor_lookup (gfc_constructor_base base, int offset)
+{
+ gfc_constructor *c;
+ splay_tree_node node;
+
+ if (!base)
+ return NULL;
+
+ node = splay_tree_lookup (base, (splay_tree_key) offset);
+ if (node)
+ return (gfc_constructor*) node->value;
+
+ /* 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;
+}
+
+
+gfc_expr *
+gfc_constructor_lookup_expr (gfc_constructor_base base, int offset)
+{
+ gfc_constructor *c = gfc_constructor_lookup (base, offset);
+ return c ? c->expr : NULL;
+}
+
+
+int
+gfc_constructor_expr_foreach (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+ int(*f)(gfc_expr *) ATTRIBUTE_UNUSED)
+{
+ gcc_assert (0);
+ return 0;
+}
+
+void
+gfc_constructor_swap (gfc_constructor *ctor ATTRIBUTE_UNUSED,
+ int n ATTRIBUTE_UNUSED, int m ATTRIBUTE_UNUSED)
+{
+ gcc_assert (0);
+}
+
+
+
+gfc_constructor *
+gfc_constructor_first (gfc_constructor_base base)
+{
+ if (base)
+ {
+ splay_tree_node node = splay_tree_min (base);
+ return node ? (gfc_constructor*) node->value : NULL;
+ }
+ else
+ return NULL;
+}
+
+
+gfc_constructor *
+gfc_constructor_next (gfc_constructor *ctor)
+{
+ if (ctor)
+ {
+ splay_tree_node node = splay_tree_successor (ctor->base,
+ mpz_get_si (ctor->offset));
+ return node ? (gfc_constructor*) node->value : NULL;
+ }
+ else
+ return NULL;
+}
--- /dev/null
+/* Array and structure constructors
+ Copyright (C) 2009, 2010
+ Free Software Foundation, Inc.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
+
+#ifndef GFC_CONSTRUCTOR_H
+#define GFC_CONSTRUCTOR_H
+
+#include "gfortran.h"
+#include "splay-tree.h"
+
+
+/* Get a new constructor structure. */
+gfc_constructor *gfc_constructor_get (void);
+
+gfc_constructor_base gfc_constructor_get_base (void);
+
+/* Copy a constructor structure. */
+gfc_constructor_base gfc_constructor_copy (gfc_constructor_base base);
+
+
+/* Free a gfc_constructor structure. */
+void gfc_constructor_free (gfc_constructor_base base);
+
+
+/* Given an constructor structure, append the expression node onto
+ the constructor. Returns the constructor node appended. */
+gfc_constructor *gfc_constructor_append (gfc_constructor_base *base,
+ gfc_constructor *c);
+
+gfc_constructor *gfc_constructor_append_expr (gfc_constructor_base *base,
+ gfc_expr *e, locus *where);
+
+
+/* Given an constructor structure, place the expression node at position.
+ Returns the constructor node inserted. */
+gfc_constructor *gfc_constructor_insert (gfc_constructor_base *base,
+ gfc_constructor *c, int n);
+
+gfc_constructor *gfc_constructor_insert_expr (gfc_constructor_base *base,
+ gfc_expr *e, locus *where,
+ int n);
+
+/* Given an array constructor 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. */
+
+gfc_constructor *gfc_constructor_lookup (gfc_constructor_base base, int n);
+
+/* Convenience function. Same as ...
+ gfc_constructor *c = gfc_constructor_lookup (base, n);
+ gfc_expr *e = c ? c->expr : NULL;
+*/
+gfc_expr *gfc_constructor_lookup_expr (gfc_constructor_base base, int n);
+
+
+int gfc_constructor_expr_foreach (gfc_constructor *ctor, int(*)(gfc_expr *));
+
+
+void gfc_constructor_swap (gfc_constructor *ctor, int n, int m);
+
+
+
+/* Get the first constructor node in the constructure structure.
+ Returns NULL if there is no such expression. */
+gfc_constructor *gfc_constructor_first (gfc_constructor_base base);
+
+/* Get the next constructor node in the constructure structure.
+ Returns NULL if there is no next expression. */
+gfc_constructor *gfc_constructor_next (gfc_constructor *ctor);
+
+gfc_constructor *gfc_constructor_advance (gfc_constructor *ctor, int n);
+
+#endif /* GFC_CONSTRUCTOR_H */
/* Supporting functions for resolving DATA statement.
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Lifang Zeng <zlf605@hotmail.com>
#include "config.h"
#include "gfortran.h"
#include "data.h"
+#include "constructor.h"
static void formalize_init_expr (gfc_expr *);
mpz_clear (tmp);
}
-
-/* Find if there is a constructor which offset is equal to OFFSET. */
+/* Find if there is a constructor which component is equal to COM.
+ TODO: remove this, use symbol.c(gfc_find_component) instead. */
static gfc_constructor *
-find_con_by_offset (splay_tree spt, mpz_t offset)
+find_con_by_component (gfc_component *com, gfc_constructor_base base)
{
- mpz_t tmp;
- gfc_constructor *ret = NULL;
- gfc_constructor *con;
- splay_tree_node sptn;
-
- /* The complexity is due to needing quick access to the linked list of
- constructors. Both a linked list and a splay tree are used, and both
- are kept up to date if they are array elements (which is the only time
- that a specific constructor has to be found). */
-
- gcc_assert (spt != NULL);
- mpz_init (tmp);
-
- sptn = splay_tree_lookup (spt, (splay_tree_key) mpz_get_si (offset));
-
- if (sptn)
- ret = (gfc_constructor*) sptn->value;
- else
- {
- /* Need to check and see if we match a range, so we will pull
- the next lowest index and see if the range matches. */
- sptn = splay_tree_predecessor (spt,
- (splay_tree_key) mpz_get_si (offset));
- if (sptn)
- {
- con = (gfc_constructor*) sptn->value;
- if (mpz_cmp_ui (con->repeat, 1) > 0)
- {
- mpz_init (tmp);
- mpz_add (tmp, con->n.offset, con->repeat);
- if (mpz_cmp (offset, tmp) < 0)
- ret = con;
- mpz_clear (tmp);
- }
- else
- ret = NULL; /* The range did not match. */
- }
- else
- ret = NULL; /* No pred, so no match. */
- }
-
- return ret;
-}
-
+ gfc_constructor *c;
-/* Find if there is a constructor which component is equal to COM. */
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ if (com == c->n.component)
+ return c;
-static gfc_constructor *
-find_con_by_component (gfc_component *com, gfc_constructor *con)
-{
- for (; con; con = con->next)
- {
- if (com == con->n.component)
- return con;
- }
return NULL;
}
if (init == NULL)
{
/* Create a new initializer. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_CONSTANT;
+ init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
init->ts = *ts;
-
- dest = gfc_get_wide_string (len + 1);
- dest[len] = '\0';
- init->value.character.length = len;
- init->value.character.string = dest;
- /* Blank the string if we're only setting a substring. */
- if (ref != NULL)
- gfc_wide_memset (dest, ' ', len);
}
- else
- dest = init->value.character.string;
+
+ dest = init->value.character.string;
if (ref)
{
gfc_expr *expr;
gfc_constructor *con;
gfc_constructor *last_con;
- gfc_constructor *pred;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
- splay_tree spt;
- splay_tree_node sptn;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
}
}
- /* Splay tree containing offset and gfc_constructor. */
- spt = expr->con_by_offset;
-
- if (spt == NULL)
+ con = gfc_constructor_lookup (expr->value.constructor,
+ mpz_get_si (offset));
+ if (!con)
{
- spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
- expr->con_by_offset = spt;
- con = NULL;
- }
- else
- con = find_con_by_offset (spt, offset);
-
- if (con == NULL)
- {
- splay_tree_key j;
-
- /* Create a new constructor. */
- con = gfc_get_constructor ();
- mpz_set (con->n.offset, offset);
- j = (splay_tree_key) mpz_get_si (offset);
- sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
- /* Fix up the linked list. */
- sptn = splay_tree_predecessor (spt, j);
- if (sptn == NULL)
- { /* Insert at the head. */
- con->next = expr->value.constructor;
- expr->value.constructor = con;
- }
- else
- { /* Insert in the chain. */
- pred = (gfc_constructor*) sptn->value;
- con->next = pred->next;
- pred->next = con;
- }
+ con = gfc_constructor_insert_expr (&expr->value.constructor,
+ NULL, NULL,
+ mpz_get_si (offset));
}
break;
last_ts = &ref->u.c.component->ts;
/* Find the same element in the existing constructor. */
- con = expr->value.constructor;
- con = find_con_by_component (ref->u.c.component, con);
+ con = find_con_by_component (ref->u.c.component,
+ expr->value.constructor);
if (con == NULL)
{
/* Create a new constructor. */
- con = gfc_get_constructor ();
+ con = gfc_constructor_append_expr (&expr->value.constructor,
+ NULL, NULL);
con->n.component = ref->u.c.component;
- con->next = expr->value.constructor;
- expr->value.constructor = con;
}
break;
gfc_ref *ref;
gfc_expr *init, *expr;
gfc_constructor *con, *last_con;
- gfc_constructor *pred;
gfc_symbol *symbol;
gfc_typespec *last_ts;
mpz_t offset;
- splay_tree spt;
- splay_tree_node sptn;
symbol = lvalue->symtree->n.sym;
init = symbol->value;
gcc_assert (ref->next == NULL);
}
- /* Find the same element in the existing constructor. */
-
- /* Splay tree containing offset and gfc_constructor. */
- spt = expr->con_by_offset;
-
- if (spt == NULL)
- {
- spt = splay_tree_new (splay_tree_compare_ints, NULL, NULL);
- expr->con_by_offset = spt;
- con = NULL;
- }
- else
- con = find_con_by_offset (spt, offset);
-
+ con = gfc_constructor_lookup (expr->value.constructor,
+ mpz_get_si (offset));
if (con == NULL)
{
- splay_tree_key j;
- /* Create a new constructor. */
- con = gfc_get_constructor ();
- mpz_set (con->n.offset, offset);
- j = (splay_tree_key) mpz_get_si (offset);
-
+ con = gfc_constructor_insert_expr (&expr->value.constructor,
+ NULL, NULL,
+ mpz_get_si (offset));
if (ref->next == NULL)
mpz_set (con->repeat, repeat);
- sptn = splay_tree_insert (spt, j, (splay_tree_value) con);
- /* Fix up the linked list. */
- sptn = splay_tree_predecessor (spt, j);
- if (sptn == NULL)
- { /* Insert at the head. */
- con->next = expr->value.constructor;
- expr->value.constructor = con;
- }
- else
- { /* Insert in the chain. */
- pred = (gfc_constructor*) sptn->value;
- con->next = pred->next;
- pred->next = con;
- }
}
else
gcc_assert (ref->next != NULL);
gcc_assert (expr->expr_type == EXPR_STRUCTURE);
last_ts = &ref->u.c.component->ts;
- /* Find the same element in the existing constructor. */
- con = expr->value.constructor;
- con = find_con_by_component (ref->u.c.component, con);
+ /* 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_get_constructor ();
+ con = gfc_constructor_append_expr (&expr->value.constructor,
+ NULL, NULL);
con->n.component = ref->u.c.component;
- con->next = expr->value.constructor;
- expr->value.constructor = con;
}
/* Since we're only intending to initialize arrays here,
static void
formalize_structure_cons (gfc_expr *expr)
{
- gfc_constructor *head;
- gfc_constructor *tail;
+ gfc_constructor_base base = NULL;
gfc_constructor *cur;
- gfc_constructor *last;
- gfc_constructor *c;
gfc_component *order;
- c = expr->value.constructor;
-
/* Constructor is already formalized. */
- if (!c || c->n.component == NULL)
+ cur = gfc_constructor_first (expr->value.constructor);
+ if (!cur || cur->n.component == NULL)
return;
- head = tail = NULL;
for (order = expr->ts.u.derived->components; order; order = order->next)
{
- /* Find the next component. */
- last = NULL;
- cur = c;
- while (cur != NULL && cur->n.component != order)
- {
- last = cur;
- cur = cur->next;
- }
-
- if (cur == NULL)
- {
- /* Create a new one. */
- cur = gfc_get_constructor ();
- }
+ cur = find_con_by_component (order, expr->value.constructor);
+ if (cur)
+ gfc_constructor_append_expr (&base, cur->expr, &cur->expr->where);
else
- {
- /* Remove it from the chain. */
- if (last == NULL)
- c = cur->next;
- else
- last->next = cur->next;
- cur->next = NULL;
+ gfc_constructor_append_expr (&base, NULL, NULL);
+ }
- formalize_init_expr (cur->expr);
- }
+ /* For all what it's worth, one would expect
+ gfc_constructor_free (expr->value.constructor);
+ here. However, if the constructor is actually free'd,
+ hell breaks loose in the testsuite?! */
- /* Add it to the new constructor. */
- if (head == NULL)
- head = tail = cur;
- else
- {
- tail->next = cur;
- tail = tail->next;
- }
- }
- gcc_assert (c == NULL);
- expr->value.constructor = head;
+ expr->value.constructor = base;
}
switch (type)
{
case EXPR_ARRAY:
- c = expr->value.constructor;
- while (c)
- {
- formalize_init_expr (c->expr);
- c = c->next;
- }
- break;
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
+ formalize_init_expr (c->expr);
+
+ break;
case EXPR_STRUCTURE:
formalize_structure_cons (expr);
#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);
#include "config.h"
#include "gfortran.h"
#include "dependency.h"
+#include "constructor.h"
/* static declarations */
/* Enums */
case EXPR_ARRAY:
/* Loop through the array constructor's elements. */
- for (c = expr2->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr2->value.constructor);
+ c; c = gfc_constructor_next (c))
{
/* If this is an iterator, assume the worst. */
if (c->iterator)
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; gfc_constructor_next (c))
if (contains_forall_index_p (c->expr))
return true;
break;
#include "config.h"
#include "gfortran.h"
+#include "constructor.h"
/* Keep track of indentation for symbol tree dumps. */
static int show_level = 0;
/* Display a constructor. Works recursively for array constructors. */
static void
-show_constructor (gfc_constructor *c)
+show_constructor (gfc_constructor_base base)
{
- for (; c; c = c->next)
+ gfc_constructor *c;
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
if (c->iterator == NULL)
show_expr (c->expr);
fputc (')', dumpfile);
}
- if (c->next != NULL)
+ if (gfc_constructor_next (c) != NULL)
fputs (" , ", dumpfile);
}
}
#include "arith.h"
#include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
-/* Get a new expr node. */
+
+/* The following set of functions provide access to gfc_expr* of
+ various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
+
+ There are two functions available elsewhere that provide
+ slightly different flavours of variables. Namely:
+ expr.c (gfc_get_variable_expr)
+ symbol.c (gfc_lval_expr_from_sym)
+ TODO: Merge these functions, if possible. */
+
+/* Get a new expression node. */
gfc_expr *
gfc_get_expr (void)
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
- e->con_by_offset = NULL;
return e;
}
-/* Free an argument list and everything below it. */
+/* Get a new expression node that is an array constructor
+ of given type and kind. */
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
{
- gfc_actual_arglist *a2;
+ gfc_expr *e;
- while (a1)
- {
- a2 = a1->next;
- gfc_free_expr (a1->expr);
- gfc_free (a1);
- a1 = a2;
- }
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->value.constructor = NULL;
+ e->rank = 1;
+ e->shape = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
}
-/* Copy an arglist structure and all of the arguments. */
+/* Get a new expression node that is the NULL expression. */
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
+gfc_expr *
+gfc_get_null_expr (locus *where)
{
- gfc_actual_arglist *head, *tail, *new_arg;
+ gfc_expr *e;
- head = tail = NULL;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_NULL;
+ e->ts.type = BT_UNKNOWN;
- for (; p; p = p->next)
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an operator expression node. */
+
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+ gfc_expr *op1, gfc_expr *op2)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_OP;
+ e->value.op.op = op;
+ e->value.op.op1 = op1;
+ e->value.op.op2 = op2;
+
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an structure constructor
+ of given type and kind. */
+
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_STRUCTURE;
+ e->value.constructor = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an constant of given type and kind. */
+
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ if (!where)
+ gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+
+ e = gfc_get_expr ();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = type;
+ e->ts.kind = kind;
+ e->where = *where;
+
+ switch (type)
{
- new_arg = gfc_get_actual_arglist ();
- *new_arg = *p;
+ case BT_INTEGER:
+ mpz_init (e->value.integer);
+ break;
- new_arg->expr = gfc_copy_expr (p->expr);
- new_arg->next = NULL;
+ case BT_REAL:
+ gfc_set_model_kind (kind);
+ mpfr_init (e->value.real);
+ break;
- if (head == NULL)
- head = new_arg;
- else
- tail->next = new_arg;
+ case BT_COMPLEX:
+ gfc_set_model_kind (kind);
+ mpc_init2 (e->value.complex, mpfr_get_default_prec());
+ break;
- tail = new_arg;
+ default:
+ break;
}
- return head;
+ return e;
}
-/* Free a list of reference structures. */
+/* Get a new expression node that is an string constant.
+ If no string is passed, a string of len is allocated,
+ blanked and null-terminated. */
-void
-gfc_free_ref_list (gfc_ref *p)
+gfc_expr *
+gfc_get_character_expr (int kind, locus *where, const char *src, int len)
{
- gfc_ref *q;
- int i;
+ gfc_expr *e;
+ gfc_char_t *dest;
- for (; p; p = q)
+ if (!src)
{
- q = p->next;
+ dest = gfc_get_wide_string (len + 1);
+ gfc_wide_memset (dest, ' ', len);
+ dest[len] = '\0';
+ }
+ else
+ dest = gfc_char_to_widechar (src);
- switch (p->type)
+ e = gfc_get_constant_expr (BT_CHARACTER, kind,
+ where ? where : &gfc_current_locus);
+ e->value.character.string = dest;
+ e->value.character.length = len;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an integer constant. */
+
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_INTEGER, kind,
+ where ? where : &gfc_current_locus);
+
+ mpz_init_set_si (p->value.integer, value);
+
+ return p;
+}
+
+
+/* Get a new expression node that is a logical constant. */
+
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_LOGICAL, kind,
+ where ? where : &gfc_current_locus);
+
+ p->value.logical = value;
+
+ return p;
+}
+
+
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+ gfc_expr *e;
+
+ /* Set the types to something compatible with iokind. This is needed to
+ get through gfc_free_expr later since iokind really has no Basic Type,
+ BT, of its own. */
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = BT_LOGICAL;
+ e->value.iokind = k;
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Given an expression pointer, return a copy of the expression. This
+ subroutine is recursive. */
+
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
+{
+ gfc_expr *q;
+ gfc_char_t *s;
+ char *c;
+
+ if (p == NULL)
+ return NULL;
+
+ q = gfc_get_expr ();
+ *q = *p;
+
+ switch (q->expr_type)
+ {
+ case EXPR_SUBSTRING:
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ break;
+
+ case EXPR_CONSTANT:
+ /* Copy target representation, if it exists. */
+ if (p->representation.string)
{
- case REF_ARRAY:
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ c = XCNEWVEC (char, p->representation.length + 1);
+ q->representation.string = c;
+ memcpy (c, p->representation.string, (p->representation.length + 1));
+ }
+
+ /* Copy the values of any pointer components of p->value. */
+ switch (q->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_init_set (q->value.integer, p->value.integer);
+ break;
+
+ case BT_REAL:
+ gfc_set_model_kind (q->ts.kind);
+ mpfr_init (q->value.real);
+ mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (q->ts.kind);
+ mpc_init2 (q->value.complex, mpfr_get_default_prec());
+ mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+ if (p->representation.string)
+ q->value.character.string
+ = gfc_char_to_widechar (q->representation.string);
+ else
{
- gfc_free_expr (p->u.ar.start[i]);
- gfc_free_expr (p->u.ar.end[i]);
- gfc_free_expr (p->u.ar.stride[i]);
- }
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ /* This is the case for the C_NULL_CHAR named constant. */
+ if (p->value.character.length == 0
+ && (p->ts.is_c_interop || p->ts.is_iso_c))
+ {
+ *s = '\0';
+ /* Need to set the length to 1 to make sure the NUL
+ terminator is copied. */
+ q->value.character.length = 1;
+ }
+ else
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ }
break;
- case REF_SUBSTRING:
- gfc_free_expr (p->u.ss.start);
- gfc_free_expr (p->u.ss.end);
+ case BT_HOLLERITH:
+ case BT_LOGICAL:
+ case BT_DERIVED:
+ case BT_CLASS:
+ break; /* Already done. */
+
+ case BT_PROCEDURE:
+ case BT_VOID:
+ /* Should never be reached. */
+ case BT_UNKNOWN:
+ gfc_internal_error ("gfc_copy_expr(): Bad expr node");
+ /* Not reached. */
+ }
+
+ break;
+
+ case EXPR_OP:
+ switch (q->value.op.op)
+ {
+ case INTRINSIC_NOT:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
break;
- case REF_COMPONENT:
+ default: /* Binary operators. */
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+ q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
break;
}
- gfc_free (p);
+ break;
+
+ case EXPR_FUNCTION:
+ q->value.function.actual =
+ gfc_copy_actual_arglist (p->value.function.actual);
+ break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ q->value.compcall.actual =
+ gfc_copy_actual_arglist (p->value.compcall.actual);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ q->value.constructor = gfc_constructor_copy (p->value.constructor);
+ break;
+
+ case EXPR_VARIABLE:
+ case EXPR_NULL:
+ break;
}
+
+ q->shape = gfc_copy_shape (p->shape, p->rank);
+
+ q->ref = gfc_copy_ref (p->ref);
+
+ return q;
}
case EXPR_ARRAY:
case EXPR_STRUCTURE:
- gfc_free_constructor (e->value.constructor);
+ gfc_constructor_free (e->value.constructor);
break;
case EXPR_SUBSTRING:
for (n = 0; n < e->rank; n++)
mpz_clear (e->shape[n]);
- gfc_free (e->shape);
- }
+ gfc_free (e->shape);
+ }
+
+ gfc_free_ref_list (e->ref);
+
+ memset (e, '\0', sizeof (gfc_expr));
+}
+
+
+/* Free an expression node and everything beneath it. */
+
+void
+gfc_free_expr (gfc_expr *e)
+{
+ if (e == NULL)
+ return;
+ free_expr0 (e);
+ gfc_free (e);
+}
+
+
+/* Free an argument list and everything below it. */
+
+void
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
+{
+ gfc_actual_arglist *a2;
+
+ while (a1)
+ {
+ a2 = a1->next;
+ gfc_free_expr (a1->expr);
+ gfc_free (a1);
+ a1 = a2;
+ }
+}
+
+
+/* Copy an arglist structure and all of the arguments. */
+
+gfc_actual_arglist *
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
+{
+ gfc_actual_arglist *head, *tail, *new_arg;
+
+ head = tail = NULL;
+
+ for (; p; p = p->next)
+ {
+ new_arg = gfc_get_actual_arglist ();
+ *new_arg = *p;
+
+ new_arg->expr = gfc_copy_expr (p->expr);
+ new_arg->next = NULL;
+
+ if (head == NULL)
+ head = new_arg;
+ else
+ tail->next = new_arg;
+
+ tail = new_arg;
+ }
+
+ return head;
+}
+
+
+/* Free a list of reference structures. */
+
+void
+gfc_free_ref_list (gfc_ref *p)
+{
+ gfc_ref *q;
+ int i;
+
+ for (; p; p = q)
+ {
+ q = p->next;
- gfc_free_ref_list (e->ref);
+ switch (p->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ gfc_free_expr (p->u.ar.start[i]);
+ gfc_free_expr (p->u.ar.end[i]);
+ gfc_free_expr (p->u.ar.stride[i]);
+ }
- memset (e, '\0', sizeof (gfc_expr));
-}
+ break;
+ case REF_SUBSTRING:
+ gfc_free_expr (p->u.ss.start);
+ gfc_free_expr (p->u.ss.end);
+ break;
-/* Free an expression node and everything beneath it. */
+ case REF_COMPONENT:
+ break;
+ }
-void
-gfc_free_expr (gfc_expr *e)
-{
- if (e == NULL)
- return;
- if (e->con_by_offset)
- splay_tree_delete (e->con_by_offset);
- free_expr0 (e);
- gfc_free (e);
+ gfc_free (p);
+ }
}
}
-/* Given an expression pointer, return a copy of the expression. This
- subroutine is recursive. */
-
-gfc_expr *
-gfc_copy_expr (gfc_expr *p)
-{
- gfc_expr *q;
- gfc_char_t *s;
- char *c;
-
- if (p == NULL)
- return NULL;
-
- q = gfc_get_expr ();
- *q = *p;
-
- switch (q->expr_type)
- {
- case EXPR_SUBSTRING:
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- break;
-
- case EXPR_CONSTANT:
- /* Copy target representation, if it exists. */
- if (p->representation.string)
- {
- c = XCNEWVEC (char, p->representation.length + 1);
- q->representation.string = c;
- memcpy (c, p->representation.string, (p->representation.length + 1));
- }
-
- /* Copy the values of any pointer components of p->value. */
- switch (q->ts.type)
- {
- case BT_INTEGER:
- mpz_init_set (q->value.integer, p->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.real);
- mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (q->ts.kind);
- mpc_init2 (q->value.complex, mpfr_get_default_prec());
- mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
- break;
-
- case BT_CHARACTER:
- if (p->representation.string)
- q->value.character.string
- = gfc_char_to_widechar (q->representation.string);
- else
- {
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
-
- /* This is the case for the C_NULL_CHAR named constant. */
- if (p->value.character.length == 0
- && (p->ts.is_c_interop || p->ts.is_iso_c))
- {
- *s = '\0';
- /* Need to set the length to 1 to make sure the NUL
- terminator is copied. */
- q->value.character.length = 1;
- }
- else
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- }
- break;
-
- case BT_HOLLERITH:
- case BT_LOGICAL:
- case BT_DERIVED:
- case BT_CLASS:
- break; /* Already done. */
-
- case BT_PROCEDURE:
- case BT_VOID:
- /* Should never be reached. */
- case BT_UNKNOWN:
- gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached. */
- }
-
- break;
-
- case EXPR_OP:
- switch (q->value.op.op)
- {
- case INTRINSIC_NOT:
- case INTRINSIC_PARENTHESES:
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- break;
-
- default: /* Binary operators. */
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
- break;
- }
-
- break;
-
- case EXPR_FUNCTION:
- q->value.function.actual =
- gfc_copy_actual_arglist (p->value.function.actual);
- break;
-
- case EXPR_COMPCALL:
- case EXPR_PPC:
- q->value.compcall.actual =
- gfc_copy_actual_arglist (p->value.compcall.actual);
- q->value.compcall.tbp = p->value.compcall.tbp;
- break;
-
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- q->value.constructor = gfc_copy_constructor (p->value.constructor);
- break;
-
- case EXPR_VARIABLE:
- case EXPR_NULL:
- break;
- }
-
- q->shape = gfc_copy_shape (p->shape, p->rank);
-
- q->ref = gfc_copy_ref (p->ref);
-
- return q;
-}
-
-
/* Return the maximum kind of two expressions. In general, higher
kind numbers mean more precision for numeric types. */
}
-/* Returns an expression node that is an integer constant. */
-
-gfc_expr *
-gfc_int_expr (int i)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_INTEGER;
- p->ts.kind = gfc_default_integer_kind;
-
- p->where = gfc_current_locus;
- mpz_init_set_si (p->value.integer, i);
-
- return p;
-}
-
-
-/* Returns an expression node that is a logical constant. */
-
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_LOGICAL;
- p->ts.kind = gfc_default_logical_kind;
-
- if (where == NULL)
- where = &gfc_current_locus;
- p->where = *where;
- p->value.logical = i;
-
- return p;
-}
-
-
/* Return an expression node with an optional argument list attached.
A variable number of gfc_expr pointers are strung together in an
argument list with a NULL pointer terminating the list. */
{
gfc_constructor *c;
gfc_actual_arglist *arg;
- int rv;
if (e == NULL)
return 1;
switch (e->expr_type)
{
case EXPR_OP:
- rv = (gfc_is_constant_expr (e->value.op.op1)
- && (e->value.op.op2 == NULL
- || gfc_is_constant_expr (e->value.op.op2)));
- break;
+ return (gfc_is_constant_expr (e->value.op.op1)
+ && (e->value.op.op2 == NULL
+ || gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
- rv = 0;
- break;
+ return 0;
case EXPR_FUNCTION:
case EXPR_PPC:
case EXPR_COMPCALL:
/* Specification functions are constant. */
if (check_specification_function (e) == MATCH_YES)
- {
- rv = 1;
- break;
- }
+ return 1;
/* Call to intrinsic with at least one argument. */
- rv = 0;
if (e->value.function.isym && e->value.function.actual)
{
for (arg = e->value.function.actual; arg; arg = arg->next)
- {
- if (!gfc_is_constant_expr (arg->expr))
- break;
- }
- if (arg == NULL)
- rv = 1;
+ if (!gfc_is_constant_expr (arg->expr))
+ return 0;
+
+ return 1;
}
- break;
+ else
+ return 0;
case EXPR_CONSTANT:
case EXPR_NULL:
- rv = 1;
- break;
+ return 1;
case EXPR_SUBSTRING:
- rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
- break;
+ return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+ && gfc_is_constant_expr (e->ref->u.ss.end));
case EXPR_STRUCTURE:
- rv = 0;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
if (!gfc_is_constant_expr (c->expr))
- break;
+ return 0;
- if (c == NULL)
- rv = 1;
- break;
+ return 1;
case EXPR_ARRAY:
- rv = gfc_constant_ac (e);
- break;
+ return gfc_constant_ac (e);
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+ return 0;
}
-
- return rv;
}
with gfc_simplify_expr(). */
static gfc_try
-simplify_constructor (gfc_constructor *c, int type)
+simplify_constructor (gfc_constructor_base base, int type)
{
+ gfc_constructor *c;
gfc_expr *p;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
if (c->iterator
&& (gfc_simplify_expr (c->iterator->start, type) == FAILURE
/* Pull a single array element out of an array constructor. */
static gfc_try
-find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
+find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
gfc_constructor **rval)
{
unsigned long nelemen;
mpz_t offset;
mpz_t span;
mpz_t tmp;
+ gfc_constructor *cons;
gfc_expr *e;
gfc_try t;
mpz_mul (span, span, tmp);
}
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
+ cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
{
- if (cons)
+ if (cons->iterator)
{
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
+ cons = NULL;
+ goto depart;
}
}
/* Find a component of a structure constructor. */
static gfc_constructor *
-find_component_ref (gfc_constructor *cons, gfc_ref *ref)
+find_component_ref (gfc_constructor_base base, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
+ gfc_constructor *c = gfc_constructor_first (base);
comp = ref->u.c.sym->components;
pick = ref->u.c.component;
while (comp != pick)
{
comp = comp->next;
- cons = cons->next;
+ c = gfc_constructor_next (c);
}
- return cons;
+ return c;
}
mpz_t tmp_mpz;
mpz_t nelts;
mpz_t ptr;
- mpz_t index;
- gfc_constructor *cons;
- gfc_constructor *base;
+ gfc_constructor_base base;
+ gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
gfc_expr *begin;
gfc_expr *finish;
gfc_expr *step;
gfc_expr *upper;
gfc_expr *lower;
- gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
gfc_try t;
t = SUCCESS;
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
+ gfc_constructor *ci;
gcc_assert (begin);
if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
break;
}
- vecsub[d] = begin->value.constructor;
+ vecsub[d] = gfc_constructor_first (begin->value.constructor);
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
mpz_mul (nelts, nelts, begin->shape[0]);
mpz_set (expr->shape[shape_i++], begin->shape[0]);
/* Check bounds. */
- for (c = vecsub[d]; c; c = c->next)
+ for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
{
- if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
- || mpz_cmp (c->expr->value.integer,
+ if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
+ || mpz_cmp (ci->expr->value.integer,
lower->value.integer) < 0)
{
gfc_error ("index in dimension %d is out of bounds "
mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
}
- mpz_init (index);
mpz_init (ptr);
- cons = base;
+ cons = gfc_constructor_first (base);
/* Now clock through the array reference, calculating the index in
the source constructor and transferring the elements to the new
{
gcc_assert(vecsub[d]);
- if (!vecsub[d]->next)
- vecsub[d] = ref->u.ar.start[d]->value.constructor;
+ if (!gfc_constructor_next (vecsub[d]))
+ vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
else
{
- vecsub[d] = vecsub[d]->next;
+ vecsub[d] = gfc_constructor_next (vecsub[d]);
incr_ctr = false;
}
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
}
}
- /* There must be a better way of dealing with negative strides
- than resetting the index and the constructor pointer! */
- if (mpz_cmp (ptr, index) < 0)
- {
- mpz_set_ui (index, 0);
- cons = base;
- }
-
- while (cons && cons->next && mpz_cmp (ptr, index) > 0)
- {
- mpz_add_ui (index, index, one);
- cons = cons->next;
- }
-
- gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+ cons = gfc_constructor_lookup (base, mpz_get_ui (ptr));
+ gcc_assert (cons);
+ gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (cons->expr), NULL);
}
mpz_clear (ptr);
- mpz_clear (index);
cleanup:
mpz_clear (ctr[d]);
mpz_clear (stride[d]);
}
- gfc_free_constructor (base);
+ gfc_constructor_free (base);
return t;
}
static gfc_try
simplify_const_ref (gfc_expr *p)
{
- gfc_constructor *cons;
+ gfc_constructor *cons, *c;
gfc_expr *newp;
gfc_ref *last_ref;
if (p->ref->next != NULL
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
- cons = p->value.constructor;
- for (; cons; cons = cons->next)
+ for (c = gfc_constructor_first (p->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- cons->expr->ref = gfc_copy_ref (p->ref->next);
- if (simplify_const_ref (cons->expr) == FAILURE)
+ c->expr->ref = gfc_copy_ref (p->ref->next);
+ if (simplify_const_ref (c->expr) == FAILURE)
return FAILURE;
}
if (p->ts.type == BT_DERIVED
&& p->ref->next
- && p->value.constructor)
+ && (c = gfc_constructor_first (p->value.constructor)))
{
/* There may have been component references. */
- p->ts = p->value.constructor->expr->ts;
+ p->ts = c->expr->ts;
}
last_ref = p->ref;
character length according to the first element
(as all should have the same length). */
int string_len;
- if (p->value.constructor)
+ if ((c = gfc_constructor_first (p->value.constructor)))
{
- const gfc_expr* first = p->value.constructor->expr;
+ const gfc_expr* first = c->expr;
gcc_assert (first->expr_type == EXPR_CONSTANT);
gcc_assert (first->ts.type == BT_CHARACTER);
string_len = first->value.character.length;
else
gfc_free_expr (p->ts.u.cl->length);
- p->ts.u.cl->length = gfc_int_expr (string_len);
+ p->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, string_len);
}
}
gfc_free_ref_list (p->ref);
p->value.character.string = s;
p->value.character.length = end - start;
p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
+ p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL,
+ p->value.character.length);
gfc_free_ref_list (p->ref);
p->ref = NULL;
p->expr_type = EXPR_CONSTANT;
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
- gfc_constructor *args[5], *ctor, *new_ctor;
+ gfc_constructor_base ctor;
+ gfc_constructor *args[5];
+ gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
-
+
/* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/
old = gfc_copy_expr (e);
- gfc_free_constructor (expr->value.constructor);
+ gfc_constructor_free (expr->value.constructor);
expr->value.constructor = NULL;
-
expr->ts = old->ts;
expr->where = old->where;
expr->expr_type = EXPR_ARRAY;
{
rank[n] = a->expr->rank;
ctor = a->expr->symtree->n.sym->value->value.constructor;
- args[n] = gfc_copy_constructor (ctor);
+ args[n] = gfc_constructor_first (ctor);
}
else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
{
rank[n] = a->expr->rank;
else
rank[n] = 1;
- args[n] = gfc_copy_constructor (a->expr->value.constructor);
+ ctor = gfc_constructor_copy (a->expr->value.constructor);
+ args[n] = gfc_constructor_first (ctor);
}
else
args[n] = NULL;
+
n++;
}
/* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[array_arg - 1];
- new_ctor = NULL;
- for (; ctor; ctor = ctor->next)
+ for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
{
- if (expr->value.constructor == NULL)
- expr->value.constructor
- = new_ctor = gfc_get_constructor ();
+ new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (old), NULL);
+
+ gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+ a = NULL;
+ b = old->value.function.actual;
+ for (i = 0; i < n; i++)
+ {
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
else
{
- new_ctor->next = gfc_get_constructor ();
- new_ctor = new_ctor->next;
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
}
- new_ctor->expr = gfc_copy_expr (old);
- gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
- a = NULL;
- b = old->value.function.actual;
- for (i = 0; i < n; i++)
- {
- if (a == NULL)
- new_ctor->expr->value.function.actual
- = a = gfc_get_actual_arglist ();
- else
- {
- a->next = gfc_get_actual_arglist ();
- a = a->next;
- }
- if (args[i])
- a->expr = gfc_copy_expr (args[i]->expr);
- else
- a->expr = gfc_copy_expr (b->expr);
- b = b->next;
- }
+ if (args[i])
+ a->expr = gfc_copy_expr (args[i]->expr);
+ else
+ a->expr = gfc_copy_expr (b->expr);
+
+ b = b->next;
+ }
- /* Simplify the function calls. If the simplification fails, the
- error will be flagged up down-stream or the library will deal
- with it. */
- gfc_simplify_expr (new_ctor->expr, 0);
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = args[i]->next;
+ for (i = 0; i < n; i++)
+ if (args[i])
+ args[i] = gfc_constructor_next (args[i]);
- for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
- || (args[i] == NULL && args[array_arg - 1] != NULL)))
- goto compliance;
+ for (i = 1; i < n; i++)
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
+ goto compliance;
}
free_expr0 (e);
static gfc_try
check_alloc_comp_init (gfc_expr *e)
{
- gfc_component *c;
+ gfc_component *comp;
gfc_constructor *ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
gcc_assert (e->ts.type == BT_DERIVED);
- for (c = e->ts.u.derived->components, ctor = e->value.constructor;
- c; c = c->next, ctor = ctor->next)
+ for (comp = e->ts.u.derived->components,
+ ctor = gfc_constructor_first (e->value.constructor);
+ comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
{
- if (c->attr.allocatable
+ if (comp->attr.allocatable
&& ctor->expr->expr_type != EXPR_NULL)
{
gfc_error("Invalid initialization expression for ALLOCATABLE "
"component '%s' in structure constructor at %L",
- c->name, &ctor->expr->where);
+ comp->name, &ctor->expr->where);
return FAILURE;
}
}
gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
- gfc_constructor *tail;
gfc_expr *init;
- gfc_component *c;
+ gfc_component *comp;
/* See if we have a default initializer. */
- for (c = ts->u.derived->components; c; c = c->next)
- if (c->initializer || c->attr.allocatable)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
+ if (comp->initializer || comp->attr.allocatable)
break;
- if (!c)
+ if (!comp)
return NULL;
- /* Build the constructor. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_STRUCTURE;
+ init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+ &ts->u.derived->declared_at);
init->ts = *ts;
- init->where = ts->u.derived->declared_at;
- tail = NULL;
- for (c = ts->u.derived->components; c; c = c->next)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
{
- if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_constructor *ctor = gfc_constructor_get();
- if (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
+ if (comp->initializer)
+ ctor->expr = gfc_copy_expr (comp->initializer);
- if (c->attr.allocatable)
+ if (comp->attr.allocatable)
{
- tail->expr = gfc_get_expr ();
- tail->expr->expr_type = EXPR_NULL;
- tail->expr->ts = c->ts;
+ ctor->expr = gfc_get_expr ();
+ ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->ts = comp->ts;
}
+
+ gfc_constructor_append (&init->value.constructor, ctor);
}
+
return init;
}
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (gfc_traverse_expr (c->expr, sym, func, f))
return true;
#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 *);
/* Deal with I/O statements & related stuff.
- 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
Free Software Foundation, Inc.
Contributed by Andy Vaught
new_st.loc = start;
new_st.op = EXEC_NOP;
- e = gfc_get_expr();
- e->expr_type = EXPR_CONSTANT;
- e->ts.type = BT_CHARACTER;
- e->ts.kind = gfc_default_character_kind;
- e->where = start;
- e->value.character.string = format_string
- = gfc_get_wide_string (format_length + 1);
- e->value.character.length = format_length;
+ e = gfc_get_character_expr (gfc_default_character_kind, &start,
+ NULL, format_length);
+ format_string = e->value.character.string;
gfc_statement_label->format = e;
mode = MODE_COPY;
else
unit = 6;
- return gfc_int_expr (unit);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, unit);
}
that might have a format expression without unit number. */
if (!comma_flag && gfc_match_char (',') == MATCH_YES)
{
- dt->extra_comma = gfc_get_expr ();
-
- /* Set the types to something compatible with iokind. This is needed to
- get through gfc_free_expr later since iokind really has no Basic Type,
- BT, of its own. */
- dt->extra_comma->expr_type = EXPR_CONSTANT;
- dt->extra_comma->ts.type = BT_LOGICAL;
-
/* Save the iokind and locus for later use in resolution. */
- dt->extra_comma->value.iokind = k;
- dt->extra_comma->where = gfc_current_locus;
+ dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k);
}
io_code = NULL;
#include "tree.h"
#include "gfortran.h"
#include "intrinsic.h"
+#include "constructor.h"
/* Given printf-like arguments, return a stable version of the result string.
if (source->expr_type == EXPR_CONSTANT)
{
- source->ts.u.cl->length = gfc_int_expr (source->value.character.length);
+ source->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ source->value.character.length);
source->rank = 0;
}
else if (source->expr_type == EXPR_ARRAY)
- source->ts.u.cl->length =
- gfc_int_expr (source->value.constructor->expr->value.character.length);
+ {
+ gfc_constructor *c = gfc_constructor_first (source->value.constructor);
+ source->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ c->expr->value.character.length);
+ }
}
/* Helper function for resolving the "mask" argument. */
f->ts.kind = (kind == NULL)
? gfc_default_character_kind : mpz_get_si (kind->value.integer);
f->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- f->ts.u.cl->length = gfc_int_expr (1);
+ f->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
f->value.function.name = gfc_get_string (name, f->ts.kind,
gfc_type_letter (x->ts.type),
void
gfc_resolve_dcmplx (gfc_expr *f, gfc_expr *x, gfc_expr *y)
{
- gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
+ gfc_resolve_cmplx (f, x, y, gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ gfc_default_double_kind));
}
{
gfc_constructor *c;
f->shape = gfc_get_shape (f->rank);
- c = shape->value.constructor;
+ c = gfc_constructor_first (shape->value.constructor);
for (i = 0; i < f->rank; i++)
{
mpz_init_set (f->shape[i], c->expr->value.integer);
- c = c->next;
+ c = gfc_constructor_next (c);
}
}
{
int len;
if (mold->expr_type == EXPR_CONSTANT)
- mold->ts.u.cl->length = gfc_int_expr (mold->value.character.length);
+ {
+ len = mold->value.character.length;
+ mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, len);
+ }
else
{
- len = mold->value.constructor->expr->value.character.length;
- mold->ts.u.cl->length = gfc_int_expr (len);
+ gfc_constructor *c = gfc_constructor_first (mold->value.constructor);
+ len = c->expr->value.character.length;
+ mold->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, len);
}
}
/* 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);
/* Expression parser.
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
{
gfc_expr *e2;
- e2 = gfc_get_expr();
- e2->expr_type = EXPR_OP;
+ e2 = gfc_get_operator_expr (&e->where, INTRINSIC_PARENTHESES, e, NULL);
e2->ts = e->ts;
e2->rank = e->rank;
- e2->where = e->where;
- e2->value.op.op = INTRINSIC_PARENTHESES;
- e2->value.op.op1 = e;
- e2->value.op.op2 = NULL;
+
return e2;
}
}
-/* Build an operator expression node. */
-
-static gfc_expr *
-build_node (gfc_intrinsic_op op, locus *where,
- gfc_expr *op1, gfc_expr *op2)
-{
- gfc_expr *new_expr;
-
- new_expr = gfc_get_expr ();
- new_expr->expr_type = EXPR_OP;
- new_expr->value.op.op = op;
- new_expr->where = *where;
-
- new_expr->value.op.op1 = op1;
- new_expr->value.op.op2 = op2;
-
- return new_expr;
-}
-
-
/* Match a level 1 expression. */
static match
*result = e;
else
{
- f = build_node (INTRINSIC_USER, &where, e, NULL);
+ f = gfc_get_operator_expr (&where, INTRINSIC_USER, e, NULL);
f->value.op.uop = uop;
*result = f;
}
return MATCH_ERROR;
}
- all = build_node (INTRINSIC_USER, &where, all, e);
+ all = gfc_get_operator_expr (&where, INTRINSIC_USER, all, e);
all->value.op.uop = uop;
}
#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;
/* Primary expression subroutines
- Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "match.h"
#include "parse.h"
#include "toplev.h"
+#include "constructor.h"
/* Matches a kind-parameter expression, which is either a named
symbolic constant or a nonnegative integer constant. If
else
{
gfc_free_expr (e);
- e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
- &gfc_current_locus);
+ e = gfc_get_constant_expr (BT_HOLLERITH, gfc_default_character_kind,
+ &gfc_current_locus);
e->representation.string = XCNEWVEC (char, num + 1);
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 && cl)
end = gfc_copy_expr (cl->length);
if (peek == 'b' || peek == 'o' || peek =='z' || peek == 'x')
goto no_match;
-
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
+ e = gfc_get_character_expr (kind, &start_locus, NULL, length);
e->ref = NULL;
- e->ts.type = BT_CHARACTER;
- e->ts.kind = kind;
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = start_locus;
-
- e->value.character.string = p = gfc_get_wide_string (length + 1);
- e->value.character.length = length;
gfc_current_locus = start_locus;
gfc_next_char (); /* Skip delimiter */
warn_ampersand = gfc_option.warn_ampersand;
gfc_option.warn_ampersand = 0;
+ p = e->value.character.string;
for (i = 0; i < length; i++)
{
c = next_string_char (delimiter, &ret);
return MATCH_ERROR;
}
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = i;
- e->ts.type = BT_LOGICAL;
- e->ts.kind = kind;
+ e = gfc_get_logical_expr (kind, &gfc_current_locus, i);
e->ts.is_c_interop = 0;
e->ts.is_iso_c = 0;
- e->where = gfc_current_locus;
*result = e;
return MATCH_YES;
for components without explicit value given. */
static gfc_try
build_actual_constructor (gfc_structure_ctor_component **comp_head,
- gfc_constructor **ctor_head, gfc_symbol *sym)
+ gfc_constructor_base *ctor_head, gfc_symbol *sym)
{
gfc_structure_ctor_component *comp_iter;
- gfc_constructor *ctor_tail = NULL;
gfc_component *comp;
for (comp = sym->components; comp; comp = comp->next)
a value expression for the parent derived type and calling self. */
if (!comp_iter && comp == sym->components && sym->attr.extension)
{
- value = gfc_get_expr ();
- value->expr_type = EXPR_STRUCTURE;
- value->value.constructor = NULL;
+ value = gfc_get_structure_constructor_expr (comp->ts.type,
+ comp->ts.kind,
+ &gfc_current_locus);
value->ts = comp->ts;
- value->where = gfc_current_locus;
if (build_actual_constructor (comp_head, &value->value.constructor,
comp->ts.u.derived) == FAILURE)
gfc_free_expr (value);
return FAILURE;
}
- *ctor_head = ctor_tail = gfc_get_constructor ();
- ctor_tail->expr = value;
+
+ gfc_constructor_append_expr (ctor_head, value, NULL);
continue;
}
value = comp_iter->val;
/* Add the value to the constructor chain built. */
- if (ctor_tail)
- {
- ctor_tail->next = gfc_get_constructor ();
- ctor_tail = ctor_tail->next;
- }
- else
- *ctor_head = ctor_tail = gfc_get_constructor ();
- gcc_assert (value);
- ctor_tail->expr = value;
+ gfc_constructor_append_expr (ctor_head, value, NULL);
/* Remove the entry from the component list. We don't want the expression
value to be free'd, so set it to NULL. */
bool parent)
{
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
- gfc_constructor *ctor_head, *ctor_tail;
+ gfc_constructor_base ctor_head = NULL;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
locus where;
const char* last_name = NULL;
comp_tail = comp_head = NULL;
- ctor_head = ctor_tail = NULL;
if (!parent && gfc_match_char ('(') != MATCH_YES)
goto syntax;
else
gcc_assert (!comp_head);
- e = gfc_get_expr ();
-
- e->expr_type = EXPR_STRUCTURE;
-
- e->ts.type = BT_DERIVED;
+ e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
e->ts.u.derived = sym;
- e->where = where;
-
e->value.constructor = ctor_head;
*result = e;
gfc_free_structure_ctor_component (comp_iter);
comp_iter = next;
}
- gfc_free_constructor (ctor_head);
+ gfc_constructor_free (ctor_head);
return MATCH_ERROR;
}
#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);
#include "arith.h"
#include "intrinsic.h"
#include "target-memory.h"
+#include "constructor.h"
-/* Savely advance an array constructor by 'n' elements.
- Mainly used by simplifiers of transformational intrinsics. */
-#define ADVANCE(ctor, n) do { int i; for (i = 0; i < n && ctor; ++i) ctor = ctor->next; } while (0)
gfc_expr gfc_bad_expr;
be a part of the new expression.
NULL pointer indicating that no simplification was possible and
- the original expression should remain intact. If the
- simplification function sets the type and/or the function name
- via the pointer gfc_simple_expression, then this type is
- retained.
+ the original expression should remain intact.
An expression pointer to gfc_bad_expr (a static placeholder)
- indicating that some error has prevented simplification. For
- example, sqrt(-1.0). The error is generated within the function
- and should be propagated upwards
+ indicating that some error has prevented simplification. The
+ error is generated within the function and should be propagated
+ upwards
By the time a simplification function gets control, it has been
decided that the function call is really supposed to be the
subroutine may have to look at the type of an argument as part of
its processing.
- Array arguments are never passed to these subroutines.
+ Array arguments are only passed to these subroutines that implement
+ the simplification of transformational intrinsics.
The functions in this file don't have much comment with them, but
everything is reasonably straight-forward. The Standard, chapter 13
}
-/* Helper function to get an integer constant with a kind number given
- by an integer constant expression. */
-static gfc_expr *
-int_expr_with_kind (int i, gfc_expr *kind, const char *name)
-{
- gfc_expr *res = gfc_int_expr (i);
- res->ts.kind = get_kind (BT_INTEGER, kind, name, gfc_default_integer_kind);
- if (res->ts.kind == -1)
- return NULL;
- else
- return res;
-}
-
-
/* Converts an mpz_t signed variable into an unsigned one, assuming
two's complement representations and a binary width of bitsize.
The conversion is a no-op unless x is negative; otherwise, it can
}
}
+
+/* In-place convert BOZ to REAL of the specified kind. */
+
+static gfc_expr *
+convert_boz (gfc_expr *x, int kind)
+{
+ if (x && x->ts.type == BT_INTEGER && x->is_boz)
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+ ts.type = BT_REAL;
+ ts.kind = kind;
+
+ if (!gfc_convert_boz (x, &ts))
+ return &gfc_bad_expr;
+ }
+
+ return x;
+}
+
+
/* Test that the expression is an constant array. */
static bool
if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
return false;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
if (c->expr->expr_type != EXPR_CONSTANT)
return false;
{
if (e && e->expr_type == EXPR_ARRAY)
{
- gfc_constructor *ctor = e->value.constructor;
+ gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
while (ctor)
{
init_result_expr (ctor->expr, init, array);
- ctor = ctor->next;
+ ctor = gfc_constructor_next (ctor);
}
}
else if (e && e->expr_type == EXPR_CONSTANT)
/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul. */
static gfc_expr *
-compute_dot_product (gfc_constructor *ctor_a, int stride_a,
- gfc_constructor *ctor_b, int stride_b)
+compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
+ gfc_expr *matrix_b, int stride_b, int offset_b)
{
- gfc_expr *result;
- gfc_expr *a = ctor_a->expr, *b = ctor_b->expr;
-
- gcc_assert (gfc_compare_types (&a->ts, &b->ts));
+ gfc_expr *result, *a, *b;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ result = gfc_get_constant_expr (matrix_a->ts.type, matrix_a->ts.kind,
+ &matrix_a->where);
init_result_expr (result, 0, NULL);
- while (ctor_a && ctor_b)
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
+ while (a && b)
{
/* Copying of expressions is required as operands are free'd
by the gfc_arith routines. */
{
case BT_LOGICAL:
result = gfc_or (result,
- gfc_and (gfc_copy_expr (ctor_a->expr),
- gfc_copy_expr (ctor_b->expr)));
+ gfc_and (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
break;
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
result = gfc_add (result,
- gfc_multiply (gfc_copy_expr (ctor_a->expr),
- gfc_copy_expr (ctor_b->expr)));
+ gfc_multiply (gfc_copy_expr (a),
+ gfc_copy_expr (b)));
break;
default:
gcc_unreachable();
}
- ADVANCE (ctor_a, stride_a);
- ADVANCE (ctor_b, stride_b);
+ offset_a += stride_a;
+ a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
+
+ offset_b += stride_b;
+ b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
}
return result;
int i, nelem;
if (!dim || array->rank == 1)
- return gfc_constant_result (type, kind, where);
+ return gfc_get_constant_expr (type, kind, where);
- result = gfc_start_constructor (type, kind, where);
+ result = gfc_get_array_expr (type, kind, where);
result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
result->rank = array->rank - 1;
for (i = 0; i < nelem; ++i)
{
- gfc_expr *e = gfc_constant_result (type, kind, where);
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_get_constant_expr (type, kind, where),
+ NULL);
}
return result;
&& !mask->value.logical)
return result;
- array_ctor = array->value.constructor;
+ array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (array_ctor)
{
a = array_ctor->expr;
- array_ctor = array_ctor->next;
+ array_ctor = gfc_constructor_next (array_ctor);
/* A constant MASK equals .TRUE. here and can be ignored. */
if (mask_ctor)
{
m = mask_ctor->expr;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
if (!m->value.logical)
continue;
}
arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
- array_ctor = array->value.constructor;
+ array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
for (i = 0; i < arraysize; ++i)
{
arrayvec[i] = array_ctor->expr;
- array_ctor = array_ctor->next;
+ array_ctor = gfc_constructor_next (array_ctor);
if (mask_ctor)
{
if (!mask_ctor->expr->value.logical)
arrayvec[i] = NULL;
- mask_ctor = mask_ctor->next;
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
mpz_clear (size);
resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
- result_ctor = result->value.constructor;
+ result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
resultvec[i] = result_ctor->expr;
- result_ctor = result_ctor->next;
+ result_ctor = gfc_constructor_next (result_ctor);
}
gfc_extract_int (dim, &dim_index);
}
/* Place updated expression in result constructor. */
- result_ctor = result->value.constructor;
+ result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor->expr = resultvec[i];
- result_ctor = result_ctor->next;
+ result_ctor = gfc_constructor_next (result_ctor);
}
gfc_free (arrayvec);
switch (e->ts.type)
{
- case BT_INTEGER:
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
-
- mpz_abs (result->value.integer, e->value.integer);
-
- result = range_check (result, "IABS");
- break;
-
- case BT_REAL:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-
- mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
-
- result = range_check (result, "ABS");
- break;
-
- case BT_COMPLEX:
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
+ mpz_abs (result->value.integer, e->value.integer);
+ return range_check (result, "IABS");
- gfc_set_model_kind (e->ts.kind);
+ case BT_REAL:
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
+ return range_check (result, "ABS");
- mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
- result = range_check (result, "CABS");
- break;
+ case BT_COMPLEX:
+ gfc_set_model_kind (e->ts.kind);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
+ return range_check (result, "CABS");
- default:
- gfc_internal_error ("gfc_simplify_abs(): Bad type");
+ default:
+ gfc_internal_error ("gfc_simplify_abs(): Bad type");
}
-
- return result;
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
- result->value.character.string = gfc_get_wide_string (2);
- result->value.character.length = 1;
+ result = gfc_get_character_expr (kind, &e->where, NULL, 1);
result->value.character.string[0] = mpz_get_ui (e->value.integer);
- result->value.character.string[1] = '\0'; /* For debugger */
+
return result;
}
&x->where);
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_acos(): Bad type");
}
-
return range_check (result, "ACOS");
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
}
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_get_wide_string (len + 1);
-
for (count = 0, i = 0; i < len; ++i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < len - count; ++i)
result->value.character.string[i] = e->value.character.string[count + i];
- for (i = len - count; i < len; ++i)
- result->value.character.string[i] = ' ';
-
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
len = e->value.character.length;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
- result->value.character.length = len;
- result->value.character.string = gfc_get_wide_string (len + 1);
-
for (count = 0, i = len - 1; i >= 0; --i)
{
ch = e->value.character.string[i];
++count;
}
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < count; ++i)
result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
result->value.character.string[i] = e->value.character.string[i - count];
- result->value.character.string[len] = '\0'; /* For debugger */
-
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "AINT");
return NULL;
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, gfc_default_double_kind);
+
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "ANINT");
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_and (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "AND");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical && y->value.logical;
- return result;
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "AND");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical && y->value.logical);
+
+ default:
+ gcc_unreachable ();
}
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
&x->where);
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_asin(): Bad type");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
switch (x->ts.type)
{
case BT_REAL:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
-
+
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
+
switch (x->ts.type)
{
case BT_REAL:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_atan(): Bad type");
}
"to 1", &x->where);
return &gfc_bad_expr;
}
-
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
break;
+
case BT_COMPLEX:
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
+
default:
gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
gfc_expr *
-gfc_simplify_bessel_j0 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_j0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J0");
gfc_expr *
-gfc_simplify_bessel_j1 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_j1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J1");
gfc_expr *
-gfc_simplify_bessel_jn (gfc_expr *order ATTRIBUTE_UNUSED,
- gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
return NULL;
n = mpz_get_si (order->value.integer);
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_JN");
gfc_expr *
-gfc_simplify_bessel_y0 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_y0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y0");
gfc_expr *
-gfc_simplify_bessel_y1 (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_y1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y1");
gfc_expr *
-gfc_simplify_bessel_yn (gfc_expr *order ATTRIBUTE_UNUSED,
- gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
return NULL;
n = mpz_get_si (order->value.integer);
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_YN");
gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_INTEGER, e->ts.kind, &e->where);
- mpz_set_ui (result->value.integer, gfc_integer_kinds[i].bit_size);
-
- return result;
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ return gfc_get_int_expr (e->ts.kind, &e->where,
+ gfc_integer_kinds[i].bit_size);
}
return NULL;
if (gfc_extract_int (bit, &b) != NULL || b < 0)
- return gfc_logical_expr (0, &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
- return gfc_logical_expr (mpz_tstbit (e->value.integer, b), &e->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
+ mpz_tstbit (e->value.integer, b));
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
ceil = gfc_copy_expr (e);
-
mpfr_ceil (ceil->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
gfc_free_expr (ceil);
}
-/* Common subroutine for simplifying CMPLX and DCMPLX. */
+/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
static gfc_expr *
simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
- result = gfc_constant_result (BT_COMPLEX, kind, &x->where);
+ if (convert_boz (x, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (convert_boz (y, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
+
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- if (!x->is_boz)
+ case BT_INTEGER:
mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
- break;
+ break;
- case BT_REAL:
- mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- break;
+ case BT_COMPLEX:
+ mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
}
- if (y != NULL)
- {
- switch (y->ts.type)
- {
- case BT_INTEGER:
- if (!y->is_boz)
- mpfr_set_z (mpc_imagref (result->value.complex),
- y->value.integer, GFC_RND_MODE);
- break;
-
- case BT_REAL:
- mpfr_set (mpc_imagref (result->value.complex),
- y->value.real, GFC_RND_MODE);
- break;
-
- default:
- gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
- }
- }
+ if (!y)
+ return range_check (result, name);
- /* Handle BOZ. */
- if (x->is_boz)
+ switch (y->ts.type)
{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.kind = result->ts.kind;
- ts.type = BT_REAL;
- if (!gfc_convert_boz (x, &ts))
- return &gfc_bad_expr;
- mpfr_set (mpc_realref (result->value.complex),
- x->value.real, GFC_RND_MODE);
- }
+ case BT_INTEGER:
+ mpfr_set_z (mpc_imagref (result->value.complex),
+ y->value.integer, GFC_RND_MODE);
+ break;
- if (y && y->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.kind = result->ts.kind;
- ts.type = BT_REAL;
- if (!gfc_convert_boz (y, &ts))
- return &gfc_bad_expr;
- mpfr_set (mpc_imagref (result->value.complex),
- y->value.real, GFC_RND_MODE);
+ case BT_REAL:
+ mpfr_set (mpc_imagref (result->value.complex),
+ y->value.real, GFC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
}
return range_check (result, name);
}
-/* Function called when we won't simplify an expression like CMPLX (or
- COMPLEX or DCMPLX) but still want to convert BOZ arguments. */
-
-static gfc_expr *
-only_convert_cmplx_boz (gfc_expr *x, gfc_expr *y, int kind)
-{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
-
- if (x->is_boz && !gfc_convert_boz (x, &ts))
- return &gfc_bad_expr;
-
- if (y && y->is_boz && !gfc_convert_boz (y, &ts))
- return &gfc_bad_expr;
-
- return NULL;
-}
-
-
gfc_expr *
gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
- kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_real_kind);
+ kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
if (kind == -1)
return &gfc_bad_expr;
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, kind);
-
return simplify_cmplx ("CMPLX", x, y, kind);
}
{
int kind;
- if (x->ts.type == BT_INTEGER)
- {
- if (y->ts.type == BT_INTEGER)
- kind = gfc_default_real_kind;
- else
- kind = y->ts.kind;
- }
+ if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
+ kind = gfc_default_complex_kind;
+ else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
+ kind = x->ts.kind;
+ else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
+ kind = y->ts.kind;
+ else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
+ kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
else
- {
- if (y->ts.type == BT_REAL)
- kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
- else
- kind = x->ts.kind;
- }
-
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, kind);
+ gcc_unreachable ();
return simplify_cmplx ("COMPLEX", x, y, kind);
}
result = gfc_copy_expr (e);
mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
+
return range_check (result, "CONJG");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
- break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
- mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- break;
- default:
- gfc_internal_error ("in gfc_simplify_cos(): Bad type");
+ case BT_REAL:
+ mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "COS");
-
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- if (x->ts.type == BT_REAL)
- mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
- else if (x->ts.type == BT_COMPLEX)
- mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- else
- gcc_unreachable ();
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "COSH");
}
gfc_expr *
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
-
- if (x->expr_type != EXPR_CONSTANT
- || (y != NULL && y->expr_type != EXPR_CONSTANT))
- return only_convert_cmplx_boz (x, y, gfc_default_double_kind);
-
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- if (!e->is_boz)
- result = gfc_int2real (e, gfc_default_double_kind);
- break;
-
- case BT_REAL:
- result = gfc_real2real (e, gfc_default_double_kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2real (e, gfc_default_double_kind);
- break;
-
- default:
- gfc_internal_error ("gfc_simplify_dble(): bad type at %L", &e->where);
- }
+ if (convert_boz (e, gfc_default_double_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
- if (e->ts.type == BT_INTEGER && e->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = gfc_default_double_kind;
- result = gfc_copy_expr (e);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
+ result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
return range_check (result, "DBLE");
}
int i, digits;
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+
switch (x->ts.type)
{
- case BT_INTEGER:
- digits = gfc_integer_kinds[i].digits;
- break;
+ case BT_INTEGER:
+ digits = gfc_integer_kinds[i].digits;
+ break;
- case BT_REAL:
- case BT_COMPLEX:
- digits = gfc_real_kinds[i].digits;
- break;
+ case BT_REAL:
+ case BT_COMPLEX:
+ digits = gfc_real_kinds[i].digits;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- return gfc_int_expr (digits);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
}
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- result = gfc_constant_result (x->ts.type, kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp (x->value.integer, y->value.integer) > 0)
- mpz_sub (result->value.integer, x->value.integer, y->value.integer);
- else
- mpz_set_ui (result->value.integer, 0);
+ case BT_INTEGER:
+ if (mpz_cmp (x->value.integer, y->value.integer) > 0)
+ mpz_sub (result->value.integer, x->value.integer, y->value.integer);
+ else
+ mpz_set_ui (result->value.integer, 0);
- break;
+ break;
- case BT_REAL:
- if (mpfr_cmp (x->value.real, y->value.real) > 0)
- mpfr_sub (result->value.real, x->value.real, y->value.real,
- GFC_RND_MODE);
- else
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
+ case BT_REAL:
+ if (mpfr_cmp (x->value.real, y->value.real) > 0)
+ mpfr_sub (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
- break;
+ break;
- default:
- gfc_internal_error ("gfc_simplify_dim(): Bad type");
+ default:
+ gfc_internal_error ("gfc_simplify_dim(): Bad type");
}
return range_check (result, "DIM");
gfc_expr*
gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
- gfc_expr *result;
-
if (!is_constant_array_expr (vector_a)
|| !is_constant_array_expr (vector_b))
return NULL;
gcc_assert (vector_b->rank == 1);
gcc_assert (gfc_compare_types (&vector_a->ts, &vector_b->ts));
- if (vector_a->value.constructor && vector_b->value.constructor)
- return compute_dot_product (vector_a->value.constructor, 1,
- vector_b->value.constructor, 1);
-
- /* Zero sized array ... */
- result = gfc_constant_result (vector_a->ts.type,
- vector_a->ts.kind,
- &vector_a->where);
- init_result_expr (result, 0, NULL);
- return result;
+ return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0);
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &x->where);
-
a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, gfc_default_double_kind);
+ result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
- gfc_free_expr (a1);
gfc_free_expr (a2);
+ gfc_free_expr (a1);
return range_check (result, "DPROD");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ERF");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ERFC");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
asympt_erfc_scaled (result->value.real, x->value.real);
else
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
return range_check (result, "EPSILON");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- gfc_set_model_kind (x->ts.kind);
- mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- break;
+ case BT_COMPLEX:
+ gfc_set_model_kind (x->ts.kind);
+ mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_exp(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_exp(): Bad type");
}
return range_check (result, "EXP");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &x->where);
gfc_set_model (x->value.real);
if (a->is_boz)
{
- gfc_typespec ts;
- gfc_clear_ts (&ts);
-
- ts.type = BT_REAL;
- ts.kind = gfc_default_real_kind;
+ if (convert_boz (a, gfc_default_real_kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
result = gfc_copy_expr (a);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
}
else
result = gfc_int2real (a, gfc_default_real_kind);
+
return range_check (result, "FLOAT");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
gfc_set_model_kind (kind);
+
mpfr_init (floor);
mpfr_floor (floor, e->value.real);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
mpfr_clear (floor);
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "GAMMA");
int i;
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
switch (e->ts.type)
{
- case BT_INTEGER:
- mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
- break;
+ case BT_INTEGER:
+ mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
+ break;
- case BT_REAL:
- mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
return result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
return range_check (result, "HYPOT");
}
{
gfc_expr *result;
gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
gfc_warning ("Argument of IACHAR function at %L outside of range 0..127",
&e->where);
- if ((result = int_expr_with_kind (index, kind, "IACHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
return range_check (result, "IACHAR");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IAND");
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
convert_mpz_to_unsigned (result->value.integer,
gfc_integer_kinds[k].bit_size);
{
gfc_expr *result;
gfc_char_t index;
+ int k;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
index = e->value.character.string[0];
- if ((result = int_expr_with_kind (index, kind, "ICHAR")) == NULL)
+ k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
+ if (k == -1)
return &gfc_bad_expr;
- result->where = e->where;
+ result = gfc_get_int_expr (k, &e->where, index);
+
return range_check (result, "ICHAR");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "IEOR");
if (k == -1)
return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, k, &x->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
len = x->value.character.length;
lensub = y->value.character.length;
}
-gfc_expr *
-gfc_simplify_int (gfc_expr *e, gfc_expr *k)
+static gfc_expr *
+simplify_intconv (gfc_expr *e, int kind, const char *name)
{
gfc_expr *result = NULL;
- int kind;
-
- kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
- if (kind == -1)
- return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2int (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2int (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2int (e, kind);
- break;
-
- default:
- gfc_error ("Argument of INT at %L is not a valid type", &e->where);
- return &gfc_bad_expr;
- }
+ result = gfc_convert_constant (e, BT_INTEGER, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
- return range_check (result, "INT");
+ return range_check (result, name);
}
-static gfc_expr *
-simplify_intconv (gfc_expr *e, int kind, const char *name)
+gfc_expr *
+gfc_simplify_int (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result = NULL;
-
- if (e->expr_type != EXPR_CONSTANT)
- return NULL;
-
- switch (e->ts.type)
- {
- case BT_INTEGER:
- result = gfc_int2int (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2int (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2int (e, kind);
- break;
+ int kind;
- default:
- gfc_error ("Argument of %s at %L is not a valid type", name, &e->where);
- return &gfc_bad_expr;
- }
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
+ if (kind == -1)
+ return &gfc_bad_expr;
- return range_check (result, name);
+ return simplify_intconv (e, kind, "INT");
}
-
gfc_expr *
gfc_simplify_int2 (gfc_expr *e)
{
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IFIX");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
-
rtrunc = gfc_copy_expr (e);
-
mpfr_trunc (rtrunc->value.real, e->value.real);
+
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &e->where);
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
gfc_free_expr (rtrunc);
+
return range_check (result, "IDINT");
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+
return range_check (result, "IOR");
}
gfc_expr *
gfc_simplify_is_iostat_end (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_END) == 0);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_END) == 0);
}
gfc_expr *
gfc_simplify_is_iostat_eor (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = (mpz_cmp_si (x->value.integer, LIBERROR_EOR) == 0);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpz_cmp_si (x->value.integer,
+ LIBERROR_EOR) == 0);
}
gfc_expr *
gfc_simplify_isnan (gfc_expr *x)
{
- gfc_expr *result;
-
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, gfc_default_logical_kind,
- &x->where);
- result->value.logical = mpfr_nan_p (x->value.real);
-
- return result;
+ return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
+ mpfr_nan_p (x->value.real));
}
return &gfc_bad_expr;
}
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
if (shift == 0)
{
return &gfc_bad_expr;
}
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_set (result->value.integer, e->value.integer);
gfc_expr *
gfc_simplify_kind (gfc_expr *e)
{
-
- if (e->ts.type == BT_DERIVED)
- {
- gfc_error ("Argument of KIND at %L is a DERIVED type", &e->where);
- return &gfc_bad_expr;
- }
-
- return gfc_int_expr (e->ts.kind);
+ return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
}
if (k == -1)
return &gfc_bad_expr;
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
/* Then, we need to know the extent of the given dimension. */
/* Multi-dimensional bounds. */
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
gfc_expr *e;
- gfc_constructor *head, *tail;
int k;
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
}
/* 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 ? "UBOUND" : "LBOUND",
- gfc_default_integer_kind);
+ gfc_default_integer_kind);
if (k == -1)
- {
- gfc_free_expr (e);
- return &gfc_bad_expr;
- }
- e->ts.kind = k;
+ return &gfc_bad_expr;
+
+ e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
/* The result is a rank 1 array; its size is the rank of the first
argument to {L,U}BOUND. */
mpz_init_set_ui (e->shape[0], array->rank);
/* Create the constructor for this array. */
- head = tail = NULL;
for (d = 0; d < array->rank; d++)
- {
- /* Get a new constructor element. */
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = e->where;
- tail->expr = bounds[d];
- }
- e->value.constructor = head;
+ gfc_constructor_append_expr (&e->value.constructor,
+ bounds[d], &e->where);
return e;
}
gfc_expr *
gfc_simplify_leadz (gfc_expr *e)
{
- gfc_expr *result;
unsigned long lz, bs;
int i;
else
lz = bs - mpz_sizeinbase (e->value.integer, 2);
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &e->where);
- mpz_set_ui (result->value.integer, lz);
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
}
if (e->expr_type == EXPR_CONSTANT)
{
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
mpz_set_si (result->value.integer, e->value.character.length);
- if (gfc_range_check (result) == ARITH_OK)
- return result;
- else
- {
- gfc_free_expr (result);
- return NULL;
- }
+ return range_check (result, "LEN");
}
-
- if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
- && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
- && e->ts.u.cl->length->ts.type == BT_INTEGER)
+ else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
+ && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
+ && e->ts.u.cl->length->ts.type == BT_INTEGER)
{
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
- if (gfc_range_check (result) == ARITH_OK)
- return result;
- else
- {
- gfc_free_expr (result);
- return NULL;
- }
+ return range_check (result, "LEN");
}
-
- return NULL;
+ else
+ return NULL;
}
gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
{
gfc_expr *result;
- int count, len, lentrim, i;
+ int count, len, i;
int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
if (k == -1)
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
len = e->value.character.length;
-
for (count = 0, i = 1; i <= len; i++)
if (e->value.character.string[len - i] == ' ')
count++;
else
break;
- lentrim = len - count;
-
- mpz_set_si (result->value.integer, lentrim);
+ result = gfc_get_int_expr (k, &e->where, len - count);
return range_check (result, "LEN_TRIM");
}
gfc_expr *
-gfc_simplify_lgamma (gfc_expr *x ATTRIBUTE_UNUSED)
+gfc_simplify_lgamma (gfc_expr *x)
{
gfc_expr *result;
int sg;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
return range_check (result, "LGAMMA");
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) >= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) >= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) > 0,
- &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) > 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) <= 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) <= 0);
}
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
return NULL;
- return gfc_logical_expr (gfc_compare_string (a, b) < 0, &a->where);
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_string (a, b) < 0);
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
return &gfc_bad_expr;
}
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "LOG10");
gfc_expr *
gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
{
- gfc_expr *result;
int kind;
kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_LOGICAL, kind, &e->where);
-
- result->value.logical = e->value.logical;
-
- return result;
+ return gfc_get_logical_expr (kind, &e->where, e->value.logical);
}
gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
{
gfc_expr *result;
- gfc_constructor *ma_ctor, *mb_ctor;
- int row, result_rows, col, result_columns, stride_a, stride_b;
+ int row, result_rows, col, result_columns;
+ int stride_a, offset_a, stride_b, offset_b;
if (!is_constant_array_expr (matrix_a)
|| !is_constant_array_expr (matrix_b))
return NULL;
gcc_assert (gfc_compare_types (&matrix_a->ts, &matrix_b->ts));
- result = gfc_start_constructor (matrix_a->ts.type,
- matrix_a->ts.kind,
- &matrix_a->where);
+ result = gfc_get_array_expr (matrix_a->ts.type,
+ matrix_a->ts.kind,
+ &matrix_a->where);
if (matrix_a->rank == 1 && matrix_b->rank == 2)
{
else
gcc_unreachable();
- ma_ctor = matrix_a->value.constructor;
- mb_ctor = matrix_b->value.constructor;
-
+ offset_a = offset_b = 0;
for (col = 0; col < result_columns; ++col)
{
- ma_ctor = matrix_a->value.constructor;
+ offset_a = 0;
for (row = 0; row < result_rows; ++row)
{
- gfc_expr *e;
- e = compute_dot_product (ma_ctor, stride_a,
- mb_ctor, 1);
+ gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
+ matrix_b, 1, offset_b);
+ gfc_constructor_append_expr (&result->value.constructor,
+ e, NULL);
- gfc_append_constructor (result, e);
-
- ADVANCE (ma_ctor, 1);
- }
+ offset_a += 1;
+ }
- ADVANCE (mb_ctor, stride_b);
+ offset_b += stride_b;
}
return result;
static gfc_expr *
simplify_minval_maxval (gfc_expr *expr, int sign)
{
- gfc_constructor *ctr, *extremum;
+ gfc_constructor *c, *extremum;
gfc_intrinsic_sym * specific;
extremum = NULL;
specific = expr->value.function.isym;
- ctr = expr->value.constructor;
-
- for (; ctr; ctr = ctr->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- if (ctr->expr->expr_type != EXPR_CONSTANT)
+ if (c->expr->expr_type != EXPR_CONSTANT)
return NULL;
if (extremum == NULL)
{
- extremum = ctr;
+ extremum = c;
continue;
}
- min_max_choose (ctr->expr, extremum->expr, sign);
+ min_max_choose (c->expr, extremum->expr, sign);
}
if (extremum == NULL)
{
if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
return NULL;
-
+
return simplify_minval_maxval (array, -1);
}
{
if (array->expr_type != EXPR_ARRAY || array->rank != 1 || dim || mask)
return NULL;
+
return simplify_minval_maxval (array, 1);
}
gfc_expr *
gfc_simplify_maxexponent (gfc_expr *x)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].max_exponent);
- result->where = x->where;
-
- return result;
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].max_exponent);
}
gfc_expr *
gfc_simplify_minexponent (gfc_expr *x)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].min_exponent);
- result->where = x->where;
-
- return result;
+ int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
+ gfc_real_kinds[i].min_exponent);
}
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument MOD at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
- break;
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument MOD at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ break;
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MOD at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MOD at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
- gfc_set_model_kind (kind);
- mpfr_init (tmp);
- mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_trunc (tmp, tmp);
- mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
- mpfr_clear (tmp);
- break;
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_trunc (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
}
return range_check (result, "MOD");
return NULL;
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
- result = gfc_constant_result (a->ts.type, kind, &a->where);
+ result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
- case BT_INTEGER:
- if (mpz_cmp_ui (p->value.integer, 0) == 0)
- {
- /* Result is processor-dependent. This processor just opts
- to not handle it at all. */
- gfc_error ("Second argument of MODULO at %L is zero", &a->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
+ case BT_INTEGER:
+ if (mpz_cmp_ui (p->value.integer, 0) == 0)
+ {
+ /* Result is processor-dependent. This processor just opts
+ to not handle it at all. */
+ gfc_error ("Second argument of MODULO at %L is zero", &a->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
+ mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
- break;
+ break;
- case BT_REAL:
- if (mpfr_cmp_ui (p->value.real, 0) == 0)
- {
- /* Result is processor-dependent. */
- gfc_error ("Second argument of MODULO at %L is zero", &p->where);
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
+ case BT_REAL:
+ if (mpfr_cmp_ui (p->value.real, 0) == 0)
+ {
+ /* Result is processor-dependent. */
+ gfc_error ("Second argument of MODULO at %L is zero", &p->where);
+ gfc_free_expr (result);
+ return &gfc_bad_expr;
+ }
- gfc_set_model_kind (kind);
- mpfr_init (tmp);
- mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
- mpfr_floor (tmp, tmp);
- mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
- mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
- mpfr_clear (tmp);
- break;
+ gfc_set_model_kind (kind);
+ mpfr_init (tmp);
+ mpfr_div (tmp, a->value.real, p->value.real, GFC_RND_MODE);
+ mpfr_floor (tmp, tmp);
+ mpfr_mul (tmp, tmp, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, tmp, GFC_RND_MODE);
+ mpfr_clear (tmp);
+ break;
- default:
- gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
+ default:
+ gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
}
return range_check (result, "MODULO");
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_INTEGER, kind, &e->where);
-
itrunc = gfc_copy_expr (e);
-
mpfr_round (itrunc->value.real, e->value.real);
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
gfc_free_expr (itrunc);
{
gfc_expr *result;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
- result->value.character.string = gfc_get_wide_string (2);
- result->value.character.length = 1;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
result->value.character.string[0] = '\n';
- result->value.character.string[1] = '\0'; /* For debugger */
+
return result;
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
-
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
mpz_com (result->value.integer, e->value.integer);
return range_check (result, "NOT");
{
gfc_expr *result;
- if (mold == NULL)
+ if (mold)
{
- result = gfc_get_expr ();
- result->ts.type = BT_UNKNOWN;
+ result = gfc_copy_expr (mold);
+ result->expr_type = EXPR_NULL;
}
else
- result = gfc_copy_expr (mold);
- result->expr_type = EXPR_NULL;
+ result = gfc_get_null_expr (NULL);
return result;
}
{
gfc_expr *result;
/* FIXME: gfc_current_locus is wrong. */
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
+ result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &gfc_current_locus);
mpz_set_si (result->value.integer, 1);
return result;
}
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_ior (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "OR");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = x->value.logical || y->value.logical;
- return result;
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "OR");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ x->value.logical || y->value.logical);
+ default:
+ gcc_unreachable();
}
}
&& !is_constant_array_expr(mask)))
return NULL;
- result = gfc_start_constructor (array->ts.type,
- array->ts.kind,
- &array->where);
+ result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
- array_ctor = array->value.constructor;
- vector_ctor = vector ? vector->value.constructor : NULL;
+ array_ctor = gfc_constructor_first (array->value.constructor);
+ vector_ctor = vector
+ ? gfc_constructor_first (vector->value.constructor)
+ : NULL;
if (mask->expr_type == EXPR_CONSTANT
&& mask->value.logical)
/* Copy all elements of ARRAY to RESULT. */
while (array_ctor)
{
- gfc_append_constructor (result,
- gfc_copy_expr (array_ctor->expr));
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
- ADVANCE (array_ctor, 1);
- ADVANCE (vector_ctor, 1);
+ array_ctor = gfc_constructor_next (array_ctor);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
}
else if (mask->expr_type == EXPR_ARRAY)
{
/* Copy only those elements of ARRAY to RESULT whose
MASK equals .TRUE.. */
- mask_ctor = mask->value.constructor;
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
while (mask_ctor)
{
if (mask_ctor->expr->value.logical)
{
- gfc_append_constructor (result,
- gfc_copy_expr (array_ctor->expr));
- ADVANCE (vector_ctor, 1);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (array_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
- ADVANCE (array_ctor, 1);
- ADVANCE (mask_ctor, 1);
+ array_ctor = gfc_constructor_next (array_ctor);
+ mask_ctor = gfc_constructor_next (mask_ctor);
}
}
/* Append any left-over elements from VECTOR to RESULT. */
while (vector_ctor)
{
- gfc_append_constructor (result,
- gfc_copy_expr (vector_ctor->expr));
- ADVANCE (vector_ctor, 1);
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (vector_ctor->expr),
+ NULL);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
result->shape = gfc_get_shape (1);
gfc_expr *
gfc_simplify_precision (gfc_expr *e)
{
- gfc_expr *result;
- int i;
-
- i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
-
- result = gfc_int_expr (gfc_real_kinds[i].precision);
- result->where = e->where;
-
- return result;
+ int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
+ gfc_real_kinds[i].precision);
}
gfc_expr *
gfc_simplify_radix (gfc_expr *e)
{
- gfc_expr *result;
int i;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
+
switch (e->ts.type)
{
- case BT_INTEGER:
- i = gfc_integer_kinds[i].radix;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].radix;
+ break;
- case BT_REAL:
- i = gfc_real_kinds[i].radix;
- break;
+ case BT_REAL:
+ i = gfc_real_kinds[i].radix;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (i);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
gfc_expr *
gfc_simplify_range (gfc_expr *e)
{
- gfc_expr *result;
int i;
- long j;
-
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
switch (e->ts.type)
{
- case BT_INTEGER:
- j = gfc_integer_kinds[i].range;
- break;
+ case BT_INTEGER:
+ i = gfc_integer_kinds[i].range;
+ break;
- case BT_REAL:
- case BT_COMPLEX:
- j = gfc_real_kinds[i].range;
- break;
+ case BT_REAL:
+ case BT_COMPLEX:
+ i = gfc_real_kinds[i].range;
+ break;
- default:
- gcc_unreachable ();
+ default:
+ gcc_unreachable ();
}
- result = gfc_int_expr (j);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- switch (e->ts.type)
- {
- case BT_INTEGER:
- if (!e->is_boz)
- result = gfc_int2real (e, kind);
- break;
-
- case BT_REAL:
- result = gfc_real2real (e, kind);
- break;
-
- case BT_COMPLEX:
- result = gfc_complex2real (e, kind);
- break;
-
- default:
- gfc_internal_error ("bad type in REAL");
- /* Not reached */
- }
+ if (convert_boz (e, kind) == &gfc_bad_expr)
+ return &gfc_bad_expr;
- if (e->ts.type == BT_INTEGER && e->is_boz)
- {
- gfc_typespec ts;
- gfc_clear_ts (&ts);
- ts.type = BT_REAL;
- ts.kind = kind;
- result = gfc_copy_expr (e);
- if (!gfc_convert_boz (result, &ts))
- {
- gfc_free_expr (result);
- return &gfc_bad_expr;
- }
- }
+ result = gfc_convert_constant (e, BT_REAL, kind);
+ if (result == &gfc_bad_expr)
+ return &gfc_bad_expr;
return range_check (result, "REAL");
}
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+
return range_check (result, "REALPART");
}
len = e->value.character.length;
nlen = ncop * len;
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, e->ts.kind, &e->where);
if (ncop == 0)
- {
- result->value.character.string = gfc_get_wide_string (1);
- result->value.character.length = 0;
- result->value.character.string[0] = '\0';
- return result;
- }
+ return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
- result->value.character.length = nlen;
- result->value.character.string = gfc_get_wide_string (nlen + 1);
+ len = e->value.character.length;
+ nlen = ncop * len;
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
for (i = 0; i < ncop; i++)
for (j = 0; j < len; j++)
result->value.character.string[j+i*len]= e->value.character.string[j];
{
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
- gfc_constructor *head, *tail;
mpz_t index, size;
unsigned long j;
size_t nsource;
- gfc_expr *e;
+ gfc_expr *e, *result;
/* Check that argument expression types are OK. */
if (!is_constant_array_expr (source)
mpz_init (index);
rank = 0;
- head = tail = NULL;
for (;;)
{
- e = gfc_get_array_element (shape_exp, rank);
+ e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
if (e == NULL)
break;
gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
gcc_assert (shape[rank] >= 0);
- gfc_free_expr (e);
rank++;
}
for (i = 0; i < rank; i++)
{
- e = gfc_get_array_element (order_exp, i);
+ e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
gcc_assert (e);
gfc_extract_int (e, &order[i]);
- gfc_free_expr (e);
gcc_assert (order[i] >= 1 && order[i] <= rank);
order[i]--;
for (i = 0; i < rank; i++)
x[i] = 0;
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
+ result->rank = rank;
+ result->shape = gfc_get_shape (rank);
+ for (i = 0; i < rank; i++)
+ mpz_init_set_ui (result->shape[i], shape[i]);
+
while (nsource > 0 || npad > 0)
{
/* Figure out which element to extract. */
j = mpz_get_ui (index);
if (j < nsource)
- e = gfc_get_array_element (source, j);
+ e = gfc_constructor_lookup_expr (source->value.constructor, j);
else
{
gcc_assert (npad > 0);
j = j - nsource;
j = j % npad;
- e = gfc_get_array_element (pad, j);
+ e = gfc_constructor_lookup_expr (pad->value.constructor, j);
}
gcc_assert (e);
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = e->where;
- tail->expr = e;
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (e), &e->where);
/* Calculate the next element. */
i = 0;
mpz_clear (index);
- e = gfc_get_expr ();
- e->where = source->where;
- e->expr_type = EXPR_ARRAY;
- e->value.constructor = head;
- e->shape = gfc_get_shape (rank);
-
- for (i = 0; i < rank; i++)
- mpz_init_set_ui (e->shape[i], shape[i]);
-
- e->ts = source->ts;
- e->rank = rank;
-
- return e;
+ return result;
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
-
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
/* Special case x = -0 and 0. */
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &e->where);
-
len = e->value.character.length;
lenc = c->value.character.length;
}
}
}
- mpz_set_ui (result->value.integer, indx);
+
+ result = gfc_get_int_expr (k, &e->where, indx);
return range_check (result, "SCAN");
}
gfc_simplify_selected_char_kind (gfc_expr *e)
{
int kind;
- gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
else
kind = -1;
- result = gfc_int_expr (kind);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
gfc_simplify_selected_int_kind (gfc_expr *e)
{
int i, kind, range;
- gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range) != NULL)
return NULL;
if (kind == INT_MAX)
kind = -1;
- result = gfc_int_expr (kind);
- result->where = e->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
}
gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q)
{
int range, precision, i, kind, found_precision, found_range;
- gfc_expr *result;
if (p == NULL)
precision = 0;
kind -= 2;
}
- result = gfc_int_expr (kind);
- result->where = (p != NULL) ? p->where : q->where;
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind,
+ p ? &p->where : &q->where, kind);
}
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
if (mpfr_sgn (x->value.real) == 0)
{
gfc_try t;
if (source->rank == 0)
- return gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
if (source->expr_type != EXPR_VARIABLE)
return NULL;
- result = gfc_start_constructor (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
ar = gfc_find_array_ref (source);
for (n = 0; n < source->rank; n++)
{
- e = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &source->where);
if (t == SUCCESS)
{
}
}
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
}
return result;
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
- gfc_expr *result;
int d;
int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
return NULL;
}
- result = gfc_constant_result (BT_INTEGER, k, &array->where);
- mpz_set (result->value.integer, size);
- return result;
+ return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
}
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_INTEGER:
- mpz_abs (result->value.integer, x->value.integer);
- if (mpz_sgn (y->value.integer) < 0)
- mpz_neg (result->value.integer, result->value.integer);
- break;
+ case BT_INTEGER:
+ mpz_abs (result->value.integer, x->value.integer);
+ if (mpz_sgn (y->value.integer) < 0)
+ mpz_neg (result->value.integer, result->value.integer);
+ break;
- case BT_REAL:
- if (gfc_option.flag_sign_zero)
- mpfr_copysign (result->value.real, x->value.real, y->value.real,
- GFC_RND_MODE);
- else
- mpfr_setsign (result->value.real, x->value.real,
- mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ if (gfc_option.flag_sign_zero)
+ mpfr_copysign (result->value.real, x->value.real, y->value.real,
+ GFC_RND_MODE);
+ else
+ mpfr_setsign (result->value.real, x->value.real,
+ mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("Bad type in gfc_simplify_sign");
+ default:
+ gfc_internal_error ("Bad type in gfc_simplify_sign");
}
return result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
- case BT_REAL:
- mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
- break;
+ case BT_REAL:
+ mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- case BT_COMPLEX:
- gfc_set_model (x->value.real);
- mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- break;
+ case BT_COMPLEX:
+ gfc_set_model (x->value.real);
+ mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("in gfc_simplify_sin(): Bad type");
+ default:
+ gfc_internal_error ("in gfc_simplify_sin(): Bad type");
}
return range_check (result, "SIN");
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- if (x->ts.type == BT_REAL)
- mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
- else if (x->ts.type == BT_COMPLEX)
- mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- else
- gcc_unreachable ();
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "SINH");
}
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
/* Special case x = 0 and -0. */
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
{
gcc_assert (dim == 0);
- result = gfc_start_constructor (source->ts.type,
- source->ts.kind,
- &source->where);
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
result->rank = 1;
result->shape = gfc_get_shape (result->rank);
mpz_init_set_si (result->shape[0], ncopies);
for (i = 0; i < ncopies; ++i)
- gfc_append_constructor (result, gfc_copy_expr (source));
+ gfc_constructor_append_expr (&result->value.constructor,
+ gfc_copy_expr (source), NULL);
}
else if (source->expr_type == EXPR_ARRAY)
{
- int result_size, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
- gfc_constructor *ctor, *source_ctor, *result_ctor;
+ int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
+ gfc_constructor *source_ctor;
gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
gcc_assert (dim >= 0 && dim <= source->rank);
- result = gfc_start_constructor (source->ts.type,
- source->ts.kind,
- &source->where);
+ result = gfc_get_array_expr (source->ts.type, source->ts.kind,
+ &source->where);
result->rank = source->rank + 1;
result->shape = gfc_get_shape (result->rank);
- result_size = 1;
for (i = 0, j = 0; i < result->rank; ++i)
{
if (i != dim)
extent[i] = mpz_get_si (result->shape[i]);
rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
- result_size *= extent[i];
}
- for (i = 0; i < result_size; ++i)
- gfc_append_constructor (result, NULL);
-
- source_ctor = source->value.constructor;
- result_ctor = result->value.constructor;
- while (source_ctor)
+ offset = 0;
+ for (source_ctor = gfc_constructor_first (source->value.constructor);
+ source_ctor; source_ctor = gfc_constructor_next (source_ctor))
{
- ctor = result_ctor;
-
for (i = 0; i < ncopies; ++i)
- {
- ctor->expr = gfc_copy_expr (source_ctor->expr);
- ADVANCE (ctor, rstride[dim]);
- }
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (source_ctor->expr),
+ NULL, offset + i * rstride[dim]);
- ADVANCE (result_ctor, (dim == 0 ? ncopies : 1));
- ADVANCE (source_ctor, 1);
+ offset += (dim == 0 ? ncopies : 1);
}
}
else
gfc_expr *
gfc_simplify_sqrt (gfc_expr *e)
{
- gfc_expr *result;
+ gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (e->ts.type, e->ts.kind, &e->where);
-
switch (e->ts.type)
{
- case BT_REAL:
- if (mpfr_cmp_si (e->value.real, 0) < 0)
- goto negative_arg;
- mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+ case BT_REAL:
+ if (mpfr_cmp_si (e->value.real, 0) < 0)
+ {
+ gfc_error ("Argument of SQRT at %L has a negative value",
+ &e->where);
+ return &gfc_bad_expr;
+ }
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
+ break;
- break;
+ case BT_COMPLEX:
+ gfc_set_model (e->value.real);
- case BT_COMPLEX:
- gfc_set_model (e->value.real);
- mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
- break;
+ result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
+ mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
+ break;
- default:
- gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
+ default:
+ gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
}
return range_check (result, "SQRT");
-
-negative_arg:
- gfc_free_expr (result);
- gfc_error ("Argument of SQRT at %L has a negative value", &e->where);
- return &gfc_bad_expr;
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- if (x->ts.type == BT_REAL)
- mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
- else if (x->ts.type == BT_COMPLEX)
- mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- else
- gcc_unreachable ();
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
return range_check (result, "TAN");
}
if (x->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
- if (x->ts.type == BT_REAL)
- mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
- else if (x->ts.type == BT_COMPLEX)
- mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
- else
- gcc_unreachable ();
+ switch (x->ts.type)
+ {
+ case BT_REAL:
+ mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
+ break;
- return range_check (result, "TANH");
+ case BT_COMPLEX:
+ mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+ return range_check (result, "TANH");
}
i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
- result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
return result;
gfc_expr *
gfc_simplify_trailz (gfc_expr *e)
{
- gfc_expr *result;
unsigned long tz, bs;
int i;
bs = gfc_integer_kinds[i].bit_size;
tz = mpz_scan1 (e->value.integer, 0);
- result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &e->where);
- mpz_set_ui (result->value.integer, MIN (tz, bs));
-
- return result;
+ return gfc_get_int_expr (gfc_default_integer_kind,
+ &e->where, MIN (tz, bs));
}
source_size = gfc_target_expr_size (source);
/* Create an empty new expression with the appropriate characteristics. */
- result = gfc_constant_result (mold->ts.type, mold->ts.kind,
- &source->where);
+ result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
+ &source->where);
result->ts = mold->ts;
mold_element = mold->expr_type == EXPR_ARRAY
- ? mold->value.constructor->expr
+ ? gfc_constructor_first (mold->value.constructor)->expr
: mold;
/* Set result character length, if needed. Note that this needs to be
gfc_expr *
gfc_simplify_transpose (gfc_expr *matrix)
{
- int i, matrix_rows;
+ int row, matrix_rows, col, matrix_cols;
gfc_expr *result;
- gfc_constructor *matrix_ctor;
if (!is_constant_array_expr (matrix))
return NULL;
gcc_assert (matrix->rank == 2);
- result = gfc_start_constructor (matrix->ts.type, matrix->ts.kind, &matrix->where);
+ result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
+ &matrix->where);
result->rank = 2;
result->shape = gfc_get_shape (result->rank);
mpz_set (result->shape[0], matrix->shape[1]);
result->ts.u.cl = matrix->ts.u.cl;
matrix_rows = mpz_get_si (matrix->shape[0]);
- matrix_ctor = matrix->value.constructor;
- for (i = 0; i < matrix_rows; ++i)
- {
- gfc_constructor *column_ctor = matrix_ctor;
- while (column_ctor)
- {
- gfc_append_constructor (result,
- gfc_copy_expr (column_ctor->expr));
-
- ADVANCE (column_ctor, matrix_rows);
- }
-
- ADVANCE (matrix_ctor, 1);
- }
+ matrix_cols = mpz_get_si (matrix->shape[1]);
+ for (row = 0; row < matrix_rows; ++row)
+ for (col = 0; col < matrix_cols; ++col)
+ {
+ gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
+ col * matrix_rows + row);
+ gfc_constructor_insert_expr (&result->value.constructor,
+ gfc_copy_expr (e), &matrix->where,
+ row * matrix_cols + col);
+ }
return result;
}
return NULL;
len = e->value.character.length;
-
- result = gfc_constant_result (BT_CHARACTER, e->ts.kind, &e->where);
-
for (count = 0, i = 1; i <= len; ++i)
{
if (e->value.character.string[len - i] == ' ')
lentrim = len - count;
- result->value.character.length = lentrim;
- result->value.character.string = gfc_get_wide_string (lentrim + 1);
-
+ result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
for (i = 0; i < lentrim; i++)
result->value.character.string[i] = e->value.character.string[i];
- result->value.character.string[lentrim] = '\0'; /* For debugger */
-
return result;
}
&& !is_constant_array_expr(field)))
return NULL;
- result = gfc_start_constructor (vector->ts.type,
- vector->ts.kind,
- &vector->where);
+ result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
+ &vector->where);
result->rank = mask->rank;
result->shape = gfc_copy_shape (mask->shape, mask->rank);
if (vector->ts.type == BT_CHARACTER)
result->ts.u.cl = vector->ts.u.cl;
- vector_ctor = vector->value.constructor;
- mask_ctor = mask->value.constructor;
- field_ctor = field->expr_type == EXPR_ARRAY ? field->value.constructor : NULL;
+ vector_ctor = gfc_constructor_first (vector->value.constructor);
+ mask_ctor = gfc_constructor_first (mask->value.constructor);
+ field_ctor
+ = field->expr_type == EXPR_ARRAY
+ ? gfc_constructor_first (field->value.constructor)
+ : NULL;
while (mask_ctor)
{
{
gcc_assert (vector_ctor);
e = gfc_copy_expr (vector_ctor->expr);
- ADVANCE (vector_ctor, 1);
+ vector_ctor = gfc_constructor_next (vector_ctor);
}
else if (field->expr_type == EXPR_ARRAY)
e = gfc_copy_expr (field_ctor->expr);
else
e = gfc_copy_expr (field);
- gfc_append_constructor (result, e);
+ gfc_constructor_append_expr (&result->value.constructor, e, NULL);
- ADVANCE (mask_ctor, 1);
- ADVANCE (field_ctor, 1);
+ mask_ctor = gfc_constructor_next (mask_ctor);
+ field_ctor = gfc_constructor_next (field_ctor);
}
return result;
else
back = 0;
- result = gfc_constant_result (BT_INTEGER, k, &s->where);
+ result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
len = s->value.character.length;
lenset = set->value.character.length;
return NULL;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
- if (x->ts.type == BT_INTEGER)
- {
- result = gfc_constant_result (BT_INTEGER, kind, &x->where);
- mpz_xor (result->value.integer, x->value.integer, y->value.integer);
- return range_check (result, "XOR");
- }
- else /* BT_LOGICAL */
+
+ switch (x->ts.type)
{
- result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
- result->value.logical = (x->value.logical && !y->value.logical)
- || (!x->value.logical && y->value.logical);
- return result;
- }
+ case BT_INTEGER:
+ result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
+ mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ return range_check (result, "XOR");
+
+ case BT_LOGICAL:
+ return gfc_get_logical_expr (kind, &x->where,
+ (x->value.logical && !y->value.logical)
+ || (!x->value.logical && y->value.logical));
+ default:
+ gcc_unreachable ();
+ }
}
gfc_convert_constant (gfc_expr *e, bt type, int kind)
{
gfc_expr *g, *result, *(*f) (gfc_expr *, int);
- gfc_constructor *head, *c, *tail = NULL;
+ gfc_constructor *c;
switch (e->ts.type)
{
if (!gfc_is_constant_expr (e))
break;
- head = NULL;
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- tail->where = c->where;
-
+ gfc_expr *tmp;
if (c->iterator == NULL)
- tail->expr = f (c->expr, kind);
+ tmp = f (c->expr, kind);
else
{
g = gfc_convert_constant (c->expr, type, kind);
if (g == &gfc_bad_expr)
- return g;
- tail->expr = g;
+ {
+ gfc_free_expr (result);
+ return g;
+ }
+ tmp = g;
}
- if (tail->expr == NULL)
+ if (tmp == NULL)
{
- gfc_free_constructor (head);
+ gfc_free_expr (result);
return NULL;
}
+
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
}
- result = gfc_get_expr ();
- result->ts.type = type;
- result->ts.kind = kind;
- result->expr_type = EXPR_ARRAY;
- result->value.constructor = head;
- result->shape = gfc_copy_shape (e->shape, e->rank);
- result->where = e->where;
- result->rank = e->rank;
break;
default:
if (e->expr_type == EXPR_CONSTANT)
{
/* Simple case of a scalar. */
- result = gfc_constant_result (BT_CHARACTER, kind, &e->where);
+ result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
if (result == NULL)
return &gfc_bad_expr;
else if (e->expr_type == EXPR_ARRAY)
{
/* For an array constructor, we convert each constructor element. */
- gfc_constructor *head = NULL, *tail = NULL, *c;
+ gfc_constructor *c;
- for (c = e->value.constructor; c; c = c->next)
- {
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ result = gfc_get_array_expr (type, kind, &e->where);
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->rank = e->rank;
+ result->ts.u.cl = e->ts.u.cl;
- tail->where = c->where;
- tail->expr = gfc_convert_char_constant (c->expr, type, kind);
- if (tail->expr == &gfc_bad_expr)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
+ if (tmp == &gfc_bad_expr)
{
- tail->expr = NULL;
+ gfc_free_expr (result);
return &gfc_bad_expr;
}
- if (tail->expr == NULL)
+ if (tmp == NULL)
{
- gfc_free_constructor (head);
+ gfc_free_expr (result);
return NULL;
}
- }
- result = gfc_get_expr ();
- result->ts.type = type;
- result->ts.kind = kind;
- result->expr_type = EXPR_ARRAY;
- result->value.constructor = head;
- result->shape = gfc_copy_shape (e->shape, e->rank);
- result->where = e->where;
- result->rank = e->rank;
- result->ts.u.cl = e->ts.u.cl;
+ gfc_constructor_append_expr (&result->value.constructor,
+ tmp, &c->where);
+ }
return result;
}
#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;
/* Simulate storage of variables into target memory.
- Copyright (C) 2007, 2008, 2009
+ Copyright (C) 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Thomas and Brooks Moses
#include "tree.h"
#include "gfortran.h"
#include "arith.h"
+#include "constructor.h"
#include "trans.h"
#include "trans-const.h"
#include "trans-types.h"
size_array (gfc_expr *e)
{
mpz_t array_size;
- size_t elt_size = gfc_target_expr_size (e->value.constructor->expr);
+ gfc_constructor *c = gfc_constructor_first (e->value.constructor);
+ size_t elt_size = gfc_target_expr_size (c->expr);
gfc_array_size (e, &array_size);
return (size_t)mpz_get_ui (array_size) * elt_size;
int i;
int ptr = 0;
+ gfc_constructor_base ctor = expr->value.constructor;
+
gfc_array_size (expr, &array_size);
for (i = 0; i < (int)mpz_get_ui (array_size); i++)
{
- ptr += gfc_target_encode_expr (gfc_get_array_element (expr, i),
+ ptr += gfc_target_encode_expr (gfc_constructor_lookup_expr (ctor, i),
&buffer[ptr], buffer_size - ptr);
}
static int
encode_derived (gfc_expr *source, unsigned char *buffer, size_t buffer_size)
{
- gfc_constructor *ctr;
+ gfc_constructor *c;
gfc_component *cmp;
int ptr;
tree type;
type = gfc_typenode_for_spec (&source->ts);
- ctr = source->value.constructor;
- cmp = source->ts.u.derived->components;
- for (;ctr; ctr = ctr->next, cmp = cmp->next)
+ for (c = gfc_constructor_first (source->value.constructor),
+ cmp = source->ts.u.derived->components;
+ c;
+ c = gfc_constructor_next (c), cmp = cmp->next)
{
gcc_assert (cmp);
- if (!ctr->expr)
+ if (!c->expr)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
- if (ctr->expr->expr_type == EXPR_NULL)
+ if (c->expr->expr_type == EXPR_NULL)
memset (&buffer[ptr], 0,
int_size_in_bytes (TREE_TYPE (cmp->backend_decl)));
else
- gfc_target_encode_expr (ctr->expr, &buffer[ptr],
+ gfc_target_encode_expr (c->expr, &buffer[ptr],
buffer_size - ptr);
}
static int
interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
+ gfc_constructor_base base = NULL;
int array_size = 1;
int i;
int ptr = 0;
- gfc_constructor *head = NULL, *tail = NULL;
/* Calculate array size from its shape and rank. */
gcc_assert (result->rank > 0 && result->shape);
/* Iterate over array elements, producing constructors. */
for (i = 0; i < array_size; i++)
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_expr *e = gfc_get_constant_expr (result->ts.type, result->ts.kind,
+ &result->where);
+ e->ts = result->ts;
- tail->where = result->where;
- tail->expr = gfc_constant_result (result->ts.type,
- result->ts.kind, &result->where);
- tail->expr->ts = result->ts;
+ if (e->ts.type == BT_CHARACTER)
+ e->value.character.length = result->value.character.length;
- if (tail->expr->ts.type == BT_CHARACTER)
- tail->expr->value.character.length = result->value.character.length;
+ gfc_constructor_append_expr (&base, e, &result->where);
- ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
- tail->expr);
+ ptr += gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
}
- result->value.constructor = head;
+ result->value.constructor = base;
return ptr;
}
gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
gfc_component *cmp;
- gfc_constructor *head = NULL, *tail = NULL;
int ptr;
tree type;
/* Run through the derived type components. */
for (;cmp; cmp = cmp->next)
{
- if (head == NULL)
- head = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
-
- /* The constructor points to the component. */
- tail->n.component = cmp;
-
- tail->expr = gfc_constant_result (cmp->ts.type, cmp->ts.kind,
- &result->where);
- tail->expr->ts = cmp->ts;
+ gfc_constructor *c;
+ gfc_expr *e = gfc_get_constant_expr (cmp->ts.type, cmp->ts.kind,
+ &result->where);
+ e->ts = cmp->ts;
/* Copy shape, if needed. */
if (cmp->as && cmp->as->rank)
{
int n;
- tail->expr->expr_type = EXPR_ARRAY;
- tail->expr->rank = cmp->as->rank;
+ e->expr_type = EXPR_ARRAY;
+ e->rank = cmp->as->rank;
- tail->expr->shape = gfc_get_shape (tail->expr->rank);
- for (n = 0; n < tail->expr->rank; n++)
+ e->shape = gfc_get_shape (e->rank);
+ for (n = 0; n < e->rank; n++)
{
- mpz_init_set_ui (tail->expr->shape[n], 1);
- mpz_add (tail->expr->shape[n], tail->expr->shape[n],
+ mpz_init_set_ui (e->shape[n], 1);
+ mpz_add (e->shape[n], e->shape[n],
cmp->as->upper[n]->value.integer);
- mpz_sub (tail->expr->shape[n], tail->expr->shape[n],
+ mpz_sub (e->shape[n], e->shape[n],
cmp->as->lower[n]->value.integer);
}
}
- ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
- gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr,
- tail->expr);
+ c = gfc_constructor_append_expr (&result->value.constructor, e, NULL);
- result->value.constructor = head;
+ /* The constructor points to the component. */
+ c->n.component = cmp;
+
+ ptr = TREE_INT_CST_LOW (DECL_FIELD_OFFSET (cmp->backend_decl));
+ gfc_target_interpret_expr (&buffer[ptr], buffer_size - ptr, e);
}
return int_size_in_bytes (type);
{
int i;
int ptr;
- gfc_constructor *ctr;
+ gfc_constructor *c;
gfc_component *cmp;
unsigned char *buffer;
declaration. */
if (e->ts.type == BT_DERIVED)
{
- ctr = e->value.constructor;
- cmp = e->ts.u.derived->components;
- for (;ctr; ctr = ctr->next, cmp = cmp->next)
+ for (c = gfc_constructor_first (e->value.constructor),
+ cmp = e->ts.u.derived->components;
+ c; c = gfc_constructor_next (c), cmp = cmp->next)
{
gcc_assert (cmp && cmp->backend_decl);
- if (!ctr->expr)
+ if (!c->expr)
continue;
ptr = TREE_INT_CST_LOW(DECL_FIELD_OFFSET(cmp->backend_decl))
+ TREE_INT_CST_LOW(DECL_FIELD_BIT_OFFSET(cmp->backend_decl))/8;
- expr_to_char (ctr->expr, &data[ptr], &chk[ptr], len);
+ expr_to_char (c->expr, &data[ptr], &chk[ptr], len);
}
return len;
}
break;
case EXPR_ARRAY:
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
{
size_t elt_size = gfc_target_expr_size (c->expr);
- if (c->n.offset)
- len = elt_size * (size_t)mpz_get_si (c->n.offset);
+ if (c->offset)
+ len = elt_size * (size_t)mpz_get_si (c->offset);
len = len + gfc_merge_initializers (ts, c->expr, &data[len],
&chk[len], length - len);
#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);
}
void gfc_add_intrinsic_ss_code (gfc_loopinfo *, gfc_ss *);
/* Functions for constant array constructor processing. */
-unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor *);
+unsigned HOST_WIDE_INT gfc_constant_array_constructor_p (gfc_constructor_base);
tree gfc_build_constant_array_constructor (gfc_expr *, tree);
/* Copy a string from src to dest. */
/* Translation of constants
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
- Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
+ Free Software Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
|| expr->symtree->n.sym->intmod_sym_id == ISOCBINDING_NULL_FUNPTR)
{
/* Create a new EXPR_CONSTANT expression for our local uses. */
- expr = gfc_int_expr (0);
+ expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
}
}
if (expr->expr_type != EXPR_CONSTANT)
{
+ gfc_expr *e = gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
gfc_error ("non-constant initialization expression at %L", &expr->where);
- se->expr = gfc_conv_constant_to_tree (gfc_int_expr (0));
+ se->expr = gfc_conv_constant_to_tree (e);
return;
}
#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 ();
gfc_add_component_ref (a, "$hash");
}
else if (a->ts.type == BT_DERIVED)
- a = gfc_int_expr (a->ts.u.derived->hash_value);
+ a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ a->ts.u.derived->hash_value);
if (b->ts.type == BT_CLASS)
{
gfc_add_component_ref (b, "$hash");
}
else if (b->ts.type == BT_DERIVED)
- b = gfc_int_expr (b->ts.u.derived->hash_value);
+ b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ b->ts.u.derived->hash_value);
gfc_conv_expr (&se1, a);
gfc_conv_expr (&se2, b);
}
-static gfc_expr *
-gfc_new_nml_name_expr (const char * name)
-{
- gfc_expr * nml_name;
-
- nml_name = gfc_get_expr();
- nml_name->ref = NULL;
- nml_name->expr_type = EXPR_CONSTANT;
- nml_name->ts.kind = gfc_default_character_kind;
- nml_name->ts.type = BT_CHARACTER;
- nml_name->value.character.length = strlen(name);
- nml_name->value.character.string = gfc_char_to_widechar (name);
-
- return nml_name;
-}
/* nml_full_name builds up the fully qualified name of a
derived type component. */
if (dt->format_expr || dt->format_label)
gfc_internal_error ("build_dt: format with namelist");
- nmlname = gfc_new_nml_name_expr (dt->namelist->name);
+ nmlname = gfc_get_character_expr (gfc_default_character_kind, NULL,
+ dt->namelist->name,
+ strlen (dt->namelist->name));
mask |= set_string (&block, &post_block, var, IOPARM_dt_namelist_name,
nmlname);
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*, ...);
projects / gcc.git / commitdiff