From 4ca842c83eaf39fd6d1a3764471e8ce510ecbb1d Mon Sep 17 00:00:00 2001 From: burnus Date: Sat, 11 Jul 2009 00:03:07 +0000 Subject: 2009-07-09 Tobias Burnus PR fortran/33197 * check.c (gfc_check_fn_rc2008): New function. * intrinsic.h (gfc_check_fn_rc2008): New prototype. * intrinsic.c (add_functions): Add complex tan, cosh, sinh, and tanh. 2009-07-09 Tobias Burnus PR fortran/33197 * gfortran.dg/complex_intrinsic_3.f90: New test. * gfortran.dg/complex_intrinsic_4.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149503 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 103c9417790..8f949d2c093 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1211,6 +1211,23 @@ gfc_check_fn_rc (gfc_expr *a) } +gfc_try +gfc_check_fn_rc2008 (gfc_expr *a) +{ + if (real_or_complex_check (a, 0) == FAILURE) + return FAILURE; + + if (a->ts.type == BT_COMPLEX + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: COMPLEX argument '%s' " + "argument of '%s' intrinsic at %L", + gfc_current_intrinsic_arg[0], gfc_current_intrinsic, + &a->where) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + gfc_try gfc_check_fnum (gfc_expr *unit) { -- cgit v1.2.1 From 95a5b0404422238760875d27cb777af75dcf8dc1 Mon Sep 17 00:00:00 2001 From: kargl Date: Sun, 19 Jul 2009 15:37:50 +0000 Subject: 2009-07-18 Steven G. Kargl PR fortran/40727 * fortran/check.c (gfc_check_cmplx, gfc_check_dcmplx): Add check that the optional second argument isn't of COMPLEX type. 2009-07-18 Steven G. Kargl PR fortran/40727 * gfortran.dg/intrinsic_cmplx.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@149793 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 8f949d2c093..e19f8124f09 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -819,6 +819,15 @@ gfc_check_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *kind) gfc_current_intrinsic, &y->where); return FAILURE; } + + if (y->ts.type == BT_COMPLEX) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &y->where); + return FAILURE; + } + } if (kind_check (kind, 2, BT_COMPLEX) == FAILURE) @@ -977,6 +986,14 @@ gfc_check_dcmplx (gfc_expr *x, gfc_expr *y) gfc_current_intrinsic, &y->where); return FAILURE; } + + if (y->ts.type == BT_COMPLEX) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must have a type " + "of either REAL or INTEGER", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &y->where); + return FAILURE; + } } return SUCCESS; -- cgit v1.2.1 From 1b25477b41ad226112d46626a26d189b837d3d83 Mon Sep 17 00:00:00 2001 From: burnus Date: Sun, 26 Jul 2009 17:25:56 +0000 Subject: 2009-07-26 Tobias Burnus PR fortran/33197 * intrinsic.c (make_generic): Remove assert as "atan" can be both ISYM_ATAN and ISYM_ATAN2. (add_functions): Add two-argument variant of ATAN. * intrinsic.h (gfc_check_atan_2): Add check for it. * intrinsic.texi (ATAN2): Correct and enhance description. (ATAN): Describe two-argument variant of ATAN. 2009-07-26 Tobias Burnus PR fortran/33197 * gfortran.dg/atan2_1.f90: New test * gfortran.dg/atan2_2.f90: New test git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150100 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 13 +++++++++++++ 1 file changed, 13 insertions(+) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index e19f8124f09..779af2038e9 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -675,6 +675,19 @@ null_arg: } +gfc_try +gfc_check_atan_2 (gfc_expr *y, gfc_expr *x) +{ + /* gfc_notify_std would be a wast of time as the return value + is seemingly used only for the generic resolution. The error + will be: Too many arguments. */ + if ((gfc_option.allow_std & GFC_STD_F2008) == 0) + return FAILURE; + + return gfc_check_atan2 (y, x); +} + + gfc_try gfc_check_atan2 (gfc_expr *y, gfc_expr *x) { -- cgit v1.2.1 From eeebe20ba63ca092de5e2d4575b5765dd88a7ce6 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 13 Aug 2009 19:46:46 +0000 Subject: 2009-08-13 Janus Weil PR fortran/40941 * gfortran.h (gfc_typespec): Put 'derived' and 'cl' into union. * decl.c (build_struct): Make sure 'cl' is only used if type is BT_CHARACTER. * symbol.c (gfc_set_default_type): Ditto. * resolve.c (resolve_symbol, resolve_fl_derived): Ditto. (resolve_equivalence,resolve_equivalence_derived): Make sure 'derived' is only used if type is BT_DERIVED. * trans-io.c (transfer_expr): Make sure 'derived' is only used if type is BT_DERIVED or BT_INTEGER (special case: C_PTR/C_FUNPTR). * array.c: Mechanical replacements to accomodate union in gfc_typespec. * check.c: Ditto. * data.c: Ditto. * decl.c: Ditto. * dump-parse-tree.c: Ditto. * expr.c: Ditto. * interface.c: Ditto. * iresolve.c: Ditto. * match.c: Ditto. * misc.c: Ditto. * module.c: Ditto. * openmp.c: Ditto. * parse.c: Ditto. * primary.c: Ditto. * resolve.c: Ditto. * simplify.c: Ditto. * symbol.c: Ditto. * target-memory.c: Ditto. * trans-array.c: Ditto. * trans-common.c: Ditto. * trans-const.c: Ditto. * trans-decl.c: Ditto. * trans-expr.c: Ditto. * trans-intrinsic.c: Ditto. * trans-io.c: Ditto. * trans-stmt.c: Ditto. * trans-types.c: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150725 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 779af2038e9..6e2ce410225 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -410,20 +410,20 @@ gfc_check_same_strlen (const gfc_expr *a, const gfc_expr *b, const char *name) long len_a, len_b; len_a = len_b = -1; - if (a->ts.cl && a->ts.cl->length - && a->ts.cl->length->expr_type == EXPR_CONSTANT) - len_a = mpz_get_si (a->ts.cl->length->value.integer); + if (a->ts.u.cl && a->ts.u.cl->length + && a->ts.u.cl->length->expr_type == EXPR_CONSTANT) + len_a = mpz_get_si (a->ts.u.cl->length->value.integer); else if (a->expr_type == EXPR_CONSTANT - && (a->ts.cl == NULL || a->ts.cl->length == NULL)) + && (a->ts.u.cl == NULL || a->ts.u.cl->length == NULL)) len_a = a->value.character.length; else return SUCCESS; - if (b->ts.cl && b->ts.cl->length - && b->ts.cl->length->expr_type == EXPR_CONSTANT) - len_b = mpz_get_si (b->ts.cl->length->value.integer); + if (b->ts.u.cl && b->ts.u.cl->length + && b->ts.u.cl->length->expr_type == EXPR_CONSTANT) + len_b = mpz_get_si (b->ts.u.cl->length->value.integer); else if (b->expr_type == EXPR_CONSTANT - && (b->ts.cl == NULL || b->ts.cl->length == NULL)) + && (b->ts.u.cl == NULL || b->ts.u.cl->length == NULL)) len_b = b->value.character.length; else return SUCCESS; @@ -1400,12 +1400,12 @@ gfc_check_ichar_iachar (gfc_expr *c, gfc_expr *kind) { /* Check that the argument is length one. Non-constant lengths can't be checked here, so assume they are ok. */ - if (c->ts.cl && c->ts.cl->length) + if (c->ts.u.cl && c->ts.u.cl->length) { /* If we already have a length for this expression then use it. */ - if (c->ts.cl->length->expr_type != EXPR_CONSTANT) + if (c->ts.u.cl->length->expr_type != EXPR_CONSTANT) return SUCCESS; - i = mpz_get_si (c->ts.cl->length->value.integer); + i = mpz_get_si (c->ts.u.cl->length->value.integer); } else return SUCCESS; -- cgit v1.2.1 From eb67c215519d8619b801c38ac575c38f8777f07b Mon Sep 17 00:00:00 2001 From: janus Date: Mon, 31 Aug 2009 10:22:32 +0000 Subject: 2009-08-31 Janus Weil PR fortran/40996 * check.c (gfc_check_allocated): Implement allocatable scalars. * resolve.c (resolve_allocate_expr,resolve_fl_var_and_proc): Ditto. * trans-intrinsic.c (gfc_conv_allocated): Ditto. 2009-08-31 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_1.f90: New. * gfortran.dg/allocatable_scalar_2.f90: Renamed from finalize_9.f03. * gfortran.dg/finalize_9.f03: Renamed to allocatable_scalar_2.f90. * gfortran.dg/proc_ptr_comp_pass_4.f90: Modified. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@151240 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 3 --- 1 file changed, 3 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6e2ce410225..01775abdd30 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -546,9 +546,6 @@ gfc_check_allocated (gfc_expr *array) return FAILURE; } - if (array_check (array, 0) == FAILURE) - return FAILURE; - return SUCCESS; } -- cgit v1.2.1 From 1de1b1a9e40b5aa064d5e3d032dd43ce14f6d2ad Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 30 Sep 2009 19:55:45 +0000 Subject: fortran/ 2009-09-30 Janus Weil * check.c (gfc_check_same_type_as): New function for checking SAME_TYPE_AS and EXTENDS_TYPE_OF. * decl.c (encapsulate_class_symbol): Set ABSTRACT attribute for class container, if the contained type has it. Add an initializer for the class container. (add_init_expr_to_sym): Handle BT_CLASS. (vindex_counter): New counter for setting vindices. (gfc_match_derived_decl): Set vindex for all derived types, not only those which are being extended. * expr.c (gfc_check_assign_symbol): Handle NULL initialization of class pointers. * gfortran.h (gfc_isym_id): New values GFC_ISYM_SAME_TYPE_AS and GFC_ISYM_EXTENDS_TYPE_OF. (gfc_type_is_extensible): New prototype. * intrinsic.h (gfc_check_same_type_as): New prototype. * intrinsic.c (add_functions): Add SAME_TYPE_AS and EXTENDS_TYPE_OF. * primary.c (gfc_expr_attr): Handle CLASS-valued functions. * resolve.c (resolve_structure_cons): Handle BT_CLASS. (type_is_extensible): Make non-static and rename to 'gfc_type_is_extensible. (resolve_select_type): Renamed type_is_extensible. (resolve_class_assign): Handle NULL pointers. (resolve_fl_variable_derived): Renamed type_is_extensible. (resolve_fl_derived): Ditto. * trans-expr.c (gfc_trans_subcomponent_assign): Handle NULL initialization of class pointer components. (gfc_conv_structure): Handle BT_CLASS. * trans-intrinsic.c (gfc_conv_same_type_as,gfc_conv_extends_type_of): New functions. (gfc_conv_intrinsic_function): Handle SAME_TYPE_AS and EXTENDS_TYPE_OF. 2009-09-30 Janus Weil * gfortran.h (type_selector, select_type_tmp): New global variables. * match.c (type_selector, select_type_tmp): New global variables, used for SELECT TYPE statements. (gfc_match_select_type): Better error handling. Remember selector. (gfc_match_type_is): Create temporary variable. * module.c (ab_attribute): New value 'AB_IS_CLASS'. (attr_bits): New string. (mio_symbol_attribute): Handle 'is_class'. * resolve.c (resolve_select_type): Insert pointer assignment statement, to assign temporary to selector. * symbol.c (gfc_get_ha_sym_tree): Replace selector by a temporary in SELECT TYPE statements. 2009-09-30 Janus Weil * dump-parse-tree.c (show_code_node): Renamed 'alloc_list'. * gfortran.h (gfc_code): Rename 'alloc_list'. Add member 'ts'. (gfc_expr_to_initialize): New prototype. * match.c (alloc_opt_list): Correctly check type compatibility. Renamed 'alloc_list'. (dealloc_opt_list): Renamed 'alloc_list'. * resolve.c (expr_to_initialize): Rename to 'gfc_expr_to_initialize' and make it non-static. (resolve_allocate_expr): Set vindex for CLASS variables correctly. Move initialization code to gfc_trans_allocate. Renamed 'alloc_list'. (resolve_allocate_deallocate): Renamed 'alloc_list'. (check_class_pointer_assign): Rename to 'resolve_class_assign'. Change argument type. Adjust to work with ordinary assignments. (resolve_code): Call 'resolve_class_assign' for ordinary assignments. Renamed 'check_class_pointer_assign'. * st.c (gfc_free_statement): Renamed 'alloc_list'. * trans-stmt.c (gfc_trans_allocate): Renamed 'alloc_list'. Handle size determination and initialization of CLASS variables. Bugfix for ALLOCATE statements with default initialization and SOURCE block. (gfc_trans_deallocate): Renamed 'alloc_list'. 2009-09-30 Paul Thomas * trans-expr.c (gfc_conv_procedure_call): Convert a derived type actual to a class object if the formal argument is a class. 2009-09-30 Janus Weil PR fortran/40996 * decl.c (build_struct): Handle allocatable scalar components. * expr.c (gfc_add_component_ref): Correctly set typespec of expression, after inserting component reference. * match.c (gfc_match_type_is,gfc_match_class_is): Make sure that no variables are being used uninitialized. * primary.c (gfc_match_varspec): Handle CLASS array components. * resolve.c (resolve_select_type): Transform EXEC_SELECT_TYPE to EXEC_SELECT. * trans-array.c (structure_alloc_comps,gfc_trans_deferred_array): Handle allocatable scalar components. * trans-expr.c (gfc_conv_component_ref): Ditto. * trans-types.c (gfc_get_derived_type): Ditto. 2009-09-30 Janus Weil * decl.c (encapsulate_class_symbol): Modify names of class container components by prefixing with '$'. (gfc_match_end): Handle COMP_SELECT_TYPE. * expr.c (gfc_add_component_ref): Modify names of class container components by prefixing with '$'. * gfortran.h (gfc_statement): Add ST_SELECT_TYPE, ST_TYPE_IS and ST_CLASS_IS. (gfc_case): New field 'ts'. (gfc_exec_op): Add EXEC_SELECT_TYPE. (gfc_type_is_extension_of): New prototype. * match.h (gfc_match_select_type,gfc_match_type_is,gfc_match_class_is): New prototypes. * match.c (match_derived_type_spec): New function. (match_type_spec): Use 'match_derived_type_spec'. (match_case_eos): Modify error message. (gfc_match_select_type): New function. (gfc_match_case): Modify error message. (gfc_match_type_is): New function. (gfc_match_class_is): Ditto. * parse.h (gfc_compile_state): Add COMP_SELECT_TYPE. * parse.c (decode_statement): Handle SELECT TYPE, TYPE IS and CLASS IS statements. (next_statement): Handle ST_SELECT_TYPE. (gfc_ascii_statement): Handle ST_SELECT_TYPE, ST_TYPE_IS, ST_CLASS_IS. (parse_select_type_block): New function. (parse_executable): Handle ST_SELECT_TYPE. * resolve.c (resolve_deallocate_expr): Handle BT_CLASS. Modify names of class container components by prefixing with '$'. (resolve_allocate_expr): Ditto. (resolve_select_type): New function. (gfc_resolve_blocks): Handle EXEC_SELECT_TYPE. (check_class_pointer_assign): Modify names of class container components by prefixing with '$'. (resolve_code): Ditto. * st.c (gfc_free_statement): Ditto. * symbol.c (gfc_type_is_extension_of): New function. (gfc_type_compatible): Use 'gfc_type_is_extension_of', plus a bugfix. * trans.c (gfc_trans_code): Handel EXEC_SELECT_TYPE. 2009-09-30 Janus Weil Paul Thomas * check.c (gfc_check_move_alloc): Arguments don't have to be arrays. The second argument needs to be type-compatible with the first (not the other way around, which makes a difference for CLASS entities). * decl.c (encapsulate_class_symbol): New function. (build_sym,build_struct): Handle BT_CLASS, call 'encapsulate_class_symbol'. (gfc_match_decl_type_spec): Remove warning, use BT_CLASS. (gfc_match_derived_decl): Set vindex; * expr.c (gfc_add_component_ref): New function. (gfc_copy_expr,gfc_check_pointer_assign,gfc_check_assign_symbol): Handle BT_CLASS. * dump-parse-tree.c (show_symbol): Print vindex. * gfortran.h (bt): New basic type BT_CLASS. (symbol_attribute): New field 'is_class'. (gfc_typespec): Remove field 'is_class'. (gfc_symbol): New field 'vindex'. (gfc_get_ultimate_derived_super_type): New prototype. (gfc_add_component_ref): Ditto. * interface.c (gfc_compare_derived_types): Pointer equality check moved here from gfc_compare_types. (gfc_compare_types): Handle BT_CLASS and use gfc_type_compatible. * match.c (gfc_match_allocate,gfc_match_deallocate,gfc_match_call): Handle BT_CLASS. * misc.c (gfc_clear_ts): Removed is_class. (gfc_basic_typename,gfc_typename): Handle BT_CLASS. * module.c (bt_types,mio_typespec): Handle BT_CLASS. (mio_symbol): Handle vindex. * primary.c (gfc_match_varspec,gfc_variable_attr): Handle BT_CLASS. * resolve.c (find_array_spec,check_typebound_baseobject): Handle BT_CLASS. (resolve_ppc_call,resolve_expr_ppc): Don't call 'gfc_is_proc_ptr_comp' inside 'gcc_assert'. (resolve_deallocate_expr,resolve_allocate_expr): Handle BT_CLASS. (check_class_pointer_assign): New function. (resolve_code): Handle BT_CLASS, call check_class_pointer_assign. (resolve_fl_var_and_proc,type_is_extensible,resolve_fl_variable_derived, resolve_fl_variable): Handle BT_CLASS. (check_generic_tbp_ambiguity): Add special case. (resolve_typebound_procedure,resolve_fl_derived): Handle BT_CLASS. * symbol.c (gfc_get_ultimate_derived_super_type): New function. (gfc_type_compatible): Handle BT_CLASS. * trans-expr.c (conv_parent_component_references): Handle CLASS containers. (gfc_conv_initializer): Handle BT_CLASS. * trans-types.c (gfc_typenode_for_spec,gfc_get_derived_type): Handle BT_CLASS. testsuite/ 2009-09-30 Janus Weil * gfortran.dg/same_type_as_1.f03: New test. * gfortran.dg/same_type_as_2.f03: Ditto. 2009-09-30 Janus Weil * gfortran.dg/select_type_1.f03: Extended. * gfortran.dg/select_type_3.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/class_allocate_1.f03: New test. 2009-09-30 Janus Weil PR fortran/40996 * gfortran.dg/allocatable_scalar_3.f90: New test. * gfortran.dg/select_type_2.f03: Ditto. * gfortran.dg/typebound_proc_5.f03: Changed error messages. 2009-09-30 Janus Weil * gfortran.dg/block_name_2.f90: Modified error message. * gfortran.dg/select_6.f90: Ditto. * gfortran.dg/select_type_1.f03: New test. 2009-09-30 Janus Weil * gfortran.dg/allocate_derived_1.f90: Remove -w option. * gfortran.dg/class_1.f03: Ditto. * gfortran.dg/class_2.f03: Ditto. * gfortran.dg/proc_ptr_comp_pass_1.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_2.f90: Ditto. * gfortran.dg/proc_ptr_comp_pass_3.f90: Ditto. * gfortran.dg/typebound_call_10.f03: Ditto. * gfortran.dg/typebound_call_2.f03: Ditto. * gfortran.dg/typebound_call_3.f03: Ditto. * gfortran.dg/typebound_call_4.f03: Ditto. * gfortran.dg/typebound_call_9.f03: Ditto. * gfortran.dg/typebound_generic_3.f03: Ditto. * gfortran.dg/typebound_generic_4.f03: Ditto. * gfortran.dg/typebound_operator_1.f03: Ditto. * gfortran.dg/typebound_operator_2.f03: Ditto. * gfortran.dg/typebound_operator_3.f03: Ditto. * gfortran.dg/typebound_operator_4.f03: Ditto. * gfortran.dg/typebound_proc_1.f08: Ditto. * gfortran.dg/typebound_proc_5.f03: Ditto. * gfortran.dg/typebound_proc_6.f03: Ditto. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@152345 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 48 +++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 41 insertions(+), 7 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 01775abdd30..171eeaa97bf 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2135,9 +2135,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (variable_check (from, 0) == FAILURE) return FAILURE; - if (array_check (from, 0) == FAILURE) - return FAILURE; - attr = gfc_variable_attr (from, NULL); if (!attr.allocatable) { @@ -2150,9 +2147,6 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) if (variable_check (to, 0) == FAILURE) return FAILURE; - if (array_check (to, 0) == FAILURE) - return FAILURE; - attr = gfc_variable_attr (to, NULL); if (!attr.allocatable) { @@ -2162,7 +2156,7 @@ gfc_check_move_alloc (gfc_expr *from, gfc_expr *to) return FAILURE; } - if (same_type_check (from, 0, to, 1) == FAILURE) + if (same_type_check (to, 1, from, 0) == FAILURE) return FAILURE; if (to->rank != from->rank) @@ -2646,6 +2640,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, } +gfc_try +gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) +{ + + if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (a->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (b->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + return SUCCESS; +} + + gfc_try gfc_check_scale (gfc_expr *x, gfc_expr *i) { -- cgit v1.2.1 From 7035e05707c314e5d76d25386cf4cf6a4d06f4d5 Mon Sep 17 00:00:00 2001 From: burnus Date: Thu, 29 Oct 2009 15:24:38 +0000 Subject: 2009-10-29 Tobias Burnus PR fortran/41777 * trans-expr.c * (gfc_conv_procedure_call,gfc_conv_expr_reference): Use for generic EXPR_FUNCTION the attributes of the specific function. 2009-10-29 Tobias Burnus PR fortran/41777 gfortran.dg/associated_target_3.f90: New testcase. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@153706 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 171eeaa97bf..9b6f8ea0a4f 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -599,10 +599,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) where = &pointer->where; - if (pointer->expr_type == EXPR_VARIABLE) - attr1 = gfc_variable_attr (pointer, NULL); - else if (pointer->expr_type == EXPR_FUNCTION) - attr1 = pointer->symtree->n.sym->attr; + if (pointer->expr_type == EXPR_VARIABLE || pointer->expr_type == EXPR_FUNCTION) + attr1 = gfc_expr_attr (pointer); else if (pointer->expr_type == EXPR_NULL) goto null_arg; else @@ -624,10 +622,8 @@ gfc_check_associated (gfc_expr *pointer, gfc_expr *target) if (target->expr_type == EXPR_NULL) goto null_arg; - if (target->expr_type == EXPR_VARIABLE) - attr2 = gfc_variable_attr (target, NULL); - else if (target->expr_type == EXPR_FUNCTION) - attr2 = target->symtree->n.sym->attr; + if (target->expr_type == EXPR_VARIABLE || target->expr_type == EXPR_FUNCTION) + attr2 = gfc_expr_attr (target); else { gfc_error ("'%s' argument of '%s' intrinsic at %L must be a pointer " -- cgit v1.2.1 From 126387b5b6b5a55db23d87e27562c91cc235c906 Mon Sep 17 00:00:00 2001 From: jvdelisle Date: Tue, 13 Apr 2010 01:59:35 +0000 Subject: 2010-04-12 Jerry DeLisle * 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 * 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 * 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 * 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 * 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 * 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 * constructor.h: New. * constructor.c: New. * Make-lang.in: Add new files to F95_PARSER_OBJS. * arith.c (reducy_unary): Use constructor API. (reduce_binary_ac): Likewise. (reduce_binary_ca): Likewise. (reduce_binary_aa): Likewise. * check.c (gfc_check_pack): Likewise. (gfc_check_reshape): Likewise. (gfc_check_unpack): Likewise. * decl.c (add_init_expr_to_sym): Likewise. (build_struct): Likewise. * dependency.c (gfc_check_dependency): Likewise. (contains_forall_index_p): Likewise. * dump-parse-tree.c (show_constructor): Likewise. * expr.c (free_expr0): Likewise. (gfc_copy_expr): Likewise. (gfc_is_constant_expr): Likewise. (simplify_constructor): Likewise. (find_array_element): Likewise. (find_component_ref): Likewise. (find_array_section): Likewise. (find_substring_ref): Likewise. (simplify_const_ref): Likewise. (scalarize_intrinsic_call): Likewise. (check_alloc_comp_init): Likewise. (gfc_default_initializer): Likewise. (gfc_traverse_expr): Likewise. * iresolve.c (check_charlen_present): Likewise. (gfc_resolve_reshape): Likewise. (gfc_resolve_transfer): Likewise. * module.c (mio_constructor): Likewise. * primary.c (build_actual_constructor): Likewise. (gfc_match_structure_constructor): Likewise. * resolve.c (resolve_structure_cons): Likewise. * simplify.c (is_constant_array_expr): Likewise. (init_result_expr): Likewise. (transformational_result): Likewise. (simplify_transformation_to_scalar): Likewise. (simplify_transformation_to_array): Likewise. (gfc_simplify_dot_product): Likewise. (simplify_bound): Likewise. (simplify_matmul): Likewise. (simplify_minval_maxval): Likewise. (gfc_simplify_pack): Likewise. (gfc_simplify_reshape): Likewise. (gfc_simplify_shape): Likewise. (gfc_simplify_spread): Likewise. (gfc_simplify_transpose): Likewise. (gfc_simplify_unpack): Likewise.q (gfc_convert_constant): Likewise. (gfc_convert_char_constant): Likewise. * target-memory.c (size_array): Likewise. (encode_array): Likewise. (encode_derived): Likewise. (interpret_array): Likewise. (gfc_interpret_derived): Likewise. (expr_to_char): Likewise. (gfc_merge_initializers): Likewise. * trans-array.c (gfc_get_array_constructor_size): Likewise. (gfc_trans_array_constructor_value): Likewise. (get_array_ctor_strlen): Likewise. (gfc_constant_array_constructor_p): Likewise. (gfc_build_constant_array_constructor): Likewise. (gfc_trans_array_constructor): Likewise. (gfc_conv_array_initializer): Likewise. * trans-decl.c (check_constant_initializer): Likewise. * trans-expr.c (flatten_array_ctors_without_strlen): Likewise. (gfc_apply_interface_mapping_to_cons): Likewise. (gfc_trans_structure_assign): Likewise. (gfc_conv_structure): Likewise. * array.c (check_duplicate_iterator): Likewise. (match_array_list): Likewise. (match_array_cons_element): Likewise. (gfc_match_array_constructor): Likewise. (check_constructor_type): Likewise. (check_constructor): Likewise. (expand): Likewise. (expand_constructor): Likewise. (extract_element): Likewise. (gfc_expanded_ac): Likewise. (resolve_array_list): Likewise. (gfc_resolve_character_array_constructor): Likewise. (copy_iterator): Renamed to ... (gfc_copy_iterator): ... this. (gfc_append_constructor): Removed. (gfc_insert_constructor): Removed unused function. (gfc_get_constructor): Removed. (gfc_free_constructor): Removed. (qgfc_copy_constructor): Removed. * gfortran.h (struct gfc_expr): Removed member 'con_by_offset'. Removed all references. Replaced constructor list by splay-tree. (struct gfc_constructor): Removed member 'next', moved 'offset' from the inner struct, added member 'base'. (gfc_append_constructor): Removed prototype. (gfc_insert_constructor): Removed prototype. (gfc_get_constructor): Removed prototype. (gfc_free_constructor): Removed prototype. (qgfc_copy_constructor): Removed prototype. (gfc_copy_iterator): New prototype. * trans-array.h (gfc_constant_array_constructor_p): Adjusted prototype. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158253 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 33 ++++++++++++++------------------- 1 file changed, 14 insertions(+), 19 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 9b6f8ea0a4f..bd2791a100b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -31,6 +31,7 @@ along with GCC; see the file COPYING3. If not see #include "flags.h" #include "gfortran.h" #include "intrinsic.h" +#include "constructor.h" /* Make sure an expression is a scalar. */ @@ -2266,7 +2267,8 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 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) @@ -2278,7 +2280,7 @@ gfc_check_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 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) @@ -2508,12 +2510,9 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, 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) @@ -2523,8 +2522,6 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, gfc_current_intrinsic, &e->where, extent); return FAILURE; } - - gfc_free_expr (e); } } @@ -2569,12 +2566,9 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, 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); @@ -2597,7 +2591,6 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, } perm[dim-1] = 1; - gfc_free_expr (e); } } } @@ -2613,9 +2606,10 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *shape, 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; @@ -3224,7 +3218,8 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) && 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) @@ -3236,7 +3231,7 @@ gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) 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) -- cgit v1.2.1 From a250d5604c330534faa5c2c410c33db5d8253768 Mon Sep 17 00:00:00 2001 From: burnus Date: Wed, 14 Apr 2010 05:43:30 +0000 Subject: 2010-04-14 Tobias Burnus PR fortran/18918 * array.c (gfc_find_array_ref): Handle codimensions. (gfc_match_array_spec,gfc_match_array_ref): Use gfc_fatal_error. * check.c (is_coarray, dim_corank_check, gfc_check_lcobound, gfc_check_image_index, gfc_check_this_image, gfc_check_ucobound): New functions. * gfortran.h (gfc_isym_id): Add GFC_ISYM_IMAGE_INDEX, GFC_ISYM_LCOBOUND, GFC_ISYM_THIS_IMAGE, GFC_ISYM_UCOBOUND. * intrinsic.h (add_functions): Add this_image, image_index, lcobound and ucobound intrinsics. * intrinsic.c (gfc_check_lcobound,gfc_check_ucobound, gfc_check_image_index, gfc_check_this_image, gfc_simplify_image_index, gfc_simplify_lcobound, gfc_simplify_this_image, gfc_simplify_ucobound): New function prototypes. * intrinsic.texi (IMAGE_INDEX, LCOBOUND, THIS_IMAGE IMAGE_INDEX): Document new intrinsic functions. * match.c (gfc_match_critical, sync_statement): Make * -fcoarray=none error fatal. * simplify.c (simplify_bound_dim): Handle coarrays. (simplify_bound): Update simplify_bound_dim call. (gfc_simplify_num_images): Add -fcoarray=none check. (simplify_cobound, gfc_simplify_lcobound, gfc_simplify_ucobound, gfc_simplify_ucobound, gfc_simplify_ucobound): New functions. 2010-04-14 Tobias Burnus PR fortran/18918 * gfortran.dg/coarray_9.f90: Update dg-errors. * gfortran.dg/coarray_10.f90: New test. * gfortran.dg/coarray_11.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@158292 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 188 +++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 187 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index bd2791a100b..799b8c9feea 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1,5 +1,5 @@ /* Check functions - 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 Andy Vaught & Katherine Holcomb @@ -183,6 +183,32 @@ double_check (gfc_expr *d, int n) } +/* Check whether an expression is a coarray (without array designator). */ + +static bool +is_coarray (gfc_expr *e) +{ + bool coarray = false; + gfc_ref *ref; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + coarray = e->symtree->n.sym->attr.codimension; + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + coarray = ref->u.c.component->attr.codimension; + else if (ref->type != REF_ARRAY || ref->u.ar.dimen != 0 + || ref->u.ar.codimen != 0) + coarray = false; + } + + return coarray; +} + + /* Make sure the expression is a logical array. */ static gfc_try @@ -329,6 +355,36 @@ dim_check (gfc_expr *dim, int n, bool optional) } +/* If a coarray DIM parameter is a constant, make sure that it is greater than + zero and less than or equal to the corank of the given array. */ + +static gfc_try +dim_corank_check (gfc_expr *dim, gfc_expr *array) +{ + gfc_array_ref *ar; + int corank; + + gcc_assert (array->expr_type == EXPR_VARIABLE); + + if (dim->expr_type != EXPR_CONSTANT) + return SUCCESS; + + ar = gfc_find_array_ref (array); + corank = ar->as->corank; + + if (mpz_cmp_ui (dim->value.integer, 1) < 0 + || mpz_cmp_ui (dim->value.integer, corank) > 0) + { + gfc_error ("'dim' argument of '%s' intrinsic at %L is not a valid " + "codimension index", gfc_current_intrinsic, &dim->where); + + return FAILURE; + } + + return SUCCESS; +} + + /* If a DIM parameter is a constant, make sure that it is greater than zero and less than or equal to the rank of the given array. If allow_assumed is zero then dim must be less than the rank of the array @@ -1640,6 +1696,38 @@ gfc_check_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) } +gfc_try +gfc_check_lcobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to the LCOBOUND " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + gfc_try gfc_check_len_lentrim (gfc_expr *s, gfc_expr *kind) { @@ -3137,6 +3225,72 @@ gfc_check_stat_sub (gfc_expr *name, gfc_expr *array, gfc_expr *status) } +gfc_try +gfc_check_image_index (gfc_expr *coarray, gfc_expr *sub) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to IMAGE_INDEX " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (sub->rank != 1) + { + gfc_error ("%s argument to IMAGE_INDEX must be a rank one array at %L", + gfc_current_intrinsic_arg[1], &sub->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try +gfc_check_this_image (gfc_expr *coarray, gfc_expr *dim) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (dim != NULL && coarray == NULL) + { + gfc_error ("DIM argument without ARRAY argument not allowed for THIS_IMAGE " + "intrinsic at %L", &dim->where); + return FAILURE; + } + + if (coarray == NULL) + return SUCCESS; + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to THIS_IMAGE " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + return SUCCESS; +} + + gfc_try gfc_check_transfer (gfc_expr *source ATTRIBUTE_UNUSED, gfc_expr *mold ATTRIBUTE_UNUSED, gfc_expr *size) @@ -3197,6 +3351,38 @@ gfc_check_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind) } +gfc_try +gfc_check_ucobound (gfc_expr *coarray, gfc_expr *dim, gfc_expr *kind) +{ + if (gfc_option.coarray == GFC_FCOARRAY_NONE) + { + gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable"); + return FAILURE; + } + + if (!is_coarray (coarray)) + { + gfc_error ("Expected coarray variable as '%s' argument to the UCOBOUND " + "intrinsic at %L", gfc_current_intrinsic_arg[0], &coarray->where); + return FAILURE; + } + + if (dim != NULL) + { + if (dim_check (dim, 1, false) == FAILURE) + return FAILURE; + + if (dim_corank_check (dim, coarray) == FAILURE) + return FAILURE; + } + + if (kind_check (kind, 2, BT_INTEGER) == FAILURE) + return FAILURE; + + return SUCCESS; +} + + gfc_try gfc_check_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field) { -- cgit v1.2.1 From b53b53b4d02d73419519acd48cfbd1123950f062 Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 19 May 2010 11:43:53 +0000 Subject: gcc/fortran/: 2010-05-19 Daniel Franke PR fortran/34505 * intrinsic.h (gfc_check_float): New prototype. (gfc_check_sngl): New prototype. * check.c (gfc_check_float): New. (gfc_check_sngl): New. * intrinsic.c (add_functions): Moved DFLOAT from aliasing DBLE to be a specific for REAL. Added check routines for FLOAT, DFLOAT and SNGL. * intrinsic.texi: Removed individual nodes of FLOAT, DFLOAT and SNGL, added them to the list of specifics of REAL instead. gcc/testsuite/: 2010-05-19 Daniel Franke PR fortran/34505 * gfortran.dg/dfloat_1.f90: Add warnings for non-default kind arguments; add check for return value kind. * gfortran.dg/float_1.f90: Likewise. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@159558 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 799b8c9feea..3a68c29b543 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -1244,6 +1244,20 @@ gfc_check_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary, return SUCCESS; } +gfc_try +gfc_check_float (gfc_expr *a) +{ + if (type_check (a, 0, BT_INTEGER) == FAILURE) + return FAILURE; + + if ((a->ts.kind != gfc_default_integer_kind) + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non-default INTEGER" + "kind argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where) == FAILURE ) + return FAILURE; + + return SUCCESS; +} /* A single complex argument. */ @@ -1256,7 +1270,6 @@ gfc_check_fn_c (gfc_expr *a) return SUCCESS; } - /* A single real argument. */ gfc_try @@ -2953,6 +2966,20 @@ gfc_check_sleep_sub (gfc_expr *seconds) return SUCCESS; } +gfc_try +gfc_check_sngl (gfc_expr *a) +{ + if (type_check (a, 0, BT_REAL) == FAILURE) + return FAILURE; + + if ((a->ts.kind != gfc_default_double_kind) + && gfc_notify_std (GFC_STD_GNU, "GNU extension: non double precision" + "REAL argument to %s intrinsic at %L", + gfc_current_intrinsic, &a->where) == FAILURE) + return FAILURE; + + return SUCCESS; +} gfc_try gfc_check_spread (gfc_expr *source, gfc_expr *dim, gfc_expr *ncopies) -- cgit v1.2.1 From f1d241cc353f610b130907dbc3a58ab209a326c2 Mon Sep 17 00:00:00 2001 From: kargl Date: Wed, 9 Jun 2010 16:24:59 +0000 Subject: 2010-06-09 Steven G. Kargl * testsuite/gfortran.dg/mvbits_9.f90: New test. * testsuite/gfortran.dg/ibset_1.f90: Ditto. * testsuite/gfortran.dg/ibits_1.f90: Ditto. * testsuite/gfortran.dg/btest_1.f90: Ditto. * testsuite/gfortran.dg/ibclr_1.f90: Ditto. 2010-06-09 Steven G. Kargl * fortran/intrinsic.c (add_functions): Change gfc_check_btest, gfc_check_ibclr, and gfc_check_ibset to gfc_check_bitfcn. * fortran/intrinsic.h: Remove prototypes for gfc_check_btest, gfc_check_ibclr, and gfc_check_ibset. Add prototype for gfc_check_bitfcn. * fortran/check.c (nonnegative_check, less_than_bitsize1, less_than_bitsize2): New functions. (gfc_check_btest): Renamed to gfc_check_bitfcn. Use nonnegative_check and less_than_bitsize1. (gfc_check_ibclr, gfc_check_ibset): Removed. (gfc_check_ibits,gfc_check_mvbits): Use nonnegative_check and less_than_bitsize1. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160492 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 124 ++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 102 insertions(+), 22 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 3a68c29b543..6a5c263ed50 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -241,6 +241,80 @@ array_check (gfc_expr *e, int n) } +/* If expr is a constant, then check to ensure that it is greater than + of equal to zero. */ + +static gfc_try +nonnegative_check (const char *arg, gfc_expr *expr) +{ + int i; + + if (expr->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr, &i); + if (i < 0) + { + gfc_error ("'%s' at %L must be nonnegative", arg, &expr->where); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* If expr2 is constant, then check that the value is less than + bit_size(expr1). */ + +static gfc_try +less_than_bitsize1 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 >= gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s' at %L must be less than BIT_SIZE('%s')", + arg2, &expr2->where, arg1); + return FAILURE; + } + } + + return SUCCESS; +} + + +/* If expr2 and expr3 are constants, then check that the value is less than + or equal to bit_size(expr1). */ + +static gfc_try +less_than_bitsize2 (const char *arg1, gfc_expr *expr1, const char *arg2, + gfc_expr *expr2, const char *arg3, gfc_expr *expr3) +{ + int i2, i3; + + if (expr2->expr_type == EXPR_CONSTANT && expr3->expr_type == EXPR_CONSTANT) + { + gfc_extract_int (expr2, &i2); + gfc_extract_int (expr3, &i3); + i2 += i3; + i3 = gfc_validate_kind (BT_INTEGER, expr1->ts.kind, false); + if (i2 > gfc_integer_kinds[i3].bit_size) + { + gfc_error ("'%s + %s' at %L must be less than or equal " + "to BIT_SIZE('%s')", + arg2, arg3, &expr2->where, arg1); + return FAILURE; + } + } + + return SUCCESS; +} + /* Make sure two expressions have the same type. */ static gfc_try @@ -766,13 +840,20 @@ gfc_check_besn (gfc_expr *n, gfc_expr *x) gfc_try -gfc_check_btest (gfc_expr *i, gfc_expr *pos) +gfc_check_bitfcn (gfc_expr *i, gfc_expr *pos) { if (type_check (i, 0, BT_INTEGER) == FAILURE) return FAILURE; + if (type_check (pos, 1, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; + + if (less_than_bitsize1 ("i", i, "pos", pos) == FAILURE) + return FAILURE; + return SUCCESS; } @@ -1388,19 +1469,6 @@ gfc_check_iand (gfc_expr *i, gfc_expr *j) } -gfc_try -gfc_check_ibclr (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) - return FAILURE; - - if (type_check (pos, 1, BT_INTEGER) == FAILURE) - return FAILURE; - - return SUCCESS; -} - - gfc_try gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) { @@ -1413,17 +1481,13 @@ gfc_check_ibits (gfc_expr *i, gfc_expr *pos, gfc_expr *len) if (type_check (len, 2, BT_INTEGER) == FAILURE) return FAILURE; - return SUCCESS; -} - + if (nonnegative_check ("pos", pos) == FAILURE) + return FAILURE; -gfc_try -gfc_check_ibset (gfc_expr *i, gfc_expr *pos) -{ - if (type_check (i, 0, BT_INTEGER) == FAILURE) + if (nonnegative_check ("len", len) == FAILURE) return FAILURE; - if (type_check (pos, 1, BT_INTEGER) == FAILURE) + if (less_than_bitsize2 ("i", i, "pos", pos, "len", len) == FAILURE) return FAILURE; return SUCCESS; @@ -3646,6 +3710,22 @@ gfc_check_mvbits (gfc_expr *from, gfc_expr *frompos, gfc_expr *len, if (type_check (topos, 4, BT_INTEGER) == FAILURE) return FAILURE; + if (nonnegative_check ("frompos", frompos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("topos", topos) == FAILURE) + return FAILURE; + + if (nonnegative_check ("len", len) == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("from", from, "frompos", frompos, "len", len) + == FAILURE) + return FAILURE; + + if (less_than_bitsize2 ("to", to, "topos", topos, "len", len) == FAILURE) + return FAILURE; + return SUCCESS; } -- cgit v1.2.1 From 0d290c9d17fe55e9c70da316068fd3fb2d0ab72d Mon Sep 17 00:00:00 2001 From: dfranke Date: Wed, 9 Jun 2010 21:36:33 +0000 Subject: gcc/fortran/: 2010-06-09 Daniel Franke PR fortran/44347 * check.c (gfc_check_selected_real_kind): Verify that the actual arguments are scalar. gcc/testsuite/: 2010-06-09 Daniel Franke PR fortran/44347 * gfortran.dg/selected_real_kind_1.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@160506 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 6a5c263ed50..81f3e24847b 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2930,11 +2930,23 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) return FAILURE; } - if (p != NULL && type_check (p, 0, BT_INTEGER) == FAILURE) - return FAILURE; + if (p) + { + if (type_check (p, 0, BT_INTEGER) == FAILURE) + return FAILURE; - if (r != NULL && type_check (r, 1, BT_INTEGER) == FAILURE) - return FAILURE; + if (scalar_check (p, 0) == FAILURE) + return FAILURE; + } + + if (r) + { + if (type_check (r, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (r, 1) == FAILURE) + return FAILURE; + } return SUCCESS; } -- cgit v1.2.1 From 1011a9ca98952b1fff364a3350b9372a7ef340b0 Mon Sep 17 00:00:00 2001 From: burnus Date: Fri, 25 Jun 2010 19:40:37 +0000 Subject: 2010-06-25 Tobias Burnus * intrinsic.h (gfc_check_selected_real_kind, gfc_simplify_selected_real_kind): Update prototypes. * intrinsic.c (add_functions): Add radix support to selected_real_kind. * check.c (gfc_check_selected_real_kind): Ditto. * simplify.c (gfc_simplify_selected_real_kind): Ditto. * trans-decl.c (gfc_build_intrinsic_function_decls): Change call from selected_real_kind to selected_real_kind2008. * intrinsic.texi (SELECTED_REAL_KIND): Update for radix. (PRECISION, RANGE, RADIX): Add cross @refs. 2010-06-25 Tobias Burnus * intrinsics/selected_real_kind.f90 (_gfortran_selected_real_kind2008): Add function. (_gfortran_selected_real_kind): Stub which calls _gfortran_selected_real_kind2008. * gfortran.map (GFORTRAN_1.4): Add _gfortran_selected_real_kind2008. * mk-srk-inc.sh: Save also RADIX. 2010-06-25 Tobias Burnus * selected_real_kind_2.f90: New. * selected_real_kind_3.f90: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161411 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 81f3e24847b..34527172431 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2920,15 +2920,13 @@ gfc_check_selected_int_kind (gfc_expr *r) gfc_try -gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) +gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r, gfc_expr *radix) { - if (p == NULL && r == NULL) - { - gfc_error ("Missing arguments to %s intrinsic at %L", - gfc_current_intrinsic, gfc_current_intrinsic_where); - - return FAILURE; - } + if (p == NULL && r == NULL + && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SELECTED_REAL_KIND with" + " neither 'P' nor 'R' argument at %L", + gfc_current_intrinsic_where) == FAILURE) + return FAILURE; if (p) { @@ -2948,6 +2946,20 @@ gfc_check_selected_real_kind (gfc_expr *p, gfc_expr *r) return FAILURE; } + if (radix) + { + if (type_check (radix, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (radix, 1) == FAILURE) + return FAILURE; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: '%s' intrinsic with " + "RADIX argument at %L", gfc_current_intrinsic, + &radix->where) == FAILURE) + return FAILURE; + } + return SUCCESS; } -- cgit v1.2.1 From b9cef582e9e64a5fece477a27c24d639d0c0f271 Mon Sep 17 00:00:00 2001 From: tkoenig Date: Tue, 6 Jul 2010 19:48:58 +0000 Subject: 2010-07-06 Thomas Koenig PR fortran/PR44693 * check.c (dim_rank_check): Also check intrinsic functions. Adjust permissible rank for functions which reduce the rank of their argument. Spread is an exception, where DIM can be one larger than the rank of array. 2010-07-06 Thomas Koenig PR fortran/PR44693 * gfortran.dg/dim_range_1.f90: New test. * gfortran.dg/minmaxloc_4.f90: Remove invalid test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161884 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 34527172431..27bd900f9e3 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -473,12 +473,15 @@ dim_rank_check (gfc_expr *dim, gfc_expr *array, int allow_assumed) if (dim == NULL) return SUCCESS; - if (dim->expr_type != EXPR_CONSTANT - || (array->expr_type != EXPR_VARIABLE - && array->expr_type != EXPR_ARRAY)) + if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; - rank = array->rank; + if (array->expr_type == EXPR_FUNCTION && array->value.function.isym + && array->value.function.isym->id == GFC_ISYM_SPREAD) + rank = array->rank + 1; + else + rank = array->rank; + if (array->expr_type == EXPR_VARIABLE) { ar = gfc_find_array_ref (array); -- cgit v1.2.1 From 95bf00d57a5dddd773b91d637479d17a4ca5fd76 Mon Sep 17 00:00:00 2001 From: janus Date: Thu, 8 Jul 2010 21:29:56 +0000 Subject: 2010-07-08 Janus Weil PR fortran/44649 * gfortran.h (gfc_isym_id): Add GFC_ISYM_C_SIZEOF,GFC_ISYM_STORAGE_SIZE. * intrinsic.h (gfc_check_c_sizeof,gfc_check_storage_size, gfc_resolve_storage_size): New prototypes. * check.c (gfc_check_c_sizeof,gfc_check_storage_size): New functions. * intrinsic.c (add_functions): Add STORAGE_SIZE. * iresolve.c (gfc_resolve_storage_size): New function. * trans-intrinsic.c (gfc_conv_intrinsic_sizeof): Handle polymorphic arguments. (gfc_conv_intrinsic_storage_size): New function. (gfc_conv_intrinsic_function): Handle STORAGE_SIZE. 2010-07-08 Janus Weil PR fortran/44649 * gfortran.dg/c_sizeof_1.f90: Modified. * gfortran.dg/storage_size_1.f08: New. * gfortran.dg/storage_size_2.f08: New. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@161977 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/check.c | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) (limited to 'gcc/fortran/check.c') diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 27bd900f9e3..7578775ef42 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -3045,6 +3045,20 @@ gfc_check_sizeof (gfc_expr *arg ATTRIBUTE_UNUSED) } +gfc_try +gfc_check_c_sizeof (gfc_expr *arg) +{ + if (verify_c_interop (&arg->ts) != SUCCESS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be be an " + "interoperable data entity", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &arg->where); + return FAILURE; + } + return SUCCESS; +} + + gfc_try gfc_check_sleep_sub (gfc_expr *seconds) { @@ -4559,3 +4573,27 @@ gfc_check_and (gfc_expr *i, gfc_expr *j) return SUCCESS; } + + +gfc_try +gfc_check_storage_size (gfc_expr *a ATTRIBUTE_UNUSED, gfc_expr *kind) +{ + if (kind == NULL) + return SUCCESS; + + if (type_check (kind, 1, BT_INTEGER) == FAILURE) + return FAILURE; + + if (scalar_check (kind, 1) == FAILURE) + return FAILURE; + + if (kind->expr_type != EXPR_CONSTANT) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L must be a constant", + gfc_current_intrinsic_arg[1], gfc_current_intrinsic, + &kind->where); + return FAILURE; + } + + return SUCCESS; +} -- cgit v1.2.1